*DECK DP1VLU
      SUBROUTINE DP1VLU (L, NDER, X, YFIT, YP, A)
C***BEGIN PROLOGUE  DP1VLU
C***PURPOSE  Use the coefficients generated by DPOLFT to evaluate the
C            polynomial fit of degree L, along with the first NDER of
C            its derivatives, at a specified point.
C***LIBRARY   SLATEC
C***CATEGORY  K6
C***TYPE      DOUBLE PRECISION (PVALUE-S, DP1VLU-D)
C***KEYWORDS  CURVE FITTING, LEAST SQUARES, POLYNOMIAL APPROXIMATION
C***AUTHOR  Shampine, L. F., (SNLA)
C           Davenport, S. M., (SNLA)
C***DESCRIPTION
C
C     Abstract
C
C     The subroutine  DP1VLU  uses the coefficients generated by  DPOLFT
C     to evaluate the polynomial fit of degree  L , along with the first
C     NDER  of its derivatives, at a specified point.  Computationally
C     stable recurrence relations are used to perform this task.
C
C     The parameters for  DP1VLU  are
C
C     Input -- ALL TYPE REAL variables are DOUBLE PRECISION
C         L -      the degree of polynomial to be evaluated.  L  may be
C                  any non-negative integer which is less than or equal
C                  to  NDEG , the highest degree polynomial provided
C                  by  DPOLFT .
C         NDER -   the number of derivatives to be evaluated.  NDER
C                  may be 0 or any positive value.  If NDER is less
C                  than 0, it will be treated as 0.
C         X -      the argument at which the polynomial and its
C                  derivatives are to be evaluated.
C         A -      work and output array containing values from last
C                  call to  DPOLFT .
C
C     Output -- ALL TYPE REAL variables are DOUBLE PRECISION
C         YFIT -   value of the fitting polynomial of degree  L  at  X
C         YP -     array containing the first through  NDER  derivatives
C                  of the polynomial of degree  L .  YP  must be
C                  dimensioned at least  NDER  in the calling program.
C
C***REFERENCES  L. F. Shampine, S. M. Davenport and R. E. Huddleston,
C                 Curve fitting by polynomials in one variable, Report
C                 SLA-74-0270, Sandia Laboratories, June 1974.
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   740601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DP1VLU
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER I,IC,ILO,IN,INP1,IUP,K1,K1I,K2,K3,K3P1,K3PN,K4,K4P1,K4PN,
     * KC,L,LM1,LP1,MAXORD,N,NDER,NDO,NDP1,NORD
      DOUBLE PRECISION A(*),CC,DIF,VAL,X,YFIT,YP(*)
      CHARACTER*8 XERN1, XERN2
C***FIRST EXECUTABLE STATEMENT  DP1VLU
      IF (L .LT. 0) GO TO 12
      NDO = MAX(NDER,0)
      NDO = MIN(NDO,L)
      MAXORD = A(1) + 0.5D0
      K1 = MAXORD + 1
      K2 = K1 + MAXORD
      K3 = K2 + MAXORD + 2
      NORD = A(K3) + 0.5D0
      IF (L .GT. NORD) GO TO 11
      K4 = K3 + L + 1
      IF (NDER .LT. 1) GO TO 2
      DO 1 I = 1,NDER
 1      YP(I) = 0.0D0
 2    IF (L .GE. 2) GO TO 4
      IF (L .EQ. 1) GO TO 3
C
C L IS 0
C
      VAL = A(K2+1)
      GO TO 10
C
C L IS 1
C
 3    CC = A(K2+2)
      VAL = A(K2+1) + (X-A(2))*CC
      IF (NDER .GE. 1) YP(1) = CC
      GO TO 10
C
C L IS GREATER THAN 1
C
 4    NDP1 = NDO + 1
      K3P1 = K3 + 1
      K4P1 = K4 + 1
      LP1 = L + 1
      LM1 = L - 1
      ILO = K3 + 3
      IUP = K4 + NDP1
      DO 5 I = ILO,IUP
 5      A(I) = 0.0D0
      DIF = X - A(LP1)
      KC = K2 + LP1
      A(K4P1) = A(KC)
      A(K3P1) = A(KC-1) + DIF*A(K4P1)
      A(K3+2) = A(K4P1)
C
C EVALUATE RECURRENCE RELATIONS FOR FUNCTION VALUE AND DERIVATIVES
C
      DO 9 I = 1,LM1
        IN = L - I
        INP1 = IN + 1
        K1I = K1 + INP1
        IC = K2 + IN
        DIF = X - A(INP1)
        VAL = A(IC) + DIF*A(K3P1) - A(K1I)*A(K4P1)
        IF (NDO .LE. 0) GO TO 8
        DO 6 N = 1,NDO
          K3PN = K3P1 + N
          K4PN = K4P1 + N
 6        YP(N) = DIF*A(K3PN) + N*A(K3PN-1) - A(K1I)*A(K4PN)
C
C SAVE VALUES NEEDED FOR NEXT EVALUATION OF RECURRENCE RELATIONS
C
        DO 7 N = 1,NDO
          K3PN = K3P1 + N
          K4PN = K4P1 + N
          A(K4PN) = A(K3PN)
 7        A(K3PN) = YP(N)
 8      A(K4P1) = A(K3P1)
 9      A(K3P1) = VAL
C
C NORMAL RETURN OR ABORT DUE TO ERROR
C
 10   YFIT = VAL
      RETURN
C
   11 WRITE (XERN1, '(I8)') L
      WRITE (XERN2, '(I8)') NORD
      CALL XERMSG ('SLATEC', 'DP1VLU',
     *   'THE ORDER OF POLYNOMIAL EVALUATION, L = ' // XERN1 //
     *   ' REQUESTED EXCEEDS THE HIGHEST ORDER FIT, NORD = ' // XERN2 //
     *   ', COMPUTED BY DPOLFT -- EXECUTION TERMINATED.', 8, 2)
      RETURN
C
   12 CALL XERMSG ('SLATEC', 'DP1VLU',
     +   'INVALID INPUT PARAMETER.  ORDER OF POLYNOMIAL EVALUATION ' //
     +   'REQUESTED IS NEGATIVE.', 2, 2)
      RETURN
      END


      subroutine rec(n, m)

      if(n.eq.0) then
         m = 1
      else
         call rec(n-1, m)
         m = n*m
      endif

      end


	FUNCTION PR_CLHX ( comx )
C************************************************************************
C* PR_CLHX								*
C*									*
C* This function gets CLHx from COMx, where x represents the L (Low),	*
C* M (Mid), or H (High) cloud level.  COMx is the cloud height		*
C* (in hundreds of feet) * 10 + the numeric cloud coverage code.	*
C*									*
C* REAL PR_CLHX ( COMX )						*
C*									*
C* Input parameters:							*
C*	COMX		REAL		Combined height and coverage	*
C*									*
C* Output parameters:							*
C*	PR_CLHX		REAL		Cloud height in feet * 100	*
C**									*
C* Log:									*
C* S. Schotz/GSC	10/89						*
C* S. Schotz/GSC	11/89	corrected for partially	(thin)		*
C*					obscured case			*
C* M. Linda/GSC		10/97	Corrected the prologue format		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C
	INTEGER		icomx
C
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing code.
C
	IF  ( ERMISS ( comx ) .or. ( comx .lt. 10 ) )  THEN
	    PR_CLHX = RMISSD
	    RETURN
	END IF
C
C*	Check for partially obscured case.
C
	IF  ( comx .gt. 10000 )  THEN
	    icomx = INT ( comx ) - 10000
	  ELSE
	    icomx = INT ( comx)
	END IF
C
C*	Get cloud height in hundreds of feet.
C
	PR_CLHX = icomx / 10
C*
	RETURN
	END


! MIT License
!
! Copyright (c) 2017 Anders Steen Christensen, Bing Huang
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

module slatm_utils

    implicit none

contains

function linspace(x0, x1, nx) result(xs)

    implicit none

    double precision, intent(in) :: x0
    double precision, intent(in) :: x1
    integer, intent(in) :: nx

    double precision, dimension(nx) :: xs

    integer :: i
    double precision :: step

    step = (x1 - x0) / (nx - 1)

    !$OMP PARALLEL DO
    do i = 1, nx
        xs(i) = x0 + (i - 1) * step
    enddo
    !$OMP END PARALLEL DO

end function linspace

function calc_angle(a, b, c) result(angle)

    implicit none

    double precision, intent(in), dimension(3) :: a
    double precision, intent(in), dimension(3) :: b
    double precision, intent(in), dimension(3) :: c

    double precision, dimension(3) :: v1
    double precision, dimension(3) :: v2

    double precision :: cos_angle
    double precision :: angle

    v1 = a - b
    v2 = c - b

    v1 = v1 / norm2(v1)
    v2 = v2 / norm2(v2)

    cos_angle = dot_product(v1,v2)

    ! Clipping
    if (cos_angle > 1.0d0) cos_angle = 1.0d0
    if (cos_angle < -1.0d0) cos_angle = -1.0d0

    angle = acos(cos_angle)

end function calc_angle

function calc_cos_angle(a, b, c) result(cos_angle)

    implicit none

    double precision, intent(in), dimension(3) :: a
    double precision, intent(in), dimension(3) :: b
    double precision, intent(in), dimension(3) :: c

    double precision, dimension(3) :: v1
    double precision, dimension(3) :: v2

    double precision :: cos_angle

    v1 = a - b
    v2 = c - b

    v1 = v1 / norm2(v1)
    v2 = v2 / norm2(v2)

    cos_angle = dot_product(v1,v2)

end function calc_cos_angle

end module slatm_utils

