function funcrd(param,npara,ifuge,timev)
!------------------------------------------------------------------------
!
! This function yields the derivative of a parabolic or periodic
! evolution
!
!------------------------------------------------------------------------
  use      typre
  implicit none
  real(rp)                 :: funcrd
  integer(ip), intent(in)  :: npara,ifuge
  real(rp),    intent(in)  :: param(npara),timev
  real(rp)                 :: timea,zerom

  funcrd=0.0_rp
  zerom=epsilon(1.0_rp)

  if(ifuge==0) then
!
! No time dependence
!
     funcrd=0.0_rp

  else if(ifuge==1) then
!
! Parabolic evolution
!
     if(param(1)-zerom<=timev.and.timev<=param(2)+zerom) then
        funcrd=2.0_rp*param(3)*timev+param(4)
     else if (timev>param(2)+zerom) then
        timea=param(2)
        funcrd=2.0_rp*param(3)*timea+param(4)
     else if (timev<param(1)-zerom) then
        timea=param(1)
        funcrd=2.0_rp*param(3)*timea+param(4)
     end if
  else if(ifuge==2) then
!
! Periodic evolution
!
     if(param(1)-zerom<=timev.and.timev>=param(2)+zerom) then
        funcrd=param(3)*param(4)*cos(param(4)*timev+param(5))
     else if (timev>param(2)+zerom) then
        timea=param(2)
        funcrd=param(3)*param(4)*cos(param(4)*timea+param(5))
     else if (timev<param(1)-zerom) then
        timea=param(1)
        funcrd=param(3)*param(4)*cos(param(4)*timea+param(5))
     end if

  end if

end function funcrd


module num_integration
  use utils

  implicit none

  contains

    function trapezoid(f,a,b,h)
      real(wp), intent(in) :: a,b,h
      integer :: i,j,steps
      real(wp) :: trapezoid
      class(fun), intent(in) :: f

      steps = (b-a)/h
      trapezoid = 0
      do i = 1, steps
        trapezoid = trapezoid + (f%eval(a+(i-1)*h) + f%eval(a+i*h))*h/2
      end do
    end function trapezoid

    function romberg(f,a,b,k)
      real(wp), intent(in) :: a,b
      real(wp), allocatable :: r(:)
      class(fun), intent(in) :: f
      real(wp) :: h
      integer, intent(in) :: k
      integer :: i,j,m,np
      real(wp) :: romberg

      h = b - a
      allocate(r(k))

      r(1) = h*(f%eval(a)+f%eval(b))/2
      write(*,*) "h ", h
      write(*,*) "a ", a
      write(*,*) "b ", b
      write(*,*) "f(a) ", f%eval(a)
      write(*,*) "f(b) ", f%eval(b)
      write(*,*) "r(1) ", r(1)

      np = 1
      do i = 2,k
        h = h/2
        r(i) = r(i-1)/2
        do j = 1,np
          r(i) = r(i) + h*f%eval(a+(2*j-1)*h)
        end do
        m = 1
        do j = 2,i
          m = 4*m
          r(i-j+1) = (m*r(i-j+2)-r(i-j+1))/(m-1)
        end do
        np = np*2
      end do
      romberg = r(1)
      write(*,*) "r(end) ", r(1)
      write(*,*)
    end function romberg

end module num_integration


PROGRAM integer_exp
  IMPLICIT NONE
  INTEGER (KIND=4) :: int1, int2, int3

  ! This is the begin of a comment line in Fortran 90
  ! Now we read from screen the variable int2

  WRITE(*,*) 'Read in the number to be exponentiated'
  READ(*,*) int2
  int1=2**int2
  WRITE(*,*) '2^N*2^N', int1*int1
  int3=int1-1
  WRITE(*,*) '2^N*(2^N-1)', int1*int3
  WRITE(*,*) '2^N-1', int3

END PROGRAM integer_exp


MODULE m_sort
    USE m_globals

CONTAINS

! regular unmodified quicksort on real*4
RECURSIVE SUBROUTINE quicksort(a, first, last)
    IMPLICIT NONE

    REAL (KIND=4) :: a(*), x, t
    INTEGER :: first, last
    INTEGER :: i, j

    x = a( (first+last) / 2 )
    i = first
    j = last

    DO
        DO WHILE (a(i) < x)
            i=i+1
        END DO

        DO WHILE (x < a(j))
            j=j-1
        END DO

        IF(i >= j) EXIT    ! sort completed, exit

        t = a(i);  a(i) = a(j);  a(j) = t
        i=i+1
        j=j-1
    END DO

    IF (first < i-1) CALL quicksort(a, first, i-1)
    IF (j+1 < last)  CALL quicksort(a, j+1, last)
END SUBROUTINE

! modified quickstort, order by a%x
RECURSIVE SUBROUTINE quicksort_x(a, first, last)
    IMPLICIT NONE

    TYPE(data_t) :: a(*), x, t
    INTEGER :: first, last
    INTEGER :: i, j

    x = a( (first+last) / 2 )
    i = first
    j = last
    DO
        DO WHILE(a(i)%x < x%x)
            i=i+1
        END DO

        DO WHILE(x%x < a(j)%x)
            j=j-1
        END DO

        IF(i >= j) EXIT

        t = a(i)
        a(i) = a(j)
        a(j) = t
        i=i+1
        j=j-1

    END DO

    IF(first < i-1) CALL quicksort_x(a, first, i-1)
    IF(j+1 < last)  CALL quicksort_x(a, j+1, last)

END SUBROUTINE

END MODULE


subroutine spline(x,y,n,gam,y2)
implicit none
INTEGER, INTENT(IN) :: n
REAL, INTENT(IN) :: gam
REAL, INTENT(IN) :: x(n,1), y(n,1)
REAL, INTENT(OUT) :: y2(n,1)
INTEGER :: i, k
!REAL :: qn, un
REAL :: yp1
REAL :: p, sig
REAL, ALLOCATABLE :: u(:,:)
ALLOCATE(u(n,1))
yp1 = x(1,1)**(-gam)
y2(1,1)=-0.5
u(1,1)=(3.0/(x(2,1)-x(1,1)))*((y(2,1)-y(1,1))/(x(2,1)-x(1,1))-yp1)
do i=2,n-1
   sig = (x(i,1)-x(i-1,1))/(x(i+1,1)-x(i-1,1))
   p = sig*y2(i-1,1)+2.0
   y2(i,1) = (sig-1.0)/p
   u(i,1) = (6.0*((y(i+1,1)-y(i,1))/(x(i+1,1)-x(i,1))-(y(i,1)-y(i-1,1))/(x(i,1)-x(i-1,1)))/(x(i+1,1)-x(i-1,1))-sig*u(i-1,1))/p
end do
y2(n,1) =0.0
do k=n-1,1,-1
   y2(k,1) = y2(k,1)*y2(k+1,1)+u(k,1)
end do
DEALLOCATE(u)
RETURN
end subroutine


!This program calculates PI using MPI in Fortran
!
!To compile: mpif90 -o <executable name> <source>
!
!To run: mpirun -n <processes> ./<executable> <number of tosses>
!

program picalc

	use mpi

        use omp_lib

	implicit none

	!initialize variables

	real(kind=8) :: start, finish, PI, elapsed

	real, external :: get_rand

	integer(kind=4) :: mpi_error_code, myrank, worldsize, error, j

    integer(kind=4) :: num_omp

	integer(kind=8) :: tosses, hits_in_circle, hits_in_circle_l, hits_omp ,counter, ltosses, i

	integer(kind=4) :: status(MPI_Status_Size)

    character(len=640) :: arg

	CALL MPI_Init(mpi_error_code)

	start = MPI_Wtime()

	!set variables

	call MPI_Comm_size ( MPI_COMM_WORLD, worldsize, error )

	call MPI_Comm_rank ( MPI_COMM_WORLD, myrank, error )

	hits_in_circle = 0_8

	hits_in_circle_l = 0_8

	call srand(myrank)

	!if 0, calculate total number of throws needed, broadcast that number to all processes,
	!do throws, then recieve from others in a reduce

	if(myrank == 0) then

		call getarg(1, arg)

		read(arg, '(i100)') tosses

		ltosses = tosses / worldsize

		!brodcast total amount of work to other threads

		call MPI_Bcast(ltosses, 1, MPI_UNSIGNED_LONG_LONG, 0, MPI_COMM_WORLD, status, mpi_error_code)

		call omp_set_num_threads(8)

		!$OMP PARALLEL DO REDUCTION(+:hits_in_circle_l)

		do counter = 1, ltosses

			call toss_darts(hits_in_circle_l)

		end do

                !$OMP END PARALLEL DO

		call MPI_Reduce(hits_in_circle_l, hits_in_circle,1,MPI_UNSIGNED_LONG_LONG,MPI_SUM, 0,MPI_COMM_WORLD, mpi_error_code)

		PI = 4. * real(hits_in_circle) / real(tosses)

		print *, "PI is calculated as appx ", PI

		finish = MPI_Wtime()

		elapsed = finish - start

		print *, "Program ran in ", elapsed, " seconds"

		!others calculate, then send

        else

        call MPI_Bcast(ltosses, 1, MPI_UNSIGNED_LONG_LONG, 0, MPI_COMM_WORLD, status, mpi_error_code)

		if(ltosses == 0) then

		call exit()

		end if

		call omp_set_num_threads(8)

		!$OMP PARALLEL DO reduction(+:hits_in_circle_l)

		do counter = 1, ltosses

			call toss_darts(hits_in_circle_l)

		end do

                !$OMP END PARALLEL DO

		!send to 0

        call MPI_Reduce(hits_in_circle_l, hits_in_circle, 1, MPI_UNSIGNED_LONG_LONG, MPI_SUM, 0, MPI_COMM_WORLD, mpi_error_code)

	end if

	!finalize

	CALL MPI_Finalize(mpi_error_code)

end program picalc

subroutine toss_darts(hits)

	implicit none

	real, external :: get_rand

	integer(kind=8) :: prev

	integer(kind=8), intent(inout) :: hits

	real(kind=8) :: x, y

	x = get_rand()

	y = get_rand()

	x = x ** 2

	y = y ** 2

	if(x + y <= 1) then

		hits = hits + 1

	end if

end subroutine toss_darts

real function get_rand()

	implicit none

	get_rand = (rand()* 2) -1

	return

end function get_rand

subroutine usage

	call exit()

end subroutine


!
! Project Euler Problem 4: Largest palindrome product
!
! D. C. Groothuizen Dijkema - November, 2019
!

function reversible(num)
  ! Determine if an integer is palindromic in its digits

  implicit none

  logical :: reversible
  integer, intent(in) :: num
  integer :: len,itr
  ! 999*999 is 998001, so only 6 characters are needed
  character(len=6) :: str,rev
  ! print to the string
  write (str,"(I6)") num
  len=len_trim(str)
  ! flip the string and save to rev
  do itr=1,len
    rev(itr:itr)=str(len+1-itr:len+1-itr)
  end do

  reversible=str(1:len).eq.rev(1:len)

end function reversible

subroutine run
  implicit none
  logical, external :: reversible

  integer :: itr,jtr,val
  val=0

  itr=993
  jtr=913

  do itr=999,100,-1
    do jtr=999,itr,-1
      if (reversible(itr*jtr) .and. itr*jtr.gt.val) then
        val=itr*jtr
        exit ! multiplying itr by a smaller jtr isn't going to give us a bigger number
      end if
    end do
  end do

  print *,'The largest palindrome which is the product of two three digit numbers is:',val

end subroutine run

program palindrome
  implicit none
  integer :: beginning,end,rate

  call system_clock(beginning,rate)
  call run
  call system_clock(end)
  print *,"Elapsed time:",real(end-beginning)/real(rate)

end program


