      SUBROUTINE PRESHYBRID(P0,PS,HYA,HYB,KLVL,PHY)
      IMPLICIT NONE

c NCL: phy  = pres_hybrid (ps,p0,hya,hyb)
c      klvl = dimsizes(hya)
c                              input
      INTEGER KLVL
      DOUBLE PRECISION P0,PS,HYA(KLVL),HYB(KLVL)
c                              output
      DOUBLE PRECISION PHY(KLVL)
c                              local
      INTEGER K

      DO K = 1,KLVL
          PHY(K) = P0*HYA(K) + HYB(K)*PS
      END DO

      RETURN
      END

      SUBROUTINE DPRESHYBRID(P0,PS,HYAI,HYBI,KLVL,DPHY)
      IMPLICIT NONE

c NCL: dphy  = dpres_hybrid (ps,p0,hyai,hybi)
c      klvl  = dimsizes(hyai)

c this routine interploates ccm2/3 hybrid coordinate data
c     to pressure coordinates. These are ordered from top-to-bottom.

c     formula for the pressure of a hybrid surface is;
c          phy(k) = hya(k)*p0 + hyb(k)*psfc

c     input
c          hyai   - is the "a" or pressure hybrid coef
c          hybi   - is the "b" or sigma coeficient
c          p0     - is the base pressure in pascals [Pa]
c          psfc   - is the surface pressure in pascals [Pa]
c     output
c          dphy    - delta pressure [Pa]
c                              INPUT
      INTEGER KLVL
      DOUBLE PRECISION P0,PS,HYAI(KLVL),HYBI(KLVL)
c                              OUTPUT
      DOUBLE PRECISION DPHY(KLVL-1)
c                              LOCAL
      INTEGER K

      DO K = 1,KLVL - 1
          DPHY(K) = ABS(P0* (HYAI(K+1)-HYAI(K))+ (HYAI(K+1)-HYBI(K))*PS)
      END DO

      RETURN
      END


program spell

  implicit none
  integer :: e
  integer :: i
  integer :: m
  integer :: n
  character (9), dimension (19), parameter :: small =       &
    & (/'one      ', 'two      ', 'three    ', 'four     ', &
    &   'five     ', 'six      ', 'seven    ', 'eight    ', &
    &   'nine     ', 'ten      ', 'eleven   ', 'twelve   ', &
    &   'thirteen ', 'fourteen ', 'fifteen  ', 'sixteen  ', &
    &   'seventeen', 'eighteen ', 'nineteen '/)
  character (7), dimension (2 : 9), parameter :: tens =        &
    & (/'twenty ', 'thirty ', 'forty  ', 'fifty  ', 'sixty  ', &
    &   'seventy', 'eighty ', 'ninety '/)
  character (8), dimension (3), parameter :: big = &
    & (/'thousand', 'million ', 'billion '/)
  character (256) :: r

  do
    read (*, *, iostat = i) n
    if (i /= 0) then
      exit
    end if
    if (n == 0) then
      r = 'zero'
    else
      r = ''
      m = abs (n)
      e = 0
      do
        if (m == 0) then
          exit
        end if
        if (modulo (m, 1000) > 0) then
          if (e > 0) then
            r = trim (big (e)) // ' ' // r
          end if
          if (modulo (m, 100) > 0) then
            if (modulo (m, 100) < 20) then
              r = trim (small (modulo (m, 100))) // ' ' // r
            else
              if (modulo (m, 10) > 0) then
                r = trim (small (modulo (m, 10))) // ' ' // r
                r = trim (tens (modulo (m, 100) / 10)) // '-' // r
              else
                r = trim (tens (modulo (m, 100) / 10)) // ' ' // r
              end if
            end if
          end if
          if (modulo (m, 1000) / 100 > 0) then
            r = 'hundred' // ' ' // r
            r = trim (small (modulo (m, 1000) / 100)) // ' ' // r
          end if
        end if
        m = m / 1000
        e = e + 1
      end do
      if (n < 0) then
        r = 'negative' // ' ' // r
      end if
    end if
    write (*, '(a)') trim (r)
  end do

end program spell


program problem83
  implicit none
  integer, parameter      :: n=80
  integer, dimension(n,n) :: data
  integer, dimension(n,n) :: state
  integer                 :: i,j

  open(33,file='./data/problem83.dat')
  read(33,*) data

  do i=1,n
     do j=1,n
        state(i,j)=huge(state)
     end do
  end do

  call search(1,1,0)

  print *, state(n,n)

contains

  recursive subroutine search(x,y,previous)
    implicit none
    integer, intent(in) :: x,y,previous
    integer             :: current

    current=data(x,y)+previous
    if (current<state(x,y)) then
       state(x,y)=current
       if (x>1) call search(x-1,y,current)
       if (x<n) call search(x+1,y,current)
       if (y>1) call search(x,y-1,current)
       if (y<n) call search(x,y+1,current)
    end if

  end subroutine search

end program problem83


subroutine get_area(radius, area)
    implicit none
    real, intent(in) :: radius(:)
    real, intent(out) :: area(:)
    area = 3.1415926 * radius**2
end subroutine get_area

program circle
    interface
        subroutine get_area(radius, area)
            real, intent(in) :: radius(:)
            real, intent(out) :: area(:)
        end subroutine get_area
    end interface
    real :: r(3), a(3)
    r = [1.0, 2.0, 3.0]
    call get_area(r, a)
    print '(3(f0.2, 2x))', a ! 3.14  12.57  28.27
end program circle


C     LAST UPDATE 22/03/94
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE FGAUSS(X,A,Y,DYDA)
      IMPLICIT NONE
C
C Purpose: Y(X;A) is Gaussian. The amplitude. centre
C          and width of the Gaussian are stored in consecutive locations
C          of A: A(1) = H,  A(2) = P,  A(3) = FWHM
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Parameters:
C
      DOUBLE PRECISION TINY,FACTOR
      PARAMETER(TINY=1.0D-10,FACTOR=1.66510922231D0)
C
C Arguments:
C
      DOUBLE PRECISION A(10),DYDA(10)
      DOUBLE PRECISION X,Y
C
C Local variables:
C
      DOUBLE PRECISION  ARG,EX,FAC,W
C
C-----------------------------------------------------------------------
      IF(A(3).LT.TINY)A(3) = TINY
      W = A(3)/FACTOR
      ARG = (X-A(2))/W
      EX = EXP(-ARG*ARG)
      FAC = A(1)*EX*2.0D0*ARG
      Y = A(1)*EX
      DYDA(1) = EX
      DYDA(2) = FAC/W
      DYDA(3) = FACTOR*FAC*ARG/W
C
      RETURN
      END


program potencial

    implicit none
    double precision, dimension (1:300) :: v, r, dv, dr, f
    double precision :: e, s
    integer :: c
    real :: cont

	e = 0.01
	s = 3.40

	cont = 3.3
	    do c = 1,300
		cont = cont + 0.01
		r(c) = cont
		v(c) = 4*e*(((s/r(c))**12)-((s/r(c))**6))
	    end do

	call forca(v, r, dv, dr, f)

	    do c = 1,300
		write(*,*) r(c), v(c), f(c)
	    end do

	open(1,FILE = "dados.txt")

	    do c = 1,300
		write(1,*) r(c), v(c), f(c)
	    end do

	close(1)

end program potencial

subroutine forca(v, r, dv, dr, f)

    double precision, dimension(1:300) ::  v, r, dv, dr, f
    integer :: c

	do c = 1,299
	    dv(c) = v(c+1) - v(c)
	    dr(c) = r(c+1) - r(c)
	    f(c) = -(dv(c)/dr(c))
	end do

    return

    end subroutine


program ImageDifference

  use RCImageBasic
  use RCImageIO

  implicit none

  integer, parameter :: input1_u = 20, &
                        input2_u = 21

  type(rgbimage) :: lenna1, lenna2
  real           :: totaldiff

  open(input1_u, file="Lenna100.ppm", action="read")
  open(input2_u, file="Lenna50.ppm", action="read")
  call read_ppm(input1_u, lenna1)
  call read_ppm(input2_u, lenna2)
  close(input1_u)
  close(input2_u)

  totaldiff = sum(  (abs(lenna1%red - lenna2%red) + &
                     abs(lenna1%green - lenna2%green) + &
                     abs(lenna1%blue - lenna2%blue)) / 255.0 )

  print *, 100.0 * totaldiff / (lenna1%width * lenna1%height * 3.0)

  call free_img(lenna1)
  call free_img(lenna2)

end program ImageDifference


C
C
*+ noise_map

       subroutine noise_map(map,n,m,i1,i2,j1,j2,xmean,xsd,npts,status)
C      ---------------------------------------------------------------
C
C Calculate the mean and noise in specified map window
C
C Input
C    MAP          -      R*4(array) -    map data
C    M,N          -      I4         -    range of map data
C    I1,I2        -      I4         -    range in I
C    J1,J2        -      I4         -    range in J
C
C Returned
C    XMEAN        -      R4         -    mean in window
C    XSD          -      R4         -    standard deviation in window
C    NPTS         -      I4         -    number of points in window
C
C  This routine calculates the mean and noise in the window I1-I2,J1-J2
C  of the input map.  No rejection is used.
*-
       integer    status, m, n, i1, i2, j1, j2, i, j, npts
       real*4     map(m,n), xmean, xsd, x
       real*4     xsum1, xsum2, fn

       xsum1=0.0
       xsum2=0.0
       npts=0
       do j=j1,j2
         do i=i1,i2
           x=map(i,j)
           xsum1=xsum1+x
           xsum2=xsum2+x*x
           npts=npts+1
         end do
       end do

C calculate statistics
       fn=float(npts)
       xmean=xsum1/fn
       xsd=sqrt((xsum2-xmean*xsum1)/(fn-1.0))
       end


MODULE Circle
    REAL, PARAMETER :: Pi = 3.1415927
    REAL :: radius
END MODULE Circle

PROGRAM Area
    USE Circle, ONLY : radius
    IMPLICIT NONE
    real:: AreaCircle
    ! Prompt user for radius of circle
    write(*, '(A)', ADVANCE = "NO") "Enter the radius of the circle: "
    read(*, *) radius
    ! Write out area of circle using function call
    write(*, 100) "Area of circle with radius", radius, " is", AreaCircle(radius)
    100 format (A, 2x, F6.2, A, 2x, F11.2)
END PROGRAM Area

REAL FUNCTION AreaCircle(r)
    USE Circle, ONLY : Pi
    IMPLICIT NONE
    REAL :: r
    AreaCircle = Pi * r * r
END FUNCTION