subroutine fget_sbot(coordinates, nuclear_charges, z1, z2, z3, rcut, nx, dgrid, sigma, coeff, ys)

    use slatm_utils, only: linspace, calc_angle, calc_cos_angle

    implicit none

    double precision, dimension(:,:), intent(in) :: coordinates
    double precision, dimension(:), intent(in) :: nuclear_charges
    double precision, intent(in) :: rcut
    integer, intent(in) :: nx
    double precision, intent(in) :: dgrid
    double precision, intent(in) :: sigma
    double precision, intent(in) :: coeff
    double precision, dimension(nx), intent(out) :: ys

    ! MBtype
    integer, intent(in) :: z1, z2, z3

    integer, dimension(:), allocatable :: ias1, ias2, ias3
    integer :: nias1, nias2, nias3

    integer :: ia1, ia2, ia3

    double precision, allocatable, dimension(:, :) :: distance_matrix

    double precision :: norm

    integer :: i, j, k
    integer :: natoms

    double precision, parameter :: eps = epsilon(0.0d0)
    double precision, parameter :: pi = 4.0d0 * atan(1.0d0)
    double precision :: d2r
    double precision :: c0
    double precision :: ang
    double precision :: cak
    double precision :: cai
    double precision :: prefactor
    double precision :: r
    double precision :: a0, a1
    double precision, dimension(nx) :: xs
    double precision, dimension(nx) :: cos_xs
    double precision :: inv_sigma

    natoms = size(coordinates, dim=1)
    if (size(coordinates, dim=1) /= size(nuclear_charges, dim=1)) then
        write(*,*) "ERROR: Coulomb matrix generation"
        write(*,*) size(coordinates, dim=1), "coordinates, but", &
            & size(nuclear_charges, dim=1), "atom_types!"
        stop
    endif

    ! Allocate temporary
    allocate(distance_matrix(natoms, natoms))
    distance_matrix = 0.0d0

    !$OMP PARALLEL DO PRIVATE(norm)
    do i = 1, natoms
        do j = i+1, natoms
            norm = sqrt(sum((coordinates(j,:) - coordinates(i,:))**2))
            distance_matrix(i, j) = norm
            distance_matrix(j, i) = norm
        enddo
    enddo
    !$OMP END PARALLEL DO

    allocate(ias1(natoms))
    allocate(ias2(natoms))
    allocate(ias3(natoms))

    ias1 = 0
    ias2 = 0
    ias3 = 0

    nias1 = 0
    do i = 1, natoms
        if (int(nuclear_charges(i)).eq.z1) then
            nias1 = nias1 + 1
            ias1(nias1) = i
        endif
    enddo

    nias2 = 0
    do i = 1, natoms
        if (int(nuclear_charges(i)).eq.z2) then
            nias2 = nias2 + 1
            ias2(nias2) = i
        endif
    enddo

    nias3 = 0
    do i = 1, natoms
        if (int(nuclear_charges(i)).eq.z3) then
            nias3 = nias3 + 1
            ias3(nias3) = i
        endif
    enddo

    d2r = pi/180.0d0
    a0 = -20.0d0 * d2r
    a1 = pi + 20.0d0 * d2r

    xs = linspace(a0, a1, nx)

    prefactor = 1.0d0 / 3.0d0

    c0 = prefactor * (mod(z1,1000)*mod(z2,1000)*mod(z3,1000)) * coeff * dgrid

    ys = 0.0d0
    inv_sigma = -1.0d0 / (2*sigma**2)

    !$OMP PARALLEL DO
    do i = 1, nx
        cos_xs(i) = cos(xs(i)) * c0
    enddo
    !$OMP END PARALLEL do

    if (z1 == z3) then

        !$OMP PARALLEL DO PRIVATE(i,j,k,ang,cai,cak,r) REDUCTION(+:ys) SCHEDULE(DYNAMIC)
        do ia1 = 1, nias1
            do ia2 = 1, nias2
                if (.not. ((distance_matrix(ias1(ia1),ias2(ia2)) > eps) .and. &
                         & (distance_matrix(ias1(ia1),ias2(ia2)) <= rcut))) cycle
                do ia3 = ia1 + 1, nias3
                    if (distance_matrix(ias1(ia1),ias3(ia3)) > rcut) cycle
                    if (.not. ((distance_matrix(ias2(ia2),ias3(ia3)) > eps) .and. &
                             & (distance_matrix(ias2(ia2),ias3(ia3)) <= rcut))) cycle

                        i = ias1(ia1)
                        j = ias2(ia2)
                        k = ias3(ia3)

                        ang = calc_angle(coordinates(i, :), coordinates(j, :), coordinates(k, :))
                        cak = calc_cos_angle(coordinates(i, :), coordinates(k, :), coordinates(j, :))
                        cai = calc_cos_angle(coordinates(k, :), coordinates(i, :), coordinates(j, :))

                        r = distance_matrix(i,j) * distance_matrix(i,k) * distance_matrix(k,j)

                        ys = ys + (c0 + cos_xs*cak*cai)/(r**3) * ( exp((xs-ang)**2 * inv_sigma) )

                enddo
            enddo
        enddo
        !$OMP END PARALLEL do

    else

        !$OMP PARALLEL DO PRIVATE(i,j,k,ang,cai,cak,r) REDUCTION(+:ys) SCHEDULE(DYNAMIC)
        do ia1 = 1, nias1
            do ia2 = 1, nias2
                if (.not. ((distance_matrix(ias1(ia1),ias2(ia2)) > eps) .and. &
                         & (distance_matrix(ias1(ia1),ias2(ia2)) <= rcut))) cycle
                do ia3 = 1, nias3
                    if (distance_matrix(ias1(ia1),ias3(ia3)) > rcut) cycle
                    if (.not. ((distance_matrix(ias2(ia2),ias3(ia3)) > eps) .and. &
                             & (distance_matrix(ias2(ia2),ias3(ia3)) <= rcut))) cycle

                        i = ias1(ia1)
                        j = ias2(ia2)
                        k = ias3(ia3)

                        ang = calc_angle(coordinates(i, :), coordinates(j, :), coordinates(k, :))
                        cak = calc_cos_angle(coordinates(i, :), coordinates(k, :), coordinates(j, :))
                        cai = calc_cos_angle(coordinates(k, :), coordinates(i, :), coordinates(j, :))

                        r = distance_matrix(i,j) * distance_matrix(i,k) * distance_matrix(k,j)
                        ys = ys + (c0 + cos_xs*cak*cai)/(r**3 ) * ( exp((xs-ang)**2 * inv_sigma) )

                enddo
            enddo
        enddo
        !$OMP END PARALLEL do

    endif

    ! !$OMP PARALLEL DO PRIVATE(i,j,k,ang,cai,cak,r) REDUCTION(+:ys) SCHEDULE(DYNAMIC)
    ! do ia1 = 1, nias1
    !     do ia2 = 1, nias2
    !         if (.not. ((distance_matrix(ias1(ia1),ias2(ia2)) > eps) .and. &
    !                  & (distance_matrix(ias1(ia1),ias2(ia2)) <= rcut))) cycle
    !         do ia3 = 1, nias3
    !             if ((z1 == z3) .and. (ias1(ia1) < ias3(ia3))) cycle
    !             if (.not. ((distance_matrix(ias1(ia1),ias3(ia3)) > eps) .and. &
    !                      & (distance_matrix(ias1(ia1),ias3(ia3)) <= rcut))) cycle
    !             if (.not. ((distance_matrix(ias2(ia2),ias3(ia3)) > eps) .and. &
    !                      & (distance_matrix(ias2(ia2),ias3(ia3)) <= rcut))) cycle

    !                 i = ias1(ia1)
    !                 j = ias2(ia2)
    !                 k = ias3(ia3)

    !                 ang = calc_angle(coordinates(i, :), coordinates(j, :), coordinates(k, :))
    !                 cak = calc_cos_angle(coordinates(i, :), coordinates(k, :), coordinates(j, :))
    !                 cai = calc_cos_angle(coordinates(k, :), coordinates(i, :), coordinates(j, :))

    !                 r = distance_matrix(i,j) * distance_matrix(i,k) * distance_matrix(k,j)

    !                 ! ys = ys + c0 *( (1.0d0 + cos_xs*cak*cai)/(r**3 ) ) * ( exp((xs-ang)**2 * inv_sigma) )
    !                 ys = ys + (c0 + cos_xs*cak*cai)/(r**3 ) * ( exp((xs-ang)**2 * inv_sigma) )

    !         enddo
    !     enddo
    ! enddo
    ! !$OMP END PARALLEL do

    deallocate(ias1)
    deallocate(ias2)
    deallocate(ias3)
    deallocate(distance_matrix)

end subroutine fget_sbot

subroutine fget_sbot_local(coordinates, nuclear_charges, ia_python, z1, z2, z3, rcut, nx, dgrid, sigma, coeff, ys)

    use slatm_utils, only: linspace, calc_angle, calc_cos_angle

    implicit none

    double precision, dimension(:,:), intent(in) :: coordinates
    double precision, dimension(:), intent(in) :: nuclear_charges
    double precision, intent(in) :: rcut
    integer, intent(in) :: nx
    integer, intent(in) :: ia_python
    double precision, intent(in) :: dgrid
    double precision, intent(in) :: sigma
    double precision, intent(in) :: coeff
    double precision, dimension(nx), intent(out) :: ys

    ! MBtype
    integer, intent(in) :: z1, z2, z3

    integer, dimension(:), allocatable :: ias1, ias2, ias3
    integer :: nias1, nias2, nias3

    integer :: ia1, ia2, ia3

    double precision, allocatable, dimension(:, :) :: distance_matrix

    double precision :: norm

    integer :: i, j, k
    integer :: natoms

    double precision, parameter :: eps = epsilon(0.0d0)
    double precision, parameter :: pi = 4.0d0 * atan(1.0d0)
    double precision :: d2r
    double precision :: c0
    double precision :: ang
    double precision :: cak
    double precision :: cai
    double precision :: prefactor
    double precision :: r
    double precision :: a0, a1
    double precision, dimension(nx) :: xs
    double precision, dimension(nx) :: cos_xs
    double precision :: inv_sigma

    logical :: stop_flag

    integer :: ia
    ia = ia_python + 1

    natoms = size(coordinates, dim=1)
    if (size(coordinates, dim=1) /= size(nuclear_charges, dim=1)) then
        write(*,*) "ERROR: Coulomb matrix generation"
        write(*,*) size(coordinates, dim=1), "coordinates, but", &
            & size(nuclear_charges, dim=1), "atom_types!"
        stop
    endif

    ! Allocate temporary
    allocate(distance_matrix(natoms, natoms))
    distance_matrix = 0.0d0

    !$OMP PARALLEL DO PRIVATE(norm)
    do i = 1, natoms
        do j = i+1, natoms
            norm = sqrt(sum((coordinates(j,:) - coordinates(i,:))**2))
            distance_matrix(i, j) = norm
            distance_matrix(j, i) = norm
        enddo
    enddo
    !$OMP END PARALLEL DO

    allocate(ias1(natoms))
    allocate(ias2(natoms))
    allocate(ias3(natoms))

    ias1 = 0
    ias2 = 0
    ias3 = 0

    nias1 = 0
    do i = 1, natoms
        if (int(nuclear_charges(i)).eq.z1) then
            nias1 = nias1 + 1
            ias1(nias1) = i
        endif
    enddo

    nias2 = 0
    do i = 1, natoms
        if (int(nuclear_charges(i)).eq.z2) then
            nias2 = nias2 + 1
            ias2(nias2) = i
        endif
    enddo

    nias3 = 0
    do i = 1, natoms
        if (int(nuclear_charges(i)).eq.z3) then
            nias3 = nias3 + 1
            ias3(nias3) = i
        endif
    enddo

    stop_flag = .true.
    do ia2 = 1, nias2
        if (ias2(ia2) == ia) stop_flag = .false.
    enddo
    if (stop_flag) return

    d2r = pi/180.0d0
    a0 = -20.0d0 * d2r
    a1 = pi + 20.0d0 * d2r

    xs = linspace(a0, a1, nx)

    prefactor = 1.0d0 / 3.0d0

    c0 = prefactor * (mod(z1,1000)*mod(z2,1000)*mod(z3,1000)) * coeff * dgrid

    ys = 0.0d0
    inv_sigma = -1.0d0 / (2*sigma**2)

    !$OMP PARALLEL DO
    do i = 1, nx
        cos_xs(i) = cos(xs(i)) * c0
    enddo
    !$OMP END PARALLEL do

    if (z1 == z3) then

        !$OMP PARALLEL DO PRIVATE(i,j,k,ang,cai,cak,r) REDUCTION(+:ys) SCHEDULE(DYNAMIC)
        do ia1 = 1, nias1
            if (.not. ((distance_matrix(ias1(ia1),ia) > eps) .and. &
                     & (distance_matrix(ias1(ia1),ia) <= rcut))) cycle
            do ia3 = ia1 + 1, nias3
                if (distance_matrix(ias1(ia1),ias3(ia3)) > rcut) cycle
                if (.not. ((distance_matrix(ia,ias3(ia3)) > eps) .and. &
                         & (distance_matrix(ia,ias3(ia3)) <= rcut))) cycle

                    i = ias1(ia1)
                    j = ia
                    k = ias3(ia3)

                    ang = calc_angle(coordinates(i, :), coordinates(j, :), coordinates(k, :))
                    cak = calc_cos_angle(coordinates(i, :), coordinates(k, :), coordinates(j, :))
                    cai = calc_cos_angle(coordinates(k, :), coordinates(i, :), coordinates(j, :))

                    r = distance_matrix(i,j) * distance_matrix(i,k) * distance_matrix(k,j)

                    ys = ys + (c0 + cos_xs*cak*cai)/(r**3) * ( exp((xs-ang)**2 * inv_sigma) )

            enddo
        enddo
        !$OMP END PARALLEL do

    else

        !$OMP PARALLEL DO PRIVATE(i,j,k,ang,cai,cak,r) REDUCTION(+:ys) SCHEDULE(DYNAMIC)
        do ia1 = 1, nias1
            if (.not. ((distance_matrix(ias1(ia1),ia) > eps) .and. &
                     & (distance_matrix(ias1(ia1),ia) <= rcut))) cycle
            do ia3 = 1, nias3
                if (distance_matrix(ias1(ia1),ias3(ia3)) > rcut) cycle
                if (.not. ((distance_matrix(ia,ias3(ia3)) > eps) .and. &
                         & (distance_matrix(ia,ias3(ia3)) <= rcut))) cycle

                    i = ias1(ia1)
                    j = ia
                    k = ias3(ia3)

                    ang = calc_angle(coordinates(i, :), coordinates(j, :), coordinates(k, :))
                    cak = calc_cos_angle(coordinates(i, :), coordinates(k, :), coordinates(j, :))
                    cai = calc_cos_angle(coordinates(k, :), coordinates(i, :), coordinates(j, :))

                    r = distance_matrix(i,j) * distance_matrix(i,k) * distance_matrix(k,j)
                    ys = ys + (c0 + cos_xs*cak*cai)/(r**3 ) * ( exp((xs-ang)**2 * inv_sigma) )

            enddo
        enddo
        !$OMP END PARALLEL do

    endif

    deallocate(ias1)
    deallocate(ias2)
    deallocate(ias3)
    deallocate(distance_matrix)