program project1
!------------------------------------------------------------------------------------------------
! Fortran program to solve Laplace's equation on a plate of unit width and height
! subject to the boundary conditions
!					T(0,y) = 0,
!					T(x,0) = 0,
!					T(1,y) = sin(pi*y),
!					T(x,1) = sin(pi*x)
!	The main program includes:
!	(a) array storage for the points of the grid;
!	(b) boundary conditions at the boundary points;
!	(c) some initial conditions at the interior points;
!	(d) T at each interior point by the average value of T for the nearest four points;
!	(e) the L(infty) norm of the difference between T(n+1) and T(n) to see if the scheme
!		is converged (Use 1E-5 as your primary convergence criteria, for some cases you
!		may need to consider going smaller);
!	(f) to step d. if convergence is not satisfied, else;
!	(g) write the solution to an output file;
!	(h) write the convergence history to another output file.

implicit none

! define variables
integer :: alstat_1, alstat_2, alstat_3, hori_grid, vert_grid, n1, n2, h, n, i, j, iter, 		&
			wropst_1, wropst_2, wropst_3, wropst_4, wropst_5
real, allocatable, dimension(:,:) :: T, errors, trun_err
real, parameter :: PI = 4. * atan(1.), criteria = 1E-5
real :: dx, dy, conver_norm, r, temp, L_1, L_2, L_infty
character(30) :: wrfile_convergence, wrfile_solution, wrfile_errors, wrfile_trunerrors,			&
					wrfile_norms

	write (*, '(/a/a/)') "------------------------------------------------------------",		&
				"Fortran solver to Laplace equation with boundary conditions."
	do
		write (*, '(2x, a)', advance = "no") "Enter grid sizes (horizontal and vertical): "

		! read grid size (horizontal and vertical)
		read (*,*) hori_grid, vert_grid

		! constrain the grid size between 1 and 1000000
		if (hori_grid >= 1 .and. hori_grid <= 1000000) then
			if (vert_grid >= 1 .and. vert_grid <= 1000000) then
				exit
			else
				write (*, '(2x, a)') "Error, grid size must be integers between 1 and 1000000."
				write (*, '(2x, a)') "Please re-enter."
			end if
		else
			write (*, '(2x, a)') "Error, grid size must be integers between 1 and 1000000."
			write (*, '(2x, a)') "Please re-enter."
		end if
	end do

! allocate two dimension array for storing the points of the grid
	allocate (T(0:hori_grid, 0:vert_grid), stat = alstat_1)
	if (alstat_1 /= 0) then
		write (*, '(2x, a, /a)') "Error, unable to allocate memory. ", "Program terminated."
		stop
	end if

! initial conditions (all zero) at the interior points
	T = 0.

! allocate two dimension array for storing the errors
	allocate (errors(1:(hori_grid-1), 1:(vert_grid-1)), stat = alstat_2)
	if (alstat_2 /= 0) then
		write (*, '(2x, a, /a)') "Error, unable to allocate memory. ", "Program terminated."
		stop
	end if

! initial conditions for the errors
	errors = 0.

! allocate two dimension array for storing the truncation errors
	allocate (trun_err(1:(hori_grid-1), 1:(vert_grid-1)), stat = alstat_3)
	if (alstat_3 /= 0) then
		write (*, '(2x, a, /a)') "Error, unable to allocate memory. ", "Program terminated."
		stop
	end if

! initial conditions for the truncation errors
	trun_err = 0.

! prompt for the convergence history output file name
	do
		write (*,'(/2x, a)', advance = "no") "Convergence history output File Name: "

		! read output file name
		read (*,*) wrfile_convergence

		! open output file (read access)
		! if open unsuccessful, display error message
		! 		otherwise, end loop
		open(12, file = wrfile_convergence, status="new", 				&
					action="write", position="rewind", 					&
					iostat=wropst_1)
		if (wropst_1 == 0) exit
		write (*,'(2x, a,a/,a)') "Unable to create ",					&
				"convergence output file.", "Please re-enter..."
	end do
	write (12,'(a, T16, a)') "Iteration", "Convergence_norm"

! grid steps
	dx = 1.0 / hori_grid
	dy = 1.0 / vert_grid

! Boundary conditions
	do i = 0, hori_grid
		T(i,vert_grid) = sin(pi*(dx*i))

		! eliminate the round error when T = sin(pi) = 0.
		if (abs(T(i,vert_grid) - 0.) < 1E-6) T(i,vert_grid) = 0.
	end do
	do j = 0, vert_grid
		T(hori_grid,j) = sin(pi*(dy*j))

		! eliminate the round error when T = sin(pi) = 0.
		if (abs(T(hori_grid,j) - 0.) < 1E-6) T(hori_grid,j) = 0.
	end do

! initialization including convergence norm and iteration time
	n1 = hori_grid - 1; n2 = vert_grid - 1; conver_norm = 0; iter = 0
	do
		do i = 1, n1
			do j = 1, n2
				! five-point scheme
				r = 0.25 * (T(i+1,j)+T(i-1,j)+T(i,j+1)+T(i,j-1))

				! to find maximum |T(n+1)-T(n)|, which is L_infinity
				temp = abs(T(i,j) - r)
				if (temp > conver_norm) conver_norm = temp

				! update temperature of the interior point
				T(i,j) = r
			end do
		end do

		iter = iter + 1

		! write the convergence history into the output file
		write (12, '(i5, T16, f9.7)') iter, conver_norm

		! convergence criteria for convergence norm
		if (conver_norm < criteria) then
			! if converged, output the convergence history to the file
			write (*, '(2x, a, a, i4, a)') "The solution has converged.",			 		&
							"Iteration time is ", iter, "."
			write (*, '(2x, a/)') "Convergence history output successfully done!"
			exit
		else
			! if not converged yet, set the L_infty value to be zero
			conver_norm = 0
		end if

		! if it has taken too long to converge, the program will be terminated
		if (iter > 1E5) then
			write (*, '(2x, a/, 2x, a)') "It has taken so long to converge.", 				&
										"Program terminated."
			stop
		end if
	end do

! initialize L_1, L_2 and L_infinity norm
	L_1 = 0.; L_2 = 0.; L_infty = 0.

! evaluate actual errors, truncation errors and three norms
	do i = 1, n1
		do j = 1, n2
			errors(i,j) = abs((sin(PI*dx*i) * sinh(PI*dy*j) + sin(PI*dy*j) * sinh(PI*dx*i))		&
							/ (sinh(PI)) - T(i,j))
			trun_err(i,j) = (sin(PI*dx*i) * sinh(PI*dy*j) + sin(PI*dy*j) * sinh(PI*dx*i))		&
							/ (sinh(PI))*PI**4/48*(dx**4+dy**4)
			L_1 = L_1 + errors(i,j)
			L_2 = L_2 + errors(i,j)**2
			if (L_infty < errors(i,j)) L_infty = errors(i,j)
		end do
	end do

! calculate L_1 and L_2 norm
	L_1 = L_1 / (n1 * n2)
	L_2 = sqrt(L_2 / (n1 * n2))

! prompt for the solution output file name
	do
		write (*, '(2x, a)', advance = "no") "Solution output File Name: "

		! read solution output file name
		read (*,*) wrfile_solution

		! open output file (read access)
		! if open successful, exit loop
		! 		otherwise, display error message
		open(14, file = wrfile_solution, status="new", 					&
					action="write", position="rewind", 					&
					iostat=wropst_2)
		if (wropst_2 == 0) exit
		write (*, '(2x, a,a/,a)') "Unable to create ",					&
								"output file.", "Please re-enter..."
	end do

! write the solution into the output file
	do j = 0, vert_grid
		do i = 0, hori_grid
			write (14, '(2x, f9.7)', advance = "no") T(i,j)
		end do
		write (14,*)
	end do

	write (*, '(2x, a/)') "Solution output successfully done!"

! prompt for the errors output file name
	do
		write (*, '(2x, a)', advance = "no") "Errors output File Name: "

		! read errors output file name
		read (*,*) wrfile_errors

		! open output file (read access)
		! if open successful, exit loop
		! 		otherwise, display error message
		open(16, file = wrfile_errors, status="new", 					&
					action="write", position="rewind", 					&
					iostat=wropst_3)
		if (wropst_3 == 0) exit
		write (*, '(2x, a,a/,a)') "Unable to create ",					&
								"output file.", "Please re-enter..."
	end do

! write the errors into the output file
	do j = 1, vert_grid-1
		do i = 1, hori_grid-1
			write (16, '(2x, f9.7)', advance = "no") errors(i,j)
		end do
		write (16,*)
	end do

	write (*, '(2x, a/)') "Errors output successfully done!"

! prompt for the truncation errors output file name
	do
		write (*, '(2x, a)', advance = "no") "Truncation errors output File Name: "

		! read truncation errors output file name
		read (*,*) wrfile_trunerrors

		! open output file (read access)
		! if open successful, exit loop
		! 		otherwise, display error message
		open(18, file = wrfile_trunerrors, status="new", 					&
					action="write", position="rewind", 					&
					iostat=wropst_4)
		if (wropst_4 == 0) exit
		write (*, '(2x, a,a/,a)') "Unable to create ",					&
								"output file.", "Please re-enter..."
	end do

! write the truncation errors into the output file
	do j = 1, vert_grid-1
		do i = 1, hori_grid-1
			write (18, '(2x, f9.7)', advance = "no") trun_err(i,j)
		end do
		write (18,*)
	end do

	write (*, '(2x, a/)') "Truncation errors output successfully done!"

! prompt for the norms output file name
	do
		write (*, '(2x, a)', advance = "no") "Norms output File Name: "

		! read norms output file name
		read (*,*) wrfile_norms

		! open output file (read access)
		! if open successful, exit loop
		! 		otherwise, display error message
		open(20, file = wrfile_norms, status="new", 					&
					action="write", position="rewind", 					&
					iostat=wropst_5)
		if (wropst_5 == 0) exit
		write (*, '(2x, a,a/,a)') "Unable to create ",					&
								"output file.", "Please re-enter..."
	end do

! write the norms into the output file
	write (20,'(a, T12, a, T24, a)') "L_1", "L_2", "L_infinity"
	write (20, '(f9.7, T12, f9.7, T24, f9.7)', advance = "no") L_1, L_2, L_infty

	write (*, '(2x, a/)') "Norms output successfully done!"

	write (*, '(a)') "------------------------------------------------------------"

end program project1


c
c
c
c
      double precision function fbody(x,y)

      implicit double precision (a-h,o-z)
      include "cuserdt.i"
c
c  negative inside the body (exterior to the domain), positive otherwise.
c

c  cylinder geometry
      pi = 3.14159265358979d0
      ptDist2 = (x-.5d0)**2 + (y-.5d0)**2
      radius = 0.15d0
      radiusSquared = radius**2

      if (ptDist2 .le. radiusSquared) then
           fbody = -1.d0
      else
           fbody =  1.d0
      endif

      return
      end