c subroutine lfp (init,n,m,l,cp,pb,w)
c
c dimension of           cp((n/2)+1), pb(l), w(5*l+41)
c arguments
c
c purpose                routine lfp uses coefficients computed by
c                        routine alfk to calculate the single precision
c                        normalized associated legendre function pbar(n,
c                        m,theta) at colatitudes theta=(i-1)*pi/(l-1),
c                        i=1,...,l. subroutine lfp evaluates pbar
c                        using one of the following trigonometric
c                        expansions
c
c                        1) for n even and m even, pbar(m,n,theta) =
c                           .5*cp(1) plus the sum from k=1 to k=n/2
c                           of cp(k)*cos(2*k*th)
c
c                        2) for n even and m odd, pbar(m,n,theta) =
c                           the sum from k=1 to k=n/2 of
c                           cp(k)*sin(2*k*th)
c
c                        3) for n odd and m even, pbar(m,n,theta) =
c                           the sum from k=1 to k=(n+1)/2 of
c                           cp(k)*cos((2*k-1)*th)
c
c                        4) for n odd and m odd,  pbar(m,n,theta) =
c                           the sum from k=1 to k=(n+1)/2 of
c                           cp(k)*sin((2*k-1)*th)
c
c
c usage                  call lfp(init,n,m,l,cp,pb,w)
c
c arguments
c
c on input               init
c                          = 0 initialization only
c                          = 1 compute pbar(n,m,theta)
c
c                          lfp call with init = 0 initializes array w;
c                          no values of pbar(n,m,theta) are computed.
c                          init=0 should be used on the first call, or
c                          if l or w values differ from those in the
c                          previous call.
c
c                        n
c                          nonnegative integer, less than l, specifying
c                          the degree of pbar(n,m,theta)
c
c                        m
c                          is the order of pbar(n,m,theta). m can be
c                          any integer however pbar(n,m,theta) = 0
c                          if abs(m) is greater than n and
c                          pbar(n,m,theta) = (-1)**m*pbar(n,-m,theta)
c                          for negative m.
c
c                        l
c                          number of colatitudes theta=(i-1)*pi/(l-1)
c                          for i=1,...,l where l is greater than 1.
c                          l must be an odd integer.
c
c                        cp
c                          single precision array of length (n/2)+1
c                          containing coefficients computed by routine
c                          alfk
c
c                        w
c                          a single precision work array with at
c                          least 5*l+41 locations
c
c on output              pb
c                          single precision array of length l containing
c                          pbar(n,m,theta), theta=(i-1)*pi/(l-1) for i=1
c                          ,...,l.
c
c                        w
c                          a single precision array containing values
c                          which must not be destroyed if the next call
c                          will have the same value of input parameter n
c
c special conditions     calls to routine lfp must be preceded by an
c                        appropriate call to routine alfk.
c
c precision              single
c
c algorithm              the trigonometric series formula used by
c                        routine lfp to calculate pbar(n,m,theta) for
c                        theta=(i-1)*pi/(l-1), i=1,...,n, depends on
c                        m and n as follows:
c
c                           1) for n even and m even, the formula is
c                              .5*cp(1) plus the sum from k=1 to k=n/2
c                              of cp(k)*cos(2*k*theta)
c                           2) for n even and m odd. the formula is
c                              the sum from k=1 to k=n/2 of
c                              cp(k)*sin(2*k*theta)
c                           3) for n odd and m even, the formula is
c                              the sum from k=1 to k=(n+1)/2 of
c                              cp(k)*cos((2*k-1)*theta)
c                           4) for n odd and m odd, the formula is
c                              the sum from k=1 to k=(n+1)/2 of
c                              cp(k)*sin((2*k-1)*theta)
c
c accuracy               comparison between routines lfp and double
c                        precision dlfp on the cray1 indicates greater
c                        accuracy for smaller values of input parameter
c                        n.  agreement to 12 places was obtained for
c                        n=10 and to 11 places for n=100.
c
c timing                 time per call to routine lfp is dependent on
c                        the input parameters l and n.
c
      subroutine lfp (init,n,m,l,cp,pb,w)
      dimension       cp(1)       ,pb(1)    ,w(1)
c
      do 10 i=1,l
      pb(i) = 0.
   10 continue
      ma = iabs(m)
      if(ma .gt. n) return
      iw1 = l+l+12
      iw2 = iw1+3*(l+1)/2+15
      call lfp1(init,n,ma,l,cp,pb,w,w(iw1),w(iw2))
      return
      end
      subroutine lfp1(init,n,m,l,cp,p,wsave1,wsave2,wsave3)
      dimension cp(1),p(1),wsave1(1),wsave2(1),wsave3(1)
      save lc, lq, ls
      if(init.ne.0) go to 41
      lc=(l+1)/2
      ls=lc-2
      lq=lc-1
      call sinti(ls,wsave1)
      call costi(lc,wsave2)
      call cosqi(lq,wsave3)
      return
   41 if (n)  10, 10, 40
   10 if (m)  20, 20, 40
   20 ssqrt2 = 1./sqrt(2.)
      do  30 i=1,l
         p(i) = ssqrt2
   30 continue
      return
   40 ls2 = (l+1)/2
      lm1 = l-1
      np1 = n+1
      pi = 4.*atan(1.)
      dt = pi/lm1
      nmod = mod(n,2)
      mmod = mod(m,2)
      if (nmod)  50, 50,120
   50 if (mmod)  60, 60, 90
   60 kdp = n/2+1
      do 70 i=1,kdp
      p(i)=.5*cp(i)
   70 continue
      p(lc)=p(lc)+p(lc)
      call cost(lc,p,wsave2)
      do 80 i=1,lc
      lmi=l-i
      p(lmi+1)=p(i)
   80 continue
      go to 190
   90 kdp=n/2
      do 100 i=1,kdp
      p(i+1)=.5*cp(i)
  100 continue
      p(ls+2)=0.
      call sint(ls,p(2),wsave1)
      do 110 i=1,ls
      lmi=l-i
      p(lmi)=-p(i+1)
  110 continue
      p(l)=0.
      go to 190
  120 kdp=(n+1)/2
      if(mmod)140,140,160
  140 do 130 i=1,kdp
      p(i)=.25*cp(i)
  130 continue
      call cosqb(lq,p,wsave3)
      do 150 i=1,lq
      lmi=l-i
      p(lmi+1)=-p(i)
  150 continue
      go to 190
  160 do 180 i=1,kdp
      p(i+1)=.25*cp(i)
  180 continue
      call sinqb(lq,p(2),wsave3)
      do 170 i=1,lq
      lmi=l-i
      p(lmi)=p(i+1)
  170 continue
      p(l)=0.
  190 return
      end


      SUBROUTINE vol2d(dvol,x,xcen,ntype)
!---------------------------------------------------
!***  calculates volume in 2D
!---------------------------------------------------

      IMPLICIT NONE

      INTEGER(kind=4):: ntype
      REAL(kind=8):: dvol,x(2,2),xcen(2)

      REAL(kind=8) :: x1(2),x2(2)
      REAL (kind=8), PARAMETER  :: twopi=6.283185307179586

      X1(:) = X(:,2)-X(:,1)
      X2(:) = XCEN(:)-X(:,1)
      dvol = x1(1)*x2(2) - x1(2)*x2(1)
      dvol = dvol/2.d0
      IF(ntype == 3) dvol=dvol*twopi*(x(1,1)+x(1,2))/3d0

      END SUBROUTINE vol2d


program main
    use FEMSolverClass
    implicit none

    type(FEMSolver_) :: solver
    type(FEMDomain_),target :: domains(1)
    type(IO_) :: f
    integer(int32) :: i
    real(real64) :: Vs,t,dt,E_Al
    real(real64),allocatable :: Mode_U(:),mode_Ut(:),freq(:),eigen_value(:),eigen_vectors(:,:)

    ! Modal analysis
!Create file or...
    call domains(1)%create("Cube3D",x_num=2,y_num=6,z_num=40)
    call domains(1)%resize(x=1.0d0)
    call domains(1)%resize(y=5.0d0)
    call domains(1)%resize(z=50.0d0)
    call domains(1)%vtk("AlminiumBar")

!read file
    !call domains(1) % read("AlminiumBar.vtk")

    call solver%init(NumDomain=1,NumInterfaceElement=0)
    call solver%setDomain(FEMDomain=domains(1),DomainID=1)
    call solver%setCRS(DOF=3)

    !$OMP parallel do
    do i=1,domains(1)%ne()
        call solver%setMatrix(&
            DomainID=1,&
            ElementID=i,&
            DOF=3,&
            Matrix=domains(1)%MassMatrix(ElementID=i,Density=2.70d0,DOF=3) &
            )
    enddo
    !$OMP end parallel do

    call solver%keepThisMatrixAs("B")
    call solver%zeros()

    print *, "Save Stiffness Matrix"

    E_Al = 70.0d0*1000.0d0*1000.0d0
    !$OMP parallel do
    do i=1,domains(1)%ne()
        call solver%setMatrix(&
            DomainID=1,&
            ElementID=i,&
            DOF=3,&
            Matrix=domains(1)%StiffnessMatrix(ElementID=i,E=70.0d0*1000.0d0*1000.0d0,v=0.300d0) &
            )
    enddo
    !$OMP end parallel do

    call solver%keepThisMatrixAs("A")

    ! Eigen value problem solver by scipy

    print *, "solver%eig"
    call solver%eig(num_eigen=domains(1)%nn()*domains(1)%nd(),eigen_value=eigen_value,eigen_vectors=eigen_vectors)

    ! read results
    freq = sqrt(abs(eigen_value))/2.0d0/3.141590d0
    dt = 0.10d0

    ! 20 modes
    do i_i=1,20
        mode_U = zeros(size(eigen_vectors,1))
        mode_U = eigen_vectors(:,i_i)
        dt = 1.0d0/freq(i_i)/100.0d0
        do j_j=1,100
            t = dt * dble(j_j-1)
            mode_Ut = mode_U*cos( 2.0d0*3.140d0*freq(i_i)*t )

            domains(1)%mesh%nodcoord = domains(1)%mesh%nodcoord &
            +10.0d0*reshape(mode_Ut,domains(1)%nn(),3 )

            call domains(1)%vtk("Mode_Fortran_"+str(i_i)+"_t_"+str(j_j))
            domains(1)%mesh%nodcoord = domains(1)%mesh%nodcoord &
            -10.0d0*reshape(mode_Ut,domains(1)%nn(),3 )
        enddo
    enddo

    print *, "Freq (Hz)"
    call print(sqrt(abs(eigen_value(1:30)))/2.0d0/3.141590d0 )

end program main


module math_routines_lib
	! module for various mathematical functions and subroutines

	! load additional modules
	!use constants_lib
	use iso_c_binding, only: dbl => c_double

    implicit none