end subroutine fget_sbot_local

subroutine fget_sbop(coordinates, nuclear_charges, z1, z2, rcut, nx, dgrid, sigma, coeff, rpower, ys)

    use slatm_utils, only: linspace

    implicit none

    double precision, dimension(:,:), intent(in) :: coordinates
    double precision, dimension(:), intent(in) :: nuclear_charges
    double precision, intent(in) :: rcut
    integer, intent(in) :: nx
    double precision, intent(in) :: dgrid
    double precision, intent(in) :: sigma
    double precision, intent(in) :: rpower
    double precision, intent(in) :: coeff
    double precision, dimension(nx), intent(out) :: ys

    integer, intent(in) :: z1, z2

    double precision :: r0
    double precision :: r
    double precision :: rcut2
    integer :: i
    integer :: natoms

    integer, dimension(:), allocatable :: ias1, ias2
    integer :: nias1, nias2

    integer :: ia1, ia2
    double precision, parameter :: eps = epsilon(0.0d0)
    double precision, dimension(nx) :: xs
    double precision, parameter :: pi = 4.0d0 * atan(1.0d0)
    double precision :: c0
    double precision :: inv_sigma

    double precision, dimension(nx) :: xs0

    natoms = size(coordinates, dim=1)
    if (size(coordinates, dim=1) /= size(nuclear_charges, dim=1)) then
        write(*,*) "ERROR: Coulomb matrix generation"
        write(*,*) size(coordinates, dim=1), "coordinates, but", &
            & size(nuclear_charges, dim=1), "atom_types!"
        stop
    endif

    allocate(ias1(natoms))
    allocate(ias2(natoms))

    ias1 = 0
    ias2 = 0

    nias1 = 0
    do i = 1, natoms
        if (int(nuclear_charges(i)).eq.z1) then
            nias1 = nias1 + 1
            ias1(nias1) = i
        endif
    enddo

    nias2 = 0
    do i = 1, natoms
        if (int(nuclear_charges(i)).eq.z2) then
            nias2 = nias2 + 1
            ias2(nias2) = i
        endif
    enddo

    r0 = 0.1d0
    xs = linspace(r0, rcut, nx)
    ys = 0.0d0

    c0 = (mod(z1,1000)*mod(z2,1000)) * coeff
    inv_sigma = -0.5d0 / sigma**2
    xs0 = c0/(xs**rpower) * dgrid

    rcut2 = rcut**2

    if (z1.eq.z2) then

        !$OMP PARALLEL DO REDUCTION(+:ys)
        do ia1 = 1, nias1
            do ia2 = ia1 + 1, nias2
                r = sum((coordinates(ias1(ia1),:) - coordinates(ias2(ia2),:))**2)

                if (r < rcut2) ys = ys + xs0 * exp( inv_sigma * (xs - sqrt(r))**2 )

            enddo
        enddo
        !$OMP END PARALLEL DO

    else

        !$OMP PARALLEL DO REDUCTION(+:ys)
        do ia1 = 1, nias1
            do ia2 = 1, nias2
                r = sum((coordinates(ias1(ia1),:) - coordinates(ias2(ia2),:))**2)

                if (r < rcut2) ys = ys + xs0 * exp( inv_sigma * (xs - sqrt(r))**2 )
            enddo
        enddo
        !$OMP END PARALLEL DO

    endif

    deallocate(ias1)
    deallocate(ias2)

end subroutine fget_sbop

subroutine fget_sbop_local(coordinates, nuclear_charges, ia_python, z1, z2, rcut, nx, dgrid, sigma, coeff, rpower, ys)

    use slatm_utils, only: linspace

    implicit none

    double precision, dimension(:,:), intent(in) :: coordinates
    double precision, dimension(:), intent(in) :: nuclear_charges
    double precision, intent(in) :: rcut
    integer, intent(in) :: nx
    integer, intent(in) :: ia_python
    double precision, intent(in) :: dgrid
    double precision, intent(in) :: sigma
    double precision, intent(in) :: rpower
    double precision, intent(in) :: coeff
    double precision, dimension(nx), intent(out) :: ys

    integer, intent(in) :: z1, z2

    double precision :: r0
    double precision :: r
    double precision :: rcut2
    integer :: i
    integer :: natoms

    integer, dimension(:), allocatable :: ias1, ias2
    integer :: nias1, nias2

    integer :: ia1, ia2
    double precision, parameter :: eps = epsilon(0.0d0)
    double precision, dimension(nx) :: xs
    double precision, parameter :: pi = 4.0d0 * atan(1.0d0)
    double precision :: c0
    double precision :: inv_sigma

    double precision, dimension(nx) :: xs0
    integer :: ia

    ia = ia_python + 1

    natoms = size(coordinates, dim=1)
    if (size(coordinates, dim=1) /= size(nuclear_charges, dim=1)) then
        write(*,*) "ERROR: Coulomb matrix generation"
        write(*,*) size(coordinates, dim=1), "coordinates, but", &
            & size(nuclear_charges, dim=1), "atom_types!"
        stop
    endif

    allocate(ias1(natoms))
    allocate(ias2(natoms))

    ias1 = 0
    ias2 = 0

    nias1 = 0
    do i = 1, natoms
        if (int(nuclear_charges(i)).eq.z1) then
            nias1 = nias1 + 1
            ias1(nias1) = i
        endif
    enddo

    nias2 = 0
    do i = 1, natoms
        if (int(nuclear_charges(i)).eq.z2) then
            nias2 = nias2 + 1
            ias2(nias2) = i
        endif
    enddo

    r0 = 0.1d0
    xs = linspace(r0, rcut, nx)
    ys = 0.0d0

    c0 = (mod(z1,1000)*mod(z2,1000)) * coeff
    inv_sigma = -0.5d0 / sigma**2
    xs0 = c0/(xs**rpower) * dgrid

    rcut2 = rcut**2

    if (z1.eq.z2) then

        !$OMP PARALLEL DO REDUCTION(+:ys)
        do ia1 = 1, nias1
            do ia2 = ia1 + 1, nias2
                if ((ias1(ia1) /= ia).and.(ias2(ia2)/= ia)) cycle
                r = sum((coordinates(ias1(ia1),:) - coordinates(ias2(ia2),:))**2)

                if (r < rcut2) ys = ys + xs0 * exp( inv_sigma * (xs - sqrt(r))**2 )

            enddo
        enddo
        !$OMP END PARALLEL DO

    else

        !$OMP PARALLEL DO REDUCTION(+:ys)
        do ia1 = 1, nias1
            do ia2 = 1, nias2
                if ((ias1(ia1) /= ia).and.(ias2(ia2)/= ia)) cycle
                r = sum((coordinates(ias1(ia1),:) - coordinates(ias2(ia2),:))**2)

                if (r < rcut2) ys = ys + xs0 * exp( inv_sigma * (xs - sqrt(r))**2 )
            enddo
        enddo
        !$OMP END PARALLEL DO

    endif

    deallocate(ias1)
    deallocate(ias2)

end subroutine fget_sbop_local


program main
    use plantFEM
    implicit none

    type(FEMDomain_) :: dam
    real(real64) :: x(6),altitude(6),top
    integer(int32) :: i

    ! plantFEM用メッシュ生成スクリプト
    ! https://github.com/kazulagi/plantFEM

    ! メッシュの元となったデータ：
    ! 牧　隆泰, 1958, 日本水利施設進展の研究, 土木雑誌社
    ! p. 209 入鹿池（愛知県犬山市)

    ! 以下、メッシュ分割プログラム
    ! 要素分割数
    call dam%create(meshtype="Cube",x_num=30,y_num=30,z_num=12)
    ! 堤体寸法(上下流方向長185m,堤長95間, 堤高29m)
    call dam%resize(x=200.00d0,y=95.0d0*1.80d0,z=3.0d0)
    call dam%move(x=-5.0d0,z=-2.0d0)
    ! 上流からx(n) m 進んだ地点の高さがaltitude(n) m
    x(1) = 0.00d0; altitude(1) = 1.00d0;
    x(2) = 73.5d0; altitude(2) = 29.4d0+1.0d0;
    x(3) = 81.3d0; altitude(3) = 29.4d0+1.0d0;
    x(4) =120.3d0; altitude(4) = 16.4d0+1.0d0;
    x(5) =127.8d0; altitude(5) = 16.4d0+1.0d0;
    x(6) =185.2d0; altitude(6) = 1.00d0;

    call dam%edit(x=x, altitude=altitude)

    ! 保存
    call dam%msh("入鹿池")
    call dam%stl("入鹿池")

end program main


MODULE m_dostetra

   USE m_types
   USE m_tetrahedronInit

   IMPLICIT NONE

   CONTAINS

   SUBROUTINE dostetra(kpts,input,ndos,ne,eMesh,neig,eig,qal,g)

      TYPE(t_kpts),        INTENT(IN)     :: kpts
      TYPE(t_input),       INTENT(IN)     :: input
      INTEGER,             INTENT(IN)     :: ndos
      INTEGER,             INTENT(IN)     :: ne
      REAL,                INTENT(IN)     :: eMesh(:)
      INTEGER,             INTENT(IN)     :: neig(:)
      REAL,                INTENT(IN)     :: eig(:,:)
      REAL,                INTENT(IN)     :: qal(:,:,:)
      REAL,                INTENT(INOUT)  :: g(:,:)

      INTEGER :: ikpt,iBand,idos,ie
      REAL    :: w(ne,MAXVAL(neig))

      g = 0.0
      DO ikpt = 1, kpts%nkpt
         !------------------------------------------------------
         ! Calculate the weights for the DOS on the energy Grid
         !------------------------------------------------------
         CALL tetrahedronInit(kpts,ikpt,eig,MINVAL(neig),eMesh,ne,&
                              input%film,w,dos=.TRUE.)
         DO iBand = 1, neig(ikpt)
            DO idos = 1, ndos
               DO ie = 1, ne
                  g(ie,idos) = g(ie,idos) + w(ie,iBand) * 2.0/input%jspins * qal(idos,iBand,ikpt)
               ENDDO
            ENDDO
         ENDDO
      ENDDO

   END SUBROUTINE dostetra