c


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Spherepack                            *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
! Purpose:
!
! Program shallow solves the nonlinear shallow-water equations
! on the sphere using spherepack software.
!
!
!     the nonlinear shallow-water equations on the sphere are
!     solved using a spectral method based on the spherical
!     vector harmonics. the method is described in the paper:
!
! [1] p. n. swarztrauber, spectral transform methods for solving
!     the shallow-water equations on the sphere, p.n. swarztrauber,
!     monthly weather review, vol. 124, no. 4, april 1996, pp. 730-744.
!
!     this program implements test case 3 (steady nonlinear rotated flow)
!     in the paper:
!
! [2] d.l. williamson, j.b. drake, j.j. hack, r. jakob, and
!     p.n. swarztrauber, j. comp. phys., a standard test set
!     for numerical approximations to the shallow-water
!     equations in spherical geometry, j. comp. phys.,
!     vol. 102, no. 1, sept. 1992, pp. 211-224.
!
! definitions:
!
!
!     nlat          number of latitudes including poles
!     nlon          number of distinct longitudes
!     mmode         max wave number
!     omega         rotation rate of earth in radians per second
!     aa            radius of earth in meters
!     pzero         mean height of geopotential
!     uzero         maximum velocity
!     alpha         tilt angle of the rotated grid
!     ncycle        cycle number
!     time          model time in seconds
!     dt            time step
!     lambda        longitude
!     theta         colatitude
!
!   the first dimension of the following two dimensional arrays
!   corresponds to the latitude index with values i=1, ..., nlat
!   where i=1 is the north pole and i=nlat is the south pole.
!   the second dimension is longitude with values j=1, ..., nlon
!   where j=1 corresponds to zero longitude and j=nlon corresponds
!   to 2pi minus 2pi/nlon.
!
!     u(i, j)       east longitudinal velocity component at t=time
!     v(i, j)       latitudinal velocity component at t=time
!     p(i, j)       +pzero = geopotential at t=time
!
!     unew(i, j)    east longitudinal velocity component at t=time+dt
!     vnew(i, j)    latitudinal velocity component at t=time+dt
!     pnew(i, j)    +pzero = geopotential at t=time+dt
!
!     uold(i, j)    east longitudinal velocity component at t=time-dt
!     vold(i, j)    latitudinal velocity component at t=time-dt
!     pold(i, j)    +pzero = geopotential at t=time-dt
!
!     divg(i, j)    divergence (d/dtheta (cos(theta) v)
!                                          + du/dlambda)/cos(theta)
!     vort(i, j)    vorticity  (d/dtheta (cos(theta) u)
!                                          - dv/dlambda)/cos(theta)
!
!     ut(i, j)      latitudinal derivative of longitudinal
!                  velocity component
!     vt(i, j)      latitudinal derivative of latitudinal
!                  velocity component
!
!     dudt(i, j)    time derivative of longitudinal velocity component
!     dvdt(i, j)    time derivative of latitudinal  velocity component
!     dpdt(i, j)    time derivative of geopotential
!
!     gpdl(i, j)    first component of the gradient of p(i, j)
!                  the longitudinal derivative of the geopotential
!                  divided by the cosine of the latitude
!
!     gpdt(i, j)    second component of the gradient of p(i, j)
!                  the latitudinal derivative of the geopotential
!
!     uxact(i, j)   the "exact" longitudinal veloctiy component
!     vxact(i, j)   the "exact" latitudinal  veloctiy component
!     uxact(i, j)   the "exact" geopotential
!
!     f(i, j)       the coriolis force on rotated grid
!
!   the following two dimensional arrays are nonzero in the triangle
!   n=1, ..., nlat and m less than or equal to n.
!
!     a(m, n), b(m, n)    spectral coefficients of the geopotential
!
!     br(m, n), bi(m, n)  spectral coefficients of the velocity
!     cr(m, n), ci(m, n)  vector [u(i, j), v(i, j)]
!
!
!     phlt(i)      the coefficients in the cosine series
!                  representation of the unrotated geopotential
!
program shallow

    use spherepack

    ! Explicit typing only
    implicit none

    real(wp) :: aa
    real(wp) :: alpha
    real(wp) :: alphad

    real(wp) :: cfn

    real(wp) :: clh
    real(wp) :: cost
    real(wp) :: cth
    real(wp) :: cthclh
    real(wp) :: cthslh
    real(wp) :: ctime
    real(wp) :: dlath
    real(wp) :: dpmax
    real(wp) :: dt

    real(wp) :: degree_to_radian

    real(wp) :: dvmax, dvgm
    real(wp) :: epmax
    real(wp) :: evmax
    real(wp) :: fzero
    real(wp) :: htime
    integer(ip) :: i
    integer(ip) :: ierror
    integer(ip) :: j
    integer(ip) :: lwsha
    integer(ip) :: lwshs
    integer(ip) :: lwvha
    integer(ip) :: lwvhs
    integer(ip) :: lwvts
    integer(ip) :: ncycle
    integer(ip) :: nl
    real(wp) :: omega
    real(wp) :: p2max
    real(wp) :: pmax
    real(wp) :: pzero

    real(wp) :: slh
    real(wp) :: sint
    real(wp) :: sth
    real(wp) :: two_dt
    real(wp) :: that
    real(wp) :: theta
    real(wp) :: time
    real(wp) :: uhat
    real(wp) :: uzero
    real(wp) :: v2max
    real(wp) :: vmax

    integer(ip), parameter :: isym = 0, nt = 1, lwork = 40000
    integer(ip), parameter :: idp = 73, jdp = 144, mdab = 73, ndab = 73
    integer(ip), parameter :: itmax = 720, mprint = 72, max_wave_number = 42
    integer(ip), parameter :: nlat = 65, nlon = 128
    real(wp) :: work(lwork)
    real(wp), dimension(idp, jdp)   :: u, v, p, f
    real(wp), dimension(idp, jdp)   :: unew, vnew, pnew, uold, vold, pold
    real(wp), dimension(idp, jdp)   :: uxact, vxact, pxact, divg, vort
    real(wp), dimension(idp, jdp)   :: ut, vt, dudt, dvdt, dpdt, gpdt, gpdl
    real(wp), dimension(mdab, ndab) :: a, b, br, bi, cr, ci
    real(wp)                        :: phlt(361)
    real(wp), allocatable, dimension(:) :: wsha, wshs, wvha, wvhs, wvts
    real(wp), parameter :: ZERO = 0.0_wp, ONE = 1.0_wp
    real(wp), parameter :: TWO = 2.0_wp

    real(wp) :: lambda, lhat

    lwsha = 70928
    lwshs = 70928
    lwvha = 141647
    lwvhs = 141647
    lwvts = 141647

    degree_to_radian = PI/180
    aa = 6.37122e+6_wp
    omega = 7.292e-5_wp
    fzero = TWO * omega
    uzero = 40.0_wp
    pzero = 2.94e4_wp
    alphad = 60.0_wp
    alpha = degree_to_radian * alphad
    dt = 600.0_wp
    two_dt = TWO * dt

    ! Initialize wavetables
    call initialize_shaes(nlat, nlon, wsha, ierror)
    call initialize_shses(nlat, nlon, wshs, ierror)
    call initialize_vhaes(nlat, nlon, wvha, ierror)
    call initialize_vhses(nlat, nlon, wvhs, ierror)
    call initialize_vtses(nlat, nlon, wvts, ierror)

    !
    !
    !     compute the derivative of the unrotated geopotential
    !             p as a function of latitude
    !
    nl = 91
    cfn = ONE/(nl - 1)
    dlath = PI/(nl - 1)
    do i=1, nl - 2
        theta = real(i, kind=wp) * dlath
        sth = sin(theta)
        cth = cos(theta)
        uhat = ui(uzero, HALF_PI-theta)
        phlt(i) = cfn*cth*uhat*(uhat/sth+aa*fzero)
    end do
    !
    !     compute sine transform of the derivative of the geopotential
    !     for the purpose of computing the geopotential by integration
    !     see equation (3.9) in reference [1] above
    !
    call sine_transform(phlt(1:nl-2))
    !
    !     compute the cosine coefficients of the unrotated geopotential
    !     by the formal integration of the sine series representation
    !
    do i=1, nl - 2
        phlt(i) = -phlt(i)/i
    end do
    !
    !     phlt(i) contains the coefficients in the cosine series
    !     representation of the unrotated geopotential that are used
    !     below to compute the geopotential on the rotated grid.
    !
    !     compute the initial values of  east longitudinal
    !     and latitudinal velocities u and v as well as the
    !     geopotential p and coriolis f on the rotated grid.
    !
    block
        real(wp) :: cosa, sina, dlam, dtheta
        real(wp) :: cosl, sinl

        cosa = cos(alpha)
        sina = sin(alpha)
        dtheta = pi/(nlat-1)
        dlam = TWO_PI/nlon
        do j=1, nlon
            lambda = real(j - 1, kind=wp) * dlam
            cosl = cos(lambda)
            sinl = sin(lambda)
            do i=1, nlat
                !
                !     lambda is longitude, theta is colatitude, and pi/2-theta is
                !     latitude on the rotated grid. lhat and that are longitude
                !     and colatitude on the unrotated grid. see text starting at
                !     equation (3.10)
                !
                theta = (i-1)*dtheta
                sint = cos(theta)
                cost = sin(theta)
                sth = cosa*sint+sina*cost*cosl
                cthclh = cosa*cost*cosl-sina*sint
                cthslh = cost*sinl
                lhat = atanxy(cthclh, cthslh)
                clh = cos(lhat)
                slh = sin(lhat)
                cth = clh*cthclh+slh*cthslh
                that = atanxy(sth, cth)
                uhat = ui(uzero, HALF_PI-that)
                pxact(i, j) = cosine(that, nl-2, phlt)
                uxact(i, j) = uhat*(cosa*sinl*slh+cosl*clh)
                vxact(i, j) = uhat*(cosa*cosl*slh*sint-clh*sinl*sint+sina*slh*cost)
                f(i, j) = fzero*sth
            end do
        end do
    end block

    vmax = ZERO
    pmax = ZERO
    v2max = ZERO
    p2max = ZERO
    do  j=1, nlon
        do i=1, nlat
            v2max = v2max+uxact(i, j)**2+vxact(i, j)**2
            p2max = p2max+pxact(i, j)**2
            vmax = max(abs(uxact(i, j)), abs(vxact(i, j)), vmax)
            pmax = max(abs(pxact(i, j)), pmax)
        end do
    end do

    ! Initialize first time step
    u(1: nlat, 1: nlon) = uxact(1: nlat, 1: nlon)
    v(1: nlat, 1: nlon) = vxact(1: nlat, 1: nlon)
    p(1: nlat, 1: nlon) = pxact(1: nlat, 1: nlon)

    time = ZERO
    ctime = ZERO
    ncycle = ZERO
    !
    !     start of the time loop
    !
    !   begin step 1, section 3
    !
    !     analyze the velocity components (u, v)
    !
    do while (ncycle <= itmax)
        call vhaesgo(nlat, nlon, isym, nt, u, v, idp, jdp, br, bi, cr, ci, &
            mdab, ndab, wvha, ierror)
        if (ierror /= 0) write (*, 91) ierror
91      format(' error' i4 ' in vhaes')
        !
        !     truncate spectrum to eliminate aliasing of the
        !     product terms in the shallow-water equations
        !
        call trunc(nlat, max_wave_number, mdab, br, bi)
        call trunc(nlat, max_wave_number, mdab, cr, ci)
        !
        !     resynthesize the velocity components
        !
        call vhsesgo(nlat, nlon, isym, nt, u, v, idp, jdp, br, bi, cr, ci, &
            mdab, ndab, wvhs, lwvhs, work, lwork, ierror)
        if (ierror /= 0) write (*, 92) ierror
92      format(' error' i4 ' in vhses')
        !
        !   begin step 2, section 3
        !
        !     analyze geopotential p
        !
        call shaes(nlat, nlon, isym, nt, p, idp, jdp, a, b, mdab, ndab, &
            wsha, ierror)
        if (ierror /= 0) write (*, 93) ierror
93      format(' error' i4 ' in shaes')
        !
        !     truncate spectrum to eliminate aliasing of the
        !     product terms in the shallow-water equations
        !
        call trunc(nlat, max_wave_number, mdab, a, b)
        !
        !     resynthesize the geopotential p
        !
        call shses(nlat, nlon, isym, nt, p, idp, jdp, a, b, mdab, ndab, &
            wshs, ierror)
        if (ierror /= 0) write (*, 94) ierror
94      format(' error' i4 ' in shses')
        !
        !
        !   begin step 3, section 3
        !
        !     compute the vorticity of the velocity (u, v)
        !
        call vrtes(nlat, nlon, isym, nt, vort, idp, jdp, cr, ci, mdab, ndab, &
            wshs, ierror)
        if (ierror /= 0) write (*, 95) ierror