contains

	subroutine calc_rot_matrix_zyz(T_rot, alpha, beta, gam) bind(c)
		! computes rotation matrix (with direction cosines) for coordinate transformation of vector
		! following the zyz convention:
		! 1. rotation around z axis,
		! 2. rotation around rotated y axis,
		! 3. rotation around rotated z axis,
		! for further informations see euler angles on wikipedia
		! for definition of anisotropy (eg transverse isotropy) assume:
		! y axis to show into northern direction,
		! x axis to show into eastern direction,
		! z axis to show into skywards direction,
		! alpha to be positive in eastern direction,
		! beta to be positive in downwards direction,
		! gamma to be zero
		! for further information see Wittke: 'Rock Mechanics Based on an Anisotropic Jointed Rock Model', p. 44

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), intent(in) :: alpha		! rotation around z axis
		real(kind=dbl), intent(in) :: beta		! rotation around rotated y axis
		real(kind=dbl), intent(in) :: gam		! rotation around rotated z axis, in case if transverse isotropy zero

		! return variable
		real(kind=dbl), dimension(3,3), intent(out) :: T_rot		! rotation matrix with direction cosines between old an rotated coordinate basis

		! internal variables
		real(kind=dbl), dimension(3,3) :: Tz1	! rotation matrix for first rotation around z axis
		real(kind=dbl), dimension(3,3) :: Ty2	! rotation matrix for second rotation around rotated y axis
		real(kind=dbl), dimension(3,3) :: Tz3	! rotation matrix for third rotation around rotated z axis
		real(kind=dbl), dimension(3,3) :: Tzyz	! rotation matrix all three above combined into one: Tz1*Ty2*Tz3
		! --------------------------------------------------------------------------

		Tz1 = reshape( (/ cos(-gam), -sin(-gam), 0._dbl, sin(-gam), cos(-gam), 0._dbl, 0._dbl, 0._dbl, 1._dbl /), (/3,3/) )
		Ty2 = reshape( (/ cos(beta), 0._dbl, sin(beta), 0._dbl, 1._dbl, 0._dbl, -sin(beta), 0._dbl, cos(beta) /), (/3,3/) )
		Tz3 = reshape( (/ cos(-alpha), -sin(-alpha), 0._dbl, sin(-alpha), cos(-alpha), 0._dbl, 0._dbl, 0._dbl, 1._dbl /), (/3,3/) )
		T_rot = transpose(matmul(Tz1, matmul(Ty2, Tz3) ))

	end subroutine calc_rot_matrix_zyz

	function mcauly(x) bind(c)
		! computes <x> (mcauly brackets
		! if x < 0   =>  <x> = 0
		! if x >= 0  =>  <x> = x
		implicit none

		! --------------------------------------------------------------------------
		! return variable
		real(kind=dbl) :: mcauly

		! passed variable
		real(kind=dbl), intent(in) :: x
		! --------------------------------------------------------------------------

		if (x < 0._dbl) then

			mcauly = 0._dbl

		else

			mcauly = x

		end if

	end function mcauly

	elemental function mcauly_elemental(x)
		! computes <x> (mcauly brackets
		! if x < 0   =>  <x> = 0
		! if x >= 0  =>  <x> = x
		implicit none

		! --------------------------------------------------------------------------
		! return variable
		real(kind=dbl) :: mcauly_elemental

		! passed variable
		real(kind=dbl), intent(in) :: x
		! --------------------------------------------------------------------------

		if (x < 0._dbl) then

			mcauly_elemental = 0._dbl

		else

			mcauly_elemental = x

		end if

	end function mcauly_elemental

	function heaviside(x) bind(c)
		! computes heaviside function H(x)
		! if x < 0  => H(x) = 0
		! if x >= 0  => H(x) = 1
		implicit none

		! --------------------------------------------------------------------------
		! return variable
		real(kind=dbl) :: heaviside

		! passed variable
		real(kind=dbl), intent(in) :: x
		! --------------------------------------------------------------------------

		if (x < 0._dbl) then

			heaviside = 0._dbl

		else

			heaviside = 1._dbl

		end if

	end function heaviside

	elemental function heaviside_elemental(x)
		! computes heaviside function H(x)
		! if x < 0  => H(x) = 0
		! if x >= 0  => H(x) = 1
		implicit none

		! --------------------------------------------------------------------------
		! return variable
		real(kind=dbl) :: heaviside_elemental

		! passed variable
		real(kind=dbl), intent(in) :: x
		! --------------------------------------------------------------------------

		if (x < 0._dbl) then

			heaviside_elemental = 0._dbl

		else

			heaviside_elemental = 1._dbl

		end if

	end function heaviside_elemental

end module math_routines_lib


module test_rawmoment
    use testdrive, only : new_unittest, unittest_type, error_type, check
    use stdlib_kinds, only: sp, dp, int32
    use stdlib_stats, only: mean, moment
    use,intrinsic :: ieee_arithmetic, only : ieee_is_nan
    implicit none

    real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
    real(dp), parameter :: dptol = 1000 * epsilon(1._dp)

    real(dp), parameter :: d1(5) = [1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp, 5.0_dp]
    real(dp), parameter :: d(4, 3) = reshape([1._dp, 3._dp, 5._dp, 7._dp,&
                                   2._dp, 4._dp, 6._dp, 8._dp,&
                                   9._dp, 10._dp, 11._dp, 12._dp], [4, 3])

    complex(sp), parameter :: cs1(5) = [ cmplx(0.57706_sp, 0.00000_sp),&
                            cmplx(0.00000_sp, 1.44065_sp),&
                            cmplx(1.26401_sp, 0.00000_sp),&
                            cmplx(0.00000_sp, 0.88833_sp),&
                            cmplx(1.14352_sp, 0.00000_sp)]
    complex(sp), parameter :: cs(5,3) = reshape([cs1, cs1*3.0_sp, cs1*1.5_sp], shape(cs))

contains

    !> Collect all exported unit tests
    subroutine collect_rawmoment(testsuite)
        !> Collection of tests
        type(unittest_type), allocatable, intent(out) :: testsuite(:)

        testsuite = [ &
            new_unittest("sp", test_sp), &
            new_unittest("int32", test_int32), &
            new_unittest("csp", test_csp) &
            ]
    end subroutine collect_rawmoment

    subroutine test_sp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        real(sp), parameter :: x1(5) = d1
        real(sp), parameter :: x2(4, 3) = d

        integer :: order
        real(sp), allocatable :: x3(:, :, :)
        real(sp), allocatable :: zero2_1(:), zero2_2(:)
        real(sp), allocatable :: zero3_1(:,:), zero3_2(:,:), zero3_3(:,:)

        allocate(zero2_1(size(x2, 2)), zero2_2(size(x2, 1)))
        zero2_1 = 0
        zero2_2 = 0

        order = 1

        !1dim
        print*,' test_sp_1dim', order
        call check(error, abs(moment(x1, order, center = 0.) - mean(x1)) < sptol)
        call check(error, abs(moment(x1, order, 1, center = 0.) - mean(x1)) < sptol)

        print*,' test_sp_1dim_mask', order
        call check(error, ieee_is_nan(moment(x1, order, center = 0., mask = .false.)))
        call check(error, ieee_is_nan(moment(x1, order, dim = 1, center = 0., mask = .false.)))

        print*,' test_sp_1dim_mask_array', order
        call check(error, abs(moment(x1, order, center = 0., mask = (x1 < 5)) -&
                          mean(x1, mask = (x1 < 5)) ) < sptol)
        call check(error, abs(moment(x1, order, dim = 1, center = 0., mask = (x1 < 5)) -&
                          mean(x1, dim = 1, mask = (x1 < 5))) < sptol)

        !2dim
        print*,' test_sp_2dim', order
        call check(error, abs(moment(x2, order, center = 0.) - mean(x2)) < sptol)
        call check(error, all( abs( moment(x2, order, dim = 1, center = 0.) -&
                        mean(x2, dim = 1)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = 0.) -&
                        mean(x2, dim = 2)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1) -&
                        mean(x2, dim = 1)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2) -&
                        mean(x2, dim = 2)) < sptol))

        print*,' test_sp_2dim_mask', order
        call check(error, ieee_is_nan(moment(x2, order, center = 0., mask = .false.)))
        call check(error, any(ieee_is_nan(moment(x2, order, dim = 1, center = zero2_1,&
                        mask = .false.))))
        call check(error, any(ieee_is_nan(moment(x2, order, dim = 2, center = zero2_2,&
                        mask = .false.))))

        print*,' test_sp_2dim_mask_array', order
        call check(error, abs(moment(x2, order, center = 0., mask = (x2 < 11)) -&
                                mean(x2, x2 < 11)) < sptol)
        call check(error, all( abs( moment(x2, order, dim = 1, center = 0.,&
                                mask = (x2 < 11)) -&
                                mean(x2, 1, x2 < 11)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = 0.,&
                                mask = (x2 < 11)) -&
                                mean(x2, 2, x2 < 11)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,&
                                mask = (x2 < 11)) -&
                                mean(x2, 1, x2 < 11)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2,&
                                mask = (x2 < 11)) -&
                                mean(x2, 2, x2 < 11)) < sptol))

        !3dim
        allocate(x3(size(x2,1),size(x2,2),3))
        x3(:,:,1)=x2;
        x3(:,:,2)=x2*2;
        x3(:,:,3)=x2*4;

        allocate(zero3_1(size(x3, 2), size(x3, 3))&
                 ,zero3_2(size(x3, 1), size(x3, 3))&
                 ,zero3_3(size(x3, 1), size(x3, 2)))
        zero3_1 = 0
        zero3_2 = 0
        zero3_3 = 0

        print*,' test_sp_3dim', order
        call check(error, abs(moment(x3, order, center = 0.) - mean(x3)) < sptol)
        call check(error, all( abs( moment(x3, order, dim = 1, center = 0._sp) -&
                               mean(x3, 1)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 2, center = 0._sp) -&
                               mean(x3, 2)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 3, center = 0._sp) -&
                               mean(x3, 3)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1) -&
                               mean(x3, 1)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2) -&
                               mean(x3, 2)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3) -&
                               mean(x3, 3)) < sptol))

        print*,' test_sp_3dim_mask', order
        call check(error, ieee_is_nan(moment(x3, order, center = 0., mask = .false.)))
        call check(error, any(ieee_is_nan(moment(x3, order, dim = 1, center = zero3_1,&
                         mask = .false.))))
        call check(error, any(ieee_is_nan(moment(x3, order, dim = 2, center = zero3_2,&
                         mask = .false.))))
        call check(error, any(ieee_is_nan(moment(x3, order, dim = 3, center = zero3_3,&
                         mask = .false.))))

        print*,' test_sp_3dim_mask_array', order
        call check(error, abs(moment(x3, order, center = 0., mask = (x3 < 11)) -&
                         mean(x3, x3 < 11)) < sptol)
        call check(error, all( abs( moment(x3, order, dim = 1, center = 0.,&
                                mask = (x3 < 45)) -&
                                mean(x3, 1, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 2, center = 0.,&
                                mask = (x3 < 45)) -&
                                mean(x3, 2, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 3, center = 0.,&
                                mask = (x3 < 45)) -&
                                mean(x3, 3, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1,&
                                mask = (x3 < 45)) -&
                                mean(x3, 1, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2,&
                                mask = (x3 < 45)) -&
                                mean(x3, 2, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3,&
                                mask = (x3 < 45)) -&
                                mean(x3, 3, x3 < 45)) < sptol ))

        order = 2

        !1dim
        print*,' test_sp_1dim', order
        call check(error, abs(moment(x1, order, center = 0.) - mean(x1**2)) < sptol)
        call check(error, abs(moment(x1, order, 1, center = 0.) - mean(x1**2, 1)) < sptol)

        print*,' test_sp_1dim_mask', order
        call check(error, ieee_is_nan(moment(x1, order, center = 0., mask = .false.)))
        call check(error, ieee_is_nan(moment(x1, order, dim = 1, center = 0., mask = .false.)))

        print*,' test_sp_1dim_mask_array', order
        call check(error, abs(moment(x1, order, center = 0., mask = (x1 < 5)) -&
                          mean(x1**2, x1 < 5)) < sptol)
        call check(error, abs(moment(x1, order, dim = 1, center = 0., mask = (x1 < 5)) -&
                          mean(x1**2, 1, x1 < 5)) < sptol)

        !2dim
        print*,' test_sp_2dim', order
        call check(error, abs(moment(x2, order, center = 0.) - mean(x2**2)) < sptol)
        call check(error, all( abs( moment(x2, order, dim = 1, center = 0.) -&
                               mean(x2**2, 1)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = 0.) - &
                               mean(x2**2, 2)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1) -&
                               mean(x2**2, 1)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2) - &
                               mean(x2**2, 2)) < sptol))

        print*,' test_sp_2dim_mask', order
        call check(error, ieee_is_nan(moment(x2, order, center = 0., mask = .false.)))
        call check(error, any(ieee_is_nan(moment(x2, order, dim = 1, center = zero2_1, &
                               mask = .false.))))
        call check(error, any(ieee_is_nan(moment(x2, order, dim = 2, center = zero2_2, &
                               mask = .false.))))

        print*,' test_sp_2dim_mask_array', order
        call check(error, abs(moment(x2, order, center = 0., mask = (x2 < 11)) -&
                          mean(x2**2, x2 < 11)) < sptol)
        call check(error, all( abs( moment(x2, order, dim = 1, center = 0.,&
                               mask = (x2 < 11)) -&
                               mean(x2**2, 1, x2 < 11)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = 0.,&
                               mask = (x2 < 11)) -&
                               mean(x2**2, 2, x2 < 11)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,&
                               mask = (x2 < 11)) -&
                               mean(x2**2, 1, x2 < 11)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2,&
                               mask = (x2 < 11)) -&
                               mean(x2**2, 2, x2 < 11)) < sptol))

        !3dim
        print*,' test_sp_3dim', order
        call check(error, abs(moment(x3, order, center = 0.) - mean(x3**2)) < sptol)
        call check(error, all( abs( moment(x3, order, dim = 1, center = 0.) -&
                                mean(x3**2, 1)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 2, center = 0.) -&
                                mean(x3**2, 2)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 3, center = 0.) -&
                                mean(x3**2, 3)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1) -&
                                mean(x3**2, 1)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2) -&
                                mean(x3**2, 2)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3) -&
                                mean(x3**2, 3)) < sptol))

        print*,' test_sp_3dim_mask', order
        call check(error, ieee_is_nan(moment(x3, order, center = 0., mask = .false.)))
        call check(error, any(ieee_is_nan(moment(x3, order, dim = 1, center = zero3_1,&
                               mask = .false.))))
        call check(error, any(ieee_is_nan(moment(x3, order, dim = 2, center = zero3_2,&
                               mask = .false.))))
        call check(error, any(ieee_is_nan(moment(x3, order, dim = 3, center = zero3_3,&
                               mask = .false.))))

        print*,' test_sp_3dim_mask_array', order
        call check(error, abs(moment(x3, order, center = 0., mask = (x3 < 11)) -&
                          mean(x3**2, x3 < 11)) < sptol)
        call check(error, all( abs( moment(x3, order, dim = 1, center = 0.,&
                               mask = (x3 < 45)) -&
                               mean(x3**2, 1, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 2, center = 0.,&
                               mask = (x3 < 45)) -&
                               mean(x3**2, 2, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 3, center = 0.,&
                               mask = (x3 < 45)) -&
                               mean(x3**2, 3, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1,&
                               mask = (x3 < 45)) -&
                               mean(x3**2, 1, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2,&
                               mask = (x3 < 45)) -&
                               mean(x3**2, 2, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3,&
                               mask = (x3 < 45)) -&
                               mean(x3**2, 3, x3 < 45)) < sptol ))

    end subroutine

    subroutine test_int32(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer(int32), parameter :: x1(5) = d1
        integer(int32), parameter :: x2(4, 3) = d

        integer :: order
        integer(int32), allocatable :: x3(:, :, :)
        real(dp), allocatable :: zero2_1(:), zero2_2(:)
        real(dp), allocatable :: zero3_1(:,:), zero3_2(:,:), zero3_3(:,:)

        allocate(zero2_1(size(x2, 2)), zero2_2(size(x2, 1)))
        zero2_1 = 0
        zero2_2 = 0

        order = 1

        !1dim
        print*,' test_sp_1dim', order
        call check(error, abs(moment(x1, order, center = 0._dp) - mean(x1)) < sptol)
        call check(error, abs(moment(x1, order, 1, center = 0._dp) - mean(x1)) < sptol)

        print*,' test_sp_1dim_mask', order
        call check(error, ieee_is_nan(moment(x1, order, center = 0._dp, mask = .false.)))
        call check(error, ieee_is_nan(moment(x1, order, dim = 1, center = 0._dp,&
                               mask = .false.)))

        print*,' test_sp_1dim_mask_array', order
        call check(error, abs(moment(x1, order, center = 0._dp, mask = (x1 < 5)) -&
                          mean(x1, mask = (x1 < 5)) ) < sptol)
        call check(error, abs(moment(x1, order, dim = 1, center = 0._dp, mask = (x1 < 5)) -&
                          mean(x1, dim = 1, mask = (x1 < 5))) < sptol)

        !2dim
        print*,' test_sp_2dim', order
        call check(error, abs(moment(x2, order, center = 0._dp) - mean(x2)) < sptol)
        call check(error, all( abs( moment(x2, order, dim = 1, center = 0._dp) -&
                               mean(x2, dim = 1)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = 0._dp) -&
                               mean(x2, dim = 2)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1) -&
                               mean(x2, dim = 1)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2) -&
                               mean(x2, dim = 2)) < sptol))

        print*,' test_sp_2dim_mask', order
        call check(error, ieee_is_nan(moment(x2, order, center = 0._dp, mask = .false.)))
        call check(error, any(ieee_is_nan(moment(x2, order, dim = 1, center = zero2_1,&
                               mask = .false.))))
        call check(error, any(ieee_is_nan(moment(x2, order, dim = 2, center = zero2_2,&
                               mask = .false.))))

        print*,' test_sp_2dim_mask_array', order
        call check(error, abs(moment(x2, order, center = 0._dp, mask = (x2 < 11)) -&
                               mean(x2, x2 < 11)) < sptol)
        call check(error, all( abs( moment(x2, order, dim = 1, center = 0._dp,&
                               mask = (x2 < 11)) -&
                               mean(x2, 1, x2 < 11)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = 0._dp,&
                               mask = (x2 < 11)) -&
                               mean(x2, 2, x2 < 11)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,&
                               mask = (x2 < 11)) -&
                               mean(x2, 1, x2 < 11)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2,&
                               mask = (x2 < 11)) -&
                               mean(x2, 2, x2 < 11)) < sptol))

        !3dim
        allocate(x3(size(x2,1),size(x2,2),3))
        x3(:,:,1)=x2;
        x3(:,:,2)=x2*2;
        x3(:,:,3)=x2*4;

        allocate(zero3_1(size(x3, 2), size(x3, 3))&
                 ,zero3_2(size(x3, 1), size(x3, 3))&
                 ,zero3_3(size(x3, 1), size(x3, 2)))
        zero3_1 = 0
        zero3_2 = 0
        zero3_3 = 0

        print*,' test_sp_3dim', order
        call check(error, abs(moment(x3, order, center = 0._dp) - mean(x3)) < sptol)
        call check(error, all( abs( moment(x3, order, dim = 1, center = 0._dp) -&
                               mean(x3, 1)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 2, center = 0._dp) -&
                               mean(x3, 2)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 3, center = 0._dp) -&
                               mean(x3, 3)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1) -&
                               mean(x3, 1)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2) -&
                               mean(x3, 2)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3) -&
                               mean(x3, 3)) < sptol))

        print*,' test_sp_3dim_mask', order
        call check(error, ieee_is_nan(moment(x3, order, center = 0._dp, mask = .false.)))
        call check(error, any(ieee_is_nan(moment(x3, order, dim = 1, center = zero3_1,&
                               mask = .false.))))
        call check(error, any(ieee_is_nan(moment(x3, order, dim = 2, center = zero3_2,&
                               mask = .false.))))
        call check(error, any(ieee_is_nan(moment(x3, order, dim = 3, center = zero3_3,&
                               mask = .false.))))

        print*,' test_sp_3dim_mask_array', order
        call check(error, abs(moment(x3, order, center = 0._dp, mask = (x3 < 11)) -&
                               mean(x3, x3 < 11)) < sptol)
        call check(error, all( abs( moment(x3, order, dim = 1, center = 0._dp,&
                               mask = (x3 < 45)) -&
                               mean(x3, 1, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 2, center = 0._dp,&
                               mask = (x3 < 45)) -&
                               mean(x3, 2, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 3, center = 0._dp,&
                               mask = (x3 < 45)) -&
                               mean(x3, 3, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1,&
                               mask = (x3 < 45)) -&
                               mean(x3, 1, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2,&
                               mask = (x3 < 45)) -&
                               mean(x3, 2, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3,&
                               mask = (x3 < 45)) -&
                               mean(x3, 3, x3 < 45)) < sptol ))

        order = 2

        !1dim
        print*,' test_sp_1dim', order
        call check(error, abs(moment(x1, order, center = 0._dp) - mean(x1**2)) < sptol)
        call check(error, abs(moment(x1, order, 1, center = 0._dp) - mean(x1**2, 1)) < sptol)

        print*,' test_sp_1dim_mask', order
        call check(error, ieee_is_nan(moment(x1, order, center = 0._dp, mask = .false.)))
        call check(error, ieee_is_nan(moment(x1, order, dim = 1, center = 0._dp,&
                               mask = .false.)))

        print*,' test_sp_1dim_mask_array', order
        call check(error, abs(moment(x1, order, center = 0._dp, mask = (x1 < 5)) -&
                          mean(x1**2, x1 < 5)) < sptol)
        call check(error, abs(moment(x1, order, dim = 1, center = 0._dp, mask = (x1 < 5)) -&
                          mean(x1**2, 1, x1 < 5)) < sptol)

        !2dim
        print*,' test_sp_2dim', order
        call check(error, abs(moment(x2, order, center = 0._dp) - mean(x2**2)) < sptol)
        call check(error, all( abs( moment(x2, order, dim = 1, center = 0._dp) -&
                               mean(x2**2, 1)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = 0._dp) -&
                               mean(x2**2, 2)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1) -&
                               mean(x2**2, 1)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2) -&
                               mean(x2**2, 2)) < sptol))

        print*,' test_sp_2dim_mask', order
        call check(error, ieee_is_nan(moment(x2, order, center = 0._dp, mask = .false.)))
        call check(error, any(ieee_is_nan(moment(x2, order, dim = 1, center = 0._dp,&
                               mask = .false.))))
        call check(error, any(ieee_is_nan(moment(x2, order, dim = 2, center = 0._dp,&
                               mask = .false.))))
        call check(error, any(ieee_is_nan(moment(x2, order, dim = 1, center = zero2_1,&
                               mask = .false.))))
        call check(error, any(ieee_is_nan(moment(x2, order, dim = 2, center = zero2_2,&
                               mask = .false.))))

        print*,' test_sp_2dim_mask_array', order
        call check(error, abs(moment(x2, order, center = 0._dp, mask = (x2 < 11)) -&
                          mean(x2**2, x2 < 11)) < sptol)
        call check(error, all( abs( moment(x2, order, dim = 1, center = 0._dp,&
                               mask = (x2 < 11)) -&
                               mean(x2**2, 1, x2 < 11)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = 0._dp,&
                               mask = (x2 < 11)) -&
                               mean(x2**2, 2, x2 < 11)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,&
                               mask = (x2 < 11)) -&
                               mean(x2**2, 1, x2 < 11)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2,&
                               mask = (x2 < 11)) -&
                               mean(x2**2, 2, x2 < 11)) < sptol))

        !3dim
        print*,' test_sp_3dim', order
        call check(error, abs(moment(x3, order, center = 0._dp) - mean(x3**2)) < sptol)
        call check(error, all( abs( moment(x3, order, dim = 1, center = 0._dp) -&
                                mean(x3**2, 1)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 2, center = 0._dp) -&
                                mean(x3**2, 2)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 3, center = 0._dp) -&
                                mean(x3**2, 3)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1) -&
                                mean(x3**2, 1)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2) -&
                                mean(x3**2, 2)) < sptol))
        call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3) -&
                                mean(x3**2, 3)) < sptol))

        print*,' test_sp_3dim_mask', order
        call check(error, ieee_is_nan(moment(x3, order, center = 0._dp, mask = .false.)))
        call check(error, any(ieee_is_nan(moment(x3, order, dim = 1, center = 0._dp,&
                               mask = .false.))))
        call check(error, any(ieee_is_nan(moment(x3, order, dim = 2, center = 0._dp,&
                               mask = .false.))))
        call check(error, any(ieee_is_nan(moment(x3, order, dim = 3, center = 0._dp,&
                               mask = .false.))))
        call check(error, any(ieee_is_nan(moment(x3, order, dim = 1, center = zero3_1,&
                               mask = .false.))))
        call check(error, any(ieee_is_nan(moment(x3, order, dim = 2, center = zero3_2,&
                               mask = .false.))))
        call check(error, any(ieee_is_nan(moment(x3, order, dim = 3, center = zero3_3,&
                               mask = .false.))))

        print*,' test_sp_3dim_mask_array', order
        call check(error, abs(moment(x3, order, center = 0._dp, mask = (x3 < 11)) -&
                          mean(x3**2, x3 < 11)) < sptol)
        call check(error, all( abs( moment(x3, order, dim = 1, center = 0._dp,&
                               mask = (x3 < 45)) -&
                               mean(x3**2, 1, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 2, center = 0._dp,&
                               mask = (x3 < 45)) -&
                               mean(x3**2, 2, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 3, center = 0._dp,&
                               mask = (x3 < 45)) -&
                               mean(x3**2, 3, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1,&
                               mask = (x3 < 45)) -&
                               mean(x3**2, 1, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2,&
                               mask = (x3 < 45)) -&
                               mean(x3**2, 2, x3 < 45)) < sptol ))
        call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3,&
                               mask = (x3 < 45)) -&
                               mean(x3**2, 3, x3 < 45)) < sptol ))

    end subroutine

    subroutine test_csp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        complex(sp), parameter :: x1(5) = cs1
        complex(sp), parameter :: x2(5, 3) = cs

        integer :: order
        complex(sp), allocatable :: zero2_1(:), zero2_2(:)

        allocate(zero2_1(size(x2, 2)), zero2_2(size(x2, 1)))
        zero2_1 = (0., 0.)
        zero2_2 = (0., 0.)

        order = 1

        !1dim
        print*,' test_sp_1dim', order
        call check(error, abs(moment(x1, order, center = (0., 0.)) - mean(x1)) < sptol)
        call check(error, abs(moment(x1, order, 1, center = (0., 0.)) - mean(x1, 1)) < sptol)

        print*,' test_sp_1dim_mask', order
        call check(error, ieee_is_nan(abs(moment(x1, order, center = (0., 0.),&
                               mask = .false.))))
        call check(error, ieee_is_nan(abs(moment(x1, order, dim = 1, center = (0., 0.),&
                               mask = .false.))))

        print*,' test_sp_1dim_mask_array', order
        call check(error, abs(moment(x1, order, center = (0., 0.), mask = (aimag(x1) == 0)) -&
                          mean(x1, aimag(x1) == 0)) < sptol)
        call check(error, abs(moment(x1, order, dim = 1, center = (0., 0.),&
                          mask = (aimag(x1) == 0)) -&
                          mean(x1, 1, aimag(x1) == 0)) < sptol)

        !2dim
        print*,' test_sp_2dim', order
        call check(error, abs(moment(x2, order, center = (0., 0.)) - mean(x2)) < sptol)
        call check(error, all( abs( moment(x2, order, dim = 1, center = (0., 0.)) -&
                               mean(x2, 1)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = (0., 0.)) -&
                               mean(x2, 2)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1) -&
                               mean(x2, 1)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2) -&
                               mean(x2, 2)) < sptol))

        print*,' test_sp_2dim_mask', order
        call check(error, ieee_is_nan(abs(moment(x2, order, center = (0., 0.),&
                               mask = .false.))))
        call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 1, center = (0., 0.),&
                               mask = .false.)))))
        call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 2, center = (0., 0.),&
                               mask = .false.)))))
        call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 1, center = zero2_1,&
                               mask = .false.)))))
        call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 2, center = zero2_2,&
                               mask = .false.)))))

        print*,' test_sp_2dim_mask_array', order
        call check(error, abs(moment(x2, order, center = (0., 0.), mask = (aimag(x2) == 0)) -&
                          mean(x2, aimag(x2) == 0)) < sptol)
        call check(error, all( abs( moment(x2, order, dim = 1, center = (0., 0.),&
                               mask = (aimag(x2) == 0)) -&
                               mean(x2, 1, aimag(x2) == 0)) < sptol))
        call check(error, any(ieee_is_nan( abs( moment(x2, order,&
                         dim = 2, center = (0., 0.), mask = (aimag(x2) == 0)) -&
                         mean(x2, 2, aimag(x2) == 0)))))
        call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,&
                               mask = (aimag(x2) == 0)) -&
                               mean(x2, 1, aimag(x2) == 0)) < sptol))
        call check(error, any(ieee_is_nan( abs( moment(x2, order,&
                         dim = 2, center = zero2_2, mask = (aimag(x2) == 0)) -&
                         mean(x2, 2, aimag(x2) == 0)))))

        order = 2

        !1dim
        print*,' test_sp_1dim', order
        call check(error, abs(moment(x1, order, center = (0., 0.)) - mean(x1**2)) < sptol)
        call check(error, abs(moment(x1, order, 1, center = (0., 0.)) -&
                          mean(x1**2, 1)) < sptol)

        print*,' test_sp_1dim_mask', order
        call check(error, ieee_is_nan(abs(moment(x1, order, center = (0., 0.),&
                               mask = .false.))))
        call check(error, ieee_is_nan(abs(moment(x1, order, dim = 1, center = (0., 0.),&
                               mask = .false.))))

        print*,' test_sp_1dim_mask_array', order
        call check(error, abs(moment(x1, order, center = (0., 0.), mask = (aimag(x1) == 0)) -&
                          mean(x1**2, aimag(x1) == 0)) < sptol)
        call check(error, abs(moment(x1, order, dim = 1, center = (0., 0.),&
                          mask = (aimag(x1) == 0)) -&
                          mean(x1**2, 1, aimag(x1) == 0)) < sptol)

        !2dim
        print*,' test_sp_2dim', order
        call check(error, abs(moment(x2, order, center = (0., 0.)) - mean(x2**2)) < sptol)
        call check(error, all( abs( moment(x2, order, dim = 1, center = (0., 0.)) -&
                               mean(x2**2, 1)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = (0., 0.)) -&
                               mean(x2**2, 2)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1) -&
                               mean(x2**2, 1)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2) -&
                               mean(x2**2, 2)) < sptol))

        print*,' test_sp_2dim_mask', order
        call check(error, ieee_is_nan(abs(moment(x2, order, center = (0., 0.),&
                               mask = .false.))))
        call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 1, center = (0., 0.),&
                               mask = .false.)))))
        call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 2, center = (0., 0.),&
                               mask = .false.)))))
        call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 1, center = zero2_1,&
                               mask = .false.)))))
        call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 2, center = zero2_2,&
                               mask = .false.)))))

        print*,' test_sp_2dim_mask_array', order
        call check(error, abs(moment(x2, order, center = (0., 0.), mask = (aimag(x2) == 0)) -&
                          mean(x2**2, aimag(x2) == 0)) < sptol)
        call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,&
                          mask = (aimag(x2)==0)) -&
                          mean(x2**2, 1, aimag(x2)==0)) < sptol))
        call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,&
                          mask = (aimag(x2)==0)) -&
                          mean(x2**2, 1, aimag(x2)==0)) < sptol))

    end subroutine