END MODULE m_dostetra


      SUBROUTINE ETP3 (XI,YI,ZI, XFRMT, XO,YO,ZO)

      REAL XFRMT (4,4), PTI(4,1), PTO(4,1)
      REAL XI,YI,ZI, XO,YO,ZO, W

      PTI(1,1) = XI
      PTI(2,1) = YI
      PTI(3,1) = ZI
      PTI(4,1) = 1.0

      CALL MATMUL (4,4,1, XFRMT, PTI, PTO)
      W  = PTO(4,1)
      XO = PTO(1,1) / W
      YO = PTO(2,1) / W
      ZO = PTO(3,1) / W

      END


! @@name:	SIMD.5f
! @@type:	F-free
! @@compilable:	yes
! @@linkable:	no
! @@expect:	success
subroutine work( a, b, c,  n )
   implicit none
   integer :: i,j,n
   double precision :: a(n,n), b(n,n), c(n,n), tmp

   !$omp do simd collapse(2) private(tmp)
   do j = 1,n
      do i = 1,n
         tmp = a(i,j) + b(i,j)
         c(i,j) = tmp
      end do
   end do

end subroutine work


! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     https://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

module helpers

  use, intrinsic :: iso_c_binding, only: c_double, c_int, c_bool
  use types, only: dp
  implicit none
  private min_index, sort_in_place, is_separating
  public &
       WIGGLE, VECTOR_CLOSE_EPS, cross_product, bbox, wiggle_interval, &
       contains_nd, vector_close, in_interval, in_sorted, convex_hull, &
       polygon_collide, solve2x2

  real(c_double), parameter :: WIGGLE = 0.5_dp**44
  ! NOTE: This is intended to be used as the default value for ``eps``
  !       in ``vector_close``.
  real(c_double), parameter :: VECTOR_CLOSE_EPS = 0.5_dp**40