95      format(' error' i4 ' in vrtes')
        !
        !     compute the divergence of the velocity (u, v)
        !
        call dives(nlat, nlon, isym, nt, divg, idp, jdp, br, bi, mdab, ndab, &
            wshs, ierror)
        if (ierror /= 0) write (*, 96) ierror
96      format(' error' i4 ' in dives')
        !
        !   begin step 4, section 3
        !
        !     compute the derivative of the velocity (u, v) with
        !     respect to colatitude theta.
        !
        call vtsesgo(nlat, nlon, isym, nt, ut, vt, idp, jdp, br, bi, cr, ci, &
            mdab, ndab, wvts, lwvts, work, lwork, ierror)
        if (ierror /= 0) write (*, 97) ierror
97      format(' error' i4 ' in vtsesgo')
        !
        !   begin step 5, section 3
        !
        !     compute the gradient of the geopotential p
        !
        call gradesgo(nlat, nlon, isym, nt, gpdl, gpdt, idp, jdp, a, b, mdab, ndab, &
            wvhs, lwvhs, work, lwork, ierror)
        if (ierror /= 0) write (*, 98) ierror
98      format(' error' i4 ' in grades')
        !
        !     compute the time derivatives of the velocity (u, v)
        !     and the geopotential p using the shallow-water
        !     equations (2.8), (2.9), and (2.10), section 3.
        !
        dudt(1: nlat, 1: nlon) = (u(1: nlat, 1: nlon)*(vt(1: nlat, 1: nlon) &
            -divg(1: nlat, 1: nlon))-v(1: nlat, 1: nlon)*ut(1: nlat, 1: nlon) &
            -gpdl(1: nlat, 1: nlon))/aa+f(1: nlat, 1: nlon)*v(1: nlat, 1: nlon)
        dvdt(1: nlat, 1: nlon) = -(u(1: nlat, 1: nlon)*(vort(1: nlat, 1: nlon) &
            +ut(1: nlat, 1: nlon))+v(1: nlat, 1: nlon)*vt(1: nlat, 1: nlon) &
            +gpdt(1: nlat, 1: nlon))/aa-f(1: nlat, 1: nlon)*u(1: nlat, 1: nlon)
        dpdt(1: nlat, 1: nlon) = -((p(1: nlat, 1: nlon)+pzero)*divg(1: nlat, 1: nlon) &
            +v(1: nlat, 1: nlon)*gpdt(1: nlat, 1: nlon) &
            +u(1: nlat, 1: nlon)*gpdl(1: nlat, 1: nlon))/aa

        if (mod(ncycle, mprint) == 0) then
            htime = time/3600.

            write (*, 390) ncycle, htime, dt, nlat, nlon, max_wave_number, omega, pzero, &
                uzero, alphad
390         format(//' steady nonlinear rotated flow, test case 3'/ &
                ' cycle number              ' i10 &
                ' model time in  hours      ' f10.2/ &
                ' time step in seconds      ' f10.0 &
                ' number of latitudes       ' i10/ &
                ' number of longitudes      ' i10 &
                ' max wave number           ' i10/ &
                ' rotation rate        ' 1pe15.6 &
                ' mean height          ' 1pe15.6/ &
                ' maximum velocity     ' 1pe15.6 &
                ' tilt angle                ' f10.2)
            dvgm = ZERO
            dvmax = ZERO
            dpmax = ZERO
            evmax = ZERO
            epmax = ZERO
            do j=1, nlon
                do i=1, nlat
                    dvgm = max(dvgm, abs(divg(i, j)))
                    dvmax = dvmax+(u(i, j)-uxact(i, j))**2+(v(i, j)-vxact(i, j))**2
                    dpmax = dpmax+(p(i, j)-pxact(i, j))**2
                    evmax = max(evmax, abs(v(i, j)-vxact(i, j)), abs(u(i, j)-uxact(i, j)))
                    epmax = max(epmax, abs(p(i, j)-pxact(i, j)))
                end do
            end do

            dvmax = sqrt(dvmax/v2max)
            dpmax = sqrt(dpmax/p2max)
            evmax = evmax/vmax
            epmax = epmax/pmax

            write (*, 391) evmax, epmax, dvmax, dpmax, dvgm
391         format(' max error in velocity' 1pe15.6 &
                ' max error in geopot. ' 1pe15.6/ &
                ' l2 error in velocity ' 1pe15.6 &
                ' l2 error in geopot.  ' 1pe15.6/ &
                ' maximum divergence   ' 1pe15.6)
        end if

        ! Set values at time = -dt to values at time = 0.
        if (ncycle == 0) then
            uold(1: nlat, 1: nlon) = u(1: nlat, 1: nlon)
            vold(1: nlat, 1: nlon) = v(1: nlat, 1: nlon)
            pold(1: nlat, 1: nlon) = p(1: nlat, 1: nlon)
        end if

        ! Compute values at next time level using leap frog
        ! time differencing
        unew(1: nlat, 1: nlon) = uold(1: nlat, 1: nlon)+two_dt*dudt(1: nlat, 1: nlon)
        vnew(1: nlat, 1: nlon) = vold(1: nlat, 1: nlon)+two_dt*dvdt(1: nlat, 1: nlon)
        pnew(1: nlat, 1: nlon) = pold(1: nlat, 1: nlon)+two_dt*dpdt(1: nlat, 1: nlon)

        ! Update values to next time level
        uold(1: nlat, 1: nlon) = u(1: nlat, 1: nlon)
        vold(1: nlat, 1: nlon) = v(1: nlat, 1: nlon)
        pold(1: nlat, 1: nlon) = p(1: nlat, 1: nlon)
        u(1: nlat, 1: nlon) = unew(1: nlat, 1: nlon)
        v(1: nlat, 1: nlon) = vnew(1: nlat, 1: nlon)
        p(1: nlat, 1: nlon) = pnew(1: nlat, 1: nlon)

        ncycle = ncycle + 1
        time = time + dt
    end do

    ! Release memory
    deallocate (wsha)
    deallocate (wshs)
    deallocate (wvha)
    deallocate (wvhs)
    deallocate (wvts)

contains

    subroutine vtsesgo(nlat, nlon, ityp, nt, ut, vt, idvw, jdvw, br, bi, cr, ci, &
        mdab, ndab, wvts, lwvts, work, lwork, ierror)

        real(wp), dimension(..) :: br, bi, cr, ci
        integer(ip) :: i
        integer(ip) :: idvw
        integer(ip) :: ierror
        integer(ip) :: ityp
        integer(ip) :: j
        integer(ip) :: jdvw
        integer(ip) :: k
        integer(ip) :: lwork
        integer(ip) :: lwvts
        integer(ip) :: mdab
        integer(ip) :: ndab
        integer(ip) :: nlat
        integer(ip) :: nlon
        integer(ip) :: nt
        real(wp) :: ut(idvw, jdvw, *), vt(idvw, jdvw, *)
        real(wp) :: wvts(:), work(:)
        !
        !     vtsesgo computes the latitudinal derivatives of the
        !     velocity components using subroutine vtses which
        !     assumes the velocity components are given in terms
        !     of mathematical coordinates

        call vtses(nlat, nlon, ityp, nt, vt, ut, idvw, jdvw, br, bi, cr, ci, &
            mdab, ndab, wvts, ierror)

        do k=1, nt
            do j=1, nlon
                do i=1, nlat
                    ut(i, j, k) = -ut(i, j, k)
                end do
            end do
        end do

    end subroutine vtsesgo

    !     computes the initial unrotated longitudinal velocity
    !     see section 3.3.
    pure function ui(amp, thetad) &
        result (return_value)

        ! Dummy arguments
        real(wp), intent(in) :: amp
        real(wp), intent(in) :: thetad
        real(wp)             :: return_value

        ! Local variables
        real(wp) :: thetae, thetab, x, xe

        thetab = -PI/6
        thetae = HALF_PI
        xe = 3.0e-1_wp

        x = xe * (thetad-thetab)/(thetae-thetab)
        if (x <= ZERO .or. x >= xe) then
            return_value = ZERO
        else
            return_value = amp * exp(-ONE/x-ONE/(xe-x)+4./xe)
        end if

    end function ui

    pure function atanxy(x, y) &
        result (return_value)

        ! Dummy arguments
        real(wp), intent(in) :: x
        real(wp), intent(in) :: y
        real(wp)             :: return_value

        return_value = ZERO

        if (x == ZERO .and. y == ZERO) return

        return_value = atan2(y, x)

    end function atanxy

    subroutine sine_transform(x)

        ! Dummy arguments
        real(wp), intent(inout) :: x(:)

        ! Local variables
        integer(ip) :: i, j

        associate (n => size(x))
            block
                real(wp) :: w(n), arg

                arg = PI/(n+1)

                do j=1, n
                    w(j) = ZERO
                    do i=1, n
                        w(j) = w(j)+x(i)*sin(real(i*j, kind=wp)*arg)
                    end do
                end do

                x = TWO * w
            end block
        end associate

    end subroutine sine_transform

    real function cosine(theta, n, cf)

        real(wp) :: cf
        integer(ip) :: i
        integer(ip) :: n
        real(wp) :: theta
        !
        !     computes the cosine transform
        !
        dimension cf(n)
        cosine = ZERO
        do i=1, n
            cosine = cosine+cf(i)*cos(i*theta)
        end do

    end function cosine

    subroutine trunc(nm, ms, id, a, b)

        real(wp) :: a(id,*)
        real(wp) :: b(id,*)
        integer(ip) :: id
        integer(ip) :: m

        integer(ip) :: ms
        integer(ip) :: n
        integer(ip) :: nm
        !
        !     truncates spectral coefficients so that aliasing
        !     does not occur when computing the spectral representations
        !     of the product terms.
        !

        do n=ms + 2, nm
            do m=1, n
                a(m, n) = ZERO
                b(m, n) = ZERO
            end do
        end do

    end subroutine trunc

    subroutine vhaesgo(nlat, nlon, ityp, nt, u, v, iduv, jduv, &
        br, bi, cr, ci, mdab, ndab, wsav, ierror)

        real(wp) :: bi
        real(wp) :: br
        real(wp) :: ci
        real(wp) :: cr
        integer(ip) :: i
        integer(ip) :: iduv
        integer(ip) :: ierror
        integer(ip) :: ityp
        integer(ip) :: j
        integer(ip) :: jduv
        integer(ip) :: k

        integer(ip) :: mdab
        integer(ip) :: ndab
        integer(ip) :: nlat
        integer(ip) :: nlon
        integer(ip) :: nt
        real(wp) :: u
        real(wp) :: v
        real(wp) :: wsav(:)
        dimension u(iduv, jduv, *), v(iduv, jduv, *), br(mdab, ndab, *), &
            bi(mdab, ndab, *), cr(mdab, ndab, *), ci(mdab, ndab, *)

        !     vhaesgo computes the vector harmonic analysis of (u, v) using vhaes which
        !     assumes the velocity components are given in mathematical coordinates
        !
        do k=1, nt
            do j=1, nlon
                do i=1, nlat
                    v(i, j, k) = -v(i, j, k)
                end do
            end do
        end do

        call vhaes(nlat, nlon, ityp, nt, v, u, iduv, jduv, &
            br, bi, cr, ci, mdab, ndab, wsav, ierror)
        !
        !     restore v
        !
        do k=1, nt
            do j=1, nlon
                do i=1, nlat
                    v(i, j, k) = -v(i, j, k)
                end do
            end do
        end do

        if (ierror /= 0) return

    end subroutine vhaesgo

    subroutine vhsesgo(nlat, nlon, ityp, nt, u, v, iduv, jduv, &
        br, bi, cr, ci, mdab, ndab, wsav, lwsav, work, lwork, ierror)
        implicit none
        real(wp) :: bi
        real(wp) :: br
        real(wp) :: ci
        real(wp) :: cr
        integer(ip) :: i
        integer(ip) :: iduv
        integer(ip) :: ierror
        integer(ip) :: ityp
        integer(ip) :: j
        integer(ip) :: jduv
        integer(ip) :: k
        integer(ip) :: lwork
        integer(ip) :: lwsav
        integer(ip) :: mdab
        integer(ip) :: ndab
        integer(ip) :: nlat
        integer(ip) :: nlon
        integer(ip) :: nt
        real(wp) :: u
        real(wp) :: v
        real(wp) :: work(..)
        real(wp) :: wsav(:)
        dimension u(iduv, jduv, *), v(iduv, jduv, *), br(mdab, ndab, *), &
            bi(mdab, ndab, *), cr(mdab, ndab, *), ci(mdab, ndab, *)
        !
        !     vhsesgo computes a vector harmonic synthesis in (u, v) using vhses which
        !     assumes the velocity components are given in mathematical coordinates
        !
        call vhses(nlat, nlon, ityp, nt, v, u, iduv, jduv, &
            br, bi, cr, ci, mdab, ndab, wsav, ierror)

        if (ierror /= 0) return

        do k=1, nt
            do j=1, nlon
                do i=1, nlat
                    v(i, j, k) = -v(i, j, k)
                end do
            end do
        end do

    end subroutine vhsesgo

    subroutine gradesgo(nlat, nlon, isym, nt, u, v, iduv, jduv, a, b, &
        mdab, ndab, wsav, lwsav, work, lwork, ierror)
        implicit none
        real(wp) :: a
        real(wp) :: b
        integer(ip) :: i
        integer(ip) :: iduv
        integer(ip) :: ierror
        integer(ip) :: isym
        integer(ip) :: j
        integer(ip) :: jduv
        integer(ip) :: k
        integer(ip) :: lwork
        integer(ip) :: lwsav
        integer(ip) :: mdab
        integer(ip) :: ndab
        integer(ip) :: nlat
        integer(ip) :: nlon
        integer(ip) :: nt
        real(wp) :: u
        real(wp) :: v
        real(wp) :: work
        real(wp) :: wsav
        dimension u(iduv, jduv, nt), v(iduv, jduv, nt)
        dimension a(mdab, ndab, nt), b(mdab, ndab, nt)
        dimension wsav(lwsav), work(lwork)
        !
        !     gradesgo computes the gradient in (u, v) using grades which assumes
        !     the velocity components are given in mathematical coordinates
        !
        call grades(nlat, nlon, isym, nt, v, u, iduv, jduv, a, b, &
            mdab, ndab, wsav, ierror)

        if (ierror /= 0) return

        do k=1, nt
            do j=1, nlon
                do i=1, nlat
                    v(i, j, k) = -v(i, j, k)
                end do
            end do
        end do

    end subroutine gradesgo