end module

program tester
    use, intrinsic :: iso_fortran_env, only : error_unit
    use testdrive, only : run_testsuite, new_testsuite, testsuite_type
    use test_rawmoment, only : collect_rawmoment
    implicit none
    integer :: stat, is
    type(testsuite_type), allocatable :: testsuites(:)
    character(len=*), parameter :: fmt = '("#", *(1x, a))'

    stat = 0

    testsuites = [ &
        new_testsuite("rawmoment", collect_rawmoment) &
        ]

    do is = 1, size(testsuites)
        write(error_unit, fmt) "Testing:", testsuites(is)%name
        call run_testsuite(testsuites(is)%collect, error_unit, stat)
    end do

    if (stat > 0) then
        write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
        error stop
    end if
end program


C File: arrays-basic-04.f
C This program has a 2-D array with the implicit lower bounds of 1.

      program main
      implicit none

C     arr is a 2-D array (5x5) of integers with implicit lower-bounds
C     of 1 and upper bounds of 5.
      integer, dimension(5,5) :: arr
      integer :: i, j

      open (10, FILE="OUTPUT", STATUS="REPLACE")

      do i = 1, 5
        do j = 1, 5
          arr(i,j) = i+j     ! initialize the array
        end do
      end do

      ! write out the array
      do i = 1, 5
          write (10,10) arr(i,1), arr(i,2), arr(i,3), arr(i,4), arr(i,5)
      end do

 10   format(5(I5,X))

      stop
      end program main