contains

  pure subroutine cross_product( &
       vec0, vec1, result_) &
       bind(c, name='BEZ_cross_product')

    real(c_double), intent(in) :: vec0(2)
    real(c_double), intent(in) :: vec1(2)
    real(c_double), intent(out) :: result_

    result_ = vec0(1) * vec1(2) - vec0(2) * vec1(1)

  end subroutine cross_product

  subroutine bbox( &
       num_nodes, nodes, left, right, bottom, top) &
       bind(c, name='BEZ_bbox')

    integer(c_int), intent(in) :: num_nodes
    real(c_double), intent(in) :: nodes(2, num_nodes)
    real(c_double), intent(out) :: left, right, bottom, top
    ! Variables outside of signature.
    real(c_double) :: workspace(2)

    workspace = minval(nodes, 2)
    left = workspace(1)
    bottom = workspace(2)
    workspace = maxval(nodes, 2)
    right = workspace(1)
    top = workspace(2)

  end subroutine bbox

  subroutine wiggle_interval( &
       value_, result_, success) &
       bind(c, name='BEZ_wiggle_interval')

    real(c_double), intent(in) :: value_
    real(c_double), intent(out) :: result_
    logical(c_bool), intent(out) :: success

    success = .TRUE.
    if (-WIGGLE < value_ .AND. value_ < WIGGLE) then
       result_ = 0.0_dp
    else if (WIGGLE <= value_ .AND. value_ <= 1.0_dp - WIGGLE) then
       result_ = value_
    else if ( &
         1.0_dp - WIGGLE < value_ .AND. value_ < 1.0_dp + WIGGLE) then
       result_ = 1.0_dp
    else
       success = .FALSE.
    end if

  end subroutine wiggle_interval

  pure subroutine contains_nd( &
       num_nodes, dimension_, nodes, point, predicate) &
       bind(c, name='BEZ_contains_nd')

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    real(c_double), intent(in) :: point(dimension_)
    logical(c_bool), intent(out) :: predicate

    if (any(point < minval(nodes, 2))) then
       predicate = .FALSE.
    else if (any(maxval(nodes, 2) < point)) then
       predicate = .FALSE.
    else
       predicate = .TRUE.
    end if

  end subroutine contains_nd

  logical(c_bool) pure function vector_close( &
       num_values, vec1, vec2, eps) result(is_close) &
       bind(c, name='BEZ_vector_close')

    integer(c_int), intent(in) :: num_values
    real(c_double), intent(in) :: vec1(num_values)
    real(c_double), intent(in) :: vec2(num_values)
    real(c_double), intent(in) :: eps
    ! Variables outside of signature.
    real(c_double) :: size1, size2

    size1 = norm2(vec1)
    size2 = norm2(vec2)
    if (size1 == 0.0_dp) then
       is_close = size2 <= eps
    else if (size2 == 0.0_dp) then
       is_close = size1 <= eps
    else
       ! This is the most common path.
       is_close = norm2(vec1 - vec2) <= eps * min(size1, size2)
    end if

  end function vector_close

  pure function in_interval( &
       value_, start, end) result(predicate) &
       bind(c, name='BEZ_in_interval')

    real(c_double), intent(in) :: value_, start, end
    logical(c_bool) :: predicate

    predicate = (start <= value_) .AND. (value_ <= end)

  end function in_interval

  subroutine min_index(num_points, points, match)

    ! Finds the minimum point when sorting first by ``x`` then by
    ! ``y`` coordinate (in the case of a tie in ``x``).

    ! NOTE: This is a helper for ``sort_in_place``.
    ! NOTE: This assumes, but does not check, that ``num_points > 0``.

    integer(c_int), intent(in) :: num_points
    real(c_double), intent(inout) :: points(2, num_points)
    integer(c_int), intent(out) :: match
    ! Variables outside of signature.
    integer(c_int) :: i

    match = 1
    do i = 2, num_points
       if (points(1, i) < points(1, match)) then
          match = i
       else if (points(1, i) == points(1, match)) then
          if (points(2, i) < points(2, match)) then
             match = i
          end if
       end if
    end do

  end subroutine min_index

  subroutine sort_in_place(num_points, points, num_uniques)

    ! NOTE: This is a helper for ``convex_hull``. This does a simple quadratic
    !       sort (i.e. it is suboptimal) because it expects the number of
    !       points to be small. It **also** makes sure the values are unique
    !       to exact precision.

    integer(c_int), intent(in) :: num_points
    real(c_double), intent(inout) :: points(2, num_points)
    integer(c_int), intent(out) :: num_uniques
    ! Variables outside of signature.
    integer(c_int) :: i, match
    real(c_double) :: swap(2)

    num_uniques = num_points
    ! Place the "smallest" point first (since it can't be a duplicate).
    call min_index(num_points, points, match)
    if (match /= 1) then
       swap = points(:, match)
       points(:, match) = points(:, 1)
       points(:, 1) = swap
    end if

    i = 2
    do while (i <= num_uniques)
       call min_index(num_uniques + 1 - i, points(:, i:num_uniques), match)
       ! Shift ``match`` based on the slice ``points(:, i:...)``.
       match = match + i - 1
       if (match /= i) then
          swap = points(:, match)
          if (all(swap == points(:, i - 1))) then
             ! This means ``match`` is a duplicate.
             points(:, match) = points(:, num_uniques)
             points(:, num_uniques) = swap
             num_uniques = num_uniques - 1
          else
             points(:, match) = points(:, i)
             points(:, i) = swap
          end if
       end if
       ! Increment for next iteration.
       i = i + 1
    end do

  end subroutine sort_in_place

  logical(c_bool) pure function in_sorted( &
       num_values, values, value_) result(contained)

    ! NOTE: This assumes ``num_values >= 1``.
    ! NOTE: This subroutine is not part of the C ABI for this module,
    !       but it is (for now) public, so that it can be tested.

    integer(c_int), intent(in) :: num_values
    integer(c_int), intent(in) :: values(num_values)
    integer(c_int), intent(in) :: value_
    ! Variables outside of signature.
    integer(c_int) :: left, right, midpoint

    left = 1
    right = num_values

    do while (left < right)
       midpoint = (left + right) / 2
       if (value_ == values(midpoint)) then
          contained = .TRUE.
          return
       else if (value_ < values(midpoint)) then
          right = midpoint - 1
       else
          left = midpoint + 1
       end if
    end do

    contained = values(left) == value_

  end function in_sorted

  subroutine convex_hull( &
       num_points, points, polygon_size, polygon) &
       bind(c, name='BEZ_simple_convex_hull')

    ! NOTE: This uses Andrew's monotone chain convex hull algorithm and used
    !       (https://en.wikibooks.org/wiki/Algorithm_Implementation/
    !        Geometry/Convex_hull/Monotone_chain)
    !       as motivation. The code there is licensed CC BY-SA 3.0.

    ! NOTE: The "standard" implementation for this is in Qhull, but for now
    !       that is avoided as an extra dependency.

    integer(c_int), intent(in) :: num_points
    real(c_double), intent(in) :: points(2, num_points)
    integer(c_int), intent(out) :: polygon_size
    real(c_double), intent(out) :: polygon(2, num_points)
    ! Variables outside of signature.
    real(c_double) :: point1(2), point2(2), point3(2)
    integer(c_int) :: num_uniques
    real(c_double) :: uniques(2, num_points)
    integer(c_int) :: num_lower, num_upper
    integer(c_int) :: lower(num_points), upper(num_points)
    integer(c_int) :: i
    real(c_double) :: result_

    uniques = points
    call sort_in_place(num_points, uniques, num_uniques)

    ! In the "boring" case that we have fewer than 2 points, return.
    if (num_uniques == 0) then
       polygon_size = 0
       return
    else if (num_uniques < 3) then
       polygon_size = num_uniques
       polygon(:, :num_uniques) = uniques(:, :num_uniques)
       return
    end if

    ! First create a "lower" convex hull
    num_lower = 2  ! We know ``num_uniques >= 3``.
    lower(:2) = [1, 2]
    do i = 3, num_uniques
       point3 = uniques(:, i)
       result_ = -1.0_dp  ! Dummy value that is ``<= 0.0``.
       do while (num_lower > 1 .AND. result_ <= 0.0_dp)
          point1 = uniques(:, lower(num_lower - 1))
          point2 = uniques(:, lower(num_lower))
          ! If ``point3`` (the one we are considering) is more "inside"
          ! of ``point1`` than ``point2`` is, then we drop ``point2``.
          call cross_product(point2 - point1, point3 - point1, result_)
          if (result_ <= 0.0_dp) then
             num_lower = num_lower - 1
          end if
       end do
       num_lower = num_lower + 1
       lower(num_lower) = i
    end do

    ! Then create an "upper" convex hull
    num_upper = 1
    upper(1) = num_uniques
    upper_loop: do i = num_uniques - 1, 1, -1
       ! Don't consider indices from the lower hull (other than the ends).
       if (i > 1 .AND. in_sorted(num_lower, lower(:num_lower), i)) then
          cycle upper_loop
       end if
       point3 = uniques(:, i)
       result_ = -1.0_dp  ! Dummy value that is ``<= 0.0``.
       do while (num_upper > 1 .AND. result_ <= 0.0_dp)
          point1 = uniques(:, upper(num_upper - 1))
          point2 = uniques(:, upper(num_upper))
          ! If ``point3`` (the one we are considering) is more "inside"
          ! of ``point1`` than ``point2`` is, then we drop ``point2``.
          call cross_product(point2 - point1, point3 - point1, result_)
          if (result_ <= 0.0_dp) then
             num_upper = num_upper - 1
          end if
       end do
       num_upper = num_upper + 1
       upper(num_upper) = i
    end do upper_loop

    ! The endpoints are **both** double counted, so we skip the "end"
    ! of each hull (lower and upper).
    polygon_size = 0
    do i = 1, num_lower - 1
       polygon_size = polygon_size + 1
       polygon(:, polygon_size) = uniques(:, lower(i))
    end do
    do i = 1, num_upper - 1
       polygon_size = polygon_size + 1
       polygon(:, polygon_size) = uniques(:, upper(i))
    end do

  end subroutine convex_hull

  logical(c_bool) pure function is_separating( &
       edge_direction, polygon_size1, polygon1, polygon_size2, polygon2) &
       result(predicate)

    ! NOTE: This assumes, but does not check, that ``polygon_sizeX`` is
    !       at least two.
    real(c_double), intent(in) :: edge_direction(2)
    integer(c_int), intent(in) :: polygon_size1
    real(c_double), intent(in) :: polygon1(2, polygon_size1)
    integer(c_int), intent(in) :: polygon_size2
    real(c_double), intent(in) :: polygon2(2, polygon_size2)
    ! Variables outside of signature.
    real(c_double) :: vertex(2), norm_squared, cp_result, param
    real(c_double) :: min_param1, max_param1
    real(c_double) :: min_param2, max_param2
    integer(c_int) :: i

    ! NOTE: We assume throughout that ``norm_squared != 0``. If it **were**
    !       zero that would mean the ``edge_direction`` corresponds to an
    !       invalid edge.
    norm_squared = dot_product(edge_direction, edge_direction)

    ! Compute the parameters along the "separating axis" for the vertices
    ! of the first polygon.
    vertex = polygon1(:, 1)
    call cross_product(edge_direction, vertex, cp_result)
    param = cp_result / norm_squared
    min_param1 = param
    max_param1 = param
    do i = 2, polygon_size1
       vertex = polygon1(:, i)
       call cross_product(edge_direction, vertex, cp_result)
       param = cp_result / norm_squared
       min_param1 = min(min_param1, param)
       max_param1 = max(max_param1, param)
    end do

    ! Compute the parameters along the "separating axis" for the vertices
    ! of the first polygon.
    vertex = polygon2(:, 1)
    call cross_product(edge_direction, vertex, cp_result)
    param = cp_result / norm_squared
    min_param2 = param
    max_param2 = param
    do i = 2, polygon_size2
       vertex = polygon2(:, i)
       call cross_product(edge_direction, vertex, cp_result)
       param = cp_result / norm_squared
       min_param2 = min(min_param2, param)
       max_param2 = max(max_param2, param)
    end do

    ! Determine if [min_param1, max_param1] and [min_param2, max_param2]
    ! are disjoint intervals.
    predicate = (min_param1 > max_param2 .OR. max_param1 < min_param2)

  end function is_separating

  subroutine polygon_collide( &
       polygon_size1, polygon1, polygon_size2, polygon2, collision) &
       bind(c, name='BEZ_polygon_collide')

    ! This determines if two **convex** polygons collide. The polygons
    ! are given as ``2 x N`` arrays of ``x-y`` points (one per column)
    ! in order they appear (the first and last node are **not** the same
    ! as is sometimes expected for closed polygons).

    ! This code uses the Separating axis theorem (SAT) [1] [2] to quickly
    ! determine if the polygons intersect.
    ! [1]: https://en.wikipedia.org/wiki/Hyperplane_separation_theorem
    ! [2]: https://hackmd.io/s/ryFmIZrsl

    ! A "standard" implementation for this is in GEOS [3], but for now
    ! that is avoided as an extra dependency.
    ! [3]: https://trac.osgeo.org/geos

    integer(c_int), intent(in) :: polygon_size1
    real(c_double), intent(in) :: polygon1(2, polygon_size1)
    integer(c_int), intent(in) :: polygon_size2
    real(c_double), intent(in) :: polygon2(2, polygon_size2)
    logical(c_bool), intent(out) :: collision
    ! Variables outside of signature.
    real(c_double) :: edge_direction(2)
    integer(c_int) :: i

    collision = .TRUE.

    ! First handle the "wrap-around" edge from polygon1.
    edge_direction = polygon1(:, 1) - polygon1(:, polygon_size1)
    if (is_separating( &
         edge_direction, polygon_size1, polygon1, &
         polygon_size2, polygon2)) then
       collision = .FALSE.
       return
    end if

    ! Then, check all other edges from polygon1.
    do i = 2, polygon_size1
       edge_direction = polygon1(:, i) - polygon1(:, i - 1)
       if (is_separating( &
            edge_direction, polygon_size1, polygon1, &
            polygon_size2, polygon2)) then
          collision = .FALSE.
          return
       end if
    end do

    ! Then, handle the "wrap-around" edge from polygon2.
    edge_direction = polygon2(:, 1) - polygon2(:, polygon_size2)
    if (is_separating( &
         edge_direction, polygon_size1, polygon1, &
         polygon_size2, polygon2)) then
       collision = .FALSE.
       return
    end if

    ! Then, check all other edges from polygon1.
    do i = 2, polygon_size2
       edge_direction = polygon2(:, i) - polygon2(:, i - 1)
       if (is_separating( &
            edge_direction, polygon_size1, polygon1, &
            polygon_size2, polygon2)) then
          collision = .FALSE.
          return
       end if
    end do

  end subroutine polygon_collide

  subroutine solve2x2(lhs, rhs, singular, x_val, y_val)

    real(c_double), intent(in) :: lhs(2, 2)
    real(c_double), intent(in) :: rhs(2)
    logical(c_bool), intent(out) :: singular
    real(c_double), intent(out) :: x_val
    real(c_double), intent(out) :: y_val
    ! Variables outside of signature.
    real(c_double) :: ratio, denominator

    ! A <--> lhs(1, 1)
    ! B <--> lhs(1, 2)
    ! C <--> lhs(2, 1)
    ! D <--> lhs(2, 2)
    ! E <--> rhs(1)
    ! F <--> rhs(2)
    if (abs(lhs(2, 1)) > abs(lhs(1, 1))) then
       ! NOTE: We know there is no division by zero here since ``C``
       !       is **strictly** bigger than **some** value (in magnitude).
       ! [A | B][x] = [E]
       ! [C | D][y]   [F]
       ratio = lhs(1, 1) / lhs(2, 1)
       ! r = A / C
       ! [A - rC | B - rD][x]   [E - rF]
       ! [C      | D     ][y] = [F     ]
       ! ==> 0x + (B - rD) y = E - rF
       denominator = lhs(1, 2) - ratio * lhs(2, 2)
       if (denominator == 0.0_dp) then
          singular = .TRUE.
          return
       end if

       y_val = (rhs(1) - ratio * rhs(2)) / denominator
       ! Cx + Dy = F ==> x = (F - Dy) / C
       x_val = (rhs(2) - lhs(2, 2) * y_val) / lhs(2, 1)
       singular = .FALSE.
    else
       if (lhs(1, 1) == 0.0_dp) then
          singular = .TRUE.
          return
       end if
       ! [A | B][x] = [E]
       ! [C | D][y]   [F]
       ratio = lhs(2, 1) / lhs(1, 1)
       ! r = C / A
       ! [A      | B     ][x] = [E     ]
       ! [C - rA | D - rB][y]   [F - rE]
       ! ==> 0x + (D - rB) y = F - rE
       denominator = lhs(2, 2) - ratio * lhs(1, 2)
       if (denominator == 0.0_dp) then
          singular = .TRUE.
          return
       end if

       y_val = (rhs(2) - ratio * rhs(1)) / denominator
       ! Ax + By = E ==> x = (E - B y) / A
       x_val = (rhs(1) - lhs(1, 2) * y_val) / lhs(1, 1)
       singular = .FALSE.
    end if

  end subroutine solve2x2

end module helpers


program problem_8

!! what value is in the accumulator?

use aoc_utilities
use iso_fortran_env

implicit none

integer :: iunit, istat, n_lines, i
character(len=:),allocatable :: line, tmp
logical :: status_ok
type(string),dimension(:),allocatable :: operation_argument

integer,parameter :: chunk_size = 256

type :: instruction
    character(len=:),allocatable :: operation
    integer :: argument = 0
    logical :: done = .false. !! if this one has already been done
end type instruction
type(instruction),dimension(:),allocatable :: instructions, instructions_copy

open(newunit=iunit, file='input.txt', iostat=istat)
if (istat /= 0) error stop ' error reading file'
n_lines = number_of_lines_in_file(iunit)
allocate(instructions(n_lines))

! read the instructions:
do i = 1, n_lines
    call read_line_from_file(iunit,chunk_size,line,status_ok)
    call split(line,' ',chunk_size,operation_argument)
    instructions(i)%operation = trim(adjustl(operation_argument(1)%str))
    tmp = trim(adjustl(operation_argument(2)%str))
    read(tmp, '(I10)') instructions(i)%argument   ! string to int
    instructions(i)%done = .false.
end do
write(*,*) 'number of instructions: ', n_lines

! do i = 1, n_lines
!     write(*,*) instructions(i)%operation, instructions(i)%argument
! end do
! write(*,*) ''

! default run:
write(*,*) ''
write(*,*) 'Part 1'
write(*,*) ''
istat = execute()

! part b
write(*,*) ''
write(*,*) 'Part 2'
write(*,*) ''
instructions_copy = instructions
do i = 1, n_lines
    instructions = instructions_copy
    select case(instructions(i)%operation)
    case('jmp')
        instructions(i)%operation = 'nop'
    case('nop')
        instructions(i)%operation = 'jmp'
    case default
        cycle
    end select
    istat = execute()
    if (istat==1) exit
end do

contains

    function execute() result(ires)
    implicit none
    integer :: ires

    integer :: i, accumulator
    ! now process each one:
    accumulator = 0
    instructions%done = .false.
    i = 1  ! start with first one
    ires = 0 ! ok
    do

        !write(*,*) i, instructions(i)%operation, instructions(i)%argument, instructions(i)%done, accumulator

        if (i == n_lines+1) then
            write(*,*) 'Success: end of program'
            ires = 1
            exit
        end if

        if (i > n_lines+1 .or. i < 1) then
            write(*,*) 'invalid instruction'
            ires = 2
            return
        end if

        if (instructions(i)%done) then
            write(*,*) 'infinite loop: instruction ', i, ' has already been done'
            ires = 3
            exit
        end if

        instructions(i)%done = .true.

        select case (instructions(i)%operation)
        case('acc')
            accumulator = accumulator + instructions(i)%argument
            i = i + 1
        case('jmp')
            i = i + instructions(i)%argument
        case('nop')
            i = i + 1
        case default
            error stop 'error: unknown operation: '//instructions(i)%operation
        end select

    end do
    write(*,*) 'accumulator = ', accumulator
    end function execute

end program problem_8


program quick_and_dirty
!! COMPLEX VALUES
use M_CLI,  only : commandline, check_commandline
implicit none
character(len=:),allocatable :: readme ! stores updated namelist
integer                      :: ios
character(len=256)           :: message
complex                      :: x, y, z; namelist /args/ x,y,z

   write(*,*)'the values are specified using NAMELIST input rules so'
   write(*,*)'demo4 -x 11.1,22.2 -y 333,444'
   write(*,*)"demo4 -x '(11.1,22.2)'"

   readme=commandline('-x (1,2) -y (10,20) -z (100,200)')
   read(readme,nml=args,iostat=ios,iomsg=message)
   call check_commandline(ios,message)
   write(*,*)x,y,z, x+y+z
end program quick_and_dirty


! Copyright 2012-2018, University of Strathclyde
! Authors: Lawrence T. Campbell
! License: BSD-3-Clause

MODULE particleFunctions

USE paratype
USE ParallelInfoType
USE error_fn
USE Functions
USE typesAndConstants
USE FileType
USE IO
use parallelsetup
use globals

IMPLICIT NONE

INTEGER(KIND=IP), PARAMETER :: iLinear_CG = 1_IP
INTEGER(KIND=IP), PARAMETER :: iGaussian_CG = 2_IP

INTEGER(KIND=IP), PARAMETER :: iTopHatDistribution_CG = 1_IP
INTEGER(KIND=IP), PARAMETER :: iGaussianDistribution_CG = 2_IP

INTEGER(KIND=IP), PARAMETER :: i_oldgenmacro=1_IP
INTEGER(KIND=IP), PARAMETER :: i_newgenmacro=2_IP

CONTAINS
!********************************************************
  SUBROUTINE PulseGrid(iGridType,iNumMP,sStart,&
       sEnd,sMean,sSigma,sGrid,qOK)

    IMPLICIT NONE
! Calculate the electron grid positions
!
! iGridType - INPUT  - If linear or gaussian grid
! iNumMP    - INPUT  - Number of macro electrons
! sStart    - INPUT  - Start position for gaussian
! sEnd      - INPUT  - End position for gaussian
! sMean     - INPUT  - Mean position for gaussian
!                      optional for linear grid only
! sSigma    - INPUT  - Sigma for gaussian optional
!                      for linear grid only
! sGrid(:)  - OUTPUT - Grid positions
! qOK       - OUTPUT - Error flag
!
    INTEGER(KIND=IP),INTENT(IN)	:: iGridType,iNumMP
    REAL(KIND=WP),INTENT(IN)    :: sStart,sEnd
    REAL(KIND=WP),INTENT(IN),OPTIONAL	:: sMean,sSigma
    REAL(KIND=WP),INTENT(OUT) :: sGrid(:)
    LOGICAL, INTENT(OUT) :: qOK
!--------------------------------------------------------
! BEGIN:-
! Set error flag to false
    qOK = .FALSE.

! Create grid
    SELECT CASE (iGridType)
    CASE(iLinear_CG)
       sGrid=linspace(sStart,sEnd,iNumMP+1)
    CASE(iGaussian_CG)
       IF (.NOT. PRESENT(sMean)) THEN
          CALL Error_log('Error creating gaussian grid no mean given.',tErrorLog_G)
          GOTO 1000
       END IF
       IF (.NOT. PRESENT(sSigma)) THEN
          CALL Error_log('Error creating gaussian grid no sigma given..',tErrorLog_G)
          GOTO 1000
       END IF
       CALL GaussianGrid(iNumMP,sMean,sSigma,sStart,sEnd,sGrid)
    END SELECT

!  Set error flag and exit
    qOK = .TRUE.
    GOTO 2000

! Error Handler
1000 CALL Error_log('Error in Chow:PulseGrid',tErrorLog_G)
    PRINT*,'Error in Chow:PulseGrid'
2000 CONTINUE

  END SUBROUTINE PulseGrid
!********************************************************
  SUBROUTINE EvalIntegral(s_gridPoints,s_mean,s_sigma,&
       s_integral)

    IMPLICIT NONE

    REAL(KIND=WP),INTENT(IN)  :: s_gridPoints(:)
    REAL(KIND=WP),INTENT(IN)  :: s_mean,s_sigma
    REAL(KIND=WP),INTENT(OUT) :: s_integral(:)
!
!LOCAL VARIABLES
    INTEGER(KIND=IP) :: i
    REAL(KIND=WP)    :: s_value1,s_value2

    DO i=1,(SIZE(s_gridPoints)-1)
       s_value2=(s_gridPoints(i+1)-s_mean)/&
            (s_sigma*SQRT(2.0_WP))
       s_value1=(s_gridPoints(i)-s_mean)/&
            (s_sigma*SQRT(2.0_WP))
       s_integral(i) = 0.5_WP *&
            (erf(s_value2)-erf(s_value1))
    END DO

  END SUBROUTINE EvalIntegral
!********************************************************
  SUBROUTINE DistributionIntegral(iDistributionType,&
       iNumMP,sGrid,sMean,sSigma,sIntegral,qOK)

    IMPLICIT NONE
!
! Calculate the integral of the chosen distribution for
! the electron pulse
!
! iDistributionType - INPUT  - If Top-hat or gaussian
!                              distribution
! iNumMP            - INPUT  - Number of macro electrons
! sGrid(:)          - INTPUT - Grid positions
! sEnd              - INPUT  - End position for gaussian
! sMean             - INPUT  - Mean position for gaussian
! sSigma            - INPUT  - Sigma for gaussian
! sIntegral(:)      - OUTPUT - Integral under the
!                              specific distribution
! qOK               - OUTPUT - Error flag
!
    INTEGER(KIND=IP),INTENT(IN)	:: iDistributionType,iNumMP
    REAL(KIND=WP),INTENT(IN)		:: sGrid(:),sMean,sSigma
    REAL(KIND=WP),INTENT(OUT)		:: sIntegral(:)
    LOGICAL,      INTENT(OUT)         :: qOK
!
!LOCAL VARIABLES
!
    REAL(KIND=WP),ALLOCATABLE :: sFunc(:),sDel(:)
    INTEGER(KIND=IP) :: i
!--------------------------------------------------------
! BEGIN:-
! Set error flag to false
    qOK = .FALSE.

! Create grid
    SELECT CASE (iDistributionType)
    CASE(iTopHatDistribution_CG)
! ALLOCATE LOCAL ARRAYS
       ALLOCATE(sFunc(iNumMP),sDel(iNumMP))
       CALL GaussianDistribution(iNumMP,sGrid,sMean,&
            sSigma,sFunc)
       DO i=1,iNumMP
          sDel(i)=sGrid(i+1)-sGrid(i)
       ENDDO
       sIntegral= sFunc * sDel
!********************************************************
! DEALLOCATE LOCAL ARRAYS
       DEALLOCATE(sFunc,sDel)

    CASE(iGaussianDistribution_CG)
       CALL EvalIntegral(sGrid,sMean,sSigma,sIntegral)
    END SELECT

!  Set error flag and exit
    qOK = .TRUE.
    GOTO 2000
!
! Error Handler
1000 CALL Error_log('Error in ElectronGrid:DistributionIntegral',&
          tErrorLog_G)
    PRINT*,'Error in ElectronGrid:DistributionIntegral'
2000 CONTINUE
  END SUBROUTINE DistributionIntegral
!********************************************************
  SUBROUTINE DistributionIntegralz2(iDistributionType,&
     iLocNumMP,iNumMP,sGrid,sMean,sSigma,&
     MPI_DOUBLE_PRECISION,MPI_SUM,sIntegral,qOK)

    IMPLICIT NONE
!
! Calculate the integral of the chosen distribution
! for the electron pulse
!
! iDistributionType     - INPUT  - If Top-hat or gaussian
!                                  distribution
! iNumMP                - INPUT  - Number of macro electrons
! sGrid(:)              - INTPUT - Grid positions
! sEnd                  - INPUT  - End position for gaussian
! sMean                 - INPUT  - Mean position for gaussian
! sSigma                - INPUT  - Sigma for gaussian
! sIntegral(:)          - OUTPUT - Integral under the
!                                  specific distribution
! qOK                   - OUTPUT - Error flag
!
    INTEGER(KIND=IP),INTENT(IN)	:: iDistributionType,&
         iLocNumMP,iNumMP
    INTEGER(KIND=IP),INTENT(IN)	:: MPI_DOUBLE_PRECISION,&
         MPI_SUM
    REAL(KIND=WP),INTENT(IN)    :: sGrid(:),sMean,sSigma
    REAL(KIND=WP),INTENT(OUT)	:: sIntegral(:)
    LOGICAL,      INTENT(OUT)   :: qOK
!
! LOCAL VARIABLES
!
    REAL(KIND=WP),ALLOCATABLE :: sFunc(:),sDel(:)
    INTEGER(KIND=IP) :: i
!--------------------------------------------------------
! BEGIN:-
! Set error flag to false
    qOK = .FALSE.

! Create grid
    SELECT CASE (iDistributionType)
    CASE(iTopHatDistribution_CG)
       ALLOCATE(sFunc(iLocNumMP),sDel(iLocNumMP))
       CALL GaussianDistributionZ2(iLocNumMP,sGrid,&
            sMean,sSigma,sFunc,&
            MPI_DOUBLE_PRECISION,MPI_SUM)
       DO i=1,ilocNumMP
          sDel(i)=sGrid(i+1)-sGrid(i)
       ENDDO
       sIntegral= sFunc * sDel
       DEALLOCATE(sFunc,sDel)

    CASE(iGaussianDistribution_CG)
       CALL EvalIntegral(sGrid,sMean,sSigma,sIntegral)
    END SELECT

!  Set error flag and exit
    qOK = .TRUE.
    GOTO 2000

! Error Handler
1000 CALL Error_log('Error in ElectronGrid:DistributionIntegral',&
          tErrorLog_G)
    PRINT*,'Error in ElectronGrid:DistributionIntegral'
2000 CONTINUE

  END SUBROUTINE DistributionIntegralz2
!********************************************************

subroutine flattop2(sig_edj, len_f, sGrid, iNumMP, iLocNumMP, qPara, s_Integral)

! Create a normalised flat top distribution with rounded edges.
! Round esges are modelled with half-gaussians. Uniprocessor version.

  real(kind=wp), intent(in) :: sig_edj,  & ! sigma of each edge
                               len_f,    & ! length of flat section in centre
                               sGrid(:)    ! grid points

  integer(kind=ip), intent(in) :: iNumMP,   & ! Total number of MPs
                                  iLocNumMP   ! Local number of MPs

  logical, intent(in) :: qPara

  real(kind=wp), intent(out) :: s_Integral(:)

  real(kind=wp) :: len_gauss, sSt, sEd, sg1st, sftst, sg2st, sg1cen, &
                   sg2cen, norm_pk, tres, a1, a2, tot_ar, tmp_gdpt

  integer(kind=ip) :: ii
  integer :: iT, iStrange, error  ! MPI Vars

!!! Get grid pts assigned to each section - gaussian -> flat -> gaussian

  len_gauss = gExtEj_G * sig_edj /2.0_wp  ! model out how many sigma??

! Get start and end of gaussian (need to send data around to determine global sts and ends in parallel version)

  sSt = sGrid(1_ip)
  sEd = sGrid(iLocNumMP)

  if (qPara) then

    CALL MPI_ALLREDUCE(MPI_IN_PLACE, sSt, 1, MPI_DOUBLE_PRECISION, &
         MPI_MIN, MPI_COMM_WORLD, error)

    CALL MPI_ALLREDUCE(MPI_IN_PLACE, sEd, 1, MPI_DOUBLE_PRECISION, &
         MPI_MAX, MPI_COMM_WORLD, error)

  end if

  sg1st = sSt              ! Start of 1st half gauss
  sftst = sSt + len_gauss  ! Start of flat-top section
  sg2st = sftst + len_f    ! Start of second half-gaussian

  sg1cen = sftst      ! mean of 1st gauss
  sg2cen = sg2st

  norm_pk = 1.0_wp / (sqrt(2.0_wp*pi) * sig_edj) ! Peak of normalized gaussian

  iStrange = 0_ip

  do ii = 1,iLocNumMP

    if (sGrid(ii) < sftst .and. sGrid(ii+1) < sftst ) then

      ! area between 2 gaussian pts

       call AreaNDist(sGrid(ii:ii+1), sg1cen, sig_edj, tres)
       s_integral(ii) = tres

    else if (sGrid(ii) < sftst .and. (sGrid(ii+1) >= sftst .and.  sGrid(ii+1) <= sg2st ) ) then

      ! area to top of gaussian (sftst) + area from top of gaussian to next grid point

      tmp_gdpt = sg1cen ! temp grid point

      call AreaNDist( (/sGrid(ii),  tmp_gdpt/), sg1cen, sig_edj, tres)

      a1 = tres ! Gauss section
      a2 = norm_pk * (sGrid(ii+1) - tmp_gdpt )    ! flat top section
      s_integral(ii) = a1 + a2

    else if (    (sGrid(ii) >= sftst  .and.  sGrid(ii) <= sg2st )  &
           .and. (sGrid(ii+1) >= sftst  .and.  sGrid(ii+1) <= sg2st )  ) then

    ! Flat top section

      s_integral(ii) = norm_pk * (sGrid(ii+1) - sGrid(ii) )

    else if (    (sGrid(ii) >= sftst  .and.  sGrid(ii) <= sg2st )  &
            .and. (sGrid(ii+1) > sg2st  .and.  sGrid(ii+1) < sEd )  ) then

    ! A mix of flat-top and gaussian sections

      tmp_gdpt = sg2cen ! temp grid point

      call AreaNDist( (/tmp_gdpt,  sGrid(ii+1)/), sg2cen, sig_edj, tres)

      a1 = norm_pk * (tmp_gdpt - sGrid(ii)) ! Flat top section
      a2 = tres    ! Gaussian section
      s_integral(ii) = a1 + a2

    else if (    (sGrid(ii) > sg2st)   .and. (sGrid(ii+1) > sg2st)  ) then

    ! Last gaussian section

       call AreaNDist(sGrid(ii:ii+1), sg2cen, sig_edj, tres)
       s_integral(ii) = tres

    else

      iStrange = iStrange + 1_ip

    end if

  end do

  if (qPara) then

    CALL MPI_ALLREDUCE(iStrange, iT, 1, MPI_INTEGER, &
         MPI_SUM, MPI_COMM_WORLD, error)

    iStrange = iT

  end if

  if (iStrange > 0) then

    if (tProcInfo_G%qRoot) print*, 'ERROR IN subroutine flattop2: perhaps the beam is not sampled finely enough'
    if (tProcInfo_G%qRoot) print*, 'sum of iStrange was : ', iStrange

    call mpi_finalize(error)
    stop

  end if

! Sum over integrals and normalize result

  tot_ar = sum(s_integral)

  if (qPara) then

    CALL MPI_ALLREDUCE(MPI_IN_PLACE, tot_ar, 1, MPI_DOUBLE_PRECISION, &
         MPI_SUM, MPI_COMM_WORLD, error)

  end if

  s_integral = s_integral / tot_ar

!  print*, tot_ar

end subroutine flattop2

subroutine AreaNDist(s_gridPoints, s_mean, s_sigma, elem)

  real(kind=wp), intent(in) :: s_gridPoints(2)
  real(kind=wp), intent(in) :: s_mean, s_sigma
  real(kind=wp), intent(out) :: elem

  real(kind=wp) :: s_value1, s_value2

  s_value2=(s_gridPoints(2)-s_mean)/&
       (s_sigma*SQRT(2.0_WP))

  s_value1=(s_gridPoints(1)-s_mean)/&
       (s_sigma*SQRT(2.0_WP))

  elem = 0.5_WP *&
       (erf(s_value2)-erf(s_value1))

end subroutine AreaNDist

END MODULE particleFunctions


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!
!!!!   MIT License
!!!!
!!!!   ParaMonte: plain powerful parallel Monte Carlo library.
!!!!
!!!!   Copyright (C) 2012-present, The Computational Data Science Lab
!!!!
!!!!   This file is part of the ParaMonte library.
!!!!
!!!!   Permission is hereby granted, free of charge, to any person obtaining a
!!!!   copy of this software and associated documentation files (the "Software"),
!!!!   to deal in the Software without restriction, including without limitation
!!!!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!!!!   and/or sell copies of the Software, and to permit persons to whom the
!!!!   Software is furnished to do so, subject to the following conditions:
!!!!
!!!!   The above copyright notice and this permission notice shall be
!!!!   included in all copies or substantial portions of the Software.
!!!!
!!!!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
!!!!   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
!!!!   MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
!!!!   IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
!!!!   DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
!!!!   OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE
!!!!   OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
!!!!
!!!!   ACKNOWLEDGMENT
!!!!
!!!!   ParaMonte is an honor-ware and its currency is acknowledgment and citations.
!!!!   As per the ParaMonte library license agreement terms, if you use any parts of
!!!!   this library for any purposes, kindly acknowledge the use of ParaMonte in your
!!!!   work (education/research/industry/development/...) by citing the ParaMonte
!!!!   library as described on this page:
!!!!
!!!!       https://github.com/cdslaborg/paramonte/blob/main/ACKNOWLEDGMENT.md
!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module LogFunc_mod

    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    !%
    !%  Description:
    !%      -   Return the negative natural logarithm of the 2-dimensional Himmelblau's function.
    !%          Reference: https://en.wikipedia.org/wiki/Himmelblau%27s_function
    !%  Input:
    !%      -   ndim:   The number of dimensions of the domain of the objective function.
    !%      -   point:  The input 64-bit real-valued vector of length ndim,
    !%                  at which the natural logarithm of objective function is computed.
    !%  Output:
    !%      - logFunc:  A 64-bit real scalar number representing the natural logarithm of the objective function.
    !%  Author:
    !%      - Computational Data Science Lab, Monday 9:03 AM, May 16 2016, ICES, UT Austin
    !%
    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    use paramonte, only: IK, RK

    implicit none

    ! The number of dimensions of the domain of the objective function

    integer(IK), parameter  :: NDIM = 2_IK

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

contains

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function getLogFunc(ndim,Point) result(logFunc)
        ! Return the negative natural logarithm of Himmelblau's function evaluated at the input vector point.
        implicit none
        integer(IK), intent(in) :: ndim
        real(RK), intent(in)    :: Point(ndim)
        real(RK)                :: logFunc
        logFunc = -log( (point(1)**2 + point(2) - 11)**2 + (point(1) + point(2)**2 - 7)**2 )
    end function getLogFunc

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

end module LogFunc_mod


      PROGRAM xrofunc
C     driver for routine rofunc
      INTEGER NMAX
      REAL SPREAD
      PARAMETER(NMAX=1000,SPREAD=0.05)
      INTEGER i,idum,npt
      REAL aa,abdev,x(NMAX),y(NMAX),arr(NMAX),b,rf,gasdev,rofunc
      COMMON /arrays/ x,y,arr,aa,abdev,npt
      idum=-11
      npt=100
      do 11 i=1,npt
        x(i)=0.1*i
        y(i)=-2.0*x(i)+1.0+SPREAD*gasdev(idum)
11    continue
      write(*,'(/1x,t10,a,t20,a,t26,a,t37,a/)') 'B','A','ROFUNC','ABDEV'
      do 12 i=-5,5
        b=-2.0+0.02*i
        rf=rofunc(b)
        write(*,'(1x,4f10.2)') b,aa,rofunc(b),abdev
12    continue
      END

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


module GeometryM
  use UtilitiesM
  use DebuggerM

  use PointM
  use NodeM
  use NodePtrM

  use IntegratorM

  implicit none

  private
  public :: GeometryDT

  type, abstract :: GeometryDT
     integer(ikind)                 :: nNode
     integer(ikind)                 :: dim
     type(IntegratorDT)             :: integrator
     class(GeometryDT), allocatable :: boundaryGeometry
   contains
     procedure                                                   :: getnNode
     procedure                                                   :: getDim
     procedure                                                   :: getIntegrator

     procedure(getLenghtInterf)                       , deferred :: getLenght
     procedure(shapeFuncInterf)                       , deferred :: shapeFunc
     procedure(dShapeFuncInterf)                      , deferred :: dShapeFunc
     procedure(jacobianAllNodesInterf)                , deferred :: jacobianAllNodes
     procedure(jacobianSomeNodesInterf)               , deferred :: jacobianSomeNodes
     procedure(jacobianAtGPointsInterf)               , deferred :: jacobianAtGPoints
     procedure(jacobianDetFromCoordAllNodesInterf)    , deferred :: jacobianDetFromCoordAllNodes
     procedure(jacobianDetFromCoordSomeNodesInterf)   , deferred :: jacobianDetFromCoordSomeNodes
     procedure(jacobianDetFromJacobianInterf)         , deferred :: jacobianDetFromJacobian
     procedure(jacobianDetAtGPointsFromCoordInterf)   , deferred :: jacobianDetAtGPointsFromCoord
     procedure(jacobianDetAtGPointsFromJacobianInterf), deferred :: jacobianDetAtGPointsFromJacobian

     generic :: jacobian    => jacobianAllNodes     &
                             , jacobianSomeNodes
     generic :: jacobianDet => jacobianDetFromCoordAllNodes        &
                             , jacobianDetFromCoordSomeNodes       &
                             , jacobianDetFromJacobian
     generic :: jacobianDetAtGPoints => jacobianDetAtGPointsFromCoord     &
                                      , jacobianDetAtGPointsFromJacobian
  end type GeometryDT

  abstract interface
     real(rkind) function getLenghtInterf(this, node)
       use UtilitiesM
       import GeometryDT
       import NodePtrDT
       implicit none
       class(GeometryDT)                       , intent(inout) :: this
       class(NodePtrDT) , dimension(this%nNode), intent(in)    :: node
     end function getLenghtInterf
  end interface

  abstract interface
     function shapeFuncInterf(this, point)
       use UtilitiesM
       import GeometryDT
       import PointDT
       implicit none
       class(GeometryDT), intent(inout)         :: this
       class(PointDT)   , intent(in)            :: point
       real(rkind)      , dimension(this%nNode) :: shapeFuncInterf
     end function shapeFuncInterf
  end interface

  abstract interface
     function dShapeFuncInterf(this, point)
       use UtilitiesM
       import GeometryDT
       import PointDT
       implicit none
       class(GeometryDT), intent(inout)                   :: this
       class(PointDT)   , intent(in)                      :: point
       real(rkind)      , dimension(this%dim, this%nNode) :: dShapeFuncInterf
     end function dShapeFuncInterf
  end interface

  abstract interface
     function jacobianAllNodesInterf(this, pointToValue, node)
       use UtilitiesM
       import GeometryDT
       import PointDT
       import NodePtrDT
       implicit none
       class(GeometryDT)                       , intent(inout) :: this
       class(PointDT)                          , intent(in)    :: pointToValue
       class(NodePtrDT) , dimension(this%nNode), intent(in)    :: node
       real(rkind)      , dimension(this%dim, this%dim)        :: jacobianAllNodesInterf
     end function jacobianAllNodesInterf
  end interface

  abstract interface
     function jacobianSomeNodesInterf(this, indexList, pointToValue, node)
       use UtilitiesM
       import GeometryDT
       import PointDT
       import NodePtrDT
       implicit none
       class(GeometryDT)                       , intent(inout) :: this
       integer(ikind)   , dimension(:)         , intent(in)    :: indexList
       class(PointDT)                          , intent(in)    :: pointToValue
       class(NodePtrDT) , dimension(:)         , intent(in)    :: node
       real(rkind)      , dimension(this%dim, this%dim)        :: jacobianSomeNodesInterf
     end function jacobianSomeNodesInterf
  end interface

  abstract interface
     function jacobianAtGPointsInterf(this, node)
       use UtilitiesM
       import GeometryDT
       import NodePtrDT
       implicit none
       class(GeometryDT)                                   , intent(inout) :: this
       class(NodePtrDT), dimension(this%nNode)             , intent(in)    :: node
       real(rkind), dimension(this%integrator%integTerms,this%dim,this%dim) :: jacobianAtGPointsInterf
     end function jacobianAtGPointsInterf
  end interface

  abstract interface
     function jacobianDetFromCoordAllNodesInterf(this, pointToValue, node)
       use UtilitiesM
       import GeometryDT
       import PointDT
       import NodePtrDT
       implicit none
       class(GeometryDT)                       , intent(inout) :: this
       class(PointDT)                          , intent(in)    :: pointToValue
       class(NodePtrDT) , dimension(this%nNode), intent(in)    :: node
       real(rkind)                                             :: jacobianDetFromCoordAllNodesInterf
     end function jacobianDetFromCoordAllNodesInterf
  end interface

  abstract interface
     function jacobianDetFromCoordSomeNodesInterf(this, indexList, pointToValue, node)
       use UtilitiesM
       import GeometryDT
       import PointDT
       import NodePtrDT
       implicit none
       class(GeometryDT)              , intent(inout) :: this
       integer(ikind)   , dimension(:), intent(in)    :: indexList
       class(PointDT)                 , intent(in)    :: pointToValue
       class(NodePtrDT) , dimension(:), intent(in)    :: node
       real(rkind)                                    :: jacobianDetFromCoordSomeNodesInterf
     end function jacobianDetFromCoordSomeNodesInterf
  end interface

  abstract interface
     function jacobianDetFromJacobianInterf(this, jacobian)
       use UtilitiesM
       import GeometryDT
       implicit none
       class(GeometryDT)                , intent(inout) :: this
       real(rkind)      , dimension(:,:), intent(in)    :: jacobian
       real(rkind)                                      :: jacobianDetFromJacobianInterf
     end function jacobianDetFromJacobianInterf
  end interface

  abstract interface
     function jacobianDetAtGPointsFromCoordInterf(this, node)
       use UtilitiesM
       import GeometryDT
       import NodePtrDT
       implicit none
       class(GeometryDT)                      , intent(inout) :: this
       class(NodePtrDT), dimension(this%nNode), intent(in)    :: node
       real(rkind) , dimension(this%integrator%integTerms)    :: jacobianDetAtGPointsFromCoordInterf
     end function jacobianDetAtGPointsFromCoordInterf
  end interface

  abstract interface
     function jacobianDetAtGPointsFromJacobianInterf(this, jacobian)
       use UtilitiesM
       import GeometryDT
       implicit none
       class(GeometryDT)                 , intent(inout) :: this
       real(rkind), dimension(:,:,:)     , intent(in)    :: jacobian
       real(rkind), dimension(this%integrator%integTerms) :: jacobianDetAtGPointsFromJacobianInterf
     end function jacobianDetAtGPointsFromJacobianInterf
  end interface

contains

  integer(ikind) pure function getnNode(this)
    implicit none
    class(GeometryDT), intent(in) :: this
    getnNode = this%nNode
  end function getnNode

  integer(ikind) pure function getDim(this)
    implicit none
    class(GeometryDT), intent(in) :: this
    getDim = this%dim
  end function getDim

  type(IntegratorDT) pure function getIntegrator(this)
    implicit none
    class(GeometryDT), intent(in) :: this
    getIntegrator = this%integrator
  end function getIntegrator

end module GeometryM


      subroutine split(vel,dep,vs,ds,vf,df,npts)
c----------------------------------------------------------------------
c       splits the line between (vs,ds) and (vf,df) in space (x,y)
c  into npts equal intervals.  the routine fills the vel and dep arrays
c  with the endpoints of the intervals in a sequence going from (vs,ds)
c  to (vf,df).  the routine always sets (vel(1),dep(1)) = (vs,ds) and
c  (vel(npts),dep(npts))=vf,df) unless npts.le.1 in which case only
c  vel(1) and dep(1) are set.
c-----------------------------------------------------------------------
      dimension vel(npts),dep(npts)
      vel(1)=vs
      dep(1)=ds
      if(npts.le.1) return
      grad=(vf-vs)/(df-ds)
      ddep=(df-ds)/float(npts-1)
      do 100 i=2,npts
           dep(i)=ds+ddep*float(i-1)
  100      vel(i)=vs+(dep(i)-ds)*grad
      return
      end