end program shallow


submodule(euler_interface_m) euler_prob_0001_m
    implicit none

contains

    module character(len=20) function euler0001()
        write (euler0001, "(i20)") answer(3, 5, 1000)
    end function euler0001

    pure function answer(i, j, n) result(ret)
        integer, intent(in) :: i, j, n
        integer :: ret

        ret = sum_divisibly_by(i, n - 1) + &
              sum_divisibly_by(j, n - 1) - &
              sum_divisibly_by(i*j, n - 1)
    end function answer

    pure function sum_divisibly_by(i, j) result(ret)
        integer, intent(in) :: i, j
        integer :: ret

        ret = i*(j/i*(j/i + 1))/2
    end function sum_divisibly_by

end submodule euler_prob_0001_m


module math_mod

use constants_mod

interface minmod
    module procedure minmod2
    module procedure minmod3_foo
    module procedure minmod4
    module procedure minmod5
end interface

contains

pure elemental function sigmoid(x) result(r)

    real(dp), intent(in) :: x
    real(dp)             :: r

    !r = 0.5_dp + 0.5_dp*tanh(0.5_dp*x)
    r = 1.0_dp/(1.0_dp + exp(-x))

end function

pure elemental function minmod2(a,b) result(r)

    real(dp), intent(in) :: a,b
    real(dp)             :: r

    r = 0.5_dp*(sign(1.0_dp,a)+sign(1.0_dp,b))*min(abs(a),abs(b))

end function

pure elemental function minmod3_foo(a,b,c) result(r)

    real(dp), intent(in) :: a,b,c
    real(dp)             :: r

    r = minmod2(minmod2(a,b),c)

end function

pure elemental function minmod4(a,b,c,d) result(r)

    real(dp), intent(in) :: a,b,c,d
    real(dp)             :: r

    r = minmod2(minmod2(minmod2(a,b),c),d)

end function

pure elemental function minmod5(a,b,c,d,e) result(r)

    real(dp), intent(in) :: a,b,c,d,e
    real(dp)             :: r

    r = minmod2(minmod2(minmod2(minmod2(a,b),c),d),e)

end function

pure elemental function median(l,c,r) result(m)

    real(dp), intent(in) :: l,c,r
    real(dp)             :: m

    m = c + minmod2(c-l,c-r)

end function

pure elemental function curvature(l,c,r) result(m)

    real(dp), intent(in) :: l,c,r
    real(dp)             :: m

    m = l - 2.0_dp*c + r

end function

pure elemental function minmod3(a1,a2,a3) result(mm)

    real(dp), intent(in) :: a1, a2, a3
    real(dp)             :: mm

    if (((sign(1.0_dp,a1)*sign(1.0_dp,a2)) > 0.0_dp) .and. ((sign(1.0_dp,a2)*sign(1.0_dp,a3)) > 0.0_dp)) then
        mm = sign(min(abs(a1),abs(a2),abs(a3)),a1)
    else
        mm = 0.0_dp
    end if

end function

end module


module map

public :: stereo
public :: utmgeo

!--------------------------------------------------------------------------------------------------!
contains
!--------------------------------------------------------------------------------------------------!

subroutine stereo(lon,lat,x,y,lon0,lat0,radius,mode,ierr)
!----
! Compute the lower hemisphere stereographic projection of geographic points or the inverse
! projection for a set of Cartesian points.
!----

use io, only: stderr
use trig, only: d2r

implicit none

! Arguments
double precision :: lon, lat, x, y, lon0, lat0, radius
character(len=*) :: mode
integer :: ierr

! Local variables
double precision :: k, rho, c, arg1

ierr = 0

if (mode.eq.'lonlat2xy') then
    k = 2.0d0*radius/(1.0d0 + sin(lat0*d2r)*sin(lat*d2r) + &
                              cos(lat0*d2r)*cos(lat*d2r)*cos(lon*d2r-lon0*d2r))
    x = k*cos(lat*d2r)*sin(lon*d2r-lon0*d2r)
    y = k*(cos(lat0*d2r)*sin(lat*d2r)-sin(lat0*d2r)*cos(lat*d2r)*cos(lon*d2r-lon0*d2r))
elseif (mode.eq.'xy2lonlat') then
    rho = sqrt(x*x+y*y)
    c = 2.0d0*atan2(rho,2.0d0*radius)
    arg1 = cos(c)*sin(lat0*d2r) + y*sin(c)*cos(lat0*d2r)/rho
    lat = atan2(arg1, sqrt(1.0d0-arg1*arg1))/d2r
    lon = lon0 + atan2(x*sin(c),rho*cos(lat0*d2r)*cos(c)-y*sin(lat0*d2r)*sin(c))/d2r
else
    write(stderr,*) 'stereo: mode must be "lonlat2xy" or "xy2lonlat"'
    ierr = 1
    return
endif

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine utmgeo(rlon4,rlat4,rx4,ry4,utm_zone,iway,ierr)
!----
! Code to convert to and from UTM coordinates and geographic coordinates modified from Specfem3d
!     iway=1: utm->lonlat
!     iway=2: lonlat->utm
!
! Their note: UTM grids are actually Mercators which employ the standard UTM scale factor 0.9996
! and set the Easting Origin to 500,000.
!----

use io, only: stderr
use trig, only: r2d, d2r
use earth, only: semimajor_wgs84, semiminor_wgs84

implicit none

! Arguments
double precision :: rx4, ry4, rlon4, rlat4
integer :: utm_zone, iway, ierr

! Local variables
double precision, parameter :: scale_factor = 0.9996d0
double precision, parameter :: north = 0.0d0
double precision, parameter :: east = 500000.0d0
integer :: zone
double precision :: rlon, rlat
double precision :: e2, e4, e6, ep2, xx, yy, dlat, dlon, cm, cmr, delam
double precision :: f1, f2, f3, f4, rm, rn, t, c, a, e1, u, rlat1, dlat1, c1, t1, rn1, r1, d
double precision :: rx_save, ry_save, rlon_save, rlat_save
logical :: lsouth

ierr = 0

if (iway.ne.1.and.iway.ne.2) then
    write(stderr,*) 'utmgeo: iway must be 1 (utm to lon/lat) or 2 (lon/lat to utm)'
    ierr = 1
    return
endif

dlon = 0.0d0
dlat = 0.0d0
xx = 0.0d0
yy = 0.0d0

rlon_save = rlon4
rlat_save = rlat4
rx_save = rx4
ry_save = ry4

e2 = 1.d0-(semiminor_wgs84/semimajor_wgs84)**2
e4 = e2*e2
e6 = e2*e4
ep2 = e2/(1.d0-e2)

lsouth = .false.
if (utm_zone.lt.0) then
    lsouth = .true.
endif
zone = abs(utm_zone)
cm = zone*6.0d0 - 183.d0
cmr = cm*d2r

if (iway.eq.1) then
    xx = rx4
    yy = ry4
    if (lsouth) then
        yy = yy - 1.0d7
    endif
else
    dlat = rlat4
    dlon = rlon4
endif

if (iway.eq.2) then

    ! Longitude and latitude to UTM conversion

    rlon = d2r*dlon
    rlat = d2r*dlat

    delam = dlon - cm
    if (delam.lt.-180.d0) then
        delam = delam + 360.d0
    endif
    if (delam.gt.180.d0) then
        delam = delam - 360.d0
    endif
    delam = delam*d2r

    f1 = (1.d0 - e2/4.d0 - 3.d0*e4/64.d0 - 5.d0*e6/256d0)*rlat
    f2 = 3.d0*e2/8.d0 + 3.d0*e4/32.d0 + 45.d0*e6/1024.d0
    f2 = f2*sin(2.d0*rlat)
    f3 = 15.d0*e4/256.d0*45.d0*e6/1024.d0
    f3 = f3*sin(4.d0*rlat)
    f4 = 35.d0*e6/3072.d0
    f4 = f4*sin(6.d0*rlat)
    rm = semimajor_wgs84*(f1 - f2 + f3 - f4)

    if (abs(dlat-90.d0).lt.1.0d-6.or.abs(dlat+90.d0).lt.1.0d-6) then
        xx = 0.d0
        yy = scale_factor*rm
    else
        rn = semimajor_wgs84/sqrt(1.d0 - e2*sin(rlat)**2)
        t = tan(rlat)**2
        c = ep2*cos(rlat)**2
        a = cos(rlat)*delam

        f1 = (1.d0 - t + c)*a**3/6.d0
        f2 = 5.d0 - 18.d0*t + t**2 + 72.d0*c - 58.d0*ep2
        f2 = f2*a**5/120.d0
        xx = scale_factor*rn*(a + f1 + f2)
        f1 = a**2/2.d0
        f2 = 5.d0 - t + 9.d0*c + 4.d0*c**2
        f2 = f2*a**4/24.d0
        f3 = 61.d0 - 58.d0*t + t**2 + 600.d0*c - 330.d0*ep2
        f3 = f3*a**6/720.d0
        yy = scale_factor*(rm + rn*tan(rlat)*(f1 + f2 + f3))
    endif
    xx = xx + east
    yy = yy + north