! { dg-do run }
! { dg-options "-std=f2003 -fall-intrinsics -cpp" }

! PR fortran/38936
! Check the basic semantics of the ASSOCIATE construct.

PROGRAM main
  IMPLICIT NONE
  REAL :: a, b, c
  INTEGER, ALLOCATABLE :: arr(:)
  INTEGER :: mat(3, 3)

  TYPE :: myt
    INTEGER :: comp
  END TYPE myt

  TYPE(myt) :: tp

  a = -2.0
  b = 3.0
  c = 4.0

  ! Simple association to expressions.
  ASSOCIATE (r => SQRT (a**2 + b**2 + c**2), t => a + b)
    PRINT *, t, a, b
    IF (ABS (r - SQRT (4.0 + 9.0 + 16.0)) > 1.0e-3) CALL abort ()
    IF (ABS (t - a - b) > 1.0e-3) CALL abort ()
  END ASSOCIATE

  ! Target is vector-indexed.
  ASSOCIATE (foo => arr((/ 3, 1 /)))
    IF (LBOUND (foo, 1) /= 1 .OR. UBOUND (foo, 1) /= 2) CALL abort ()
    IF (foo(1) /= 3 .OR. foo(2) /= 1) CALL abort ()
  END ASSOCIATE

  ! Named and nested associate.
  myname: ASSOCIATE (x => a - b * c)
    ASSOCIATE (y => 2.0 * x)
      IF (ABS (y - 2.0 * (a - b * c)) > 1.0e-3) CALL abort ()
    END ASSOCIATE
  END ASSOCIATE myname ! Matching end-label.

  ! Correct behaviour when shadowing already existing names.
  ASSOCIATE (a => 1 * b, b => 1 * a, x => 1, y => 2)
    IF (ABS (a - 3.0) > 1.0e-3 .OR. ABS (b + 2.0) > 1.0e-3) CALL abort ()
    ASSOCIATE (x => 1 * y, y => 1 * x)
      IF (x /= 2 .OR. y /= 1) CALL abort ()
    END ASSOCIATE
  END ASSOCIATE

  ! Association to variables.
  mat = 0
  mat(2, 2) = 5;
  ASSOCIATE (x => arr(2), y => mat(2:3, 1:2))
    IF (x /= 2) CALL abort ()
    IF (ANY (LBOUND (y) /= (/ 1, 1 /) .OR. UBOUND (y) /= (/ 2, 2 /))) &
      CALL abort ()
    IF (y(1, 2) /= 5) CALL abort ()

    x = 7
    y = 8
  END ASSOCIATE
  IF (arr(2) /= 7 .OR. ANY (mat(2:3, 1:2) /= 8)) CALL abort ()

END PROGRAM main


! Created by EverLookNeverSee@GitHub on 4/23/20.
! This program integrate a function numerically
! using trapezoidal rule.

! Trapezoidal Rule:
!   integral f(x) dx = h[(f(a) + f(b)) / 2 + f(a + h) + f(a + 2h) +...+ f(a + nh)]

program trapezoidal_rule
    implicit none
    ! declaring counter variables
    integer :: i, n = 100
    ! declaring limits of integration
    real :: a = 1.0, b = 4.0
    ! declaring length of intervals and sum, h, x variables
    real :: sum = 0.0, h, x
    h = (b - a) / n
    sum = sum + 0.5 * (a ** 3 * exp(-a ** 3) + b ** 3 * exp(-b ** 3))
    x = a + h
    do i = 2, 100
        sum = sum + (x ** 3 * exp(-x ** 3))
    end do
    sum = sum * h
    print *, "the result of integration is:", sum
end program trapezoidal_rule


module test_linspace
    use testdrive, only : new_unittest, unittest_type, error_type, check
    use stdlib_kinds, only: sp, dp, int8, int16
    use stdlib_math, only: linspace, DEFAULT_LINSPACE_LENGTH

    implicit none
    private

    public :: collect_linspace

    real(sp), parameter :: TOLERANCE_SP = 1000 * epsilon(1.0_sp)
    real(dp), parameter :: TOLERANCE_DP = 1000 * epsilon(1.0_dp) ! Percentage of the range for which the actual gap must not exceed

    ! Testing linspace.
    !
    ! For single and double precision, check if the beginning and end values are properly recorded
    ! and make sure that the size of the result array is as expected.
    !
    ! This testing suite makes use of the a repeated section of code that will check to make
    ! sure that every element is linearly spaced (i.e., call check(|array(i+1) - array(i)| < |expected_value| * TOLERANCE)).
    ! I would convert this repeated code into a subroutine but that would require the implementation of a
    ! generic procedure given that each linear space will have a different expected_value type and kind.