c $Id$


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   pp2 :    Basic computations for continuous dynamical systems
!----------------------------------------------------------------------
!----------------------------------------------------------------------

SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!--------- ----

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, IJAC, ICP(*)
  DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
  DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
  DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,*), DFDP(NDIM,*)

  DOUBLE PRECISION e

  e=EXP(-PAR(3)*U(1))

  F(1) = PAR(2)*U(1)*(1-U(1)) - U(1)*U(2) - PAR(1)*(1-e)
  F(2) = -U(2) + PAR(4)*U(1)*U(2)

END SUBROUTINE FUNC
!----------------------------------------------------------------------

SUBROUTINE STPNT(NDIM,U,PAR,T)
!--------- -----

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM
  DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM), PAR(*)
  DOUBLE PRECISION, INTENT(IN) :: T

  PAR(:4) = (/ 0.0, 3.0, 5.0, 3.0 /)
  U = 0.0

END SUBROUTINE STPNT
!----------------------------------------------------------------------

SUBROUTINE PVLS(NDIM,U,PAR)
!--------- ----

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM
  DOUBLE PRECISION, INTENT(IN) :: U(NDIM)
  DOUBLE PRECISION, INTENT(INOUT) :: PAR(*)
  DOUBLE PRECISION GETP

! Set PAR(9) equal to U1
  PAR(9)=GETP('BV0',1,U)