else

    ! UTM to longitude and latitude
    xx = xx - east
    yy = yy - north
    e1 = sqrt(1.d0 - e2)
    e1 = (1.d0 - e1)/(1.d0 + e1)
    rm = yy/scale_factor
    u = 1.d0 - e2/4.d0 - 3.d0*e4/64.d0 - 5.d0*e6/256.d0
    u = rm/(semimajor_wgs84*u)

    f1 = 3.d0*e1/2.d0 - 27.d0*e1**3.d0/32.d0
    f1 = f1*sin(2.d0*u)
    f2 = 21.d0*e1**2/16.d0 - 55.d0*e1**4/32.d0
    f2 = f2*sin(4.d0*u)
    f3 = 151.d0*e1**3.d0/96.d0
    f3 = f3*sin(6.d0*u)
    rlat1 = u + f1 + f2 + f3
    dlat1 = rlat1*r2d
    if (dlat1.ge.90.d0.or.dlat1.le.-90.d0) then
        dlat1 = dmin1(dlat1,90.d0)
        dlat1 = dmax1(dlat1,-90.d0)
        dlon = cm
    else
        c1 = ep2*cos(rlat1)**2
        t1 = tan(rlat1)**2
        f1 = 1.d0 - e2*sin(rlat1)**2
        rn1 = semimajor_wgs84/sqrt(f1)
        r1 = semimajor_wgs84*(1.d0 - e2)/sqrt(f1**3)
        d = xx/(rn1*scale_factor)

        f1 = rn1*tan(rlat1)/r1
        f2 = d**2/2.d0
        f3 = 5.d0*3.d0*t1 + 10.d0*c1 - 4.d0*c1**2 - 9.d0*ep2
        f3 = f3*d**2*d**2/24.d0
        f4 = 61.d0 + 90.d0*t1 + 298.d0*c1 + 45.d0*t1**2 - 252.d0*ep2 - 3.d0*c1**2
        f4 = f4*(d**2)**3.d0/720.d0
        rlat = rlat1 - f1*(f2 - f3 + f4)
        dlat = rlat*r2d

        f1 = 1.d0 + 2.d0*t1 + c1
        f1 = f1*d**2*d/6.d0
        f2 = 5.d0 - 2.d0*c1 + 28.d0*t1 - 3.d0*c1**2 + 8.d0*ep2 + 24.d0*t1**2
        f2 = f2*(d**2)**2*d/120.d0
        rlon = cmr + (d - f1 + f2)/cos(rlat1)
        dlon = rlon*r2d
        if (dlon.lt.-180.d0) then
            dlon = dlon + 360.d0
        endif
        if (dlon.gt.180.d0) then
            dlon = dlon - 360.d0
        endif
    endif
endif

if (iway.eq.1) then
    rlon4 = dlon
    rlat4 = dlat
    rx4 = rx_save
    ry4 = ry_save
else
    rx4 = xx
    if (lsouth) then
        yy = yy + 1.0d7
    endif
    ry4 = yy
    rlon4 = rlon_save
    rlat4 = rlat_save
endif

return
end subroutine

end module


c
c  bcspeval -- eval bicubic spline function and/or derivatives
c
      subroutine r8bcspeval(xget,yget,iselect,fval,
     >                    x,nx,y,ny,ilinx,iliny,f,inf3,ier)
c
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      integer iselect(6)
      integer ilinx,iliny,nx,ny,inf3,ier
c
      REAL*8 xget,yget
      REAL*8 fval(*)
      REAL*8 x(nx),y(ny),f(4,4,inf3,ny)
