MODULE FUN_GammaLn
!!#### PURPOSE
!! Returns the natural log of the gamma function,
!!       Ln( Gamma( x ) ), x>0

!!#### MODULES
USE KND_IntrinsicTypes,ONLY: SP=>KIND_Rsp,DP=>KIND_Rdp,I4B=>KIND_I4 !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rdp,ONLY: c_0                                     !!((02-A-PAR_Constants_Rdp.f90))
USE FUN_Error                                                       !!((04-A-FUN_Error.f90))
USE FUN_Sequence                                                    !!((03-A-FUN_Sequence.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### PARAMETERS
REAL(DP),PARAMETER :: stp       =  2.5066282746310005_dp
REAL(DP),PARAMETER :: coef(1:6) = (/76.18009172947146_dp,&
                                   -86.50532032941677_dp,&
                                    24.01409824083091_dp,&
                                   -1.231739572450155_dp,&
                                0.1208650973866179e-2_dp,&
                                  -0.5395239384953e-5_dp/)

!!#### DEFAULT ACCESS
!debug with PUBLIC default access, run with PRIVATE default access
PRIVATE

!!#### OPERATOR OVERLOADING
INTERFACE GammaLn
 MODULE PROCEDURE GammaLn_A0Rsp
 MODULE PROCEDURE GammaLn_A1Rsp
 MODULE PROCEDURE GammaLn_A0Rdp
 MODULE PROCEDURE GammaLn_A1Rdp
ENDINTERFACE
PUBLIC :: GammaLn

CONTAINS

PURE FUNCTION GammaLn_A0Rsp(x) RESULT(LOG_gamma)
INTEGER,PARAMETER :: KIND_R = SP
INCLUDE "05-B-FUN_GammaLn_A0.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_GammaLn_A0.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION GammaLn_A1Rsp(x) RESULT(LOG_gamma)
INTEGER,PARAMETER :: KIND_R = SP
INCLUDE "05-B-FUN_GammaLn_A1.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_GammaLn_A1.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION GammaLn_A0Rdp(x) RESULT(LOG_gamma)
INTEGER,PARAMETER :: KIND_R = DP
INCLUDE "05-B-FUN_GammaLn_A0.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_GammaLn_A0.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION GammaLn_A1Rdp(x) RESULT(LOG_gamma)
INTEGER,PARAMETER :: KIND_R = DP
INCLUDE "05-B-FUN_GammaLn_A1.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_GammaLn_A1.f90.bdy"
!!--end--
END FUNCTION

ENDMODULE


program YH_Triangles
implicit none
    integer,parameter::max=10
    integer::tri(max,max)
    integer::n,i,j,k

    tri(1:,1) = 1
    tri(1,2:) = 0
    read(*,*) n

    do k=1 , n
        if (n==1) then
            continue
        else
            do i=2, k
                do j=2 ,k
                tri(i,j)=tri(i-1,j-1)+tri(i-1,j)
                end do
            end do
        end if

        write(*,"(*(I0,1X))") tri(k,1:k)
    end do

end program


module globals
  !  This module contains the global variables and derived types used
  !  throughout the program
  use precision
  public
  !
  !  cut_off is the maximum size of the wave function at the last basis vector
  !

  real(fdp), parameter :: cut_off=1.0d-5
  !
  !  pi is the parameter value of pi
  !
  real(fdp), parameter :: pi=3.14159265359
  !
  !  hbar is the parameter value of the physical constant hbar
  !

  real(fdp), parameter :: hbar=1.01d-34
  !
  !  w is the angular frequency of the harmonic oscillator
  !

  real(fdp), parameter :: w=1.0d0
  !
  !  I is the complex variable i
  !

  complex(cdp), parameter :: I=(0,1)
  !
  !  Various derived types
  !

  type basis
     !  This derived type uses a displaced number state to represent the basis
     !  The alpha is the displacement, and n is the number of basis states
     !  being used.
     complex(cdp) :: alpha
     integer(isp) :: n
  end type basis
  type wave_fn
     !  This derived type defines a wave function as a set of co-efficients
     !  and the basis that the wave function is represented on.
     complex(cdp), dimension(:), pointer :: co_eff
     type (basis) :: in_basis
  end type wave_fn
  type gauss

     !  This derived type defines the data structure of the wiener
     !  random numbers
     real(fdp), dimension(:,:), pointer :: num
  end type gauss
end module globals


      SUBROUTINE int2rms( vtpint, vtp, n )
c   int2rms converts interval velocity two-way-travel time pairs to
c rms velocity two-way-trace time pairs using Dix's formula.
c
c   Vrms(n) = SQRT( (IV(n)**2(T(n)-T(n-1) + Vrms(n-1)**2*T(n-1))  / T(n) )
c
c  ARGUMENTS:
c  vtpint - The input interval velocity (two way) time pairs.
c  vtp    - The array to receive the output average velocity
c           (two way) time pairs.
c  n      - the number of elements in the vtpint and vtp arrays.
c
      DIMENSION vtpint(n), vtp(n)
c
      vtp(1) = vtpint(1)
      vtp(2) = vtpint(2)
      IF( n .EQ. 2 ) RETURN
      DO j = 3, n, 2
         temp = vtp(j-2) * vtp(j-2) * vtp(j-1)
     &        + vtpint(j) * vtpint(j) * (vtpint(j+1)-vtpint(j-1))
         vtp(j) = SQRT( temp / vtpint(j+1) )
         vtp(j+1) = vtpint(j+1)
      ENDDO
      RETURN
      END


	FUNCTION PR_HGFM  ( hgft )
C************************************************************************
C* PR_HGFM								*
C*									*
C* This function computes HGHT from HGFT.  The following equation is	*
C* used:								*
C*									*
C*                   HGHT  =  HGFT * .3048				*
C*									*
C* REAL PR_HGFM  ( HGFT )						*
C*									*
C* Input parameters:							*
C*	HGFT		REAL		Height in feet			*
C*									*
C* Output parameters:							*
C*	PR_HGFM		REAL		Height in meters		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 9/87						*
C* G. Huffman/GSC	 7/88	rename HGFT, documentation		*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for invalid data.
C
	IF  ( ERMISS ( hgft ) ) THEN
	    PR_HGFM = RMISSD
	  ELSE
C
C*	    Multiply by .3048.
C
	    PR_HGFM = hgft * .3048
	END IF
C*
	RETURN
	END


module randomwalk
    use utilities
    use percolation
    implicit none
    private :: find_random_point
    contains

        function one_random_walker(matrix, num_steps) result(displacement)
            !! Let one random walker do **num_steps** jumps on the `.true.`
            !! values of **matrix**. The initial position is randomly selected.

            logical, dimension(:,:), intent(in) :: matrix
                !! Matrix whose `.true.` values are allowed positions for the
                !! random walker.

            integer :: num_steps
                !! Number of steps for the random walker to take.

            real(kind=dp), dimension(:,:), allocatable :: displacement
                !! Array of displacements, which has dimension
                !! 2 \\(\times\\) (**num_steps** + 1),
                !! and should logically have `dimension(2,0:num_steps)`, such that
                !! the i'th column contains the displacement after i steps.
                !! Averaged over all systems and all walkers.

            integer :: x0, y0, x, y, x_new, y_new, dx, dy, L, i, direction
            real(kind=dp) :: real_direction

            ! North - East - South - West
            integer, dimension(4) :: dxs = [0, 1, 0, -1]
            integer, dimension(4) :: dys = [1, 0, -1, 0]

            L = size(matrix, 1)
            allocate(displacement(2,0:num_steps))

            displacement(:,:) = 0

            call find_random_point(matrix, x0, y0)

            x = x0
            y = y0

            do i = 1, num_steps
                call random_number(real_direction)
                direction = int(4*real_direction + 1)

                dx = dxs(direction)
                dy = dys(direction)

                x_new = x + dx
                y_new = y + dy

                call periodic_wraparound(x_new, L)
                call periodic_wraparound(y_new, L)

                if(matrix(x_new, y_new)) then
                    x = x_new
                    y = y_new
                    displacement(:,i) = displacement(:,i-1) + [dx, dy]
                else
                    displacement(:,i) = displacement(:,i-1)
                end if

            end do
        end function

        function random_walkers(p, L, num_systems, num_walkers, num_steps) result(displacement)
            !! Start **num_walkers** on the percolating cluster of each of **num_systems**
            !! systems, and return the averaged displacement.

            real(kind=dp), intent(in) :: p
                !! The probability for each site to allow transport.
            integer, intent(in) ::  L
                !! The system size.
            integer, intent(in) ::  num_systems
                !! The number of systems over which to average.
            integer, intent(in) ::  num_walkers
                !! The number of random walkers for each system over which to average.
            integer, intent(in) ::  num_steps
                !! The number of steps which the random walkers take.

            real(kind=dp), dimension(:), allocatable :: displacement
                !! Array of squared displacements, which has dimension
                !! (**num_steps** + 1),
                !! and should logically have `dimension(0:num_steps)`, such that
                !! the i'th element contains the displacement after i steps.
                !! Averaged over all systems and all walkers.

            logical, dimension(:,:), allocatable :: binary_matrix, spanning_cluster
            integer, dimension(:,:), allocatable :: label_matrix
            real(kind=dp), dimension(:,:), allocatable :: tmp_displacement

            integer :: i, num_spanning_clusters, num_clusters, spanning_cluster_label

            allocate(displacement(0:num_steps))
            displacement(:) = 0

            num_spanning_clusters = 0
            do while(num_spanning_clusters < num_systems)
                binary_matrix = create_binary_matrix(p, L)
                call label(binary_matrix, label_matrix, num_clusters)
                spanning_cluster_label = find_spanning_cluster(label_matrix, num_clusters)

                if(spanning_cluster_label < 1) then
                    cycle
                end if
                num_spanning_clusters = num_spanning_clusters + 1

                spanning_cluster = mark_percolating_with_periodic( &
                                        label_matrix, spanning_cluster_label, &
                                        num_clusters)

                !$omp parallel do private(tmp_displacement) reduction(+:displacement)
                do i = 1, num_walkers
                    tmp_displacement = one_random_walker(spanning_cluster, num_steps)
                    displacement(:) = displacement(:) + sum(tmp_displacement(:,:)**2,dim=1)
                end do
                !$omp end parallel do
            end do
            displacement(:) = displacement(:)/(num_walkers*num_systems)

        end function

        function probability_distribution(p, L, num_steps, num_walkers, num_systems, num_hists) &
                 result(result_hist)
            !! Start **num_walkers** on the percolating cluster of each of **num_systems**
            !! systems, and compute **num_hists** histograms of the distribution
            !! of particles.

            real(kind=dp), intent(in) :: p
                !! The probability for each site to allow transport.
            integer, intent(in) ::  L
                !! The system size.
            integer, intent(in) ::  num_systems
                !! The number of systems over which to average.
            integer, intent(in) ::  num_walkers
                !! The number of random walkers for each system over which to average.
            integer, intent(in) ::  num_steps
                !! The number of steps which the random walkers take.
            integer, intent(in) :: num_hists
                !! The number of histograms to be returned.

            real(kind=dp), dimension(:,:), allocatable :: result_hist
                !! Array of histograms. The first row contains the centres of the
                !! bins, while the remaining **num_hists+1** rows each contain
                !! one histogram.

            logical, dimension(:,:), allocatable :: binary_matrix, spanning_cluster
            integer, dimension(:,:), allocatable :: label_matrix
            integer, dimension(:), allocatable :: hist_indices
            integer :: hist_dist, i, j, maxdist, x_index, y_index
            real(kind=dp), dimension(:,:), allocatable :: tmp_displacement, tmp_hist
            integer, dimension(:,:,:), allocatable :: displacement, absdisplacement

            integer :: num_spanning_clusters, num_clusters, spanning_cluster_label

            allocate(displacement(2,0:num_hists,num_walkers*num_systems))
            hist_dist = num_steps/num_hists
            allocate(hist_indices(0:num_hists))
            hist_indices(:) = [(hist_dist*i, i=0, num_hists)]

            num_spanning_clusters = 0
            do while(num_spanning_clusters < num_systems)
                binary_matrix = create_binary_matrix(p, L)
                call label(binary_matrix, label_matrix, num_clusters)
                spanning_cluster_label = find_spanning_cluster(label_matrix, num_clusters)

                if(spanning_cluster_label < 1) then
                    cycle
                end if
                num_spanning_clusters = num_spanning_clusters + 1

                spanning_cluster = mark_percolating_with_periodic( &
                                        label_matrix, spanning_cluster_label, &
                                        num_clusters)

                !$omp parallel do private(tmp_displacement)
                do i = 1, num_walkers
                    tmp_displacement = one_random_walker(spanning_cluster, num_steps)
                    do j = 0, num_hists
                        associate(hist_index => hist_indices(j), &
                                  indx => (num_spanning_clusters-1)*num_walkers+i)
                            displacement(:,j,indx) = tmp_displacement(:,hist_index+1)
                        end associate
                    end do
                end do
                !$omp end parallel do
            end do

            allocate(absdisplacement(2,0:num_hists,num_walkers*num_systems))

            !$omp parallel workshare
            absdisplacement(:,:,:) = abs(displacement(:,:,:))
            maxdist = maxval(absdisplacement)
            !$omp end parallel workshare

            allocate(result_hist(-1:num_hists,-maxdist:maxdist))
            result_hist(-1,:) = [(i, i = -maxdist, maxdist)]
            result_hist(0:,:) = 0

            !$omp parallel do private(x_index, y_index) reduction(+:result_hist)
            do i = 0, num_hists
                do j = 1, num_systems*num_walkers
                    associate(x => displacement(1,i,j), &
                              y => displacement(2,i,j))
                        result_hist(i,x) = result_hist(i,x) + 1
                        result_hist(i,y) = result_hist(i,y) + 1
                    end associate
                end do
            end do
            !$omp end parallel do

            result_hist(0:,:) = result_hist(0:,:)/(2.0d0*num_systems*num_walkers)

        end function
end module randomwalk


program P2293
    implicit none
    integer :: kinds, target, coin, i, j
    integer, dimension(0:10000) :: count
    read *, kinds, target
    do i = 0, target
        count(i) = 0
    end do
    count(0) = 1
    do i = 1, kinds
        read *, coin
        do j = coin, target
            count(j) = count(j) + count(j - coin)
        end do
    end do
    write (*, '(I0)') count(target)
end program P2293


module mod_variance

use mod_mean, only: mean

use mod_math, only: divide, subtract

implicit none

public :: variance
private

contains

subroutine variance(a,b)
  real(8),dimension(:),intent(inout) :: a
  real(8),intent(inout) :: b

  real(8) :: meanVal
  real(8) :: temp1
  real(8) :: temp2

  real(8) :: n
  integer(8) :: i

  meanVal = 0.0
  call mean(a,meanVal)

  n = real(size(a),8)

  b = 0.0
  do i = 1,int(n)
    call subtract(a(i),meanVal,temp1)
    temp1 = temp1**2
    call divide(temp1,n,temp2)
    b = b + temp2
  enddo

end subroutine variance
end module mod_variance


pure function f(x) !funcao para calcular x^2-3
	real, intent(in) :: x
	real :: y
	y = (x**2)-3
end function

program main

	real :: a, b, fa, fb, fx, erro
	real, dimension(1:2) :: x
	integer :: k = 0

	a = 1
	b = 2

	print*,"a","fa","b","fb"

	do
		fa = f(a)
		fb = f(b)

		x(k) = (a + b)/2
		fk = f(x(k))

		if( (f(a)*f(x(k))) > 0) then
			a = x(k);
		else
			b = x(k);
		end if

		if (k > 0) then
			erro = (x(k) - x(k-1))/x(k)
			if (erro < 0) then	!gambiarra para modulo!
				erro = erro * (-1)
			end if

			print*,k,a,fa,b,fb,x(k),fk,erro

			if(erro < 0.01) then
				exit
			end if
		else
			print*,k,a,fa,b,fb,x(k),fk,"-----"
		end if

		k = k+1
	end do
end program main


      PROGRAM xmidpnt
C     driver for routine midpnt
      INTEGER NMAX
      PARAMETER(NMAX=10)
      INTEGER i
      REAL a,b,fint2,func2,s
      EXTERNAL fint2,func2
      a=0.0
      b=1.0
      write(*,*) 'Integral of FUNC2 computed with MIDPNT'
      write(*,*) 'Actual value of integral is',fint2(b)-fint2(a)
      write(*,'(1x,t7,a,t20,a)') 'n','Approx. Integral'
      do 11 i=1,NMAX
        call midpnt(func2,a,b,s,i)
        write(*,'(1x,i6,f24.6)') i,s
11    continue
      END
      REAL FUNCTION func2(x)
      REAL x
      func2=1.0/sqrt(x)
      END
      REAL FUNCTION fint2(x)
C     integral of FUNC2
      REAL x
      fint2=2.0*sqrt(x)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xmidpnt.for


      SUBROUTINE slTP2S (XI, ETA, RAZ, DECZ, RA, DEC)
*+
*     - - - - -
*      T P 2 S
*     - - - - -
*
*  Transform tangent plane coordinates into spherical
*  (single precision)
*
*  Given:
*     XI,ETA      real  tangent plane rectangular coordinates
*     RAZ,DECZ    real  spherical coordinates of tangent point
*
*  Returned:
*     RA,DEC      real  spherical coordinates (0-2pi,+/-pi/2)
*
*  Called:        slRA2P
*
*  P.T.Wallace   Starlink   24 July 1995
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      REAL XI,ETA,RAZ,DECZ,RA,DEC

      REAL slRA2P

      REAL SDECZ,CDECZ,DENOM

      SDECZ=SIN(DECZ)
      CDECZ=COS(DECZ)

      DENOM=CDECZ-ETA*SDECZ

      RA=slRA2P(ATAN2(XI,DENOM)+RAZ)
      DEC=ATAN2(SDECZ+ETA*CDECZ,SQRT(XI*XI+DENOM*DENOM))

      END


PROGRAM calculate_cost
    IMPLICIT NONE

    integer :: item
    real :: discount, cost_per_item, total_cost

    write(*, *) "Enter number of items and cost of one item"
    read (*, *) item, cost_per_item;

    if(item >= 10) then
        discount = 0.25
    else if((item > 5) .and. (item <= 10)) then
        discount = 0.15
    else if((item > 1) .and. (item <= 5)) then
        discount = 0.01
    else
        discount = 0.0
    end if
    total_cost = cost_per_item * item
    total_cost = total_cost - total_cost * discount
    write(*, *) total_cost

END


!
!     file hstplr.f90
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     SUBROUTINE hstplr(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, bdd,
!                       elmbda, f, idimf, pertrb, ierror)
!
! DIMENSION OF           bda(n), bdb(n), bdc(m), bdd(m), f(idimf, n)
! ARGUMENTS
!
! LATEST REVISION        May 2016
!
! PURPOSE                Solves the standard five-point finite
!                        difference approximation on a staggered
!                        grid to the helmholtz equation in polar
!                        coordinates.  the equation is
!
!                           (1/r)(d/dr)(r(du/dr)) +
!                           (1/r**2)(d/dtheta)(du/dtheta) +
!                           lambda*u = f(r, theta)
!
! USAGE                  call hstplr(a, b, m, mbdcnd, bda, bdb, c, d, n,
!                                    nbdcnd, bdc, bdd, elmbda, f,
!                                    idimf, pertrb, ierror)
!
! ARGUMENTS
! ON INPUT               a, b
!
!                          the range of r, i.e. a <= r <= b.
!                          a must be less than b and a must be
!                          non-negative.
!
!                        m
!                          the number of grid points in the interval
!                          (a, b).  the grid points in the r-direction
!                          are given by r(i) = a + (i-0.5)dr for
!                          i=1, 2, ..., m where dr =(b-a)/m.
!                          m must be greater than 2.
!
!                        mbdcnd
!                          indicates the type of boundary conditions
!                          at r = a and r = b.
!
!                          = 1  if the solution is specified at r = a
!                               and r = b.
!
!                          = 2  if the solution is specified at r = a
!                               and the derivative of the solution
!                               with respect to r is specified at r = b.
!                               (see note 1 below)
!
!                          = 3  if the derivative of the solution
!                               with respect to r is specified at
!                               r = a (see note 2 below) and r = b.
!
!                          = 4  if the derivative of the solution
!                               with respect to r is specified at
!                               specified at r = a (see note 2 below)
!                               and the solution is specified at r = b.
!
!
!                          = 5  if the solution is unspecified at
!                               r = a = 0 and the solution is
!                               specified at r = b.
!
!                          = 6  if the solution is unspecified at
!                               r = a = 0 and the derivative of the
!                               solution with respect to r is specified
!                               at r = b.
!
!                          note 1:
!                          if a = 0, mbdcnd = 2, and nbdcnd = 0 or 3,
!                          the system of equations to be solved is
!                          singular.  the unique solution is
!                          is determined by extrapolation to the
!                          specification of u(0, theta(1)).
!                          but in this case the right side of the
!                          system will be perturbed by the constant
!                          pertrb.
!
!                          note 2:
!                          if a = 0, do not use mbdcnd = 3 or 4,
!                          but instead use mbdcnd = 1, 2, 5, or 6.
!
!                        bda
!                          a one-dimensional array of length n that
!                          specifies the boundary values (if any) of
!                          the solution at r = a.
!
!                          when mbdcnd = 1 or 2,
!                            bda(j) = u(a, theta(j)) ,     j=1, 2, ..., n.
!
!                          when mbdcnd = 3 or 4,
!                            bda(j) = (d/dr)u(a, theta(j)) ,
!                            j=1, 2, ..., n.
!
!                          when mbdcnd = 5 or 6, bda is a dummy
!                          variable.
!
!                        bdb
!                          a one-dimensional array of length n that
!                          specifies the boundary values of the
!                          solution at r = b.
!
!                          when mbdcnd = 1, 4, or 5,
!                            bdb(j) = u(b, theta(j)) ,     j=1, 2, ..., n.
!
!                          when mbdcnd = 2, 3, or 6,
!                            bdb(j) = (d/dr)u(b, theta(j)) ,
!                            j=1, 2, ..., n.
!
!                        c, d
!                          the range of theta, i.e. c <= theta <= d.
!                          c must be less than d.
!
!                        n
!                          the number of unknowns in the interval
!                          (c, d).  the unknowns in the theta-
!                          direction are given by theta(j) = c +
!                          (j-0.5)dt,   j=1, 2, ..., n, where
!                          dt = (d-c)/n.  n must be greater than 2.
!
!                        nbdcnd
!                          indicates the type of boundary conditions
!                          at theta = c  and theta = d.
!
!                          = 0  if the solution is periodic in theta,
!                               i.e. u(i, j) = u(i, n+j).
!
!                          = 1  if the solution is specified at
!                               theta = c and theta = d
!                               (see note below).
!
!                          = 2  if the solution is specified at
!                               theta = c and the derivative of the
!                               solution with respect to theta is
!                               specified at theta = d
!                               (see note below).
!
!                          = 3  if the derivative of the solution
!                               with respect to theta is specified
!                               at theta = c and theta = d.
!
!                          = 4  if the derivative of the solution
!                               with respect to theta is specified
!                               at theta = c and the solution is
!                               specified at theta = d
!                               (see note below).
!
!                          note:
!                          when nbdcnd = 1, 2, or 4, do not use
!                          mbdcnd = 5 or 6 (the former indicates that
!                          the solution is specified at r =  0; the
!                          latter indicates the solution is unspecified
!                          at r = 0).  use instead mbdcnd = 1 or 2.
!
!                        bdc
!                          a one dimensional array of length m that
!                          specifies the boundary values of the
!                          solution at theta = c.
!
!                          when nbdcnd = 1 or 2,
!                            bdc(i) = u(r(i), c) ,        i=1, 2, ..., m.
!
!                          when nbdcnd = 3 or 4,
!                            bdc(i) = (d/dtheta)u(r(i), c),
!                            i=1, 2, ..., m.
!
!                          when nbdcnd = 0, bdc is a dummy variable.
!
!                        bdd
!                          a one-dimensional array of length m that
!                          specifies the boundary values of the
!                          solution at theta = d.
!
!                          when nbdcnd = 1 or 4,
!                            bdd(i) = u(r(i), d) ,         i=1, 2, ..., m.
!
!                          when nbdcnd = 2 or 3,
!                            bdd(i) =(d/dtheta)u(r(i), d), i=1, 2, ..., m.
!
!                          when nbdcnd = 0, bdd is a dummy variable.
!
!                        elmbda
!                          the constant lambda in the helmholtz
!                          equation.  if lambda is greater than 0,
!                          a solution may not exist.  however, hstplr
!                          will attempt to find a solution.
!
!                        f
!                          a two-dimensional array that specifies the
!                          values of the right side of the helmholtz
!                          equation.
!
!                          for i=1, 2, ..., m and j=1, 2, ..., n
!                            f(i, j) = f(r(i), theta(j)) .
!
!                          f must be dimensioned at least m x n.
!
!                        idimf
!                          the row (or first) dimension of the array
!                          f as it appears in the program calling
!                          hstplr.  this parameter is used to specify
!                          the variable dimension of f.
!                          idimf must be at least m.
!
!
! ON OUTPUT
!
!                        f
!                          contains the solution u(i, j) of the finite
!                          difference approximation for the grid point
!                          (r(i), theta(j)) for i=1, 2, ..., m,
!                          j=1, 2, ..., n.
!
!                        pertrb
!                          if a combination of periodic, derivative,
!                          or unspecified boundary conditions is
!                          specified for a poisson equation
!                          (lambda = 0), a solution may not exist.
!                          pertrb is a constant calculated and
!                          subtracted from f, which ensures that a
!                          solution exists.  hstplr then computes this
!                          solution, which is a least squares solution
!                          to the original approximation.
!                          this solution plus any constant is also
!                          a solution; hence, the solution is not
!                          unique.  the value of pertrb should be
!                          small compared to the right side f.
!                          otherwise, a solution is obtained to an
!                          essentially different problem.
!                          this comparison should always be made to
!                          insure that a meaningful solution has been
!                          obtained.
!
!                        ierror
!                          an error flag that indicates invalid input
!                          parameters. except to numbers 0 and 11,
!                          a solution is not attempted.
!
!                          =  0  no error
!
!                          =  1  a < 0
!
!                          =  2  a >= b
!
!                          =  3  mbdcnd < 1 or mbdcnd > 6
!
!                          =  4  c >= d
!
!                          =  5  n <= 2
!
!                          =  6  nbdcnd < 0 or nbdcnd > 4
!
!                          =  7  a = 0 and mbdcnd = 3 or 4
!
!                          =  8  a > 0 and mbdcnd >= 5
!
!                          =  9  mbdcnd >= 5 and nbdcnd /= 0 or 3
!
!                          = 10  idimf < m
!
!                          = 11  lambda > 0
!
!                          = 12  m <= 2
!
!                          = 20 if the dynamic allocation of real and
!                               complex workspace required for solution
!                               fails (for example if n, m are too large
!                               for your computer)
!
!                          since this is the only means of indicating
!                          a possibly incorrect call to hstplr, the
!                          user should test ierror after the call.
!
!
! I/O                    None
!
! PRECISION              64-bit double precision
!
! REQUIRED FILES         type_FishpackWorkspace.f90, genbun.f90, type_CyclicReductionUtility.f9090, poistg.f90
!
! STANDARD               Fortran 2008
!
! HISTORY                Written by Roland Sweet at NCAR in 1977.
!                        released on NCAR's public software libraries
!                        IN January 1980.
!                        Revised in June 2004 by John Adams using
!                        Fortran 90 dynamically allocated workspace.
!
! PORTABILITY            FORTRAN 90
!
! ALGORITHM              This subroutine defines the finite-
!                        difference equations, incorporates boundary
!                        data, adjusts the right side when the system
!                        is singular and calls either poistg or genbun
!                        which solves the linear system of equations.
!
! TIMING                 For large m and n, the operation count
!                        is roughly proportional to m*n*log2(n).
!
! ACCURACY               The solution process employed results in
!                        a loss of no more than four significant
!                        digits for n and m as large as 64.
!                        more detailed information about accuracy
!                        can be found in the documentation for
!                        routine poistg which is the routine that
!                        actually solves the finite difference
!                        equations.
!
! REFERENCES             U. Schumann and R. Sweet, "A direct method
!                        for the solution of poisson's equation with
!                        neumann boundary conditions on a staggered
!                        grid of arbitrary size, " J. Comp. Phys.
!                        20(1976), pp. 171-182.
!
submodule(staggered_helmholtz_solvers) staggered_polar_solver

contains

    module subroutine hstplr(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, &
        bdd, elmbda, f, idimf, pertrb, ierror)
        !-----------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a
        real(wp),    intent(in)     :: b
        real(wp),    intent(in)     :: c
        real(wp),    intent(in)     :: d
        real(wp),    intent(in)     :: elmbda
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bda(:)
        real(wp),    intent(in)     :: bdb(:)
        real(wp),    intent(in)     :: bdc(:)
        real(wp),    intent(in)     :: bdd(:)
        real(wp),    intent(inout) :: f(:,:)
        !-----------------------------------------------
        ! Local variables
        !-----------------------------------------------
        type(FishpackWorkspace)  :: workspace
        !-----------------------------------------------

        ! Check input arguments
        call hstplr_check_input_arguments(a, b, m, mbdcnd, c, d, n, &
            nbdcnd, idimf, ierror)

        ! Check error flag
        if (ierror /= 0) return

        ! Allocate memory
        call workspace%initialize_staggered_workspace(n, m)

        ! Solve system
        associate( rew => workspace%real_workspace )
            call hstplr_lower_routine(a, b, m, mbdcnd, &
                bda, bdb, c, d, n, nbdcnd, bdc, bdd, &
                elmbda, f, idimf, pertrb, ierror, rew)
        end associate

        ! Release memory
        call workspace%destroy()

    end subroutine hstplr

    pure subroutine hstplr_check_input_arguments(a, b, m, mbdcnd, c, d, n, &
        nbdcnd, idimf, ierror)
        !-----------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a
        real(wp),    intent(in)     :: b
        real(wp),    intent(in)     :: c
        real(wp),    intent(in)     :: d
        !-----------------------------------------------

        ! Check validity of calling arguments
        if (a < ZERO) then
            ierror = 1
            return
        else if (a >= b) then
            ierror = 2
            return
        else if (mbdcnd <= 0 .or. mbdcnd >= 7) then
            ierror = 3
            return
        else if (c >= d) then
            ierror = 4
            return
        else if (3 > n) then
            ierror = 5
            return
        else if (nbdcnd < 0 .or. nbdcnd >= 5) then
            ierror = 6
            return
        else if (a == ZERO .and. (mbdcnd == 3 .or. mbdcnd == 4)) then
            ierror = 7
            return
        else if (a > ZERO .and. mbdcnd >= 5) then
            ierror = 8
            return
        else if (mbdcnd >= 5 .and. nbdcnd /= 0 .and. nbdcnd /= 3) then
            ierror = 9
            return
        else if (idimf < m) then
            ierror = 10
            return
        else if (3 > m) then
            ierror = 12
            return
        else
            ierror = 0
        end if

    end subroutine hstplr_check_input_arguments

    subroutine hstplr_lower_routine(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, &
        bdd, elmbda, f, idimf, pertrb, ierror, w)
        !-----------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a
        real(wp),    intent(in)     :: b
        real(wp),    intent(in)     :: c
        real(wp),    intent(in)     :: d
        real(wp),    intent(in)     :: elmbda
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bda(:)
        real(wp),    intent(in)     :: bdb(:)
        real(wp),    intent(in)     :: bdc(:)
        real(wp),    intent(in)     :: bdd(:)
        real(wp),    intent(inout)  :: f(:,:)
        real(wp),    intent(inout)  :: w(:)
        !-----------------------------------------------
        ! Local variables
        !-----------------------------------------------
        integer(ip) :: np, isw, mb, iwb, iwc, iwr
        integer(ip) :: i, j, k, lp, local_error_flag
        real(wp)    :: dr, dr2, dth, dth2, a1, a2
        type(CenteredCyclicReductionUtility)  :: centered_util
        type(StaggeredCyclicReductionUtility) :: staggered_util

        dr = (b - a)/m
        dr2 = dr**2
        dth = (d - c)/n
        dth2 = dth**2
        np = nbdcnd + 1
        isw = 1
        mb = mbdcnd

        if (a == ZERO .and. mbdcnd == 2) mb = 6
        !
        ! define a, b, c coefficients in w-array.
        !
        iwb = m
        iwc = iwb + m
        iwr = iwc + m

        do i = 1, m
            j = iwr + i
            w(j) = a + (real(i, kind=wp) - HALF)*dr
            w(i) = (a + real(i - 1, kind=wp)*dr)/dr2
            k = iwc + i
            w(k) = (a + real(i, kind=wp)*dr)/dr2
            k = iwb + i
            w(k) = (elmbda - TWO/dr2)*w(j)
        end do

        do i = 1, m
            j = iwr + i
            f(i,:n) = w(j)*f(i,:n)
        end do
        !
        ! Enter boundary data for r-boundaries.
        !
        select case (mb)
            case (1:2)
                a1 = TWO*w(1)
                w(iwb+1) = w(iwb+1) - w(1)
                f(1,:n) = f(1,:n) - a1*bda(:n)
            case (3:4)
                a1 = dr*w(1)
                w(iwb+1) = w(iwb+1) + w(1)
                f(1,:n) = f(1,:n) + a1*bda(:n)
        end select

        select case (mb)
            case (1, 4:5)
                a1 = TWO *w(iwr)
                w(iwc) = w(iwc) - w(iwr)
                f(m,:n) = f(m,:n) - a1*bdb(:n)
            case (2:3, 6)
                a1 = dr*w(iwr)
                w(iwc) = w(iwc) + w(iwr)
                f(m,:n) = f(m,:n) - a1*bdb(:n)
        end select

        !
        ! Enter boundary data for theta-boundaries.
        !

        a1 = TWO/dth2
        select case (np)
            case (2:3)
                f(:m, 1) = f(:m, 1) - a1*bdc(:m)/w(iwr+1:m+iwr)
            case (4:5)
                a1 = ONE/dth
                f(:m, 1) = f(:m, 1) + a1*bdc(:m)/w(iwr+1:m+iwr)
        end select

        a1 = TWO/dth2
        select case (np)
            case (2, 5)
                f(:m, n) = f(:m, n) - a1*bdd(:m)/w(iwr+1:m+iwr)
            case (3:4)
                a1 = ONE /dth
                f(:m, n) = f(:m, n) - a1*bdd(:m)/w(iwr+1:m+iwr)
        end select

        pertrb = ZERO
        if (elmbda >= ZERO) then
            if (elmbda /= ZERO) then
                ierror = 11
                return
            else
                select case (mb)
                    case (3, 6)
                        select case (np)
                            case (1, 4)
                                isw = 2
                                do j = 1, n
                                    pertrb = pertrb + sum(f(:m, j))
                                end do
                                pertrb = pertrb/(real(m*n, kind=wp)*HALF*(a + b))
                                do i = 1, m
                                    j = iwr + i
                                    a1 = pertrb*w(j)
                                    f(i,:n) = f(i,:n) - a1
                                end do
                                a2 = sum(f(1,:n))
                                a2 = a2/w(iwr+1)
                        end select
                end select
            end if
        end if

        do i = 1, m
            j = iwr + i
            a1 = dth2*w(j)
            w(i) = a1*w(i)
            j = iwc + i
            w(j) = a1*w(j)
            j = iwb + i
            w(j) = a1*w(j)
            f(i,:n) = a1*f(i,:n)
        end do

        lp = nbdcnd
        w(1) = ZERO
        w(iwr) = ZERO
        !
        ! To solve the system of equations.
        !
        local_error_flag = 0

        set_arguments: associate( &
            a_arg => w(1:m), &
            b_arg => w(iwb+1:iwb+1+m), &
            c_arg => w(iwc+1:iwc+1+m), &
            w_arg => w(iwr+1:iwr+1+m) &
            )
            if (lp /= 0) then
                call staggered_util%poistg_lower_routine(lp, n, 1, m, a_arg, b_arg, c_arg, idimf, f, local_error_flag, w_arg)
            else
                call centered_util%genbun_lower_routine(lp, n, 1, m, a_arg, b_arg, w_arg, idimf, f, local_error_flag, w_arg)
            end if
        end associate set_arguments

        if (.not.(a /= ZERO .or. mbdcnd /= 2 .or. isw /= 2)) then
            a1 = sum(f(1,:n))
            a1 = (a1 - dr2*a2/16)/n

            if (nbdcnd == 3) a1 = a1 + (bdd(1)-bdc(1))/(d - c)

            a1 = bda(1) - a1
            f(:m,:n) = f(:m,:n) + a1
        end if

    end subroutine hstplr_lower_routine

end submodule staggered_polar_solver
!
! REVISION HISTORY
!
! September 1973    Version 1
! April     1976    Version 2
! January   1978    Version 3
! December  1979    Version 3.1
! February  1985    Documentation upgrade
! November  1988    Version 3.2, FORTRAN 77 changes
! June      2004    Version 5.0, Fortran 90 changes
! May       2016    Fortran 2008 changes
!


C$Procedure  VZEROG ( Is a vector the zero vector?---general dim. )

      LOGICAL FUNCTION VZEROG ( V, NDIM )

C$ Abstract
C
C     Indicate whether a general-dimensional vector is the zero vector.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     MATH
C     VECTOR
C
C$ Declarations

      DOUBLE PRECISION      V    ( * )
      INTEGER               NDIM

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     V          I   Vector to be tested.
C     NDIM       I   Dimension of V.
C
C     The function returns the value .TRUE. if and only if V is the
C     zero vector.
C
C$ Detailed_Input
C
C     V,
C     NDIM           are, respectively, a vector and its dimension.
C
C$ Detailed_Output
C
C     The function returns the value .TRUE. if and only if V is the
C     zero vector.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1)   When NDIM is non-positive, this function returns the value
C          .FALSE.  (A vector of non-positive dimension cannot be the
C          zero vector.)
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This function has the same truth value as the logical expression
C
C        VNORMG ( V, NDIM )  .EQ.  0.D0
C
C     Replacing the above expression by
C
C        VZEROG ( V, NDIM )
C
C     has several advantages:  the latter expresses the test more
C     clearly, looks better, and doesn't go through the work of scaling,
C     squaring, taking a square root, and re-scaling (all of which
C     VNORMG must do) just to find out that a vector is non-zero.
C
C     A related function is VZERO, which accepts three-dimensional
C     vectors.
C
C$ Examples
C
C     1)  When testing whether a vector is the zero vector, one
C         normally constructs tests like
C
C            IF (  VNORMG ( V, NDIM )  .EQ.  0.D0  ) THEN
C                        .
C                        .
C                        .
C
C         These can be replaced with the code
C
C            IF (  VZEROG ( V, NDIM )  ) THEN
C                        .
C                        .
C                        .
C
C     2)  Make sure that a `unit' quaternion is non-zero before
C         converting it to a rotation matrix.
C
C            IF (  VZEROG ( Q, 4 )  ) THEN
C
C               [ handle error ]
C
C            ELSE
C
C               CALL VHATG ( Q, 4, Q )
C               CALL Q2M   ( Q, M )
C                        .
C                        .
C                        .
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C     I.M. Underwood (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 18-JUL-1990 (NJB) (IMU)
C
C-&

C$ Index_Entries
C
C     test whether an n-dimensional vector is the zero vector
C
C-&

C
C     Local variables
C
      INTEGER               I

C
C     Leave as soon as we find a non-zero component.  If we get through
C     the loop, we have a zero vector, as long as the vector's dimension
C     is valid.
C
      DO I = 1, NDIM

         IF ( V(I) .NE. 0.D0 ) THEN
            VZEROG = .FALSE.
            RETURN
         END IF

      END DO

C
C     We have a zero vector if and only if the vector's dimension is at
C     least 1.
C
      VZEROG  =  ( NDIM .GE. 1 )

      END


submodule(forlab_linalg) forlab_linalg_matpow

    implicit none

contains

    module procedure matpow_sp
    real(sp), allocatable :: a1(:, :)
    real(sp), parameter::zero = 0.0_sp, one = 1.0_sp
    integer::i, n, m
    if (.not. is_square(a)) then
        call error_stop("Error:A must be a square matrix")
    end if
    m = num
    if (m < 0) then
        call error_stop("Error: num must be a positive number")
    end if
    n = size(a, 1)
    allocate (a1(n, n), source=a)
    allocate (c(n, n))
    c = zero
    forall (i=1:n)
        c(i, i) = one
    end forall
    do
        if (mod(m, 2) == 1) then
            c = matmul(c, a1)
        end if
        m = shiftr(m, 1)
        if (m == 0) exit
        a1 = matmul(a1, a1)
    end do
    deallocate (a1)
    end procedure matpow_sp
    module procedure matpow_dp
    real(dp), allocatable :: a1(:, :)
    real(dp), parameter::zero = 0.0_dp, one = 1.0_dp
    integer::i, n, m
    if (.not. is_square(a)) then
        call error_stop("Error:A must be a square matrix")
    end if
    m = num
    if (m < 0) then
        call error_stop("Error: num must be a positive number")
    end if
    n = size(a, 1)
    allocate (a1(n, n), source=a)
    allocate (c(n, n))
    c = zero
    forall (i=1:n)
        c(i, i) = one
    end forall
    do
        if (mod(m, 2) == 1) then
            c = matmul(c, a1)
        end if
        m = shiftr(m, 1)
        if (m == 0) exit
        a1 = matmul(a1, a1)
    end do
    deallocate (a1)
    end procedure matpow_dp

end submodule forlab_linalg_matpow


! {  dg-do run }
! PR41278 internal compiler error related to matmul and transpose
! Test case prepared by Jerry DeLisle  <jvdelisle@gcc.gnu.org>
! Original test case by Chris <cmklaij@hetnet.nl>
program bug
  implicit none
  real, dimension(3,3) :: matA,matB,matC

  matA(1,:)=(/1., 2., 3./)
  matA(2,:)=(/4., 5., 6./)
  matA(3,:)=(/7., 8., 9./)

  matB=matmul(transpose(0.5*matA),matA)
  matC = transpose(0.5*matA)
  matC = matmul(matC, matA)
  if (any(matB.ne.matC)) STOP 1
end program bug


! test_pointsets.f90 --
!     Test the module for generating sets of points in 1, 2 or 3
!     dimensions
!
program test_pointsets
    use pointsets
    implicit none

    real, dimension(20)    :: x
    real, dimension(1000)  :: x2d
    real, dimension(1000)  :: y2d
    real, dimension(10000) :: x3d, y3d, z3d
    real                   :: ratio
    real                   :: xb
    real                   :: xe
    real                   :: yb
    real                   :: ye
    integer                :: i

!
! One-dimensional:
! - Uniform spacing
! - Spacing based on geometric series
! - Random spacing
!
    write(*,*) 'Uniform spacing:'
    call arithmetic_spacing( x, 1.0, 20.0 )
    write(*,'(5f10.4)') x
    if ( differ( x(1), 1.0 ) ) then
        write(*,*) '   Too large a difference at start'
    endif
    if ( differ( x(20), 20.0 ) ) then
        write(*,*) '   Too large a difference at end'
    endif

    write(*,*) 'Geometric spacing:'
    call geometric_spacing( x, 1.0, 20.0, 0.5 )
    write(*,'(5f10.4)') x
    if ( differ( x(1), 1.0 ) ) then
        write(*,*) '   Too large a difference at start'
    endif
    if ( differ( x(20), 20.0 ) ) then
        write(*,*) '   Too large a difference at end'
    endif
    ratio = (x(4)-x(3))/(x(3)-x(2))
    if ( differ( ratio, 0.5 ) ) then
        write(*,*) '   Ratio is incorrect'
    endif

    write(*,*) 'Random spacing:'
    call random_spacing( x, 1.0, 20.0 )
    write(*,'(5f10.4)') x
    if ( differ( x(1), 1.0 ) ) then
        write(*,*) '   Too large a difference at start'
    endif
    if ( differ( x(20), 20.0 ) ) then
        write(*,*) '   Too large a difference at end'
    endif

    if ( any( x(2:) < x(1:size(x)-1) ) ) then
        write(*,*) '   Coordinates not in ascending order'
    endif

!
! Two-dimensional case:
! TODO: We ought to test the uniformity ...
!
    write(*,*) 'Two-dimensional random points'
    call random_rectangle( x2d, y2d, 1.0, 10.0 )
    if ( any( x2d < 0.0 ) .or. any( y2d < 0.0 ) ) then
        write(*,*) '    Negative coordinates found'
    endif
    if ( any( x2d > 1.0 ) .or. any( y2d > 10.0 ) ) then
        write(*,*) '    Coordinates out of range'
    endif

    do i = 1,10
        yb = i-1
        ye = i
        write(*,'(2f10.4,i6)') yb, ye, &
            count( y2d >= yb .and. y2d <= ye )
    enddo

    do i = 1,10
        xb = 0.1*(i-1)
        xe = 0.1*i
        write(*,'(2f10.4,i6)') xb, xe, &
            count( x2d >= xb .and. x2d <= xe )
    enddo

!
! Disk:
! There should be about the same number of points in a slice
! of the disk with x > 0.8, y > 0.8 and z > 0.8. Ditto
! for points inside or outside the disk with radius 0.5**1/2
!
    write(*,*) 'Random points in a disk:'
    call random_disk( x2d, y2d, 1.0 )
    write(*,*) 'x > 0.8:', count( x2d > 0.8 )
    write(*,*) 'y > 0.8:', count( y2d > 0.8 )
    write(*,*) 'Margin: ', int(sqrt(real( count(x2d > 0.8) )))

    write(*,*) 'Distance < 0.5**1/2:', count( sqrt(x2d**2 + y2d**2) < sqrt(0.5_wp) )
    write(*,*) 'Distance > 0.5**1/2:', count( sqrt(x2d**2 + y2d**2) > sqrt(0.5_wp) )
    write(*,*) 'Margin:             ', int(sqrt(real(size(x2d)/2)))

!
! Circle:
! There should be about the same number of points in a slice
! of the circle with x > 0.8, y > 0.8 and z > 0.8.
!
    write(*,*) 'Random points in a circle:'
    call random_circle( x2d, y2d, 1.0 )
    write(*,*) 'x > 0.8:', count( x2d > 0.8 )
    write(*,*) 'y > 0.8:', count( y2d > 0.8 )
    write(*,*) 'Margin: ', int(sqrt(real( count(x2d > 0.8) )))

!
! Ball:
! There should be about the same number of points in a slice
! of the ball with x > 0.8, y > 0.8 and z > 0.8. Ditto
! for points inside or outside the ball with radius 0.5**1/3
!
    write(*,*) 'Random points in a 3D ball:'
    call random_ball( x3d, y3d, z3d, 1.0 )
    write(*,*) 'x > 0.8:', count( x3d > 0.8 )
    write(*,*) 'y > 0.8:', count( y3d > 0.8 )
    write(*,*) 'z > 0.8:', count( z3d > 0.8 )
    write(*,*) 'Margin: ', int(sqrt(real( count(x3d > 0.8) )))

    write(*,*) 'Distance < 0.5**1/3:', count( sqrt(x3d**2 + y3d**2 +z3d**2) < 0.5**0.333333 )
    write(*,*) 'Distance > 0.5**1/3:', count( sqrt(x3d**2 + y3d**2 +z3d**2) > 0.5**0.333333 )
    write(*,*) 'Margin:             ', int(sqrt(real(size(x3d)/2)))

!
! Sphere:
! There should be about the same number of points in a slice
! of the ball with x > 0.8, y > 0.8 and z > 0.8.
!
    write(*,*) 'Random points in a 3D sphere:'
    call random_sphere( x3d, y3d, z3d, 1.0 )
    write(*,*) 'x > 0.8:', count( x3d > 0.8 )
    write(*,*) 'y > 0.8:', count( y3d > 0.8 )
    write(*,*) 'z > 0.8:', count( z3d > 0.8 )
    write(*,*) 'Margin: ', int(sqrt(real( count(x3d > 0.8) )))

contains
logical function differ( x, y )
    real :: x, y

    differ = abs(x-y) > 0.1e-5
end function differ
end program


 SUBROUTINE EARTH_RADIUS(IGDTMPL, IGDTLEN, RADIUS, ECCEN_SQUARED)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! $Revision: 74917 $
!
! SUBPROGRAM:  EARTH_RADIUS   DETERMINE EARTH RADIUS AND SHAPE
!   PRGMMR: GAYNO    ORG: W/NMC23     DATE: 2015-07-14
!
! ABSTRACT: DETERMINE THE RADIUS AND SHAPE OF THE EARTH FROM
!   THE GRIB 2 GRID DEFINITION TEMPLATE ARRAY - SECTION 3
!
! PROGRAM HISTORY LOG:
! 2015-07-14  GAYNO
!
! USAGE:   CALL EARTH_RADIUS(IGDTMPL, IGDTLEN, &
!                            RADIUS, ECCEN_SQUARED)
!
!   INPUT ARGUMENT LIST:
!     IGDTMPL  - INTEGER (IGDTLEN) GRID DEFINITION TEMPLATE ARRAY.
!                CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                FOR ALL MAP PROJECTIONS RECOGNIZED BY IPLIB,
!                THE ENTRIES USE BY THIS ROUTINE ARE:
!                 (1) - SHAPE OF EARTH, SECTION 3, OCTET 15
!                 (2) - SCALE FACTOR OF SPHERICAL EARTH RADIUS,
!                       OCTET 16
!                 (3) - SCALED VALUE OF RADIUS OF SPHERICAL EARTH,
!                       OCTETS 17-20
!                 (4) - SCALE FACTOR OF MAJOR AXIS OF ELLIPTICAL EARTH,
!                       OCTET 21
!                 (5) - SCALED VALUE OF MAJOR AXIS OF ELLIPTICAL EARTH,
!                       OCTETS 22-25
!                 (6) - SCALE FACTOR OF MINOR AXIS OF ELLIPTICAL EARTH,
!                       OCTET 26
!                 (7) - SCALED VALUE OF MINOR AXIS OF ELLIPTICAL EARTH,
!                       OCTETS 27-30
!     IGDTLEN  - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD
!                DATA STRUCTURE.
!
!   OUTPUT ARGUMENT LIST:
!     RADIUS        - REAL EARTH RADIUS IN METERS.
!                     FOR ELLIPITICAL EARTHS, THIS IS THE
!                     SEMI MAJOR AXIS.  SEE "MAP PROJECTSIONS -
!                     A WORKING MANUAL" BY SNYDER (1987)
!                     FOR DETAILS.
!     ECCEN_SQUARED - REAL EARTH ECCENTRICITY SQUARED
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,                INTENT(IN   ) :: IGDTLEN
 INTEGER,                INTENT(IN   ) :: IGDTMPL(IGDTLEN)
!
 REAL,                   INTENT(  OUT) :: ECCEN_SQUARED
 REAL,                   INTENT(  OUT) :: RADIUS
!
 REAL                                  :: FLAT
 REAL                                  :: MAJOR_AXIS, MINOR_AXIS
!
 SELECT CASE (IGDTMPL(1))
   CASE (0)
     RADIUS        = 6367470.0
     ECCEN_SQUARED = 0.0
   CASE (1)  ! USER SPECIFIED SPHERICAL
     RADIUS        = FLOAT(IGDTMPL(3))/FLOAT(10**IGDTMPL(2))
     ECCEN_SQUARED = 0.0
   CASE (2)  ! IAU 1965
     RADIUS        = 6378160.0      ! SEMI MAJOR AXIS
     FLAT          = 1.0/297.0      ! FLATTENING
     ECCEN_SQUARED = (2.0*FLAT) - (FLAT**2)
   CASE (3)  ! USER SPECIFIED ELLIPTICAL (KM)
     MAJOR_AXIS    = FLOAT(IGDTMPL(5))/FLOAT(10**IGDTMPL(4))
     MAJOR_AXIS    = MAJOR_AXIS * 1000.0
     MINOR_AXIS    = FLOAT(IGDTMPL(7))/FLOAT(10**IGDTMPL(6))
     MINOR_AXIS    = MINOR_AXIS * 1000.0
     ECCEN_SQUARED = 1.0 - (MINOR_AXIS**2 / MAJOR_AXIS**2)
     RADIUS        = MAJOR_AXIS
   CASE (4)  ! IAG-GRS80 MODEL
     RADIUS        = 6378137.0      ! SEMI MAJOR AXIS
     FLAT          = 1.0/298.2572   ! FLATTENING
     ECCEN_SQUARED = (2.0*FLAT) - (FLAT**2)
   CASE (5)  ! WGS84 DATUM
     RADIUS        = 6378137.0      ! SEMI MAJOR AXIS
     ECCEN_SQUARED = 0.00669437999013
   CASE (6)
     RADIUS        = 6371229.0
     ECCEN_SQUARED = 0.0
   CASE (7)  ! USER SPECIFIED ELLIPTICAL (M)
     MAJOR_AXIS    = FLOAT(IGDTMPL(5))/FLOAT(10**IGDTMPL(4))
     MINOR_AXIS    = FLOAT(IGDTMPL(7))/FLOAT(10**IGDTMPL(6))
     ECCEN_SQUARED = 1.0 - (MINOR_AXIS**2 / MAJOR_AXIS**2)
     RADIUS        = MAJOR_AXIS
   CASE (8)
     RADIUS        = 6371200.0
     ECCEN_SQUARED = 0.0
   CASE DEFAULT
     RADIUS        = -9999.
     ECCEN_SQUARED = -9999.
 END SELECT
!
 RETURN
!
 END SUBROUTINE EARTH_RADIUS


module SuperSorting

    contains

    ! Insertion Sorting
    subroutine insertionsort(A)
        implicit none

        integer,intent(inout)   :: A(:)

        integer :: i,j,t
        integer :: L

        i = 2
        do while(i < size(A,1))
            j = i
            do while(j > 1 .and. A(j-1) > A(j))
                t = A(j)
                A(j) = A(j-1)
                A(j-1) = t
                j = j - 1
            end do
            i = i + 1
        end do
    end subroutine

    ! Merge Sorting
    recursive function mergesort(left,right) result(merged)
        implicit none

        integer,intent(in)  :: left(:),right(:)
        integer             :: merged(size(left,1)+size(right,1))

        integer             :: sR, sL

        sR = size(right,1)
        sL = size(left,1)

        if (sL .eq. 0) then
            merged = right
        elseif (sR .eq. 0) then
            merged = left
        elseif (left(1) < right(1)) then
            merged = [left(1),mergesort(left(2:),right)]
        else
            merged = [right(1),mergesort(left,right(2:))]
        end if
    end function

    ! Merge for Tim Sorting
    subroutine mergetim(A,l,m,r)
        implicit none

        integer,intent(inout)   :: A(:)
        integer,intent(in)      :: l,m,r

        integer :: i, j, k, len1, len2
        integer,allocatable :: left(:), right(:)

        len1 = m-l+1
        len2 = r-m

        allocate(left(len1),right(len2))

        left = A(l:m)
        right = A((m+1):r)

        i = 0
        j = 0
        k = l
        do while(i < len1 .and. j < len2)
            if (left(i) .le. right(j)) then
                A(k) = left(i)
                i = i + 1
            else
                A(k) = right(j)
                j = j + 1
            end if
            k = k + 1
        end do

        do while(i < len1)
            A(k) = left(i)
            k = k + 1
            i = i + 1
        end do
        do while(j < len2)
            A(k) = right(j)
            k = k + 1
            j = j + 1
        end do

        deallocate(left,right)
    end subroutine

    ! Tim Sorting
    subroutine timsort(A)
        implicit none

        integer,intent(inout)  :: A(:)

        integer :: length, n, r, st, en, mid
        integer :: minrun, left, right, sz

        ! Find minrun
        n = size(A,1)
        r = 0
        do while(n .ge. 32)
            r = ior(r,iand(n,1))
            n = ishft(n,-1)
        end do
        minrun = n + r
        n = size(A,1)

        ! Main run
        do st = 1,n,minrun
            en = minval([st + minrun - 1, n])
            call insertionsort(A(st:en))
        end do

        sz = minrun
        do while(sz < n)
            do left = 1,n,2*sz
                mid = minval([n,left+sz-1])
                right = minval([left+2*sz-1,n])

                call mergetim(A,left,mid,right)
            end do
            sz = sz*2
        end do
    end subroutine

end module


! email: personal@auliakhalqillah.com
program minmax
    implicit none
    real :: data(3), minimum, maximum
    integer :: i,j,n

    data = [2,1,4]
    n = 3

    ! Nilai Minimum
    minimum = data(1)
    i = 1
    do i = 1,n-1
        if (minimum < data(i+1)) then
            minimum = minimum
        else
            minimum = data(i+1)
        end if
    end do
    print*, 'Nilai Minimum:',minimum

    ! Nilai Maximum
    maximum = data(1)
    j = 1
    do j = 1,n-1
        if (maximum > data(j+1)) then
            maximum = maximum
        else
            maximum = data(j+1)
        end if
    end do
    print*, 'Nilai Maksimum:',maximum

end program minmax


      SUBROUTINE cosft2(y,n,isign)
      INTEGER isign,n
      REAL y(n)
CU    USES realft
      INTEGER i
      REAL sum,sum1,y1,y2,ytemp
      DOUBLE PRECISION theta,wi,wi1,wpi,wpr,wr,wr1,wtemp,PI
      PARAMETER (PI=3.141592653589793d0)
      theta=0.5d0*PI/n
      wr=1.0d0
      wi=0.0d0
      wr1=cos(theta)
      wi1=sin(theta)
      wpr=-2.0d0*wi1**2
      wpi=sin(2.d0*theta)
      if(isign.eq.1)then
        do 11 i=1,n/2
          y1=0.5*(y(i)+y(n-i+1))
          y2=wi1*(y(i)-y(n-i+1))
          y(i)=y1+y2
          y(n-i+1)=y1-y2
          wtemp=wr1
          wr1=wr1*wpr-wi1*wpi+wr1
          wi1=wi1*wpr+wtemp*wpi+wi1
11      continue
        call realft(y,n,1)
        do 12 i=3,n,2
          wtemp=wr
          wr=wr*wpr-wi*wpi+wr
          wi=wi*wpr+wtemp*wpi+wi
          y1=y(i)*wr-y(i+1)*wi
          y2=y(i+1)*wr+y(i)*wi
          y(i)=y1
          y(i+1)=y2
12      continue
        sum=0.5*y(2)
        do 13 i=n,2,-2
          sum1=sum
          sum=sum+y(i)
          y(i)=sum1
13      continue
      else if(isign.eq.-1)then
        ytemp=y(n)
        do 14 i=n,4,-2
          y(i)=y(i-2)-y(i)
14      continue
        y(2)=2.0*ytemp
        do 15 i=3,n,2
          wtemp=wr
          wr=wr*wpr-wi*wpi+wr
          wi=wi*wpr+wtemp*wpi+wi
          y1=y(i)*wr+y(i+1)*wi
          y2=y(i+1)*wr-y(i)*wi
          y(i)=y1
          y(i+1)=y2
15      continue
        call realft(y,n,-1)
        do 16 i=1,n/2
          y1=y(i)+y(n-i+1)
          y2=(0.5/wi1)*(y(i)-y(n-i+1))
          y(i)=0.5*(y1+y2)
          y(n-i+1)=0.5*(y1-y2)
          wtemp=wr1
          wr1=wr1*wpr-wi1*wpi+wr1
          wi1=wi1*wpr+wtemp*wpi+wi1
16      continue
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/cosft2.for


program problem10
  use euler
  implicit none
  integer, parameter :: limit=2000000
  integer            :: i
  integer*16         :: sum=2

  do i=3,limit-1,2
     if (is_prime(int8(i))) then
        sum=sum+i
     end if
  end do

  print *, sum

end program problem10


module gamma_module

   use system_module,only : dp

   ! Incomplete GAMMA function. Adapted from Numerical Recipes in Fortran 77.

   implicit none
!   integer, parameter :: dp = kind(1.0d0)
   integer, parameter :: max_iteration = 100
   real(dp), parameter :: eps = 1.0e-12_dp
   real(dp), parameter :: min_float = tiny(1.0_dp) * 10.0_dp
   real(dp), parameter ::  log_sqrt_2_pi = log(sqrt(2.0_dp*3.14159265358979323846264338327950288_dp) )

   interface gamma_incomplete_upper
      module procedure gamma_incomplete_upper, gamma_incomplete_upper_xarray1d, &
                       gamma_incomplete_upper_ainteger
   endinterface gamma_incomplete_upper

   contains

   function gamma_incomplete_upper_xarray1d(a,x)
      real(dp), intent(in) :: a
      real(dp), intent(in), dimension(:) :: x
      real(dp), dimension(size(x)) :: gamma_incomplete_upper_xarray1d

      integer :: i

      do i = 1, size(x)
         gamma_incomplete_upper_xarray1d(i) = gamma_incomplete_upper(a,x(i))
      enddo

   endfunction gamma_incomplete_upper_xarray1d

   function gamma_incomplete_upper_ainteger(a,x)
      integer, intent(in) :: a
      real(dp), intent(in) :: x
      real(dp) :: gamma_incomplete_upper_ainteger

      gamma_incomplete_upper_ainteger = gamma_incomplete_upper(real(a,dp),x)

   endfunction gamma_incomplete_upper_ainteger

   function gamma_incomplete_upper(a,x)

      real(dp), intent(in) :: a, x
      real(dp) :: gamma_incomplete_upper
      ! USES gcf,gser
      ! Returns the incomplete gamma function Q(a, x) ≡ 1 − P(a, x).
      real(dp) :: gammcf, gamser, gln

      if(x < 0.0_dp .or. a <= 0.0_dp ) stop 'bad arguments in gamma_incomplete_upper'

      if(x < a+1.0_dp)then                         !Use the series representation
         call gser(gamser,a,x,gln)
         gamma_incomplete_upper = 1.0_dp - gamser  !and take its complement.
      else                                         !Use the continued fraction representation.
         call gcf(gammcf,a,x,gln)
         gamma_incomplete_upper = gammcf
      endif

      gamma_incomplete_upper = gamma_incomplete_upper * exp(gln)

   endfunction gamma_incomplete_upper

   function gammp(a,x)

      real(dp), intent(in) :: a, x
      real(dp) :: gammp
      ! USES gcf,gser
      ! Returns the incomplete gamma function P(a, x).
      real(dp) :: gammcf,gamser,gln

      if(x < 0.0_dp .or. a <= 0.0_dp) stop 'bad arguments in gammp'

      if(x < a + 1.0_dp )then              !Use the series representation.
         call gser(gamser,a,x,gln)
         gammp=gamser
      else                                 !Use the continued fraction representation
         call gcf(gammcf,a,x,gln)
         gammp =1.0_dp - gammcf            !and take its complement.
      endif

   endfunction gammp

   function gammq(a,x)

      real(dp), intent(in) :: a, x
      real(dp) :: gammq
      ! USES gcf,gser
      ! Returns the incomplete gamma function Q(a, x) ≡ 1 − P(a, x).
      real(dp) :: gammcf, gamser, gln

      if(x < 0.0_dp .or. a <= 0.0_dp ) stop 'bad arguments in gammq'

      if(x < a+1.0_dp)then                  !Use the series representation
         call gser(gamser,a,x,gln)
         gammq=1.0_dp - gamser              !and take its complement.
      else                                  !Use the continued fraction representation.
         call gcf(gammcf,a,x,gln)
         gammq=gammcf
      endif

   endfunction gammq

   subroutine gser(gamser,a,x,gln)
      real(dp), intent(in) :: a, x
      real(dp), intent(out) :: gamser, gln

      ! USES ln_gamma
      !Returns the incomplete gamma function P(a, x) evaluated by its series
      !representation as
      !gamser. Also returns ln \Gamma(a) as gln.

      integer :: i
      real(dp) :: ap, del, sum

      gln = ln_gamma(a)

      if(x <= 0.0_dp)then
         if(x < 0.0_dp) stop 'x < 0 in gser'
         gamser=0.0_dp
      else
         ap = a
         sum = 1.0_dp / a
         del = sum
         i = 0
         do
            i = i + 1
            ap = ap + 1.0_dp
            del = del * x / ap
            sum = sum + del
            if(abs(del) < abs(sum)*eps) exit
            if(i == max_iteration) stop 'Number of iterations reached maximum &
               number of iterations, stopping. Consider increasing max_iteration.'
         enddo
         gamser = sum * exp(-x + a * log(x) - gln)
      endif

   endsubroutine gser

   subroutine gcf(gammcf,a,x,gln)
      real(dp), intent(in) :: a, x
      real(dp), intent(out) :: gammcf, gln

      ! USES ln_gamma
      ! Returns the incomplete gamma function Q(a, x) evaluated by its continued
      ! fraction representation as gammcf. Also returns ln \Gamma(a) as gln.

      integer :: i
      real(dp) :: an,b,c,d,del,h

      gln = ln_gamma(a)

      b = x + 1.0_dp - a               ! Set up for evaluating continued fraction by modiﬁed
      c = 1.0 / min_float              ! Lentz’s method (5.2) with b0 = 0.
      d = 1.0_dp / b
      h = d
      i = 0
      do                               ! Iterate to convergence.
         i = i + 1
         an = -i * (i-a)
         b = b + 2.0_dp
         d = an * d + b

         if(abs(d) < min_float) d = min_float

         c = b + an / c

         if(abs(c) < min_float) c = min_float

         d = 1.0_dp / d
         del = d * c
         h = h * del
         if(abs(del-1.0_dp) < eps) exit
         if(i == max_iteration) stop 'Number of iterations reached maximum &
            number of iterations, stopping. Consider increasing max_iteration.'
      enddo
      gammcf = exp(-x + a*log(x) - gln)*h ! Put factors in front.

   endsubroutine gcf

!   function ln_gamma(xx)
!      real(dp), intent(in) :: xx
!      real(dp) :: ln_gamma
!
!      ! Returns the value ln[ \Gamma(xx)] for xx > 0.
!      integer :: j
!      real(dp) :: ser, tmp, x, y
!
!      real(dp), dimension(6), parameter :: cof = (/76.18009172947146_dp,-86.50532032941677_dp, &
!      24.01409824083091_dp,-1.231739572450155_dp,0.1208650973866179e-2_dp,-0.5395239384953e-5_dp/)
!      real(dp), parameter :: stp = 2.5066282746310005_dp
!
!      x = xx
!      y = x
!      tmp = x + 5.5_dp
!      tmp = (x + 0.5_dp) * log(tmp) - tmp
!      ser = 1.000000000190015_dp
!      do j = 1, 6
!         y = y + 1.0_dp
!         ser = ser + cof(j) / y
!      enddo
!      ln_gamma = tmp + log(stp*ser/x)
!   endfunction ln_gamma

   function ln_gamma(xx)
      real(dp), intent(in) :: xx
      real(dp) :: ln_gamma

      integer :: i
      real(dp) :: z, x, t

      real(dp), parameter :: g = 7.0_dp
      integer, parameter :: n = 9
      real(dp), dimension(n), parameter :: p = &
        (/0.99999999999980993227684700473478_dp, 676.520368121885098567009190444019_dp, &
          -1259.13921672240287047156078755283_dp, 771.3234287776530788486528258894_dp, &
          -176.61502916214059906584551354_dp, 12.507343278686904814458936853_dp, &
          -0.13857109526572011689554707_dp, 9.984369578019570859563e-6_dp, 1.50563273514931155834e-7_dp /)

      !real(dp), parameter :: g = 4.74218750_dp
      !integer, parameter :: n = 15
      !real(dp), dimension(n), parameter :: p = &
      !(/0.99999999999999709182_dp,  57.156235665862923517_dp, -59.597960355475491248_dp, &
      !  14.136097974741747174_dp,  -0.49191381609762019978_dp,  .33994649984811888699e-4_dp, &
      !  0.46523628927048575665e-4_dp,  -0.98374475304879564677e-4_dp,  0.15808870322491248884e-3_dp, &
      !  -0.21026444172410488319e-3_dp,  0.21743961811521264320e-3_dp,  -0.16431810653676389022e-3_dp, &
      !  0.84418223983852743293e-4_dp,   -0.26190838401581408670e-4_dp,     0.36899182659531622704e-5_dp/)

      z = xx - 1.0_dp

      x = 0.0_dp
      do i = n, 2, -1
         x = x + p(i)/(z+real(i-1,dp))
      enddo
      x = x + p(1)

      t = z + g + 0.5_dp

      ln_gamma =  log_sqrt_2_pi - t + log(x) + (z+0.5_dp)*log(t)

   endfunction ln_gamma

endmodule gamma_module


*
* calculus - Estimate the area under the curve Y=X**2 from 0-1
*
*  Written by: C. Severance 16Mar92
*
      REAL X,AREA,RECT,ERROR
*
* Print out the table a different way - Use a real number for the index
*
      AREA = 0.0
      DO X=0.0,1.0,0.1
        RECT = 0.1 * (X ** 2)
        AREA = AREA + RECT
      ENDDO
*
* Print out the approximate area and actual area and the error
*
      PRINT *,'Approximate area =',AREA
      PRINT *,'Actual area =',1.0/3.0
      ERROR = ABS ( (1.0/3.0) - AREA )
      PRINT *,'Error =',ERROR
      END


module coarray_util

  implicit none

  public :: co_norm2, co_dot_product

contains

  !===================================================================!
  ! Function to compute the norm of a distributed vector
  !===================================================================!

  function co_norm2(x) result(norm)

    real(8), intent(in) :: x(:)
    real(8) :: xdot, norm

    ! find dot product, sum over processors, take sqrt and return
    xdot = dot_product(x,x)
    call co_sum (xdot)
    norm = sqrt(xdot)

  end function co_norm2

  !===================================================================!
  ! Function to compute the dot product of two distributed vector
  !===================================================================!

  function co_dot_product(a, b) result(dot)

    real(8), intent(in) :: a(:), b(:)
    real(8) :: dot

    ! find dot product, sum over processors, take sqrt and return
    dot = dot_product(a, b)
    call co_sum (dot)

  end function co_dot_product

end module coarray_util


function NormalGravity(geocentric_lat, GM, omega, a, b)
!------------------------------------------------------------------------------
!
!   Compute the total predicted gravity normal to the ellipsoid at a given
!   GEOCENTRIC latitude (input in DEGREES), using Somigliana's formula.
!   This is taken from Physical Geodesy (Hofmann-Wellenhof and Moritz,
!   sec. ed.), sections 2.7 and 2.8.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp) :: NormalGravity
    real(dp), intent(in) :: geocentric_lat, gm, omega, a, b
    real(dp) :: geodetic_lat, pi, ga, gb, m, ep, bigE, q0, q0p

    if (a < b) then
        print*, "Warning --- NormalGravity"
        print*, "The semimajor axis A should be greater than the " // &
                "semiminor axis B."
    end if

    if (a == b .and. omega == 0.0_dp) then
        NormalGravity = GM / a**2

    else if (a == b .and. omega /= 0.0_dp) then
        print*, "Warning --- NormalGravity"
        print*, "A can not be equal to B when OMEGA is non zero."
        print*, "Setting OMEGA equal to zero."
        NormalGravity = GM / a**2

    else
        pi = acos(-1.0_dp)

        m = omega**2 * a**2 * b / GM

        bigE = sqrt(a**2 - b**2) ! linear eccentricity

        ep = bigE / b ! second eccentricity

        q0 = 0.50_dp * ((1.0_dp + 3.0_dp * (b / bigE)**2) * atan(bigE / b) &
                        - 3.0_dp * b / bigE)

        q0p = 3.0_dp * (1.0_dp + (b / bigE)**2) &
              * (1.0_dp - b / bigE * atan(bigE / b) ) - 1.0_dp

        ! gravity on equator
        ga = GM / (a*b) * (1.0_dp - m - m * ep * q0p / 6.0_dp / q0)

        gb = GM / a**2 * (1.0_dp + m * ep * q0p / 3.0_dp / q0) ! gravity at poles

        geodetic_lat = atan((a / b)**2 * tan(geocentric_lat * pi / 180.0_dp))

        NormalGravity = a * ga * cos(geodetic_lat)**2 + b * gb &
                        * sin(geodetic_lat)**2

        NormalGravity = NormalGravity / sqrt(a**2 * cos(geodetic_lat)**2 &
                        + b**2 * sin(geodetic_lat)**2 )
    end if

end function NormalGravity