END SUBROUTINE PVLS

SUBROUTINE BCND
END SUBROUTINE BCND

SUBROUTINE ICND
END SUBROUTINE ICND

SUBROUTINE FOPT
END SUBROUTINE FOPT
!----------------------------------------------------------------------


*DECK HKSEQ
      SUBROUTINE HKSEQ (X, M, H, IERR)
C***BEGIN PROLOGUE  HKSEQ
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BSKIN
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (HKSEQ-S, DHKSEQ-D)
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C   HKSEQ is an adaptation of subroutine PSIFN described in the
C   reference below.  HKSEQ generates the sequence
C   H(K,X) = (-X)**(K+1)*(PSI(K,X) PSI(K,X+0.5))/GAMMA(K+1), for
C            K=0,...,M.
C
C***SEE ALSO  BSKIN
C***REFERENCES  D. E. Amos, A portable Fortran subroutine for
C                 derivatives of the Psi function, Algorithm 610, ACM
C                 Transactions on Mathematical Software 9, 4 (1983),
C                 pp. 494-502.
C***ROUTINES CALLED  I1MACH, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   820601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C   920528  DESCRIPTION and REFERENCES sections revised.  (WRB)
C***END PROLOGUE  HKSEQ
      INTEGER I, IERR, J, K, M, MX, NX
      INTEGER I1MACH
      REAL B, FK, FLN, FN, FNP, H, HRX, RLN, RXSQ, R1M5, S, SLOPE, T,
     * TK, TRM, TRMH, TRMR, TST, U, V, WDTOL, X, XDMY, XH, XINC, XM,
     * XMIN, YINT
      REAL R1MACH
      DIMENSION B(22), TRM(22), TRMR(25), TRMH(25), U(25), V(25), H(*)
      SAVE B