c
c  modification -- dmc 11 Jan 1999 -- remove SAVE stmts; break routine
C    into these parts:
C
C    bcspevxy -- find grid cell of target pt.
C    bcspevfn -- evaluate function using output of bcpsevxy
C
C    in cases where multiple functions are defined on the same grid,
C    time can be saved by using bcspevxy once and then bcspevfn
C    multiple times.
c
c  input:
c     (xget,yget)   location where interpolated value is desired
c                   x(1).le.xget.le.x(nx) expected
c                   y(1).le.yget.le.y(ny) expected
c
c     iselect       select desired output
c
c                     iselect(1)=1 -- want function value (f) itself
c                     iselect(2)=1 -- want  df/dx
c                     iselect(3)=1 -- want  df/dy
c                     iselect(4)=1 -- want  d2f/dx2
c                     iselect(5)=1 -- want  d2f/dy2
c                     iselect(6)=1 -- want  d2f/dxdy
c
c              example:  iselect(1)=iselect(2)=iselect(3)=1
c                            f, df/dx, and df/dy all evaluated
c                        iselect(4)=iselect(5)=iselect(6)=0
c                            2nd derivatives not evaluated.
c
c                   the number of non zero values iselect(1:6)
c                   determines the number of outputs...
c                   see fval (output) description.
c
c  new dmc December 2005 -- access to higher derivatives (even if not
c  continuous-- but can only go up to 3rd derivatives on any one coordinate.
c     if iselect(1)=3 -- want 3rd derivatives
c          iselect(2)=1 for d3f/dx3
c          iselect(3)=1 for d3f/dx2dy
c          iselect(4)=1 for d3f/dxdy2
c          iselect(5)=1 for d3f/dy3
c               number of non-zero values iselect(2:5) gives no. of outputs
c     if iselect(1)=4 -- want 4th derivatives
c          iselect(2)=1 for d4f/dx3dy
c          iselect(3)=1 for d4f/dx2dy2
c          iselect(4)=1 for d4f/dxdy3
c               number of non-zero values iselect(2:4) gives no. of outputs
c     if iselect(1)=5 -- want 5th derivatives
c          iselect(2)=1 for d5f/dx3dy2
c          iselect(3)=1 for d5f/dx2dy3
c               number of non-zero values iselect(2:3) gives no. of outputs
c     if iselect(1)=6 -- want 6th derivatives
c          d6f/dx3dy3 -- one value is returned.
c
c     x(1...nx)     independent coordinate x, strict ascending
c     y(1...ny)     independent coordinate y, strict ascending
c
c     ilinx  --  =1: flag that x is linearly spaced (avoid search for speed)
c     iliny  --  =1: flag that y is linearly spaced (avoid search for speed)
c
c  **CAUTION** actual even spacing of x, y is NOT CHECKED HERE!
c
c
c     f             the function values (at grid points) and spline coefs
c
c  evaluation formula:  for point x btw x(i) and x(i+1), dx=x-x(i)
c                             and y btw y(j) and y(j+1), dy=y-y(j),
c
c      spline value =
c        f(1,1,i,j) + dx*f(2,1,i,j) + dx**2*f(3,1,i,j) + dx**3*f(4,1,i,j)
c   +dy*(f(1,2,i,j) + dx*f(2,2,i,j) + dx**2*f(3,2,i,j) + dx**3*f(4,2,i,j))
c   +d2*(f(1,3,i,j) + dx*f(2,3,i,j) + dx**2*f(3,3,i,j) + dx**3*f(4,3,i,j))
c   +d3*(f(1,4,i,j) + dx*f(2,4,i,j) + dx**2*f(3,4,i,j) + dx**3*f(4,4,i,j))
c
c      where d2=dy**2 and d3=dy**3.
c
c  output:
c      up to 6 elements of fval, ordered as follows:
c        fval(1)=function value or lowest order derivative requested
c        fval(2)=next order derivative
c             etc
c        the ordering is a subset of the sequence given under the "iselect"
c        description.
c
c      ier = 0 -- successful completion; = 1 -- an error occurred.
c
c-------------------------------------------------------------------
c  local
c
      integer :: i(1)
      integer :: j(1)
c
      REAL*8 dx(1),dy(1)
c
c--------------------------
c
      i(1)=0
      j(1)=0
c
      call r8bcspevxy(xget,yget,x,nx,y,ny,ilinx,iliny,
     >   i(1),j(1),dx(1),dy(1),ier)
      if(ier.ne.0) return
c
      call r8bcspevfn(iselect,1,1,fval,i,j,dx,dy,f,inf3,ny)
c
      return
      end
c
c-------------------------------------------------------------------------
c  bcspevxy -- look up x-y zone
c
c  this is the "first part" of bcspeval, see comments, above.
c
      subroutine r8bcspevxy(xget,yget,x,nx,y,ny,ilinx,iliny,
     >   i,j,dx,dy,ier)
c
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER nxm,nym,ii,jj
!============
! idecl:  explicitize implicit REAL declarations:
      REAL*8 zxget,zyget,zxtol,zytol
!============
      integer nx,ny                     ! array dimensions
c
      REAL*8 xget,yget                    ! target point
      REAL*8 x(nx),y(ny)                  ! indep. coords.
c
      integer ilinx                     ! =1:  assume x evenly spaced
      integer iliny                     ! =1:  assume y evenly spaced
c
c  output of bcspevxy
c
      integer i,j                       ! index to cell containing target pt
      REAL*8 dx,dy                        ! displacement of target pt w/in cell
                                        ! dx=x-x(i)  dy=y-y(j)
C
      integer ier                       ! return ier.ne.0 on error
c
c------------------------------------
c
      ier=0
c
c  range check
c
      zxget=xget
      zyget=yget

      if((xget.lt.x(1)).or.(xget.gt.x(nx))) then
         zxtol=4.0E-7_r8*max(abs(x(1)),abs(x(nx)))
         if((xget.lt.x(1)-zxtol).or.(xget.gt.x(nx)+zxtol)) then
            ier=1
            write(6,1001) xget,x(1),x(nx)
 1001       format(' ?bcspeval:  xget=',1pe11.4,' out of range ',
     >         1pe11.4,' to ',1pe11.4)
         else
            if((xget.lt.x(1)-0.5_r8*zxtol).or.
     >         (xget.gt.x(nx)+0.5_r8*zxtol))
     >      write(6,1011) xget,x(1),x(nx)
 1011       format(' %bcspeval:  xget=',1pe15.8,' beyond range ',
     >         1pe15.8,' to ',1pe15.8,' (fixup applied)')
            if(xget.lt.x(1)) then
               zxget=x(1)
            else
               zxget=x(nx)
            endif
         endif
      endif
      if((yget.lt.y(1)).or.(yget.gt.y(ny))) then
         zytol=4.0E-7_r8*max(abs(y(1)),abs(y(ny)))
         if((yget.lt.y(1)-zytol).or.(yget.gt.y(ny)+zytol)) then
            ier=1
            write(6,1002) yget,y(1),y(ny)
 1002       format(' ?bcspeval:  yget=',1pe11.4,' out of range ',
     >         1pe11.4,' to ',1pe11.4)
         else
         if((yget.lt.y(1)-0.5_r8*zytol).or.(yget.gt.y(ny)+0.5_r8*zytol))
     >      write(6,1012) yget,y(1),y(ny)
 1012       format(' %bcspeval:  yget=',1pe15.8,' beyond range ',
     >         1pe15.8,' to ',1pe15.8,' (fixup applied)')
            if(yget.lt.y(1)) then
               zyget=y(1)
            else
               zyget=y(ny)
            endif
         endif
      endif
      if(ier.ne.0) return
c
c  now find interval in which target point lies..
c
      nxm=nx-1
      nym=ny-1
c
      if(ilinx.eq.1) then
         ii=1+nxm*(zxget-x(1))/(x(nx)-x(1))
         i=min(nxm, ii)
         if(zxget.lt.x(i)) then
            i=i-1
         else if(zxget.gt.x(i+1)) then
            i=i+1
         endif
      else
         if((1.le.i).and.(i.lt.nxm)) then
            if((x(i).le.zxget).and.(zxget.le.x(i+1))) then
               continue  ! already have the zone
            else
               call r8zonfind(x,nx,zxget,i)
            endif
         else
            i=nx/2
            call r8zonfind(x,nx,zxget,i)
         endif
      endif
c
      if(iliny.eq.1) then
         jj=1+nym*(zyget-y(1))/(y(ny)-y(1))
         j=min(nym, jj)
         if(zyget.lt.y(j)) then
            j=j-1
         else if(zyget.gt.y(j+1)) then
            j=j+1
         endif
      else
         if((1.le.j).and.(j.lt.nym)) then
            if((y(j).le.zyget).and.(zyget.le.y(j+1))) then
               continue  ! already have the zone
            else
               call r8zonfind(y,ny,zyget,j)
            endif
         else
            j=ny/2
            call r8zonfind(y,ny,zyget,j)
         endif
      endif
c
      dx=zxget-x(i)
      dy=zyget-y(j)
c
      return
      end
c------------------------------------------------------------------------
c  bcspevfn -- OK now evaluate the bicubic spline
c
      subroutine r8bcspevfn(ict,ivec,ivd,fval,iv,jv,dxv,dyv,f,inf3,ny)
c
c  input:
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER ny,iaval,i,j
!============
! idecl:  explicitize implicit REAL declarations:
      REAL*8 dx,dy
!============
      integer ict(6)                    ! selector:
c        ict(1)=1 for f      (don't evaluate f if ict(1)=0)
c        ict(2)=1 for df/dx   ""
c        ict(3)=1 for df/dy   ""
c        ict(4)=1 for d2f/dx2
c        ict(5)=1 for d2f/dy2
c        ict(6)=1 for d2f/dxdy
c
c    note:  if ict(1)=-1, evaluate f,d2f/dx2,d2f/dy2,d4f/dx2dy2
c
c                   the number of non zero values ict(1:6)
c                   determines the number of outputs...
c
c  new dmc December 2005 -- access to higher derivatives (even if not
c  continuous-- but can only go up to 3rd derivatives on any one coordinate.
c     if ict(1)=3 -- want 3rd derivatives
c          ict(2)=1 for d3f/dx3
c          ict(3)=1 for d3f/dx2dy
c          ict(4)=1 for d3f/dxdy2
c          ict(5)=1 for d3f/dy3
c               number of non-zero values ict(2:5) gives no. of outputs
c     if ict(1)=4 -- want 4th derivatives
c          ict(2)=1 for d4f/dx3dy
c          ict(3)=1 for d4f/dx2dy2
c          ict(4)=1 for d4f/dxdy3
c               number of non-zero values ict(2:4) gives no. of outputs
c     if ict(1)=5 -- want 5th derivatives
c          ict(2)=1 for d5f/dx3dy2
c          ict(3)=1 for d5f/dx2dy3
c               number of non-zero values ict(2:3) gives no. of outputs
c     if ict(1)=6 -- want 6th derivatives
c          d6f/dx3dy3 -- one value is returned.
c
      integer ivec,ivd                  ! vector dimensioning
c
c    ivec-- number of vector pts (spline values to look up)
c    ivd -- 1st dimension of fval, .ge.ivec
c
c output:
      REAL*8 fval(ivd,*)                 ! output array
c
c    v = index to element in vector;
c  fval(v,1) = first item requested by ict(...),
c  fval(v,2) = 2nd item requested,  ...etc...
c
c  input:
      integer iv(ivec),jv(ivec)         ! grid cell indices -- vectors
      REAL*8 dxv(ivec),dyv(ivec)          ! displacements w/in cell -- vectors
c
      integer inf3                      ! 3rd dimension of f -- .ge. nx
      REAL*8 f(4,4,inf3,ny)               ! bicubic fcn spline coeffs array
c
c  usage example:
c
c  1.  for each element (xx(v),yy(v)) in a vector of (x,y) pairs,
c    find the x and y zone indices and displacements with respect
c    to the "lower left corner" of the zone; store these in vectors
c    iv,jv and dxv,dyv.
c
c  2.  set ict(1)=0, ict(2)=1, ict(3)=1, the rest zero -- get only
c      the 1st derivatives.
c
c  3.  ivec is the length of the vector; ivd is the 1st dimension
c      of the array fval to receive the output
c
c      real fval(ivd,6)
c      real xv(ivd),yv(ivd)
c      integer iv(ivd),jv(ivd)
c      real dxv(ivd),dyv(ivd)
c      integer ict(6)
c
c      real fspline(4,4,nx,ny)  ! spline coeffs
c      data ict/0,1,1,0,0,0/    ! this call:  want 1st derivatives
c                               ! only ... these will be output to
c                               ! fval(*,1) fval(*,2)
c      ...
c      do iv=1,ivec
c        ...                    ! find indices and displacements
c      enddo
c      call bcspevfn(ict,ivec,ivd,fval,iv,jv,dxv,dyv,fspline,nx,ny)
c
c-------------------------------------------------------------------
c  local:
c
      integer v                         ! vector element index
c
c  OK can now do evaluations
c
      iaval=0  ! fval addressing
c
      if(ict(1).le.2) then
         if((ict(1).gt.0).or.(ict(1).eq.-1)) then
c  evaluate f
            iaval=iaval+1
            do v=1,ivec
               i=iv(v)
               j=jv(v)
               dx=dxv(v)
               dy=dyv(v)
               fval(v,iaval)=
     >       f(1,1,i,j)+dy*(f(1,2,i,j)+dy*(f(1,3,i,j)+dy*f(1,4,i,j)))
     >  +dx*(f(2,1,i,j)+dy*(f(2,2,i,j)+dy*(f(2,3,i,j)+dy*f(2,4,i,j)))
     >  +dx*(f(3,1,i,j)+dy*(f(3,2,i,j)+dy*(f(3,3,i,j)+dy*f(3,4,i,j)))
     >  +dx*(f(4,1,i,j)+dy*(f(4,2,i,j)+dy*(f(4,3,i,j)+dy*f(4,4,i,j))))))
            enddo
         endif
c
         if((ict(2).gt.0).and.(ict(1).ne.-1)) then
c  evaluate df/dx
            iaval=iaval+1
            do v=1,ivec
               i=iv(v)
               j=jv(v)
               dx=dxv(v)
               dy=dyv(v)
               fval(v,iaval)=
     >         f(2,1,i,j)+dy*(f(2,2,i,j)+dy*(f(2,3,i,j)+dy*f(2,4,i,j)))
     >       +2.0_r8*dx*(
     >         f(3,1,i,j)+dy*(f(3,2,i,j)+dy*(f(3,3,i,j)+dy*f(3,4,i,j)))
     >       +1.5_r8*dx*(
     >         f(4,1,i,j)+dy*(f(4,2,i,j)+dy*(f(4,3,i,j)+dy*f(4,4,i,j)))
     >              ))
            enddo
         endif
c
         if((ict(3).gt.0).and.(ict(1).ne.-1)) then
c  evaluate df/dy
            iaval=iaval+1
            do v=1,ivec
               i=iv(v)
               j=jv(v)
               dx=dxv(v)
               dy=dyv(v)
               fval(v,iaval)=
     >         f(1,2,i,j)+dy*(2.0_r8*f(1,3,i,j)+dy*3.0_r8*f(1,4,i,j))
     >      +dx*(f(2,2,i,j)+dy*(2.0_r8*f(2,3,i,j)+dy*3.0_r8*f(2,4,i,j))
     >      +dx*(f(3,2,i,j)+dy*(2.0_r8*f(3,3,i,j)+dy*3.0_r8*f(3,4,i,j))
     >      +dx*(f(4,2,i,j)+dy*(2.0_r8*f(4,3,i,j)+dy*3.0_r8*f(4,4,i,j))
     >              )))
            enddo
         endif
c
         if((ict(4).gt.0).or.(ict(1).eq.-1)) then
c  evaluate d2f/dx2
            iaval=iaval+1
            do v=1,ivec
               i=iv(v)
               j=jv(v)
               dx=dxv(v)
               dy=dyv(v)
               fval(v,iaval)=
     >        2.0_r8*(
     >         f(3,1,i,j)+dy*(f(3,2,i,j)+dy*(f(3,3,i,j)+dy*f(3,4,i,j))))
     >       +6.0_r8*dx*(
     >         f(4,1,i,j)+dy*(f(4,2,i,j)+dy*(f(4,3,i,j)+dy*f(4,4,i,j))))
            enddo
         endif
c
         if((ict(5).gt.0).or.(ict(1).eq.-1)) then
c  evaluate d2f/dy2
            iaval=iaval+1
            do v=1,ivec
               i=iv(v)
               j=jv(v)
               dx=dxv(v)
               dy=dyv(v)
               fval(v,iaval)=
     >              2.0_r8*f(1,3,i,j)+6.0_r8*dy*f(1,4,i,j)
     >              +dx*(2.0_r8*f(2,3,i,j)+6.0_r8*dy*f(2,4,i,j)
     >              +dx*(2.0_r8*f(3,3,i,j)+6.0_r8*dy*f(3,4,i,j)
     >              +dx*(2.0_r8*f(4,3,i,j)+6.0_r8*dy*f(4,4,i,j))))
            enddo
         endif
c
         if((ict(6).gt.0).and.(ict(1).ne.-1)) then
c  evaluate d2f/dxdy
            iaval=iaval+1
            do v=1,ivec
               i=iv(v)
               j=jv(v)
               dx=dxv(v)
               dy=dyv(v)
               fval(v,iaval)=
     >            f(2,2,i,j)+dy*(2.0_r8*f(2,3,i,j)+dy*3.0_r8*f(2,4,i,j))
     > +2._r8*dx*(f(3,2,i,j)+dy*(2.0_r8*f(3,3,i,j)+dy*3.0_r8*f(3,4,i,j))
     >+1.5_r8*dx*(f(4,2,i,j)+dy*(2.0_r8*f(4,3,i,j)+dy*3.0_r8*f(4,4,i,j))
     >              ))
            enddo
         endif
c
         if(ict(1).eq.-1) then
            iaval=iaval+1
            do v=1,ivec
               i=iv(v)
               j=jv(v)
               dx=dxv(v)
               dy=dyv(v)
               fval(v,iaval)=
     >              4.0_r8*f(3,3,i,j)+12.0_r8*dy*f(3,4,i,j)
     >              +dx*(12.0_r8*f(4,3,i,j)+36.0_r8*dy*f(4,4,i,j))
            enddo
         endif
c
c-----------------------------------
c  access to 3rd derivatives
c
      else if(ict(1).eq.3) then
         if(ict(2).eq.1) then
c  evaluate d3f/dx3 (not continuous)
            iaval=iaval+1
            do v=1,ivec
               i=iv(v)
               j=jv(v)
               dy=dyv(v)
               fval(v,iaval)=
     >              +6.0_r8*(
     >         f(4,1,i,j)+dy*(f(4,2,i,j)+dy*(f(4,3,i,j)+dy*f(4,4,i,j))))
            enddo
         endif
c
         if(ict(3).eq.1) then
c  evaluate d3f/dx2dy
            iaval=iaval+1
            do v=1,ivec
               i=iv(v)
               j=jv(v)
               dx=dxv(v)
               dy=dyv(v)
               fval(v,iaval)=
     >              2.0_r8*(
     >           f(3,2,i,j)+dy*(2.0_r8*f(3,3,i,j)+dy*3.0_r8*f(3,4,i,j)))
     >              +6.0_r8*dx*(
     >           f(4,2,i,j)+dy*(2.0_r8*f(4,3,i,j)+dy*3.0_r8*f(4,4,i,j)))
            enddo
         endif
c
         if(ict(4).eq.1) then
c  evaluate d3f/dxdy2
            iaval=iaval+1
            do v=1,ivec
               i=iv(v)
               j=jv(v)
               dx=dxv(v)
               dy=dyv(v)
               fval(v,iaval)=
     >              (2.0_r8*f(2,3,i,j)+6.0_r8*dy*f(2,4,i,j)
     >              +2.0_r8*dx*(2.0_r8*f(3,3,i,j)+6.0_r8*dy*f(3,4,i,j)
     >              +1.5_r8*dx*(2.0_r8*f(4,3,i,j)+6.0_r8*dy*f(4,4,i,j))
     >              ))
            enddo
         endif

         if(ict(5).eq.1) then
c  evaluate d3f/dy3 (not continuous)
            iaval=iaval+1
            do v=1,ivec
               i=iv(v)
               j=jv(v)
               dx=dxv(v)
               fval(v,iaval)=6.0_r8*(f(1,4,i,j)+
     >              dx*(f(2,4,i,j)+dx*(f(3,4,i,j)+dx*f(4,4,i,j))))
            enddo
         endif
c
c-----------------------------------
c  access to 4th derivatives
c
      else if(ict(1).eq.4) then
         if(ict(2).eq.1) then
c  evaluate d4f/dx3dy (not continuous)
            iaval=iaval+1
            do v=1,ivec
               i=iv(v)
               j=jv(v)
               dy=dyv(v)
               fval(v,iaval)=
     >              +6.0_r8*(
     >         f(4,2,i,j)+dy*2.0_r8*(f(4,3,i,j)+dy*1.5_r8*f(4,4,i,j)))
            enddo
         endif
c
         if(ict(3).eq.1) then
c  evaluate d4f/dx2dy2
            iaval=iaval+1
            do v=1,ivec
               i=iv(v)
               j=jv(v)
               dx=dxv(v)
               dy=dyv(v)
               fval(v,iaval)=
     >              4.0_r8*f(3,3,i,j)+12.0_r8*dy*f(3,4,i,j)
     >              +dx*(12.0_r8*f(4,3,i,j)+36.0_r8*dy*f(4,4,i,j))
            enddo
         endif
c
         if(ict(4).eq.1) then
c  evaluate d4f/dxdy3 (not continuous)
            iaval=iaval+1
            do v=1,ivec
               i=iv(v)
               j=jv(v)
               dx=dxv(v)
               fval(v,iaval)=
     >              6.0_r8*(f(2,4,i,j)
     >              +2.0_r8*dx*(f(3,4,i,j)+1.5_r8*dx*f(4,4,i,j)))
            enddo
         endif
c
c-----------------------------------
c  access to 5th derivatives
c
      else if(ict(1).eq.5) then
         if(ict(2).eq.1) then
c  evaluate d5f/dx3dy2 (not continuous)
            iaval=iaval+1
            do v=1,ivec
               i=iv(v)
               j=jv(v)
               dy=dyv(v)
               fval(v,iaval)=
     >              +12.0_r8*(f(4,3,i,j)+dy*3.0_r8*f(4,4,i,j))
            enddo
         endif
c
         if(ict(3).eq.1) then
c  evaluate d5f/dx3dy2 (not continuous)
            iaval=iaval+1
            do v=1,ivec
               i=iv(v)
               j=jv(v)
               dx=dxv(v)
               fval(v,iaval)=
     >              12.0_r8*(f(3,4,i,j)+dx*3.0_r8*f(4,4,i,j))
            enddo
         endif
c
c-----------------------------------
c  access to 6th derivatives
c
      else if(ict(1).eq.6) then
c  evaluate d6f/dx3dy3 (not continuous)
         iaval=iaval+1
         do v=1,ivec
            i=iv(v)
            j=jv(v)
            fval(v,iaval)=
     >              36.0_r8*f(4,4,i,j)
         enddo
      endif
c
      return
      end
c----------------------


program CompMid
implicit none
double precision x0,xn,x,h,Mid,exact,diff,f,y
integer j,n,m
write(*,*) 'enter n (must be even)'
read(*,*) n
m=n/2
x0=1.d0
xn=2.d0
y = n + 2
h=(xn-x0)/dfloat(y)
Mid=0.d0
do j=0,m
  x=x0+dfloat(2*j+1)*h
  Mid=Mid+f(x)
enddo
Mid=2*h*Mid
exact=0.6362943611198906188344642429163531361500026
diff=dabs(Mid-exact)
write(*,*)'exact=',exact
write(*,*)'Mid=',Mid
write(*,*)'|Mid-exact|=',diff
stop
end program CompMid

function f(x)
double precision x,f
f=x*dlog(x)
return
end function f


SUBROUTINE orb_frame(r,v, Rrtn)

! ----------------------------------------------------------------------
! SUBROUTINE: orb_frame.f90
! ----------------------------------------------------------------------
! Purpose:
!  Transformation matrix from inertial to orbital frame
! ----------------------------------------------------------------------
! Input arguments:
! - r: 			position (m)
! - v: 			velocity (m/sec)
!
! Output arguments:
! - Rrtn : 		Transformation matrix between orbital and inertial frames
! ----------------------------------------------------------------------
! Note 1:
!  Orbital frame components:
!  radial, along-track (tangential) and cross-track (normal)  [r t n]
!
! Note 2:
!  Transformation may be applied as follows:
!  [ar at an]^T = [Rrtn]  * [ax ay az]^T
!      (3x1)       (3x3)  *     (3x1)
! ----------------------------------------------------------------------
! Dr. Thomas D. Papanikolaou, Geoscience Australia           10 May 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN) :: r(3), v(3)
! OUT
      REAL (KIND = prec_q), INTENT(OUT) :: Rrtn(3,3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q) :: X,Y,Z, Vx,Vy,Vz
      REAL (KIND = prec_q) :: r_norm, v_norm
      REAL (KIND = prec_q) :: rr_dot, vv_dot
      REAL (KIND = prec_q) :: h(3), h_dot, h_norm
      REAL (KIND = prec_q) :: er(3), et(3), en(3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Position vector r = [ X Y Z ]'
X = r(1)
Y = r(2)
Z = r(3)

! Velocity vector v = [ Vx Vy Vz ]'
Vx = v(1)
Vy = v(2)
Vz = v(3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! r vector magnitude (norm)
      CALL productdot(r, r, rr_dot)
      r_norm = sqrt(rr_dot)
! v vector magnitude (norm)
      CALL productdot(v, v, vv_dot)
      v_norm = sqrt(vv_dot)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Orbital Frame unit vectors
! ----------------------------------------------------------------------
! Radial component
      er = (1D0 / r_norm) * r

! Along-track or tangential component (only for the perfect circular orbit)
!      et = (1D0 / v_norm) * v

! cross product of r,v : angular momentum per unit mass
      CALL productcross(r,v , h)
      CALL productdot(h, h, h_dot)
      h_norm = sqrt(h_dot)

! Cross-track or normal component
     en = (1D0 / h_norm) * h
! ----------------------------------------------------------------------

!! Along-track or tangential component
      CALL productcross(en, er , et)
!print *,"eT", et

! ----------------------------------------------------------------------
! Tranformation matrix from inertial to orbital frame
      Rrtn(1,1:3) = (/ er(1), er(2), er(3) /)
      Rrtn(2,1:3) = (/ et(1), et(2), et(3) /)
      Rrtn(3,1:3) = (/ en(1), en(2), en(3) /)
! ----------------------------------------------------------------------

end


      function agm(a,b)
      implicit none
      double precision agm,a,b,eps,c
      parameter(eps=1.0d-15)
   10 c=0.5d0*(a+b)
      b=sqrt(a*b)
      a=c
      if(a-b.gt.eps*a) go to 10
      agm=0.5d0*(a+b)
      end
      program test
      implicit none
      double precision agm
      print*,agm(1.0d0,1.0d0/sqrt(2.0d0))
      end


module PrimeDecompose
  implicit none

  integer, parameter :: huge = selected_int_kind(18)
  ! => integer(8) ... more fails on my 32 bit machine with gfortran(gcc) 4.3.2

contains

  subroutine find_factors(n, d)
    integer(huge), intent(in) :: n
    integer, dimension(:), intent(out) :: d

    integer(huge) :: div, next, rest
    integer :: i

    i = 1
    div = 2; next = 3; rest = n

    do while ( rest /= 1 )
       do while ( mod(rest, div) == 0 )
          d(i) = div
          i = i + 1
          rest = rest / div
       end do
       div = next
       next = next + 2
    end do

  end subroutine find_factors

end module PrimeDecompose


      subroutine colpnt(k,rho)
c  from  * a practical guide to splines *  by c. de boor
c  the	k collocation points for the standard interval (-1,1) are sup-
c  plied here as the zeros of the legendre polynomial of degree k ,
c  provided  k .le. 8 . otherwise, uniformly spaced points are given.
      integer k,  j
      real rho(k),  fkm1o2
      if (k .gt. 8)		       go to 99
				       go to (10,20,30,40,50,60,70,80),k
   10 rho(1) = 0.
				       return
c$    (single/double) dpdata
   20 rho(2) = .57735 02691 89626 d0
      rho(1) = - rho(2)
				       return
   30 rho(3) = .77459 66692 41483 d0
      rho(1) = - rho(3)
      rho(2) = 0.
				       return
   40 rho(3) = .33998 10435 84856 d0
      rho(2) = - rho(3)
      rho(4) = .86113 63115 94053 d0
      rho(1) = - rho(4)
				       return
   50 rho(4) = .53846 93101 05683 d0
      rho(2) = - rho(4)
      rho(5) = .90617 98459 38664 d0
      rho(1) = - rho(5)
      rho(3) = 0.
				       return
   60 rho(4) = .23861 91860 83197 d0
      rho(3) = - rho(4)
      rho(5) = .66120 93864 66265 d0
      rho(2) = - rho(5)
      rho(6) = .93246 95142 03152 d0
      rho(1) = - rho(6)
				       return
   70 rho(5) = .40584 51513 77397 d0
      rho(3) = - rho(5)
      rho(6) = .74153 11855 99394 d0
      rho(2) = - rho(6)
      rho(7) = .94910 79123 42759 d0
      rho(1) = - rho(7)
      rho(4) = 0.
				       return
   80 rho(5) = .18343 46424 95650 d0
      rho(4) = - rho(5)
      rho(6) = .52553 24099 16329 d0
      rho(3) = - rho(6)
      rho(7) = .79666 64774 13627 d0
      rho(2) = - rho(7)
      rho(8) = .96028 98564 97536 d0
      rho(1) = - rho(8)
c$lbl dpdata
				       return
c  if k .gt. 8, use equispaced points, but print warning
   99 print 699,k
  699 format(11h **********/
     *	     49h equispaced collocation points are used since k =,i2,
     *	     19h is greater than 8.)
      fkm1o2 = float(k-1)/2.
      do 100 j=1,k
  100	 rho(j) = float(j-1)/fkm1o2 - 1.
				       return
      end


REAL*8 FUNCTION SPHBRU(N,X)
  !IMPLICIT REAL*8(A-H,O-Z)
  IMPLICIT NONE
  INTEGER, intent(in) :: n
  REAL*8,  intent(in) :: x
  ! locals
  REAL*8, PARAMETER :: TOL = 1.D-14
  REAL*8  :: BB, DBB, FAC, FACD
  INTEGER :: i, j
  I=0
  BB=1.D0
  DO
     I=I+1
     FAC=1.D0
     DO J=1,I
        FAC=FAC/DFLOAT(J)
     ENDDO
     FACD=1.D0
     DO J=1,I
        FACD=FACD/(2.D0*DFLOAT(N)+3.D0+2.D0*DFLOAT(J-1))
     ENDDO
     DBB=(X*X/2.D0)**I*FAC*FACD
     BB=BB+DBB*(-1.D0)**I
     IF(DBB.LT.TOL) EXIT
  ENDDO
  SPHBRU=BB
  RETURN
END FUNCTION SPHBRU