contains

    !> Collect all exported unit tests
    subroutine collect_linspace(testsuite)
        !> Collection of tests
        type(unittest_type), allocatable, intent(out) :: testsuite(:)

        testsuite = [ &
            new_unittest("linspace_sp", test_linspace_sp), &
            new_unittest("linspace_dp", test_linspace_dp), &
            new_unittest("linspace_neg_index", test_linspace_neg_index), &
            new_unittest("linspace_cmplx", test_linspace_cmplx), &
            new_unittest("linspace_cmplx_2", test_linspace_cmplx_2), &
            new_unittest("linspace_cmplx_3", test_linspace_cmplx_3), &
            new_unittest("linspace_cmplx_sp", test_linspace_cmplx_sp), &
            new_unittest("linspace_cmplx_sp_2", test_linspace_cmplx_sp_2), &
            new_unittest("linspace_int16", test_linspace_int16), &
            new_unittest("linspace_int8", test_linspace_int8) &
            ]

    end subroutine collect_linspace

    subroutine test_linspace_sp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 20
        real(sp), parameter :: start = 1.0_sp
        real(sp), parameter :: end = 10.0_sp
        real(sp) :: expected_interval
        real(sp) :: true_difference

        integer :: i
        real(sp), allocatable :: x(:)

        x = linspace(start, end, n)

        expected_interval =( end - start ) / real(( n - 1 ), sp)

        call check(error, x(1), start, "Initial value of array is not equal to the passed start parameter")
        if (allocated(error)) return
        call check(error, x(n), end, "Final array value is not equal to end parameter")
        if (allocated(error)) return
        call check(error, size(x), n, "Array not allocated to appropriate size")
        if (allocated(error)) return

        print *, "Made it through first round of tests"

        ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
        do i = 1, n-1

            true_difference = x(i + 1) - x(i)
            call check(error, abs(true_difference - expected_interval) < abs(expected_interval) * TOLERANCE_SP)
            if (allocated(error)) return

        end do

    end subroutine

    subroutine test_linspace_dp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        real(dp), parameter :: start = 1.0_dp
        real(dp), parameter :: end = 10.0_dp
        integer, parameter :: n = DEFAULT_LINSPACE_LENGTH
        real(dp) :: expected_interval
        real(dp) :: true_difference

        real(dp), allocatable :: x(:)
        integer :: i

        x = linspace(start, end)

        expected_interval =( end - start ) / ( n - 1 )

        call check(error, size(x), n, "Array not allocated to default size")
        if (allocated(error)) return
        call check(error, x(1), start, "Initial value of array is not equal to the passed start parameter")
        if (allocated(error)) return
        call check(error, x(n), end, "Final array value is not equal to end parameter")
        if (allocated(error)) return

        ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
        do i = 1, n-1

            true_difference = x(i + 1) - x(i)
            call check(error, true_difference, expected_interval, &
                & thr=abs(expected_interval) * TOLERANCE_DP)
            if (allocated(error)) return

        end do

    end subroutine

    subroutine test_linspace_neg_index(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        real(dp), parameter :: start = 1.0_dp
        real(dp), parameter :: end = 10.0_dp

        real(dp), allocatable :: x(:)

        x = linspace(start, end, -15)

        call check(error, size(x), 0, "Allocated array is not empty")

    end subroutine

    subroutine test_linspace_cmplx(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        complex(dp), parameter :: start = (0.0_dp, 10.0_dp)
        complex(dp), parameter :: end = (1.0_dp, 0.0_dp)
        complex(dp) :: expected_interval
        integer, parameter :: n = 10

        complex(dp), allocatable :: z(:)

        integer :: i

        z = linspace(start, end, n)

        expected_interval =( end - start ) / ( n - 1 )

        call check(error, size(z), n, "Array not allocated to correct size")
        if (allocated(error)) return
        call check(error, z(1), start, "Initial value of array is not equal to the passed start parameter")
        if (allocated(error)) return
        call check(error, z(n), end, "Final array value is not equal to end parameter")
        if (allocated(error)) return

        ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
        do i = 1, n-1

            call check(error, z(i + 1) - z(i), expected_interval, &
                & thr=abs(expected_interval) * TOLERANCE_DP)
            if (allocated(error)) return

        end do

    end subroutine

    subroutine test_linspace_cmplx_2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        complex(dp), parameter :: start = (10.0_dp, 10.0_dp)
        complex(dp), parameter :: end = (1.0_dp, 1.0_dp)
        complex(dp) :: expected_interval

        integer, parameter :: n = 5

        complex(dp), allocatable :: z(:)

        integer :: i

        z = linspace(start, end, n)

        expected_interval =( end - start ) / ( n - 1 )

        call check(error, size(z), n, "Array not allocated to correct size")
        if (allocated(error)) return
        call check(error, z(1), start, "Initial value of array is not equal to the passed start parameter")
        if (allocated(error)) return
        call check(error, z(n), end, "Final array value is not equal to end parameter")
        if (allocated(error)) return

        ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
        do i = 1, n-1

            call check(error, z(i + 1) - z(i), expected_interval, &
                & thr=abs(expected_interval) * TOLERANCE_DP)
            if (allocated(error)) return

        end do

    end subroutine

    subroutine test_linspace_cmplx_3(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        complex(dp), parameter :: start = (-5.0_dp, 100.0_dp)
        complex(dp), parameter :: end = (20.0_dp, 13.0_dp)
        complex(dp) :: expected_interval

        integer, parameter :: n = 20

        complex(dp), allocatable :: z(:)

        integer :: i

        z = linspace(start, end, n)

        expected_interval = ( end - start ) / ( n - 1 )

        call check(error, size(z), n, "Array not allocated to correct size")
        if (allocated(error)) return
        call check(error, z(1), start, "Initial value of array is not equal to the passed start parameter")
        if (allocated(error)) return
        call check(error, z(n), end, "Final array value is not equal to end parameter")
        if (allocated(error)) return

        ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
        do i = 1, n-1

            call check(error, z(i + 1) - z(i), expected_interval, &
                & thr=abs(expected_interval) * TOLERANCE_DP)
            if (allocated(error)) return

        end do

    end subroutine

    subroutine test_linspace_cmplx_sp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        complex(sp), parameter :: start = (0.5_sp, 5.0_sp)
        complex(sp), parameter :: end = (1.0_sp, -30.0_sp)
        complex(sp) :: expected_interval

        integer, parameter :: n = 10

        complex(sp), allocatable :: z(:)

        integer :: i

        z = linspace(start, end, n)

        expected_interval =( end - start ) / ( n - 1 )

        call check(error, size(z), n, "Array not allocated to correct size")
        if (allocated(error)) return
        call check(error, z(1), start, "Initial value of array is not equal to the passed start parameter")
        if (allocated(error)) return
        call check(error, z(n), end, "Final array value is not equal to end parameter")
        if (allocated(error)) return

        ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
        do i = 1, n-1

            call check(error, z(i + 1) - z(i), expected_interval, &
                & thr=abs(expected_interval) * TOLERANCE_SP)
            if (allocated(error)) return

        end do

    end subroutine

    subroutine test_linspace_cmplx_sp_2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        complex(sp), parameter :: start = (50.0_sp, 500.0_sp)
        complex(sp), parameter :: end = (-100.0_sp, 2000.0_sp)
        complex(sp) :: expected_interval
        complex(sp) :: true_interval
        real(sp) :: offset

        integer, parameter :: n = DEFAULT_LINSPACE_LENGTH

        complex(sp), allocatable :: z(:)

        integer :: i

        z = linspace(start, end)

        expected_interval =( end - start ) / ( n - 1 )

        call check(error, size(z), n, "Array not allocated to default size")
        if (allocated(error)) return
        call check(error, z(1), start, "Initial value of array is not equal to the passed start parameter")
        if (allocated(error)) return
        call check(error, z(n), end, "Final array value is not equal to end parameter")
        if (allocated(error)) return

        ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
        do i = 1, n-1

            true_interval = (z(i + 1) - z(i))
            offset = abs(true_interval - expected_interval)
            call check(error, z(i + 1) - z(i), expected_interval, &
                & thr=abs(expected_interval) * TOLERANCE_SP)
            if (allocated(error)) return
            ! print *, i

        end do

    end subroutine

    subroutine test_linspace_int16(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer(int16), parameter :: start = 5
        integer(int16), parameter :: end = 10
        real(dp) :: expected_interval

        integer, parameter :: n = 6

        integer(int16), allocatable :: z(:)

        integer :: i

        z = linspace(start, end, n)

        expected_interval =( end - start ) / ( n - 1 )

        call check(error, size(z), n, "Array not allocated to correct size")
        if (allocated(error)) return
        call check(error, z(1), start, "Initial value of array is not equal to the passed start parameter")
        if (allocated(error)) return
        call check(error, z(n), end, "Final array value is not equal to end parameter")
        if (allocated(error)) return

        ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
        do i = 1, n-1

            call check(error, real(z(i + 1) - z(i), dp), expected_interval, &
                & thr=abs(expected_interval) * TOLERANCE_DP)
            if (allocated(error)) return

        end do

    end subroutine

    subroutine test_linspace_int8(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer(int8), parameter :: start = 20
        integer(int8), parameter :: end = 50

        real(dp) :: expected_interval

        integer, parameter :: n = 10

        real(dp), allocatable :: z(:)
        integer(int8) :: z_int(n)

        integer :: i

        z = linspace(start, end, n)
        z_int = linspace(start, end, n)

        expected_interval =real( end - start, dp ) / ( n - 1 )

        call check(error, size(z), n, "Array not allocated to correct size")
        if (allocated(error)) return
        call check(error, z(1), real(start, dp), "Initial value of array is not equal to the passed start parameter")
        if (allocated(error)) return
        call check(error, z(n), real(end, dp), "Final array value is not equal to end parameter")
        if (allocated(error)) return

        ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
        do i = 1, n-1

            call check(error, z(i + 1) - z(i), expected_interval, &
                & thr=abs(expected_interval) * TOLERANCE_DP)
            if (allocated(error)) return

        end do

    end subroutine

end module

program tester
    use, intrinsic :: iso_fortran_env, only : error_unit
    use testdrive, only : run_testsuite, new_testsuite, testsuite_type
    use test_linspace, only : collect_linspace
    implicit none
    integer :: stat, is
    type(testsuite_type), allocatable :: testsuites(:)
    character(len=*), parameter :: fmt = '("#", *(1x, a))'

    stat = 0

    testsuites = [ &
        new_testsuite("linspace", collect_linspace) &
        ]

    do is = 1, size(testsuites)
        write(error_unit, fmt) "Testing:", testsuites(is)%name
        call run_testsuite(testsuites(is)%collect, error_unit, stat)
    end do

    if (stat > 0) then
        write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
        error stop
    end if
end program tester


program mnist
use activations
implicit none

integer, allocatable :: train(:,:)
integer :: n, m, io, i, j, number_to_display
integer :: seed = 1234567
character(len=128) :: arg
character(len=128) :: filename

! Declaration of network weights and biases
double precision, dimension(30, 784) :: w_h1
double precision, dimension(30) :: b_h1
double precision, dimension(10,30) :: w_out
double precision, dimension(10) :: b_out, out

! Initializes all weights with gaussian normal distribution
! with 1 variance
call r8mat_normal_01(30, 784, seed, w_h1)
call r8vec_normal_01(30, seed, b_h1)
call r8mat_normal_01(10, 30, seed, w_out)
call r8vec_normal_01(10, seed, b_out)

call getarg(1, arg)
filename = arg
call getarg(2, arg)
read(arg, '(I10)') number_to_display

m = 784
n = 0
open(1, file = filename)
do
	read(1,*,iostat=io)
	if (io/=0) exit
	n = n + 1
end do
close(1)

n = n - 1 ! remove header line from count
allocate(train(n, m))

open(1, file = filename)
read(1,*) ! read header
do i = 1, n
	read(1, *) train(i,:)
end do

call display(train(number_to_display,:))
call feedforward(train(202,:), w_h1, b_h1, w_out, b_out, out)
write(*,*) out

contains

subroutine feedforward(input, w_h1, b_h1, w_out, b_out, out)
	integer, intent(in), dimension(784) :: input
	double precision, intent(in), dimension(30, 784) :: w_h1
	double precision, intent(in), dimension(30) :: b_h1
	double precision, intent(in), dimension(10,30) :: w_out
	double precision, intent(in), dimension(10) :: b_out
	double precision, dimension(30) :: h1
	double precision, intent(out), dimension(10) :: out

	h1 = sigmoid(matmul(w_h1, input) + b_h1)
	out = sigmoid(matmul(w_out, h1) + b_out)

end subroutine

subroutine display(x)
	integer, dimension(784) :: x
	character, dimension(28,28) :: d
	integer :: i, j, k
	k = 1
	do i = 1, 28
		do j = 1, 28
			if(x(k) > 128) then
				d(i,j) = 'X'
			else
				d(i,j) = ' '
			end if
			k = k +1
		end do
	end do

	do i = 1, 28
		write(*,*) d(i,:)
	end do

end subroutine

end program


       function fact_i(n)

        integer, intent(in) :: n
        real(kind=8) :: fact_i
        integer :: i

        fact_i = 1.d0
        do i = 2, n
            fact_i = fact_i * i
        enddo

       end function fact_i


      FUNCTION PSI(XX)
C----------------------------------------------------------------------
C
C This function program evaluates the logarithmic derivative of the
C   gamma function,
C
C      psi(x) = d/dx (gamma(x)) / gamma(x) = d/dx (ln gamma(x))
C
C   for real x, where either
C
C          -xmax1 < x < -xmin (x not a negative integer), or
C            xmin < x.
C
C   The calling sequence for this function is
C
C                  Y = PSI(X)
C
C   The main computation uses rational Chebyshev approximations
C   published in Math. Comp. 27, 123-127 (1973) by Cody, Strecok and
C   Thacher.  This transportable program is patterned after the
C   machine-dependent FUNPACK program PSI(X), but cannot match that
C   version for efficiency or accuracy.  This version uses rational
C   approximations that are theoretically accurate to 20 significant
C   decimal digits.  The accuracy achieved depends on the arithmetic
C   system, the compiler, the intrinsic functions, and proper selection
C   of the machine-dependent constants.
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants
C
C   XINF   = largest positive machine number
C   XMAX1  = beta ** (p-1), where beta is the radix for the
C            floating-point system, and p is the number of base-beta
C            digits in the floating-point significand.  This is an
C            upper bound on non-integral floating-point numbers, and
C            the negative of the lower bound on acceptable negative
C            arguments for PSI.  If rounding is necessary, round this
C            value down.
C   XMIN1  = the smallest in magnitude acceptable argument.  We
C            recommend XMIN1 = MAX(1/XINF,xmin) rounded up, where
C            xmin is the smallest positive floating-point number.
C   XSMALL = absolute argument below which  PI*COTAN(PI*X)  may be
C            represented by 1/X.  We recommend XSMALL < sqrt(3 eps)/pi,
C            where eps is the smallest positive number such that
C            1+eps > 1.
C   XLARGE = argument beyond which PSI(X) may be represented by
C            LOG(X).  The solution to the equation
C               x*ln(x) = beta ** p
C            is a safe value.
C
C     Approximate values for some important machines are
C
C                        beta  p     eps     xmin       XINF
C
C  CDC 7600      (S.P.)    2  48  7.11E-15  3.13E-294  1.26E+322
C  CRAY-1        (S.P.)    2  48  7.11E-15  4.58E-2467 5.45E+2465
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)    2  24  1.19E-07  1.18E-38   3.40E+38
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)    2  53  1.11D-16  2.23E-308  1.79D+308
C  IBM 3033      (D.P.)   16  14  1.11D-16  5.40D-79   7.23D+75
C  SUN 3/160     (D.P.)    2  53  1.11D-16  2.23D-308  1.79D+308
C  VAX 11/780    (S.P.)    2  24  5.96E-08  2.94E-39   1.70E+38
C                (D.P.)    2  56  1.39D-17  2.94D-39   1.70D+38
C   (G Format)   (D.P.)    2  53  1.11D-16  5.57D-309  8.98D+307
C
C                         XMIN1      XMAX1     XSMALL    XLARGE
C
C  CDC 7600      (S.P.)  3.13E-294  1.40E+14  4.64E-08  9.42E+12
C  CRAY-1        (S.P.)  1.84E-2466 1.40E+14  4.64E-08  9.42E+12
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)  1.18E-38   8.38E+06  1.90E-04  1.20E+06
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)  2.23D-308  4.50D+15  5.80D-09  2.71D+14
C  IBM 3033      (D.P.)  1.39D-76   4.50D+15  5.80D-09  2.05D+15
C  SUN 3/160     (D.P.)  2.23D-308  4.50D+15  5.80D-09  2.71D+14
C  VAX 11/780    (S.P.)  5.89E-39   8.38E+06  1.35E-04  1.20E+06
C                (D.P.)  5.89D-39   3.60D+16  2.05D-09  2.05D+15
C   (G Format)   (D.P.)  1.12D-308  4.50D+15  5.80D-09  2.71D+14
C
C*******************************************************************
C*******************************************************************
C
C Error Returns
C
C  The program returns XINF for  X < -XMAX1, for X zero or a negative
C    integer, or when X lies in (-XMIN1, 0), and returns -XINF
C    when X lies in (0, XMIN1).
C
C Intrinsic functions required are:
C
C     ABS, AINT, DBLE, INT, LOG, REAL, TAN
C
C----------------------------------------------------------------------
      INTEGER I,N,NQ
CS    REAL
      DOUBLE PRECISION
     1   AUG,CONV,DEN,PSI,FOUR,FOURTH,HALF,ONE,P1,P2,PIOV4,Q1,Q2,
     2   SGN,THREE,XLARGE,UPPER,W,X,XINF,XMAX1,XMIN1,XSMALL,X01,
     3   X01D,X02,XX,Z,ZERO
      DIMENSION P1(9),P2(7),Q1(8),Q2(6)
C----------------------------------------------------------------------
C  Mathematical constants.  PIOV4 = pi / 4
C----------------------------------------------------------------------
CS    DATA ZERO,FOURTH,HALF,ONE/0.0E0,0.25E0,0.5E0,1.0E0/
CS    DATA THREE,FOUR/3.0E0,4.0E0/,PIOV4/7.8539816339744830962E-01/
      DATA ZERO,FOURTH,HALF,ONE/0.0D0,0.25D0,0.5D0,1.0D0/
      DATA THREE,FOUR/3.0D0,4.0D0/,PIOV4/7.8539816339744830962D-01/
C----------------------------------------------------------------------
C  Machine-dependent constants
C----------------------------------------------------------------------
CS    DATA XINF/1.70E+38/, XMIN1/5.89E-39/, XMAX1/8.38E+06/,
CS   1     XSMALL/1.35E-04/, XLARGE/1.20E+06/
      DATA XINF/1.79D+308/, XMIN1/2.23D-308/, XMAX1/4.50D+15/,
     1     XSMALL/5.80D-09/, XLARGE/2.71D+14/
C----------------------------------------------------------------------
C  Zero of psi(x)
C----------------------------------------------------------------------
CS    DATA X01/187.0E0/,X01D/128.0E0/,X02/6.9464496836234126266E-04/
      DATA X01/187.0D0/,X01D/128.0D0/,X02/6.9464496836234126266D-04/
C----------------------------------------------------------------------
C  Coefficients for approximation to  psi(x)/(x-x0)  over [0.5, 3.0]
C----------------------------------------------------------------------
CS    DATA P1/4.5104681245762934160E-03,5.4932855833000385356E+00,
CS   1        3.7646693175929276856E+02,7.9525490849151998065E+03,
CS   2        7.1451595818951933210E+04,3.0655976301987365674E+05,
CS   3        6.3606997788964458797E+05,5.8041312783537569993E+05,
CS   4        1.6585695029761022321E+05/
CS    DATA Q1/9.6141654774222358525E+01,2.6287715790581193330E+03,
CS   1        2.9862497022250277920E+04,1.6206566091533671639E+05,
CS   2        4.3487880712768329037E+05,5.4256384537269993733E+05,
CS   3        2.4242185002017985252E+05,6.4155223783576225996E-08/
      DATA P1/4.5104681245762934160D-03,5.4932855833000385356D+00,
     1        3.7646693175929276856D+02,7.9525490849151998065D+03,
     2        7.1451595818951933210D+04,3.0655976301987365674D+05,
     3        6.3606997788964458797D+05,5.8041312783537569993D+05,
     4        1.6585695029761022321D+05/
      DATA Q1/9.6141654774222358525D+01,2.6287715790581193330D+03,
     1        2.9862497022250277920D+04,1.6206566091533671639D+05,
     2        4.3487880712768329037D+05,5.4256384537269993733D+05,
     3        2.4242185002017985252D+05,6.4155223783576225996D-08/
C----------------------------------------------------------------------
C  Coefficients for approximation to  psi(x) - ln(x) + 1/(2x)
C     for  x > 3.0
C----------------------------------------------------------------------
CS    DATA P2/-2.7103228277757834192E+00,-1.5166271776896121383E+01,
CS   1        -1.9784554148719218667E+01,-8.8100958828312219821E+00,
CS   2        -1.4479614616899842986E+00,-7.3689600332394549911E-02,
CS   3        -6.5135387732718171306E-21/
CS    DATA Q2/ 4.4992760373789365846E+01, 2.0240955312679931159E+02,
CS   1         2.4736979003315290057E+02, 1.0742543875702278326E+02,
CS   2         1.7463965060678569906E+01, 8.8427520398873480342E-01/
      DATA P2/-2.7103228277757834192D+00,-1.5166271776896121383D+01,
     1        -1.9784554148719218667D+01,-8.8100958828312219821D+00,
     2        -1.4479614616899842986D+00,-7.3689600332394549911D-02,
     3        -6.5135387732718171306D-21/
      DATA Q2/ 4.4992760373789365846D+01, 2.0240955312679931159D+02,
     1         2.4736979003315290057D+02, 1.0742543875702278326D+02,
     2         1.7463965060678569906D+01, 8.8427520398873480342D-01/
C----------------------------------------------------------------------
CS    CONV(I) = REAL(I)
      CONV(I) = DBLE(I)
      X = XX
      W = ABS(X)
      AUG = ZERO
C----------------------------------------------------------------------
C  Check for valid arguments, then branch to appropriate algorithm
C----------------------------------------------------------------------
      IF ((-X .GE. XMAX1) .OR. (W .LT. XMIN1)) THEN
            GOTO 410
         ELSE IF (X .GE. HALF) THEN
            GOTO 200
C----------------------------------------------------------------------
C  X < 0.5, use reflection formula: psi(1-x) = psi(x) + pi * cot(pi*x)
C     Use 1/X for PI*COTAN(PI*X)  when  XMIN1 < |X| <= XSMALL.
C----------------------------------------------------------------------
         ELSE IF (W .LE. XSMALL) THEN
            AUG = -ONE / X
            GOTO 150
      END IF
C----------------------------------------------------------------------
C  Argument reduction for cot
C----------------------------------------------------------------------
  100 IF (X .LT. ZERO) THEN
            SGN = PIOV4
         ELSE
            SGN = -PIOV4
      END IF
      W = W - AINT(W)
      NQ = INT(W * FOUR)
      W = FOUR * (W - CONV(NQ) * FOURTH)
C----------------------------------------------------------------------
C  W is now related to the fractional part of  4.0 * X.
C     Adjust argument to correspond to values in the first
C     quadrant and determine the sign.
C----------------------------------------------------------------------
      N = NQ / 2
      IF ((N+N) .NE. NQ) W = ONE - W
      Z = PIOV4 * W
      IF (MOD(N,2) .NE. 0) SGN = - SGN
C----------------------------------------------------------------------
C  determine the final value for  -pi * cotan(pi*x)
C----------------------------------------------------------------------
      N = (NQ + 1) / 2
      IF (MOD(N,2) .EQ. 0) THEN
C----------------------------------------------------------------------
C  Check for singularity
C----------------------------------------------------------------------
            IF (Z .EQ. ZERO) GOTO 410
            AUG = SGN * (FOUR / TAN(Z))
         ELSE
            AUG = SGN * (FOUR * TAN(Z))
      END IF
  150 X = ONE - X
  200 IF (X .GT. THREE) GOTO 300
C----------------------------------------------------------------------
C  0.5 <= X <= 3.0
C----------------------------------------------------------------------
      DEN = X
      UPPER = P1(1) * X
      DO 210 I = 1, 7
         DEN = (DEN + Q1(I)) * X
         UPPER = (UPPER + P1(I+1)) * X
  210 CONTINUE
      DEN = (UPPER + P1(9)) / (DEN + Q1(8))
      X = (X-X01/X01D) - X02
      PSI = DEN * X + AUG
      GO TO 500
C----------------------------------------------------------------------
C  3.0 < X
C----------------------------------------------------------------------
  300 IF (X .LT. XLARGE) THEN
         W = ONE / (X * X)
         DEN = W
         UPPER = P2(1) * W
         DO 310 I = 1, 5
            DEN = (DEN + Q2(I)) * W
            UPPER = (UPPER + P2(I+1)) * W
  310    CONTINUE
         AUG = (UPPER + P2(7)) / (DEN + Q2(6)) - HALF / X + AUG
      END IF
      PSI = AUG + LOG(X)
      GOTO 500
C----------------------------------------------------------------------
C  Error return
C----------------------------------------------------------------------
  410 PSI = XINF
      IF (X .GT. ZERO) PSI = -XINF
  500 RETURN
C---------- Last card of PSI ----------
      END


MODULE MODULE_GEOMETRY

USE MODULE_PBC
USE MODULE_MATH
USE MODULE_COM

CONTAINS

  FUNCTION DIST2POINTS(point1,point2,box,inv,ortho,pbc_opt) RESULT (valdist)

    IMPLICIT NONE
    INTEGER, INTENT(IN)::ortho,pbc_opt
    DOUBLE PRECISION,DIMENSION(3),INTENT(IN)::point1,point2
    DOUBLE PRECISION,DIMENSION(3,3),INTENT(IN)::box,inv
    DOUBLE PRECISION::valdist
    DOUBLE PRECISION,DIMENSION(3)::vect_aux

    vect_aux(:)=point1(:)-point2(:)
    IF (pbc_opt==1) THEN
        CALL PBC (vect_aux,box,inv,ortho)
    END IF
    valdist=sqrt(dot_product(vect_aux(:),vect_aux(:)))

  END FUNCTION DIST2POINTS

  SUBROUTINE DISTANCE(diff_set,coors1,coors2,box,inv,ortho,&
          pbc_opt,n1,n2,n_frames,matrix)

  IMPLICIT NONE
  INTEGER,INTENT(IN)::diff_set,pbc_opt,ortho
  INTEGER,INTENT(IN)::n1,n2,n_frames
  DOUBLE PRECISION,DIMENSION(n_frames,n1,3),INTENT(IN)::coors1
  DOUBLE PRECISION,DIMENSION(n_frames,n2,3),INTENT(IN)::coors2
  DOUBLE PRECISION,DIMENSION(n_frames,3,3),INTENT(IN)::box,inv
  DOUBLE PRECISION,DIMENSION(n_frames,n1,n2),INTENT(OUT)::matrix

  INTEGER::ii,jj,kk
  DOUBLE PRECISION::val_aux
  DOUBLE PRECISION,DIMENSION(:),ALLOCATABLE::vect,vect_aux,vect_aux2
  DOUBLE PRECISION,DIMENSION(:,:),ALLOCATABLE::tmp_box,tmp_inv

  ALLOCATE(vect(3),vect_aux(3),vect_aux2(3))
  ALLOCATE(tmp_box(3,3),tmp_inv(3,3))

  IF (diff_set==1) THEN
    DO kk=1,n_frames
      tmp_box=box(kk,:,:)
      tmp_inv=inv(kk,:,:)
      DO ii=1,n1
         vect_aux=coors1(kk,ii,:)
         DO jj=1,n2
            vect_aux2=coors2(kk,jj,:)
            matrix(kk,ii,jj)=DIST2POINTS(vect_aux,vect_aux2,tmp_box,tmp_inv,ortho,pbc_opt)
         END DO
      END DO
    END DO
  ELSE
    DO kk=1,n_frames
      tmp_box=box(kk,:,:)
      tmp_inv=inv(kk,:,:)
      DO ii=1,n1
         matrix(kk,ii,ii)=0.0d0
         vect_aux=coors1(kk,ii,:)
         DO jj=ii+1,n1
            vect_aux2=coors1(kk,jj,:)
            val_aux=DIST2POINTS(vect_aux,vect_aux2,tmp_box,tmp_inv,ortho,pbc_opt)
            matrix(kk,ii,jj)=val_aux
            matrix(kk,jj,ii)=val_aux
         END DO
      END DO
    END DO
  END IF

  DEALLOCATE(vect,vect_aux,vect_aux2)
  DEALLOCATE(tmp_box,tmp_inv)

  END SUBROUTINE DISTANCE

  !FUNCTION RADIUS_OF_GYRATION (coors,weights,n_frames,n_atoms) RESULT(Rg)

  !  IMPLICIT NONE
  !  INTEGER, INTENT(IN)::n_frames,n_atoms
  !  DOUBLE PRECISION,DIMENSION(n_frames,n_atoms,3),INTENT(IN)::coors
  !  DOUBLE PRECISION,DIMENSION(n_atoms),INTENT(IN)::weights
  !  DOUBLE PRECISION,DIMENSION(n_frames)::Rg

  !  INTEGER::ii,jj
  !  DOUBLE PRECISION,DIMENSION(n_frames,3)::com
  !  DOUBLE PRECISION,DIMENSION(3)::vect_aux
  !  DOUBLE PRECISION::total_weight
  !  DOUBLE PRECISION::val_aux

  !  Rg(:) = 0.0d0
  !  com = CENTER_OF_MASS(coors,weights,n_frames,n_atoms)
  !  total_weight=SUM(weights)

  !  DO ii=1,n_frames
  !      val_aux=0.0d0
  !      DO jj=1,n_atoms
  !          vect_aux = coors(ii,jj,:)-com(ii,:)
  !          Rg(ii)=Rg(ii)+weights(jj)*dot_product(vect_aux,vect_aux)
  !      END DO
  !  END DO

  !  Rg(:)=Rg(:)/total_weight
  !  Rg(:)=sqrt(Rg(:))

  !END FUNCTION

  SUBROUTINE TRANSLATE(coors, shifts, n_frames, n_atoms)

    IMPLICIT NONE
    INTEGER,INTENT(IN)::n_frames, n_atoms
    DOUBLE PRECISION,DIMENSION(n_frames, n_atoms, 3),INTENT(INOUT)::coors
    DOUBLE PRECISION,DIMENSION(n_frames,3),INTENT(IN)::shifts
    INTEGER::ii,jj

    DO ii=1,n_frames
      DO jj=1,n_atoms
          coors(ii,jj,:)=coors(ii,jj,:)+shifts(ii,:)
      END DO
    END DO

  END SUBROUTINE

END MODULE MODULE_GEOMETRY


program tsunami

  ! Tsunami simulator.
  !
  ! Solves the non-linear 2-d shallow water equation system:
  !
  !     du/dt + u du/dx + v du/dy + g dh/dx = 0
  !     dv/dt + u dv/dx + v dv/dy + g dh/dy = 0
  !     dh/dt + d(hu)/dx + d(hv)/dy = 0
  !
  ! This version is parallelized and uses derived types.

  use iso_fortran_env, only: int32, real32
  use mod_field, only: Field, diffx, diffy

  implicit none

  integer(int32) :: n

  integer(int32), parameter :: im = 201, jm = 201
  integer(int32), parameter :: num_time_steps = 1000

  real(real32), parameter :: dt = 0.02
  real(real32), parameter :: dx = 1, dy = 1
  real(real32), parameter :: g = 9.8

  integer(int32), parameter :: ic = im / 2 + 1
  integer(int32), parameter :: jc = jm / 2 + 1
  real(real32), parameter :: decay = 0.02

  type(Field) :: h, hm, u, v

  real(real32) :: hmin, hmax, hmean

  u = Field('u', [im, jm])
  v = Field('v', [im, jm])
  h = Field('h', [im, jm])
  hm = Field('h_mean', [im, jm])

  ! initialize a gaussian blob in the center
  call h % init_gaussian(decay, ic, jc)

  hm = 10.

  call h % write(0)

  time_loop: do n = 1, num_time_steps

    ! compute u at next time step
    u = u - (u * diffx(u) / dx + v * diffy(u) / dy &
      + g * diffx(h) / dx) * dt

    ! compute v at next time step
    v = v - (u * diffx(v) / dx + v * diffy(v) / dy &
      + g * diffy(h) / dy) * dt

    ! compute h at next time step
    h = h - (diffx(u * (hm + h)) / dx &
           + diffy(v * (hm + h)) / dy) * dt

    hmin = minval(h % data)
    call co_min(hmin, 1)

    hmax = maxval(h % data)
    call co_max(hmax, 1)

    hmean = sum(h % data(h % lb(1):h % ub(1),h % lb(2):h % ub(2))) &
          / size(h % data(h % lb(1):h % ub(1),h % lb(2):h % ub(2)))
    call co_sum(hmean, 1)
    hmean = hmean / num_images()

    if (this_image() == 1) &
      print '(a, i5, 3(f10.6))', &
        'step, min(h), max(h), mean(h):', &
         n, hmin, hmax, hmean

    call h % write(n)

  end do time_loop

end program tsunami


program main
  ! Default
  implicit none

  ! Parameters
  integer(4), parameter :: max_val = 999

  ! Variables
  integer(4) :: i,j,max_pal,prod

  ! Do work
  max_pal = 1
  do i=1,max_val
     do j=i,max_val
        prod = i*j
        if (is_pal(prod)) then
           max_pal = max(prod,max_pal)
        endif
     enddo
  enddo

  ! Write out result
  write(*,*) "Max palindrome: ",max_pal

contains

  pure function is_pal(targ)
    ! Default
    implicit none

    ! Local parameters
    integer(4), parameter :: max_places = 1 + int(log10(1D0*max_val**2))

    ! Function arguments
    integer(4), intent(in) :: targ
    logical                :: is_pal

    ! Local variables
    integer(4)            :: i,len_targ
    character(max_places) :: targ_char
    character(100)        :: tag
    character             :: ic,jc

    ! Write the product as a character
    if (max_places < 1e10) then
       write(tag,'(a,i10,a)') '(i',max_places,')'
    else
       write(tag,'(a,i100,a)') '(i',max_places,')'
    endif
    write(targ_char,tag) targ

    ! Find the length of the string
    len_targ = len_trim(targ_char)

    ! Test whether it's a palindrome
    do i=1,len_targ/2
       !write(ic,'(a1)') targ_char(i:i)
       !write(jc,'(a1)') targ_char(len_targ-i+1:len_targ-i+1)
       ic = targ_char(i:i)
       jc = targ_char(len_targ-i+1:len_targ-i+1)
       if (ic/=jc) then
          is_pal = .false.
          return
       endif
    enddo

    is_pal = .true.
    return
  end function is_pal

end program main


*DECK CPPSL
      SUBROUTINE CPPSL (AP, N, B)
C***BEGIN PROLOGUE  CPPSL
C***PURPOSE  Solve the complex Hermitian positive definite system using
C            the factors computed by CPPCO or CPPFA.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2D1B
C***TYPE      COMPLEX (SPPSL-S, DPPSL-D, CPPSL-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX, PACKED,
C             POSITIVE DEFINITE, SOLVE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     CPPSL solves the complex Hermitian positive definite system
C     A * X = B
C     using the factors computed by CPPCO or CPPFA.
C
C     On Entry
C
C        AP      COMPLEX (N*(N+1)/2)
C                the output from CPPCO or CPPFA.
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        B       COMPLEX(N)
C                the right hand side vector.
C
C     On Return
C
C        B       the solution vector  X .
C
C     Error Condition
C
C        A division by zero will occur if the input factor contains
C        a zero on the diagonal.  Technically this indicates
C        singularity but it is usually caused by improper subroutine
C        arguments.  It will not occur if the subroutines are called
C        correctly and  INFO .EQ. 0 .
C
C     To compute  INVERSE(A) * C  where  C  is a matrix
C     with  P  columns
C           CALL CPPCO(AP,N,RCOND,Z,INFO)
C           IF (RCOND is too small .OR. INFO .NE. 0) GO TO ...
C           DO 10 J = 1, P
C              CALL CPPSL(AP,N,C(1,J))
C        10 CONTINUE
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  CAXPY, CDOTC
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CPPSL
      INTEGER N
      COMPLEX AP(*),B(*)
C
      COMPLEX CDOTC,T
      INTEGER K,KB,KK
C***FIRST EXECUTABLE STATEMENT  CPPSL
      KK = 0
      DO 10 K = 1, N
         T = CDOTC(K-1,AP(KK+1),1,B(1),1)
         KK = KK + K
         B(K) = (B(K) - T)/AP(KK)
   10 CONTINUE
      DO 20 KB = 1, N
         K = N + 1 - KB
         B(K) = B(K)/AP(KK)
         KK = KK - K
         T = -B(K)
         CALL CAXPY(K-1,T,AP(KK+1),1,B(1),1)
   20 CONTINUE
      RETURN
      END