C-----------------------------------------------------------------------
C             SCALED BERNOULLI NUMBERS 2.0*B(2K)*(1-2**(-2K))
C-----------------------------------------------------------------------
      DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10),
     * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19),
     * B(20), B(21), B(22) /1.00000000000000000E+00,
     * -5.00000000000000000E-01,2.50000000000000000E-01,
     * -6.25000000000000000E-02,4.68750000000000000E-02,
     * -6.64062500000000000E-02,1.51367187500000000E-01,
     * -5.06103515625000000E-01,2.33319091796875000E+00,
     * -1.41840972900390625E+01,1.09941936492919922E+02,
     * -1.05824747562408447E+03,1.23842434241771698E+04,
     * -1.73160495905935764E+05,2.85103429084961116E+06,
     * -5.45964619322445132E+07,1.20316174668075304E+09,
     * -3.02326315271452307E+10,8.59229286072319606E+11,
     * -2.74233104097776039E+13,9.76664637943633248E+14,
     * -3.85931586838450360E+16/
C
C***FIRST EXECUTABLE STATEMENT  HKSEQ
      IERR=0
      WDTOL = MAX(R1MACH(4),1.0E-18)
      FN = M - 1
      FNP = FN + 1.0E0
C-----------------------------------------------------------------------
C     COMPUTE XMIN
C-----------------------------------------------------------------------
      R1M5 = R1MACH(5)
      RLN = R1M5*I1MACH(11)
      RLN = MIN(RLN,18.06E0)
      FLN = MAX(RLN,3.0E0) - 3.0E0
      YINT = 3.50E0 + 0.40E0*FLN
      SLOPE = 0.21E0 + FLN*(0.0006038E0*FLN+0.008677E0)
      XM = YINT + SLOPE*FN
      MX = INT(XM) + 1
      XMIN = MX
C-----------------------------------------------------------------------
C     GENERATE H(M-1,XDMY)*XDMY**(M) BY THE ASYMPTOTIC EXPANSION
C-----------------------------------------------------------------------
      XDMY = X
      XINC = 0.0E0
      IF (X.GE.XMIN) GO TO 10
      NX = INT(X)
      XINC = XMIN - NX
      XDMY = X + XINC
   10 CONTINUE
      RXSQ = 1.0E0/(XDMY*XDMY)
      HRX = 0.5E0/XDMY
      TST = 0.5E0*WDTOL
      T = FNP*HRX
C-----------------------------------------------------------------------
C     INITIALIZE COEFFICIENT ARRAY
C-----------------------------------------------------------------------
      S = T*B(3)
      IF (ABS(S).LT.TST) GO TO 30
      TK = 2.0E0
      DO 20 K=4,22
        T = T*((TK+FN+1.0E0)/(TK+1.0E0))*((TK+FN)/(TK+2.0E0))*RXSQ
        TRM(K) = T*B(K)
        IF (ABS(TRM(K)).LT.TST) GO TO 30
        S = S + TRM(K)
        TK = TK + 2.0E0
   20 CONTINUE
      GO TO 110
   30 CONTINUE
      H(M) = S + 0.5E0
      IF (M.EQ.1) GO TO 70
C-----------------------------------------------------------------------
C     GENERATE LOWER DERIVATIVES, I.LT.M-1
C-----------------------------------------------------------------------
      DO 60 I=2,M
        FNP = FN
        FN = FN - 1.0E0
        S = FNP*HRX*B(3)
        IF (ABS(S).LT.TST) GO TO 50
        FK = FNP + 3.0E0
        DO 40 K=4,22
          TRM(K) = TRM(K)*FNP/FK
          IF (ABS(TRM(K)).LT.TST) GO TO 50
          S = S + TRM(K)
          FK = FK + 2.0E0
   40   CONTINUE
        GO TO 110
   50   CONTINUE
        MX = M - I + 1
        H(MX) = S + 0.5E0
   60 CONTINUE
   70 CONTINUE
      IF (XINC.EQ.0.0E0) RETURN
C-----------------------------------------------------------------------
C     RECUR BACKWARD FROM XDMY TO X
C-----------------------------------------------------------------------
      XH = X + 0.5E0
      S = 0.0E0
      NX = INT(XINC)
      DO 80 I=1,NX
        TRMR(I) = X/(X+NX-I)
        U(I) = TRMR(I)
        TRMH(I) = X/(XH+NX-I)
        V(I) = TRMH(I)
        S = S + U(I) - V(I)
   80 CONTINUE
      MX = NX + 1
      TRMR(MX) = X/XDMY
      U(MX) = TRMR(MX)
      H(1) = H(1)*TRMR(MX) + S
      IF (M.EQ.1) RETURN
      DO 100 J=2,M
        S = 0.0E0
        DO 90 I=1,NX
          TRMR(I) = TRMR(I)*U(I)
          TRMH(I) = TRMH(I)*V(I)
          S = S + TRMR(I) - TRMH(I)
   90   CONTINUE
        TRMR(MX) = TRMR(MX)*U(MX)
        H(J) = H(J)*TRMR(MX) + S
  100 CONTINUE
      RETURN
  110 CONTINUE
      IERR=2
      RETURN
      END