	REAL*4 FUNCTION IPPOWER
     .  (XALPHA,XP0,XP1,XN,XM,R,CASECTRL,ALT,UORF)
	IMPLICIT NONE
C
	REAL*4 XALPHA,XP0,XP1,XN,XM
	REAL*4 R
	INTEGER*4 CASECTRL, ALT, UORF
C
C	POWER CALCULATIONS FOR INDEPENDENT PROPORTIONS
C	NORMAL APPROXIMATION ASSUMED
C
C   Power formula from:  Schlesselman:  Case-control Studies: Design,
C   Conduct, Analysis.  New York: Oxford U. Press 1982: 144-152.
C	See also:  FRIEDMAN, FURBERG AND DEMETS:
C	FUNDAMENTALS OF CLINICAL TRIALS. BOSTON: WRIGHT PSG. 1982:75.
C
C INPUT:
C	ALPHA	TYPE I ERROR probability (TWO TAILED)
C	P0	Probability of exposure in control group when CASECTL=Y
C		Probability of event in control group when CASECTL=N
C	P1	Probability of exposure in case group when CASECTL=Y
C		Probability of event in case group when CASECTL=N
C	N	NUMBER OF CASE PATIENTS
C	M	Ratio of control to case
C	R	Odds ratio or relative risk.
C	CASECTL 1 for case-control studies
C		2 for prospective studies
C	ALT	=1 if input is two proportions
C		=2 if input is other (odds ration or relative risk)
C	UORF =1 for uncorrected chi-square test
C        =2 for Fisher's exact test
C OUTPUT:
C	POWER	The probability of correctly rejecting the null
C		hypothesis of equal event (exposure) probabilities
C		with type I error probability ALPHA given P0, P1, N,
C		and M defined above.
C
C  Globals
C
	REAL ALPHA,P1,P0,N,M
	COMMON/IPFISH/ALPHA,P1,P0,N,M
C
C    Declare functions.
C
	EXTERNAL FISHSIZB
	REAL FISHSIZB
C
C  Locals
C
	REAL ZALPHA,ZCRVALUE,PBAR
	REAL Q0,Q1,QBAR,S1,S2
	DOUBLE PRECISION PHI
	INTEGER ERR
	REAL BETA,EPS,E1,Y1,Y2
C
C Code:
C
	ALPHA =	XALPHA
	P0 = XP0
	P1 = XP1
	N = XN
	M = XM

	IF (ALT.EQ.2) THEN
	    IF (CASECTRL.EQ.1) THEN
	    	P1=P0*R/(1.+P0*(R-1.))
	    ELSE
	    	P1=P0*R
	    END IF
	END IF
C
C    Calculate a single value of POWER.
C
	ZALPHA=ZCRVALUE(ALPHA/2.)
	PBAR=(P1+M*P0)/(M+1)
	QBAR=1.-PBAR
	Q1=1.-P1
	Q0=1.-P0
	S1=SQRT(PBAR*QBAR*(1.+1./M)/N)
	S2=SQRT((P0*Q0/M+P1*Q1)/N)
	BETA=REAL(PHI((ZALPHA*S1-(P0-P1))/S2))-
     .		 REAL(PHI((-ZALPHA*S1-(P0-P1))/S2))
C
C	If the test type is Fisher's exact then use the
C	uncorrected beta as a starting point and find
C	the corrected beta.
C
	IF (UORF.EQ.2) THEN
C
C    Set error tolerance values for call to bisection routine.
C
		EPS=0.00002*MIN(P0,1.-P0)
		E1 =0.00002*MIN(P0,1.-P0)
C
C	Set initial end points.  Start at beta.
C
		Y1=BETA
C
C	Power (=1-beta) must not be less than alpha.  Therefore, the
C	largest beta must be 1-alpha.
C
		Y2=1.-ALPHA
C
C	Make the approximation.  Use bisection to find the
C	zero of the function FISHSIZB.
C
		CALL BISEC(Y1,Y2,EPS,E1,FISHSIZB,BETA,ERR)
C
C	Continuity correction is invalid when the power is
C	very low.  Set BETA to 1-ALPHA.
C
		IF (ERR.NE.0.AND.FISHSIZB(Y1).GT.0.AND.FISHSIZB(Y2).GT.0) THEN
C			BETA=Y2
			IPPOWER=-1
			RETURN
	    END IF
	END IF
C
C	Set return value.  Power is 1-beta.
C
	IPPOWER=1.-BETA
C
C	Done.
C
	RETURN
	END


      MODULE m_dsphbs
!********************************************************************
!     calculates the derivative of the spherical bessel functions
!     dfj(l) = d jl(x)/dx
!     for l=0,lmax and argument x
!     note that the spherical bessel functions fj(l), l=0,lmax are
!     needed (call sphbes to generate these)
!                                            m. weinert
!********************************************************************
      CONTAINS
      SUBROUTINE dsphbs(
     >                  lmax,x,fj,
     <                  dfj)
!$acc routine
      IMPLICIT NONE
!     ..
!     .. Arguments ..
      INTEGER, INTENT  (IN) :: lmax
      REAL,    INTENT  (IN) :: x
      REAL,    INTENT  (IN) ::  fj(0:lmax)
      REAL,    INTENT (OUT) :: dfj(0:lmax)
!
!     .. Parameters ..
      REAL,    PARAMETER :: xlim = 1.0e-04
!     ..
!     .. Local Scalars ..
      REAL fac,x2
      INTEGER l

      dfj(0) = -fj(1)
!--->    small x limit
      IF (x.LT.xlim) THEN
         x2 = 0.5*x*x
         fac = 1./3.
         DO l = 1,lmax
            dfj(l) = fac* (l-x2* (l+2)/ (2*l+3))
            fac = x*fac/ (2*l+3)
         ENDDO
      ELSE
!--->    obtain dfj using recurrence relationship
         DO l = 1,lmax
            dfj(l) = fj(l-1) - (l+1)*fj(l)/x
         ENDDO
      END IF

      RETURN
      END SUBROUTINE dsphbs
      END MODULE m_dsphbs


subroutine cholin(kb)
! Choleski reduction on kb(l,iw+1) stored as a lower triangle
 implicit none
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),intent(in out)::kb(:,:)
 integer::i,j,k,l,ia,ib,n,iw
 REAL(iwp)::x
 n=ubound(kb,1)
 iw=ubound(kb,2)-1
 do i=1,n
   x=.0
   do j=1,iw
     x=x+kb(i,j)**2
   end do
   kb(i,iw+1)=sqrt(kb(i,iw+1)-x)
   do k=1,iw
     x=.0
     if(i+k<=n)then
       if(k/=iw)then
         do l=iw-k,1,-1
           x=x+kb(i+k,l)*kb(i,l+k)
         end do
       end if
       ia=i+k
       ib=iw-k+1
       kb(ia,ib)=(kb(ia,ib)-x)/kb(i,iw+1)
     end if
   end do
 end do
return
end subroutine cholin


! { dg-do run }
! tests the fix for PR39292, where the intitialization expression
! did not simplify and caused an ICE in gfc_conv_array_initializer.
!
! Contributed by Richard Guenther <rguenth@gcc.gnu.org>
!
  integer :: n
  real, dimension(2) :: a = (/ ( (float(n))**(1.0), n=1,2) /)
  if (any (a .ne. (/ ( (float(n))**(1.0), n=1,2) /))) STOP 1
end


PROGRAM main
!
! Purpose:
!  Just for homework 10 in chapter6
!
! Record of revisions:
!    Date   Programmer  Description of change
!    ====   ==========  =====================
!  04/12/17  hopeful       Original code
!
IMPLICIT NONE

REAL, EXTERNAL :: v
REAL :: p

DO p = 1, 1001, 100
    WRITE (*,*) 'The v of gas when P = ', p, ' kPa and T = ', 273, 'K is ', v(p,273.0), ' m3.'
END DO
DO p = 1, 1001, 100
    WRITE (*,*) 'The v of gas when P = ', p, ' kPa and T = ', 300, 'K is ', v(p,300.0), ' m3.'
END DO

END PROGRAM main

! 求理想气体体积
REAL FUNCTION v(p, t)
IMPLICIT NONE

REAL, PARAMETER :: n = 1.0
REAL, PARAMETER :: R = 8.31441
REAL :: p
REAL :: t

v = n * R * t * 1000 / p
RETURN
END FUNCTION v


program fibonacci_test
    use, intrinsic :: iso_fortran_env, only : I8 => INT64, output_unit
    use :: fib_mod
    implicit none
    integer(kind=I8), parameter :: n_max = 15
    integer(kind=I8) :: n, func_nr
    type :: func_t
        procedure(fib_func_t), nopass, pointer :: func => null()
    end type
    interface
        function fib_func_t(n) result(fib)
            use, intrinsic :: iso_fortran_env, only : I8 => INT64
            implicit none
            integer(kind=I8), value :: n
            integer(kind=I8) :: fib
        end function fib_func_t
    end interface
    integer, parameter :: nr_functions = 5
    type(func_t), dimension(nr_functions) :: functions
    character(len=15), dimension(nr_functions) :: names = [ &
            '      recursive', &
            '     skip ahead', &
            '       memoized', &
            '      iterative', &
            '    closed form'  &
        ]

    functions(1)%func => fib_recursive
    functions(2)%func => fib_skip_ahead
    functions(3)%func => fib_memoization
    functions(4)%func => fib_iterative
    functions(5)%func => fib_closed_form

    print '(A)', 'sanity check:'
    print '(6A15)', 'n', names
    do n = 0, n_max
        write (unit=output_unit, fmt='(I15)', advance='no') n
        do func_nr = 1, nr_functions
            write (unit=output_unit, fmt='(I15)', advance='no') &
                functions(func_nr)%func(n)
        end do
        print '(A)', ''
    end do

    print '(A)', 'check for closed form:'
    n = 0
    do while (fib_memoization(n) == fib_closed_form(n))
        n = n + 1
    end do
    print '(A, I0)', 'closed form breaks for ', n

end program fibonacci_test


C++**********************************************************************
C Program OPTIC
C To compute optic characteristics (geometrical optics with thin lenses)
C
C JLP
C Version 02-12-92
C--**********************************************************************
	program optic
        integer ioption,status
	real*4 focal_length, pp, pprime, distance, magni
        real*4 aa,bb,cc
C
C Choice of the option:
	print 67
67	format(' Program optic      ---- Version 02-12-92 ---')
	print 68
68	format(' Menu: ',/,
     1     ' 1: Compute image plane position P'' (knowing',
     1         ' P and focal length F)',/,
     1     ' 2: Compute P and P'' (knowing',
     1         ' working distance and focal length F)',/,
     1     ' 10: Exit',/,
     1     ' Enter your choice:')
        read(5,*,err=99,end=99) ioption

C*************************************************************************
C Option 1:  Compute magnification and P' knowing P and focal length
C*************************************************************************
        if(ioption.eq.1)then
	  print 41
41	  format(' Enter P and focal length F:')
	  read(5,*) pp,focal_length
          print 42
42        format(/,' Basic relation is: ',
     1       '     1/P + 1/P'' = 1/F ')
          pprime = 1./(1./focal_length - 1./pp)
          magni = pprime/pp
          print 43,pp,pprime,magni
43        format(/,' P =',1pg12.5,' P'' =',1pg12.5,
     1            ' Magnification (P''/P)=',1pg11.4)
C*************************************************************************
C Option 2:  Compute magnification, P and P' knowing working distance
C            and focal length
C*************************************************************************
C Formulae:
C              1/pp + 1/pprime = 1/focal_length
C Thus:     focal_length = pp*pprime / (pp + pprime)
C
C But:             pp + pprime = distance
C Thus:     pprime = distance - pp
C           focal_length = (distance - pp) * pp / distance
C           pp*pp - pp * distance + focal_length * distance = 0
C*************************************************************************
        elseif(ioption.eq.2)then
          print 69
69        format(' Enter working distance D (between the two image planes)',
     1           'and focal length F:')
          read(5,*) distance,focal_length
            print 70
70          format(/,' Starting relations are :  ',/,
     1       '        1/P + 1/P'' = 1/F ',/,
     1       '        P + P'' = D',/,
     1       ' We then infer that P is such that: (actually two solutions P and P'')',/,
     1       '        P*P - P*D +  F*D = 0')
            aa = 1.
            bb = -1.*distance
            cc = focal_length * distance
	    call second_order(aa,bb,cc,pprime,pp,status)
            if(status.ne.0)then
              print 71
71            format(/,' Error: no solution to this problem'
     1               ' Reduce focal length or increase working distance')
            else
              magni = pprime/pp
              print 72,pp,pprime,magni
72            format(/,' P =',1pg12.5,' P'' =',1pg12.5,
     1               ' Magnification (P''/P)=',1pg11.4)
            endif

C*************************************************************************
C Formulae:
C              1/pp + 1/pprime = 1/focal_length
C Thus:     focal_length = pp*pprime / (pp + pprime)
C
C But:             pp + pprime = distance
C Thus:     pprime = distance - pp
C           focal_length = (distance - pp) * pp / distance
C           pp*pp - pp * distance + focal_length * distance = 0
C*************************************************************************
         endif

99       stop
         end
C*************************************************************************
C Solve second order equation
C aa x2 + bb x + cc = 0
C Delta = bb*bb - 4*a*c
C*************************************************************************
	subroutine second_order(aa,bb,cc,s1,s2,status)
        integer status
	real*4 aa, bb, cc, s1, s2, delta

        status = 0

C Compute "determinant"
	delta = bb*bb - 4*aa*cc

	if(delta.lt.0)then
	  status = -1
        elseif(delta.eq.0)then
          s1 = - bb /(2*aa)
          s2 = s1
        else
          s1 = (- bb + sqrt(delta))/(2*aa)
          s2 = (- bb - sqrt(delta))/(2*aa)
        endif

	return
        end


      program TestMergeSort
        implicit none
        integer, parameter :: N = 8
        integer :: A(N) = (/ 1, 5, 2, 7, 3, 9, 4, 6 /)
        integer :: work((size(A) + 1) / 2)
        write(*,'(A,/,10I3)')'Unsorted array :',A
        call MergeSort(A, work)
        write(*,'(A,/,10I3)')'Sorted array :',A
      contains

      subroutine merge(A, B, C)
        implicit none
! The targe attribute is necessary, because A .or. B might overlap with C.
        integer, target, intent(in) :: A(:), B(:)
        integer, target, intent(inout) :: C(:)
        integer :: i, j, k

        if (size(A) + size(B) > size(C)) stop(1)

        i = 1; j = 1
        do k = 1, size(C)
          if (i <= size(A) .and. j <= size(B)) then
            if (A(i) <= B(j)) then
              C(k) = A(i)
              i = i + 1
            else
              C(k) = B(j)
              j = j + 1
            end if
          else if (i <= size(A)) then
            C(k) = A(i)
            i = i + 1
          else if (j <= size(B)) then
            C(k) = B(j)
            j = j + 1
          end if
        end do
      end subroutine merge

      subroutine swap(x, y)
        implicit none
        integer, intent(inout) :: x, y
        integer :: tmp
        tmp = x; x = y; y = tmp
      end subroutine

      recursive subroutine MergeSort(A, work)
        implicit none
        integer, intent(inout) :: A(:)
        integer, intent(inout) :: work(:)
        integer :: half
        half = (size(A) + 1) / 2
        if (size(A) < 2) then
          continue
        else if (size(A) == 2) then
          if (A(1) > A(2)) then
            call swap(A(1), A(2))
          end if
        else
          call MergeSort(A( : half), work)
          call MergeSort(A(half + 1 :), work)
          if (A(half) > A(half + 1)) then
            work(1 : half) = A(1 : half)
            call merge(work(1 : half), A(half + 1:), A)
          endif
        end if
      end subroutine MergeSort
      end program TestMergeSort


C
C ***************** FORTRAN CALLABLE ROUTINE *********************
C
C RETURNS .TRUE. IF |N| IS A POWER OF 2.
C POW IS OPTIONAL ARGUMENT GIVING FIRST POWER OF 2 .GE. |N|.
C  85-5-10  ...LWK...
C  93-7-23  ...DDK...

	INTEGER*2 FUNCTION TWOPOW( N, POW)

	INTEGER*2 N, POW, NN, P, I

        TWOPOW = 1
	IF (N.EQ.0) RETURN	! IN THIS CASE POW IS UNDEFINED

        NN = ABS(N)

	P = 0
	I = 1
	DO WHILE (I.LT.NN)
	  P = P+1
	  I = 2*I
	ENDDO

	IF (I.NE.NN) TWOPOW = 0

        IF (NN.NE.0) POW = P

	RETURN
	END


PROGRAM kindCheck
  IMPLICIT NONE

  INTEGER     :: i
  REAL        :: r
  COMPLEX     :: cp
  CHARACTER   :: c
  LOGICAL     :: lg
  !***********************************************************
  !syntax SELECTED_REAL_KIND(P, R, RADIXI)I
  !A real data type with decimal precision at least P digits
  !a deciaml exponent range of at least R
  !and with the requested RADIX
  !***********************************************************

  INTEGER, PARAMETER :: p6 = SELECTED_REAL_KIND(6)
  INTEGER, PARAMETER :: p10r100 = SELECTED_REAL_KIND(10,100)
  INTEGER, PARAMETER :: r400 = SELECTED_REAL_KIND(r=400)
  REAL(kind=p6)      :: x
  REAL(kind=p10r100) :: y
  REAL(kind=r400)    :: z

  WRITE(*,*)"________________________________________________"
  PRINT *,'The default kind of different data type '
  PRINT *,'Real     ', KIND(r)
  PRINT *,'Complex  ', KIND(cp)
  PRINT *,'Character', KIND(c)
  PRINT *,'Logical  ', KIND(lg)
  WRITE(*,*)"________________________________________________"
  PRINT *, "precision & range ",PRECISION(x),RANGE(x)
  PRINT *, "precision & range ",PRECISION(y),RANGE(y)
  PRINT *, "precision & range ",PRECISION(z),RANGE(z)
  WRITE(*,*)"________________________________________________"
  PRINT *,41_p6
END PROGRAM kindCheck


module networks
  use nrtype
  use ieee_arithmetic
!https://en.wikipedia.org/wiki/Dijkstra's_algorithm
!https://en.wikipedia.org/wiki/Brodal_queue
!https://en.wikipedia.org/wiki/Priority_queue
!https://www.cs.auckland.ac.nz/software/AlgAnim/dijkstra.html
!http://www.geeksforgeeks.org/greedy-algorithms-set-6-dijkstras-shortest-path-algorithm/
!http://www.personal.kent.edu/~rmuhamma/Algorithms/MyAlgorithms/GraphAlgor/dijkstraAlgor.htm
!https://www.cs.princeton.edu/~rs/AlgsDS07/15ShortestPaths.pdf
!http://math.mit.edu/~rothvoss/18.304.3PM/Presentations/1-Melissa.pdf
!http://rosettacode.org/wiki/Dijkstra's_algorithm

contains

  function inf(sign)
    implicit none
    integer(i1), intent(in) :: sign
    real                    :: inf

    ! Choose Sign.
    cs: if (sign > 0) then
      inf = ieee_value(inf,  ieee_positive_inf)
    else cs
      inf = ieee_value(inf,  ieee_negative_inf)
    end if cs
  end function inf

  subroutine dijkstra(graph, s, dist, prev)
    implicit none

    integer, intent(in)  :: s ! s = source
    real(dp), intent(in) :: graph(:,:)
    real(dp), intent(out), dimension(size(graph, dim = 1)) :: dist
    integer, dimension(size(graph, dim = 1))               :: visited, prev
    integer :: nv, v, u, ndist, mdist ! v = target node, u = current node with minimum distance to v, ndist = new distance from u to v.
    integer :: i ! counter

    ! Number of vertices (nodes)
    nv = size(graph, dim = 1)

    ! Check Graph Size.
    if ( nv /= size(graph, dim=2) ) &
      write(*,*) " Matrix size error: networks.f08: dijkstra: cgs: Graph provided must be a square matrix. &
      Dimension 1 = ", size(graph, dim=1), " Dimension 2 = ", size(graph, dim=2)

    ! Initialising variables.
    dist = graph(s,1:nv) ! One step distance from node s to the rest.
    !print*, "---------------"
    !print*, dist
    !print*, "---------------"
    prev = -1 ! Previously visited node.
    visited = 0 ! No nodes have been visited.
    visited(s) = 1 ! Source has been visited.
    !print*, "---------------"
    !print*, visited
    !print*, "---------------"

    ! Dijkstra's Algorithm
    da: do i = 1, nv
      if (i == s) cycle da
      call find_nearest(nv, dist, visited, v)
      if (v == -1) return
      visited(v) = 1
      call update_dist(nv, graph, dist, visited, v, prev)

    end do da
  end subroutine dijkstra

  subroutine find_nearest(nv, dist, visited, v)
    implicit none
    integer, intent(in)  :: nv
    real(dp), intent(in) :: dist(:)
    integer, intent(in)  :: visited(:)
    integer, intent(out) :: v
    real(dp) :: mdist
    integer  :: i ! counter

    mdist = inf(1_i1)
    v     = -1

    ! Find Minimum Distance.

    fmd: do i = 1, nv
      ! Check if the node has Not been Visited, and whether it is Connected to the Source node.
      nvc: if (visited(i) == 0 .and. dist(i) < mdist) then
        ! If the node has not been visited and it is connected to the source.
        ! The minimum distance is the distance to node i, and the node is node i.
        mdist = dist(i)
        v     = i
      end if nvc
    end do fmd

  end subroutine find_nearest

  subroutine update_dist(nv, graph, dist, visited, v, prev)
    implicit none
    integer, intent(in)     :: nv
    real(dp), intent(in)    :: graph(:,:)
    integer, intent(in)     :: visited(:)
    integer, intent(in)     :: v
    real(dp), intent(inout) :: dist(:)
    integer, intent(out) :: prev(:)
    real(dp) :: newdist
    integer :: i

    ! Calculate the Minimum Distance.
    cmd: do i = 1, nv
      ! Check if we've visited node i or if node v and i are not connected, move on to the next node i.
      if ( visited(i) == 1 .or. graph(v,i) == inf(1_i1) ) cycle cmd
      ! Check whether the New Distance from node v node i is Less than the Previous minimum distance to node i.
      newdist = dist(v) + graph(v,i)
      ndlpd: if (newdist < dist(i)) then
        ! If it is, then update the new minimum distance.
        dist(i) = newdist
        prev(i) = v
      end if ndlpd
    end do cmd
  end subroutine update_dist

  subroutine print_target(file, t, dist, prev)
    implicit none
    integer, intent(in)  :: file, t, prev(:) ! file unit, target, previous node
    real(dp), intent(in) :: dist(:)

    write(1,*) " Minimum distance = ", dist(t)

    do
      write(1,*) t
      t = prev(t)
      if (t == -1) return
    end do

  end subroutine print_target
end module networks


subroutine lltsol(n, y, x, alu, jlu, ju)

    implicit none
    !implicit real*8(a-h,o-z)

    integer n, jlu(*), ju(*)
    real*8 x(n), y(n), alu(*)

    ! local variables

    integer i, k
    real*8 sum

    ! forward solve (with L)

    do i = 1, n
        sum = 0.0D0
        do k=ju(i),ju(i+1)-1
            sum = sum + alu(k) * x(jlu(k))
        enddo
        x(i) = (y(i) - sum) * alu(i)
    enddo

    ! backward solve (with L^T)

    do i = n,1,-1
        do k = ju(i), ju(i+1)-1
            x(jlu(k)) = x(jlu(k)) - alu(k) * x(i) *alu(i)
        enddo
        x(i) = x(i) * alu(i)
    enddo

end subroutine lltsol


!
! nlp-unconstrained-cli/hooke-jeeves/f95/src/hooke.f95
! =============================================================================
! Nonlinear Optimization Algorithms Multilang. Version 0.1
! =============================================================================
! Nonlinear programming algorithms as the (un-)constrained minimization
! problems with the focus on their numerical expression using various
! programming languages.
!
! This is the Hooke and Jeeves nonlinear unconstrained minimization algorithm.
! =============================================================================
! Written by Radislav (Radicchio) Golubtsov, 2015-2020
!
! This is free and unencumbered software released into the public domain.
!
! Anyone is free to copy, modify, publish, use, compile, sell, or
! distribute this software, either in source code form or as a compiled
! binary, for any purpose, commercial or non-commercial, and by any
! means.
!
! (See the LICENSE file at the top of the source tree.)
!

! === Helper module.
! Contains constants and variables declaration and function prototypes.
module proto__
    implicit none

    ! Constant. The double precision kind for real type values.
    integer, parameter :: DP = kind(1.d0)

    ! Constant. The maximum number of variables.
    integer, parameter :: VARS = 250

    ! Constant. The stepsize geometric shrink.
    real(DP), parameter :: RHO_BEGIN = 0.5

    ! The Hooke & Jeeves algorithm works reasonably well on Rosenbrock's
    ! function, but can fare worse on some standard test functions,
    ! depending on rho. Here is an example that works well when rho = 0.5,
    ! but fares poorly with rho = 0.6, and better again with rho = 0.8.
    real(DP), parameter :: RHO_WOODS = 0.6

    ! Constant. The ending value of stepsize.
    real(DP), parameter :: EPSMIN = 1e-6

    ! Constant. The maximum number of iterations.
    integer, parameter :: IMAX = 5000

    ! The number of function evaluations.
    integer :: FUNEVALS = 0

    ! Function prototypes.
    interface
        ! The objective function f(x,n).
        real(kind(1.d0)) function f(x, n)
            real(kind(1.d0)), intent(in) :: x(:)
            integer, intent(in)          :: n
        end function f

        ! The helper function best_nearby(...).
        real(kind(1.d0)) function best_nearby(delta, point, prevbest, nvars)
            real(kind(1.d0)), intent(inout) :: delta(:)
            real(kind(1.d0)), intent(inout) :: point(:)
            real(kind(1.d0)), intent(in)    :: prevbest
            integer, intent(in)             :: nvars
        end function best_nearby

        ! The main optimization function hooke(...).
        integer function hooke(nvars, startpt, endpt, rho, epsilon, itermax)
            integer, intent(in)           :: nvars
            real(kind(1.d0)), intent(in)  :: startpt(:)
            real(kind(1.d0)), intent(out) :: endpt(:)
            real(kind(1.d0)), intent(in)  :: rho
            real(kind(1.d0)), intent(in)  :: epsilon
            integer, intent(in)           :: itermax
        end function hooke
    end interface
end module proto__

! === The user-supplied objective function f(x,n).
real(DP) function f(x, n)
    use proto__, only: DP, FUNEVALS

    implicit none

    ! Returns: The objective function value.

    ! Arg. The point at which f(x) should be evaluated.
    real(DP), intent(in) :: x(:)

    ! Arg. The number of coordinates of x.
    integer, intent(in) :: n

#ifndef WOODS
    ! Rosenbrock's classic parabolic valley ("banana") function.
    real(DP) :: a
    real(DP) :: b
    real(DP) :: c

    FUNEVALS = FUNEVALS + 1

    a = x(1)
    b = x(2)

    c = 100.0 * (b - (a * a)) * (b - (a * a))

    f = c + ((1.0 - a) * (1.0 - a))
#else
    ! Woods -- a la More, Garbow & Hillstrom (TOMS algorithm 566).
    real(DP) :: s1
    real(DP) :: s2
    real(DP) :: s3
    real(DP) :: t1
    real(DP) :: t2
    real(DP) :: t3
    real(DP) :: t4
    real(DP) :: t5

    FUNEVALS = FUNEVALS + 1

    s1 = x(2) - x(1) * x(1)
    s2 = 1    - x(1)
    s3 = x(2) - 1

    t1 = x(4) - x(3) * x(3)
    t2 = 1    - x(3)
    t3 = x(4) - 1

    t4 = s3 + t3
    t5 = s3 - t3

    f = 100 * (s1 * s1) + s2 * s2 &
       + 90 * (t1 * t1) + t2 * t2 &
       + 10 * (t4 * t4) + t5 * t5 / 10.
#endif

    if (n == 0) then
        write (*, '("Warning: The number of coordinates of x = 0.")')
    end if
end function f

! === Helper function.
! Given a point, look for a better one nearby, one coord at a time.
real(DP) function best_nearby(delta, point, prevbest, nvars)
    use proto__, only: DP, VARS, f

    implicit none

    ! Returns: The objective function value at a nearby.

    ! Arg. The delta between prevbest and point.
    real(DP), intent(inout) :: delta(:)

    ! Arg. The coordinate from where to begin.
    real(DP), intent(inout) :: point(:)

    ! Arg. The previous best-valued coordinate.
    real(DP), intent(in) :: prevbest

    ! Arg. The number of variables.
    integer, intent(in) :: nvars

    real(DP) :: minf
    real(DP) :: z(VARS)
    real(DP) :: ftmp

    integer :: i

    minf = prevbest

    do i = 1, nvars
        z(i) = point(i)
    end do

    do i = 1, nvars
        z(i) = point(i) + delta(i)

        ftmp = f(z, nvars)

        if (ftmp < minf) then
            minf = ftmp
        else
            delta(i) = 0.0 - delta(i)
            z(i)     = point(i) + delta(i)

            ftmp = f(z, nvars)

            if (ftmp < minf) then
                minf = ftmp
            else
                z(i) = point(i)
            end if
        end if
    end do

    do i = 1, nvars
        point(i) = z(i)
    end do

    best_nearby = minf
end function best_nearby

! === Main optimization function.
! The hooke subroutine itself.
integer function hooke(nvars, startpt, endpt, rho, epsilon, itermax)
    use proto__, only: DP, VARS, FUNEVALS, f, best_nearby

    implicit none

    ! Returns: The number of iterations used to find the local minimum.

    ! Arg. The number of variables.
    integer, intent(in) :: nvars

    ! Arg. The starting point coordinates.
    real(DP), intent(in) :: startpt(:)

    ! Arg. The ending point coordinates.
    real(DP), intent(out) :: endpt(:)

    ! Arg. The rho value.
    real(DP), intent(in) :: rho

    ! Arg. The epsilon value.
    real(DP), intent(in) :: epsilon

    ! Arg. The maximum number of iterations.
    integer, intent(in) :: itermax

    integer :: i
    integer :: iadj
    integer :: iters
    integer :: j
    integer :: keep

    real(DP) :: newx(VARS)
    real(DP) :: xbefore(VARS)
    real(DP) :: delta(VARS)
    real(DP) :: steplength
    real(DP) :: fbefore
    real(DP) :: newf
    real(DP) :: tmp

    do i = 1, nvars
        xbefore(i) = startpt(i)
        newx(i)    = xbefore(i)

        delta(i) = abs(startpt(i) * rho)

        if (delta(i) == 0.0) then
            delta(i) = rho
        end if
    end do

    iadj       = 0
    steplength = rho
    iters      = 0

    fbefore = f(newx, nvars)

    newf = fbefore

    do while ((iters < itermax) .and. (steplength > epsilon))
        iters = iters + 1
        iadj  = iadj + 1

        write ( &
            *, '(/, "After ", i5, " funevals, f(x) =  ", 1pe10.4e2, " at")' &
        ) FUNEVALS, fbefore

        do j = 1, nvars
            write (*, '("   x[", i2, "] = ", 1pe11.4e2)') j - 1, xbefore(j)
        end do

        ! Find best new point, one coord at a time.
        do i = 1, nvars
            newx(i) = xbefore(i)
        end do

        newf = best_nearby(delta, newx, fbefore, nvars)

        ! If we made some improvements, pursue that direction.
        keep = 1

        do while ((newf < fbefore) .and. (keep == 1))
            iadj = 0

            do i = 1, nvars
                ! Firstly, arrange the sign of delta().
                if (newx(i) <= xbefore(i)) then
                    delta(i) = 0.0 - abs(delta(i))
                else
                    delta(i) = abs(delta(i))
                end if

                ! Now, move further in this direction.
                tmp        = xbefore(i)
                xbefore(i) = newx(i)
                newx(i)    = newx(i) + newx(i) - tmp
            end do

            fbefore = newf

            newf = best_nearby(delta, newx, fbefore, nvars)

            ! If the further (optimistic) move was bad....
            if (newf >= fbefore) then
                exit
            end if

            ! Make sure that the differences between the new and the old
            ! points are due to actual displacements; beware of roundoff
            ! errors that might cause newf < fbefore.
            keep = 0

            do i = 1, nvars
                keep = 1

                if (abs(newx(i) - xbefore(i)) > (0.5 * abs(delta(i)))) then
                    exit
                else
                    keep = 0
                end if
            end do
        end do

        if ((steplength >= epsilon) .and. (newf >= fbefore)) then
            steplength = steplength * rho

            do i = 1, nvars
                delta(i) = delta(i) * rho
            end do
        end if
    end do

    do i = 1, nvars
        endpt(i) = xbefore(i)
    end do

    hooke = iters
end function hooke

! === Main program.
program hooke__
    use proto__, only: DP, VARS, RHO_BEGIN, RHO_WOODS, EPSMIN, IMAX, hooke

    implicit none

    integer :: nvars
    integer :: itermax
    integer :: jj
    integer :: i

    real(DP) :: startpt(VARS)
    real(DP) :: rho
    real(DP) :: epsilon
    real(DP) :: endpt(VARS)

#ifndef WOODS
    ! Starting guess for Rosenbrock's test function.
    nvars      =  2
    startpt(1) = -1.2
    startpt(2) =  1.0
    rho        =  RHO_BEGIN
#else
    ! Starting guess test problem "Woods".
    nvars      =  4
    startpt(1) = -3
    startpt(2) = -1
    startpt(3) = -3
    startpt(4) = -1
    rho        =  RHO_WOODS
#endif

    itermax = IMAX
    epsilon = EPSMIN

    jj = hooke(nvars, startpt, endpt, rho, epsilon, itermax)

    write (*, '(///, "HOOKE USED ", i2, " ITERATIONS, AND RETURNED")') jj

    do i = 1, nvars
        write (*, '("x[", i3, "] = ", 1pe15.7e2, " ")') i - 1, endpt(i)
    end do

#ifdef WOODS
    write (*, '("True answer: f(1, 1, 1, 1) = 0.")')
#endif
end program hooke__

! vim:set nu et ts=4 sw=4:


module DVectors
  private
  public :: dvector
  public :: axpby_dvector
  public :: dot_dvector
  public :: norm_dvector

  !! simple real vector
  type :: dvector
     !! vector length
     integer :: size
     !! vector coefficients
     double precision, allocatable :: coefficients(:)
   contains
     !! constructor
     procedure, public, pass :: init => init_dvector
     !! destructor
     procedure, public, pass :: kill => kill_dvector
     !! axpby procedure
     procedure, public, nopass :: axpby => axpby_dvector
     !! get procedure
     procedure, public, pass :: get => get_dvector
     !! set procedure
     procedure, public, pass :: set => set_dvector
  end type dvector

  !procedure, public :: scalar_product => scalar_product_dvector

contains
  !! constructor
  subroutine init_dvector(this,size)
    implicit none
    class(dvector),     intent(inout) :: this
    integer,       intent(in   ) :: size

    this%size=size
    allocate(this%coefficients(size))

  end subroutine init_dvector

  !! destructor
  subroutine kill_dvector(this)
    implicit none
    class(dvector),     intent(inout) :: this

    this%size=0
    deallocate(this%coefficients)

  end subroutine kill_dvector

  subroutine axpby_dvector(alpha,x,beta,y)
    use Precision
    implicit none
    double precision,      intent(in   ) :: alpha
    class(dvector),         intent(in   ) :: x
    double precision,      intent(in   ) :: beta
    class(dvector),         intent(inout) :: y

    !! not optimized
    y%coefficients=alpha*x%coefficients+beta*y%coefficients

  end subroutine axpby_dvector

  !! get one entry procedure
  function get_dvector(x, index) result(res)
    implicit none
    !!
    class(dvector),    intent(in   ) :: x
    integer,           intent(in   ) :: index
    double precision  :: res

    res = x%coefficients(index)

  end function get_dvector

  !! set one entry procedure
  subroutine set_dvector(x, index, value)
    implicit none
    !!
    class(dvector),   intent(inout) :: x
    integer,          intent(in   ) :: index
    double precision, intent(in   ) :: value

    x%coefficients(index)=value

  end subroutine set_dvector

  !! scalar product of two vectors
  function dot_dvector(x,y) result(res)
    implicit none
    class(dvector), intent(in   ) :: x
    class(dvector), intent(in   ) :: y
    double precision :: res
    ! local
    integer :: i

    res=0.0d0
    do i=1,x%size
       res=res+x%coefficients(i)*y%coefficients(i)
    end do

  end function dot_dvector

  !! vector norm
  function norm_dvector(x) result(res)
    implicit none
    class(dvector), intent(in   ) :: x
    double precision :: res

    res=sqrt(dot_dvector(x,x))

  end function norm_dvector

end module DVectors


subroutine potinv (a, q, u, v, xlam, eps, nmaxit, ier)

  use lu_interface
  use sistu_interface
  use sistl_interface

  implicit none

  real, dimension(:,:), intent(inout) :: a
  real, intent(in) :: q
  real, dimension(:), intent(out) :: u, v
  real, intent(inout) :: xlam
  real, intent(in) :: eps
  integer, intent(in) :: nmaxit
  integer, intent(out) :: ier

  real,dimension(:), allocatable :: w

  integer :: n, iter, i, j
  real :: xn , s, xlam1, xlam2, deter

  n = size(a(1,:))

  allocate(w(n))

  do i=1,n
    a(i,i) = a(i,i) - q
  end do

  call lu(a, deter, ier)

  if(ier .ne. 0) then
    ier = 1
    return
  end if

  u = 0
  u(1) = 1

  do iter = 1, nmaxit

    call sistl(a,u,w)
    call sistu(a,w,v)

    s = 0
    xn = 0

    do i=1,n
      s = s + u(i)*v(i)
      xn = xn + v(i)*v(i)
    end do

    xn = sqrt(xn)

    do i=1,n
      u(i) = v(i)/xn
    end do

    xlam = 1./(s+q)

    if(iter .ne. 1) then
      if(abs(xlam - xlam1) .le. eps) then
        ier = 3
        return
      end if
    end if
    xlam1 = xlam
  end do

  ier = 4

end subroutine


module test_func

    use testdrive, only: new_unittest, unittest_type, error_type, check
    use auto_diff, only: abs, exp, sqrt, sin, cos, tan, log, log10
    use auto_diff, only: max, min, sigmoid
    use auto_diff, only: tree_t, rk, assignment(=)
    implicit none
    private

    public :: collect_suite_func

contains

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

        testsuite = [ &
                    new_unittest("func abs valid", test_abs_valid), &
                    new_unittest("func exp valid", test_exp_valid), &
                    new_unittest("func sqrt valid", test_sqrt_valid), &
                    new_unittest("func sin valid", test_sin_valid), &
                    new_unittest("func cos valid", test_cos_valid), &
                    new_unittest("func tan valid", test_tan_valid), &
                    new_unittest("func log valid", test_log_valid), &
                    new_unittest("func log10 valid", test_log10_valid), &
                    new_unittest("func max valid", test_max_valid), &
                    new_unittest("func min valid", test_min_valid), &
                    new_unittest("func sigmoid valid", test_sigmoid_valid) &
                    ]

    end subroutine collect_suite_func

    subroutine test_abs_valid(error)
        type(error_type), allocatable, intent(out) :: error

        type(tree_t) :: a
        type(tree_t) :: b

        a = 2.0_rk
        b = abs(a)
        call b%backward()

        call check(error, b%get_value(), 2.0_rk); if (allocated(error)) return
        call check(error, a%get_grad(), 1.0_rk)

    end subroutine test_abs_valid

    subroutine test_sqrt_valid(error)
        type(error_type), allocatable, intent(out) :: error

        type(tree_t) :: a
        type(tree_t) :: b

        a = 2.0_rk
        b = sqrt(a)
        call b%backward()

        call check(error, b%get_value(), sqrt(2.0_rk)); if (allocated(error)) return
        call check(error, a%get_grad(), 1.0_rk/(2.0_rk*sqrt(2.0_rk)))

    end subroutine test_sqrt_valid

    subroutine test_exp_valid(error)
        type(error_type), allocatable, intent(out) :: error

        type(tree_t) :: a
        type(tree_t) :: b

        a = 2.0_rk
        b = exp(a)
        call b%backward()

        call check(error, b%get_value(), exp(2.0_rk)); if (allocated(error)) return
        call check(error, a%get_grad(), exp(2.0_rk))

    end subroutine test_exp_valid

    subroutine test_sin_valid(error)
        type(error_type), allocatable, intent(out) :: error

        type(tree_t) :: a
        type(tree_t) :: b

        a = 2.0_rk
        b = sin(a)
        call b%backward()

        call check(error, b%get_value(), sin(2.0_rk)); if (allocated(error)) return
        call check(error, a%get_grad(), cos(2.0_rk))

    end subroutine test_sin_valid

    subroutine test_cos_valid(error)
        type(error_type), allocatable, intent(out) :: error

        type(tree_t) :: a
        type(tree_t) :: b

        a = 2.0_rk
        b = cos(a)
        call b%backward()

        call check(error, b%get_value(), cos(2.0_rk)); if (allocated(error)) return
        call check(error, a%get_grad(), -sin(2.0_rk))

    end subroutine test_cos_valid

    subroutine test_tan_valid(error)
        type(error_type), allocatable, intent(out) :: error

        type(tree_t) :: a
        type(tree_t) :: b

        a = 2.0_rk
        b = tan(a)
        call b%backward()

        call check(error, b%get_value(), tan(2.0_rk)); if (allocated(error)) return
        call check(error, a%get_grad(), 1.0_rk/(cos(2.0_rk)**2))

    end subroutine test_tan_valid

    subroutine test_log_valid(error)
        type(error_type), allocatable, intent(out) :: error

        type(tree_t) :: a
        type(tree_t) :: b

        a = 2.0_rk
        b = log(a)
        call b%backward()

        call check(error, b%get_value(), log(2.0_rk)); if (allocated(error)) return
        call check(error, a%get_grad(), 1.0_rk/2.0_rk)

    end subroutine test_log_valid

    subroutine test_log10_valid(error)
        type(error_type), allocatable, intent(out) :: error

        type(tree_t) :: a
        type(tree_t) :: b

        a = 2.0_rk
        b = log10(a)
        call b%backward()

        call check(error, b%get_value(), log10(2.0_rk)); if (allocated(error)) return
        call check(error, a%get_grad(), 1.0_rk/log(10.0_rk)/2.0_rk)

    end subroutine test_log10_valid

    subroutine test_max_valid(error)
        type(error_type), allocatable, intent(out) :: error

        type(tree_t) :: a
        type(tree_t) :: b

        a = 2.0_rk
        b = max(a, a)
        call b%backward()

        call check(error, b%get_value(), 2.0_rk); if (allocated(error)) return
        call check(error, a%get_grad(), 1.0_rk)

    end subroutine test_max_valid

    subroutine test_min_valid(error)
        type(error_type), allocatable, intent(out) :: error

        type(tree_t) :: a
        type(tree_t) :: b

        a = 2.0_rk
        b = min(a, a)
        call b%backward()

        call check(error, b%get_value(), 2.0_rk); if (allocated(error)) return
        call check(error, a%get_grad(), 1.0_rk)

        a = 1.0_rk
        b = min(a, 2.0_rk)
        call b%backward()

        call check(error, b%get_value(), 1.0_rk); if (allocated(error)) return
        call check(error, a%get_grad(), 1.0_rk)

        !> Not implemented yet
        ! call a%constructor(value=1.0_rk)
        ! b = min(2.0_rk, a)
        ! call b%backward()

        ! call check(error, b%get_value(), 1.0_rk)
        ! call check(error, a%get_grad(), 1.0_rk)

    end subroutine test_min_valid

    subroutine test_sigmoid_valid(error)
        type(error_type), allocatable, intent(out) :: error

        type(tree_t) :: a
        type(tree_t) :: b

        a = 2.0_rk
        b = sigmoid(a)
        call b%backward()

        call check(error, b%get_value(), 1.0_rk/(1.0_rk+exp(-2.0_rk))); if (allocated(error)) return
        call check(error, a%get_grad(), 0.10499358540350662_rk)

    end subroutine test_sigmoid_valid

end module test_func


SUBROUTINE for_update1(u, dx2, dy2, nx, ny)
real(8), intent(inout) :: u(nx,ny)
real(8), intent(in) :: dx2, dy2
integer, intent(in) :: nx, ny
integer :: i, j

DO j = 2, ny-1
    DO i = 2, nx-1
        u(i, j) = ((u(i+1, j) + u(i-1, j)) * dy2 + &
                   (u(i, j+1) + u(i, j-1)) * dx2) * (1./ (2*(dx2+dy2)))
    END DO
END DO
END SUBROUTINE

SUBROUTINE for_update2(u, dx2, dy2, nx, ny)
real(8), intent(inout) :: u(nx,ny)
real(8), intent(in) :: dx2, dy2
integer, intent(in) :: nx, ny

u(2:nx-1,2:ny-1) = ((u(3:,2:ny-1)+u(:ny-2,2:ny-1))*dy2 + &
        (u(2:nx-1,3:) + u(2:nx-1,:ny-2))*dx2) * (1./ (2*(dx2+dy2)))
END SUBROUTINE


! This example is based on
!
!   http://www.radford.edu/~thompson/vodef90web/vodef90source/Double/Prologue_Examples/example1.f90
!
! Some notes from example1.f90:
!
!   The problem is from chemical kinetics, and consists of the following
!   three rate equations:
!
!     dy1/dt = -.04d0*y1 + 1.d4*y2*y3
!     dy2/dt = .04d0*y1 - 1.d4*y2*y3 - 3.d7*y2**2
!     dy3/dt = 3.d7*y2**2
!
!   on the interval from t = 0.0d0 to t = 4.d10, with initial
!   conditions y1 = 1.0d0, y2 = y3 = 0.0d0. The problem is stiff.
!
! Here we're going to solve the same problem, except:
!   * we'll evolve two solutions / initial conditions at the same time
!   * the Jacobian will be computed using the first solution only
!

module feval
  use bdf
  use bl_types
  implicit none
  integer, parameter :: neq = 3
  integer, parameter :: npt = 2
contains
  subroutine f(neq, y, t, ydot, upar)
    integer,  intent(in   ) :: neq
    real(dp_t), intent(in   ) :: y(neq), t
    real(dp_t), intent(  out) :: ydot(neq)
    real(dp_t), intent(inout), optional :: upar(:)

    ydot(1) = -.04d0*y(1) + 1.d4*y(2)*y(3)
    ydot(3) = 3.e7*y(2)*y(2)
    ydot(2) = -ydot(1) - ydot(3)
  end subroutine f
  subroutine J(neq, y, t, pd, upar)
    integer,  intent(in   ) :: neq
    real(dp_t), intent(in   ) :: y(neq), t
    real(dp_t), intent(  out) :: pd(neq,neq)
    real(dp_t), intent(inout), optional :: upar(:)

    pd(1,1) = -.04d0
    pd(1,2) = 1.d4*y(3)
    pd(1,3) = 1.d4*y(2)
    pd(2,1) = .04d0
    pd(2,3) = -pd(1,3)
    pd(3,2) = 6.e7*y(2)
    pd(2,2) = -pd(1,2) - pd(3,2)
  end subroutine J
end module feval

program test
  use bdf
  use feval
  implicit none

  type(bdf_ts)  :: ts
  double precision :: rtol(neq), atol(neq), dt
  double precision :: y0(neq,npt), t0, y1(neq,npt), t1

  integer :: i, ierr

  y0(:,1) = [ 1.d0, 0.d0, 0.d0 ]
  y0(:,2) = [ 0.98516927747181138d0, 3.3863452485889568d-5, 1.4796859075703273d-2 ]

  t0 = 0.d0
  t1 = 0.4d0

  rtol = 1.d-4
  atol = [ 1.d-8, 1.d-14, 1.d-6 ]
  dt   = 1.d-8

  call bdf_ts_build(ts, neq, npt, rtol, atol, max_order=3)

  do i = 1, 11
     call bdf_advance(ts, f, J, neq, npt, y0, t0, y1, t1, dt, .true., .false., ierr)
     print *, t1, y1(:,1), ierr, errors(ierr)
     print *, '                         ', y1(:,2), ts%dt
     if (ierr /= BDF_ERR_SUCCESS) exit
     y0 = y1
     t0 = t1
     t1 = 10*t1
     dt = 2*maxval(ts%dt)
  end do

  print *, ''
  print *, 'max stats for last interval'
  print *, 'number of steps taken      ', ts%n
  print *, 'number of function evals   ', maxval(ts%nfe)
  print *, 'number of jacobian evals   ', maxval(ts%nje)
  print *, 'number of lu decomps       ', maxval(ts%nlu)
  print *, 'number of solver iterations', maxval(ts%nit)
  print *, 'number of solver errors    ', maxval(ts%nse)

  call bdf_ts_destroy(ts)

end program test


program test_inv
   use graphite_mod
   implicit none

   real(kind=8), dimension(3,3) :: B, Binv

   B(1,1) = 212.4d0
   B(1,2) = 25.3d0
   B(1,3) = 41.3d0
   B(2,1) = 0.7d0
   B(2,2) = 8.2d0
   B(2,3) = 6.1d0
   B(3,1) = 5.0d0
   B(3,2) = 4.0d0
   B(3,3) = 3.0d0

   call inverse_3_3(B,Binv)

end program test_inv


! initialize the array, with the given value
      subroutine init(array, n1, n2, n3, value)
      implicit none
      integer n1,n2,n3,i1,i2,i3
      real array(n1,n2,n3), value

      do 300 i3=1, n3
         do 200 i2=1, n2
            do 100 i1=1, n1
               array(i1,i2,i3) = value
 100        continue
 200     continue
 300  continue
      end

! sum all the elements of the array
      real function sum_array (array, n1, n2, n3)
      implicit none
      integer n1,n2,n3,i1,i2,i3
      real array(n1,n2,n3)

      do 300 i3=1, n3
         do 200 i2=1, n2
            do 100 i1=1, n1
               sum_array = sum_array + array(i1,i2,i3)
 100        continue
 200     continue
 300  continue
      end

      subroutine stencil8(u,v,c,n1,n2,n3,is1,ie1,is2,ie2,is3,ie3)
          ! Stencil length : 2*L

          implicit none
          integer i1,i2,i3,is1,ie1,is2,ie2,is3,ie3,n1,n2,n3,L
          parameter(L=4)
          real u(n1,n2,n3), v(n1,n2,n3)
          real c(-L:L)
          real c_4, c_3, c_1, c_2, c0, c1, c2, c3, c4

          c_4 = c(-4)
          c_3 = c(-3)
          c_2 = c(-2)
          c_1 = c(-1)
          c0 = c(0)
          c1 = c(1)
          c2 = c(2)
          c3 = c(3)
          c4 = c(4)

          do 300 i3=is3+L,ie3-L
           do 200 i2=is2+L,ie2-L
            do 100 i1=is1+L,ie1-L
             u(i1,i2,i3) =
     &            c_4 * (v(i1-4,i2,i3) + v(i1,i2-4,i3) + v(i1,i2,i3-4))
     &          + c_3 * (v(i1-3,i2,i3) + v(i1,i2-3,i3) + v(i1,i2,i3-3))
     &          + c_2 * (v(i1-2,i2,i3) + v(i1,i2-2,i3) + v(i1,i2,i3-2))
     &          + c_1 * (v(i1-1,i2,i3) + v(i1,i2-1,i3) + v(i1,i2,i3-1))
     &          + c0  *  v(i1,  i2,i3) * 3
     &          + c1  * (v(i1+1,i2,i3) + v(i1,i2+1,i3) + v(i1,i2,i3+1))
     &          + c2  * (v(i1+2,i2,i3) + v(i1,i2+2,i3) + v(i1,i2,i3+2))
     &          + c3  * (v(i1+3,i2,i3) + v(i1,i2+3,i3) + v(i1,i2,i3+3))
     &          + c4  * (v(i1+4,i2,i3) + v(i1,i2+4,i3) + v(i1,i2,i3+4))
 100         continue
 200        continue
 300       continue

      end

      program main
      implicit none
      integer n1,n2,n3,L,is1,ie1,is2,ie2,is3,ie3,i
      parameter(L=4, n1=100, n2=100, n3=100)
      real src(n1,n2,n3), dst(n1,n2,n3), coeff(-L:L), result
      real sum_array
      is1=1;ie1=n1
      is2=1;ie2=n2
      is3=1;ie3=n3

      do 400 i=-L,L
         coeff(i) = 3.0
400   continue

      call init (src, n1, n2, n3, 1.0)
      call stencil8 (dst,src,coeff,n1,n2,n3,is1,ie1,is2,ie2,is3,ie3)
      result = sum_array (dst, n1, n2, n3)
      PRINT *, ("the sum is"), result
      end


SUBROUTINE bandred(a,d,e)
!
! This subroutine transforms a real symmetric band matrix a,
! of order n and band width iw, to tridiagonal form by an appropriate
! sequence of Jacobi rotations. During the transformation the
! property of the band matrix is maintained. The method yields
! a tridiagonal matrix, the diagonal elements of which are in
! d(n) and off-diagonal elements in e(n).
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN OUT)::a(:,:)
 REAL(iwp),INTENT(OUT)::d(0:),e(0:)
 INTEGER::iw,n2,n,k,maxr,irr,ir,kr,j,jm,iugl,j2,l,jl,maxl,i
 REAL(iwp)::g,b,s,c,c2,s2,cs,u,u1,zero=0.0_iwp,one=1.0_iwp,two=2.0_iwp
 n=UBOUND(a,1)
 iw=UBOUND(a,2)-1
 n2=n-2
 IF(n2>=1)THEN
   loop_1: DO k=1,n2
     maxr=iw
     IF(n-k<iw)maxr=n-k
     loop_2: DO irr=2,maxr
       ir=2+maxr-irr
       kr=k+ir
       loop_3: DO j=kr,n,iw
         IF(j/=kr)THEN
           IF(ABS(g)<TINY(g))EXIT loop_3
           jm=j-iw
           b=-a(jm-1,iw+1)/g
           iugl=j-iw
         ELSE
           IF(ABS(a(k,ir+1))<TINY(a(k,ir+1)))EXIT loop_3
           b=-a(k,ir)/a(k,ir+1)
           iugl=k
         END IF
         s=one/SQRT(one+b*b)
         c=b*s
         c2=c*c
         s2=s*s
         cs=c*s
         u=c2*a(j-1,1)-two*cs*a(j-1,2)+s2*a(j,1)
         u1=s2*a(j-1,1)+two*cs*a(j-1,2)+c2*a(j,1)
         a(j-1,2)=cs*(a(j-1,1)-a(j,1))+(c2-s2)*a(j-1,2)
         a(j-1,1)=u
         a(j,1)=u1
         j2=j-2
         DO l=iugl,j2
           jl=j-l
           u=c*a(l,jl)-s*a(l,jl+1)
           a(l,jl+1)=s*a(l,jl)+c*a(l,jl+1)
           a(l,jl)=u
         END DO
         jm=j-iw
         IF(j/=kr)a(jm-1,iw+1)=c*a(jm-1,iw+1)-s*g
         maxl=iw-1
         IF(n-j<iw-1)maxl=n-j
         IF(maxl>0)THEN
           DO l=1,maxl
             u=c*a(j-1,l+2)-s*a(j,l+1)
             a(j,l+1)=s*a(j-1,l+2)+c*a(j,l+1)
             a(j-1,l+2)=u
           END DO
         END IF
         IF(j+iw<=n)THEN
           g=-s*a(j,iw+1)
           a(j,iw+1)=c*a(j,iw+1)
         END IF
       END DO loop_3
     END DO loop_2
   END DO loop_1
 END IF
 e(1)=zero
 d(1:n)=a(1:n,1)
 IF(2<=n)THEN
   DO i=2,n
     e(i)=a(i-1,2)
   END DO
 END IF
RETURN
END SUBROUTINE bandred


      module sibalb_coeff
      implicit none

      contains

      FUNCTION COEFFSIB(TABLE, NTABL, LAI ,DX, DY)

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NTABL, LAI

      REAL, INTENT(IN) :: DX, DY
      REAL, INTENT(IN), DIMENSION(NTABL,2) :: TABLE
      REAL COEFFSIB

      COEFFSIB = (TABLE(LAI,  1)                                                  &
             + (TABLE(LAI  ,2) - TABLE(LAI  ,1)) * DY ) * (1.0-DX)             &
             + (TABLE(LAI+1,1)                                                 &
             + (TABLE(LAI+1,2) - TABLE(LAI+1,1)) * DY ) * DX

      RETURN
      END FUNCTION COEFFSIB

    end module sibalb_coeff


      SUBROUTINE TB01UX( COMPZ, N, M, P, A, LDA, B, LDB, C, LDC, Z, LDZ,
     $                   NOBSV, NLBLCK, CTAU, TOL, IWORK, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute an orthogonal transformation matrix Z which reduces the
C     N-th order system (A,B,C) to the form
C
C                ( Ano  * )               ( Bno )
C       Z'*A*Z = (        ) ,      Z'*B = (     ) ,
C                ( 0   Ao )               ( Bo  )
C
C          C*Z = ( 0   Co ) ,
C
C     where the NOBSV-th order system (Ao,Bo,Co) is observable.
C     The matrix Ano of order N-NOBSV contains the unobservable
C     eigenvalues of A.
C
C     The pencil ( Ao-lambda*I ) has full column rank NOBSV for all
C                (      Co     )
C     lambda, and is in a staircase form, with
C                     _      _            _      _
C                   ( Ak,k   Ak,k-1   ... Ak,2   Ak,1   )
C                   ( _      _            _      _      )
C       ( Ao ) =    ( Ak-1,k Ak-1,k-1 ... Ak-1,2 Ak-1,1 ) ,          (1)
C       ( Co )      (  :       :      ... _ :    _ :    )
C                   (  0       0      ... A1,2   A1,1   )
C                   (                            _      )
C                   (  0       0      ... 0      A0,1   )
C           _
C     where Ai-1,i is a CTAU(i-1)-by-CTAU(i) full column rank matrix
C     (with CTAU(0) = P).
C
C     The orthogonal transformation Z, performed to reduce the system
C     matrices, can be optionally accumulated.
C
C     The reduced order system (Ao,Bo,Co) has the same transfer-function
C     matrix as the original system (A,B,C).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPZ   CHARACTER*1
C             = 'N':  do not compute Z;
C             = 'I':  Z is initialized to the unit matrix, and the
C                     orthogonal matrix Z is returned.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The dimension of the system state vector; also the order
C             of the square matrix A, the number of rows of the matrix B
C             and the number of columns of the matrix C.  N >= 0.
C
C     M       (input) INTEGER
C             The dimension of system input vector; also the number of
C             columns of the matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The dimension of system output vector; also the number of
C             rows of the matrix C.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the N-by-N state matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the transformed state matrix Z'*A*Z,
C
C                                ( Ano  *  )
C                       Z'*A*Z = (         ) ,
C                                ( 0    Ao )
C
C             where Ao is NOBSV-by-NOBSV and Ano is
C             (N-NOBSV)-by-(N-NOBSV).
C             The matrix ( Ao ) is in the observability staircase
C                        ( Co )
C             form (1).
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C             (LDB,MAX(M,P))
C             On entry, the leading N-by-M part of this array must
C             contain the N-by-M input matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the transformed input matrix Z'*B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.
C             LDB >= MAX(1,N) if M > 0 or  P > 0;
C             LDB >= 1        if M = 0 and P = 0.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed matrix
C
C                     C*Z = (  0   Co ) ,
C
C             where Co is P-by-NOBSV.
C             The matrix ( Ao ) is in the observability staircase
C                        ( Co )
C             form (1).
C
C     LDC     INTEGER
C             The leading dimension of the array C.
C             LDC >= MAX(1,M,P) if N > 0;
C             LDC >= 1          if N = 0.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,*)
C             If COMPZ = 'N': Z is not referenced.
C             If COMPZ = 'I': on entry, Z need not be set;
C                             on exit, the leading N-by-N part of this
C                             array contains the orthogonal matrix Z,
C                             i.e., the product of the transformations
C                             applied to A and C on the right.
C
C     LDZ     INTEGER
C             The leading dimension of the array Z.
C             LDZ >= 1,        if COMPZ = 'N';
C             LDZ >= MAX(1,N), if COMPZ = 'I'.
C
C     NOBSV   (output) INTEGER
C             The order of the reduced matrix Ao, and the number of
C             columns of the reduced matrix Co; also, the order of the
C             observable part of the pair (C, A-lambda*I).
C
C     NLBLCK  (output) INTEGER                         _
C             The number k, of full column rank blocks Ai-1,i in the
C             staircase form of the pencil (Ao-lambda*I) (see (1)).
C                                          (     Co    )
C
C     CTAU    (output) INTEGER array, dimension (N)
C             CTAU(i), for i = 1, ..., NLBLCK, is the column dimension
C                                           _
C             of the full column rank block Ai-1,i in the staircase
C             form (1).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in rank determinations when
C             transforming the pair (A,C). If the user sets TOL > 0,
C             then the given value of TOL is used as a lower bound for
C             reciprocal condition numbers in rank determinations; a
C             (sub)matrix whose estimated condition number is less than
C             1/TOL is considered to be of full rank.  If the user sets
C             TOL <= 0, then an implicitly computed, default tolerance,
C             defined by  TOLDEF = N*N*EPS,  is used instead, where EPS
C             is the machine precision (see LAPACK Library routine
C             DLAMCH).  TOL < 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (P)
C
C     DWORK   DOUBLE PRECISION array, dimension (N+MAX(1, N, 3*P, M))
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The subroutine is based on the dual of the reduction
C     algorithms of [1].
C
C     REFERENCES
C
C     [1] Varga, A.
C         Computation of Irreducible Generalized State-Space
C         Realizations.
C         Kybernetika, vol. 26, pp. 89-106, 1990.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable and requires
C     0( N**3 )  floating point operations.
C
C     FURTHER COMMENTS
C
C     If the system matrices A and C are badly scaled, it is
C     generally recommendable to scale them with the SLICOT routine
C     TB01ID, before calling TG01UX.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     March 2002.
C
C     REVISIONS
C
C     V. Sima, Dec. 2016.
C
C     KEYWORDS
C
C     Observability, minimal realization, orthogonal canonical form,
C     orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          COMPZ
      INTEGER            INFO, LDA, LDB, LDC, LDZ, M, N, NLBLCK, NOBSV,
     $                   P
      DOUBLE PRECISION   TOL
C     .. Array Arguments ..
      INTEGER            CTAU( * ), IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, *  ),
     $                   DWORK( * ), Z( LDZ, * )
C     .. Local Scalars ..
      LOGICAL            ILZ
      INTEGER            LBA, LDWORK
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM(1)
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           AB07MD, MA02BD, TB01UD, TB01XD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C
C     .. Executable Statements ..
C
C     Decode COMPZ.
C
      ILZ = LSAME( COMPZ, 'I' )
C
C     Test the input scalar parameters.
C
      INFO = 0
      IF( .NOT.ILZ .AND. .NOT.LSAME( COMPZ, 'N' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.1 .OR. ( MAX( M, P ).GT.0 .AND. LDB.LT.N ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.1 .OR. ( LDC.LT.MAX( M, P ) .AND. N.GT.0 ) ) THEN
         INFO = -10
      ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN
         INFO = -12
      ELSE IF( TOL.GE.ONE ) THEN
         INFO = -16
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'TB01UX', -INFO )
         RETURN
      END IF
C
C     Build the dual system.
C
      CALL AB07MD( 'Zero D', N, M, P, A, LDA, B, LDB, C, LDC, DUM, 1,
     $             INFO )
C
      LDWORK = MAX( 1, N, 3*P, M )
      CALL TB01UD( COMPZ, N, P, M, A, LDA, B, LDB, C, LDC, NOBSV,
     $             NLBLCK, CTAU, Z, LDZ, DWORK, TOL, IWORK, DWORK(N+1),
     $             LDWORK, INFO )
      IF( NLBLCK.GT.1 ) THEN
         LBA = CTAU(1) + CTAU(2) - 1
      ELSE IF( NLBLCK.EQ.1 ) THEN
         LBA = CTAU(1) - 1
      ELSE
         LBA = 0
      END IF
C
C     Compute the pertransposed dual system exploiting matrix shapes.
C
      LBA = MAX( LBA, N-NOBSV-1 )
      CALL TB01XD( 'Zero D', N, P, M, LBA, MAX( 0, N-1 ), A, LDA, B,
     $             LDB, C, LDC, DUM, 1, INFO )
      IF( ILZ )
     $   CALL MA02BD( 'Right', N, N, Z, LDZ )
      DWORK(1) = DWORK(N+1)
      RETURN
C *** Last line of TB01UX ***
      END


program oscillator
use dftatom
implicit none

! For harmonic osccilator potential, we need to set Z=0:
integer, parameter :: Z = 0
! Omega:
real(dp), parameter :: omega = 1.138_dp
! Mesh parameters:
real(dp), parameter :: r_min = 1e-7_dp, r_max = 10.0_dp, a = 10._dp
integer, parameter :: NN = 5000

real(dp), parameter :: c = 137.035999037_dp, eps = 1e-12_dp
integer :: n, l, relat, converged
real(dp) :: r(NN+1), u(size(r)), Ein, E, E_exact, error, P(size(r)), Q(size(r))
real(dp) :: Rp(NN+1)
real(dp) :: Emin_init, Emax_init

R = mesh_exp(r_min, r_max, a, NN)
Rp = mesh_exp_deriv(r_min, r_max, a, NN)
u = omega**2 * r**2 / 2

print *, "Linear spherically symmetric harmonic oscillator"
print *, "Mesh parameters (r_min, r_max, a, N):"
print "(ES10.2, F10.2, ES10.2, I10)", r_min, r_max, a, NN
print *
print "(A3, A3, A17, A17, A10)", "n", "l", "E", "E_exact", "Error"
print *
do n = 1, 7
    do l = 0, n-1
        relat = 0
        E_exact = omega * (2*n - l - 1._dp/2)
        Ein = 10
        Emin_init = 0
        Emax_init = 100
        call solve_radial_eigenproblem(n, l, Ein, eps, 100, r, rp, u, &
            Z, c, relat, .false., Emin_init, Emax_init, converged, E, P, Q)
        error = abs(E - E_exact)
        if (converged /= 0) call stop_error("Not converged")
        print "(I3, I3, F17.8, F17.8, ES10.2)", n, l, E, E_exact, error
        if (error > 1e-8_dp) call stop_error("Error is higher than 1e-8")
    end do
end do
end program


!8. Write a program that prints all prime numbers.
!(Note: if your programming language does not support arbitrary size numbers, printing all primes up to the largest number you can easily represent is fine too.)

    program Exercises
    implicit none

    ! The type 'integer' by itself doesn't have an exact size specification, it could be a two-byte or four-byte type
    ! depending on the compiler. To get an integer with a specific size, you use integer*2 or integer*4 (or possibly integer*8 if supported).
    ! Although I don't think the integer can be smaller than 2 bytes, this uses integer*2 explicitly just in case I'm wrong about that.
    integer*2 :: i

    do i=1,32767 ! Limit of two byte type
        ! Test if prime
        if (isPrime(i)) then
            print '(I0)', i
        end if
    end do

    contains

    function isPrime(i) result(r)
        integer*2, intent(in) :: i
        integer*2 :: limit
        integer*2 :: j
        logical :: r

        if (i .eq. 1 .or. i .eq. 2) then
            r = .true.
            return
        end if

        limit = i/2

        do j=2,limit
            if (mod(i, j) == 0) then
                r = .false.
                return
            end if
        end do

        r = .true.
        return
    end function

    end program Exercises


      real             function SSIN1 (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>>   1998-10-29 SSIN1 Krogh  Moved external statement up for mangle.
c>>   1994-10-20 SSIN1 Krogh  Changes to use M77CON
c>>   1993-07-21 SSIN1 WV Snyder JPL Original code
c
c     Compute (X - SIN(X)) / X**2.
c     Use Taylor's series when |X| < CUT (an internal parameter).
c     Use the intrinsic function otherwise.
c
c--S replaces "?": ?SIN1
      real             X
      external R1MACH
      real             CUT, R1MACH, ROUND, S, X2
      parameter (CUT=0.125e0)
      integer M, N
      save N
      data N /-1/
c
      if (n .lt. 0) then
         round = r1mach(4)
         n = 1
         s = 1.0e0
10       if (s .gt. round) then
            s = s * cut * cut / ((2*n)*(2*n+1))
            n = n + 1
            go to 10
         end if
      end if
      if (abs(x) .lt. cut) then
         x2 = x*x
         m = 2*n
         s = 1.0e0 - x2/(m*(m+1))
20       if (m .gt. 4) then
            m = m - 2
            s = 1.0e0 - s*x2/(m*(m+1))
            go to 20
         end if
         ssin1 = s/6.0e0
      else
         ssin1 = (x - sin(x)) / x**3
      end if
      return
      end


FUNCTION gser_s(a,x,gln)
  USE mo_kind, only: sp, i4
  USE mo_nrutil, ONLY : nrerror
  use mo_nr, ONLY : gammln
  IMPLICIT NONE
  REAL(SP), INTENT(IN) :: a,x
  REAL(SP), OPTIONAL, INTENT(OUT) :: gln
  REAL(SP) :: gser_s
  INTEGER(I4), PARAMETER :: ITMAX=100
  REAL(SP), PARAMETER :: EPS=epsilon(x)
  INTEGER(I4) :: n
  REAL(SP) :: ap,del,summ
  if (x == 0.0) then
     gser_s=0.0
     RETURN
  end if
  ap=a
  summ=1.0_sp/a
  del=summ
  do n=1,ITMAX
     ap=ap+1.0_sp
     del=del*x/ap
     summ=summ+del
     if (abs(del) < abs(summ)*EPS) exit
  end do
  if (n > ITMAX) call nrerror('a too large, ITMAX too small in gser_s')
  if (present(gln)) then
     gln=gammln(a)
     gser_s=summ*exp(-x+a*log(x)-gln)
  else
     gser_s=summ*exp(-x+a*log(x)-gammln(a))
  end if
END FUNCTION gser_s

FUNCTION gser_v(a,x,gln)
  USE mo_kind, only: sp, i4, lgt
  USE mo_nrutil, ONLY : assert_eq,nrerror
  use mo_nr, ONLY : gammln
  IMPLICIT NONE
  REAL(SP), DIMENSION(:), INTENT(IN) :: a,x
  REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln
  REAL(SP), DIMENSION(size(a)) :: gser_v
  INTEGER(I4), PARAMETER :: ITMAX=100
  REAL(SP), PARAMETER :: EPS=epsilon(x)
  INTEGER(I4) :: n
  REAL(SP), DIMENSION(size(a)) :: ap,del,summ
  LOGICAL(LGT), DIMENSION(size(a)) :: converged,zero
  n=assert_eq(size(a),size(x),'gser_v')
  zero=(x == 0.0)
  where (zero) gser_v=0.0
  ap=a
  summ=1.0_sp/a
  del=summ
  converged=zero
  do n=1,ITMAX
     where (.not. converged)
        ap=ap+1.0_sp
        del=del*x/ap
        summ=summ+del
        converged = (abs(del) < abs(summ)*EPS)
     end where
     if (all(converged)) exit
  end do
  if (n > ITMAX) call nrerror('a too large, ITMAX too small in gser_v')
  if (present(gln)) then
     if (size(gln) < size(a)) call &
          nrerror('gser_v: Not enough space for gln')
     gln=gammln(a)
     where (.not. zero) gser_v=summ*exp(-x+a*log(x)-gln)
  else
     where (.not. zero) gser_v=summ*exp(-x+a*log(x)-gammln(a))
  end if
END FUNCTION gser_v

FUNCTION dgser_s(a,x,gln)
  USE mo_kind, only: dp, i4
  USE mo_nrutil, ONLY : nrerror
  use mo_nr, ONLY : gammln
  IMPLICIT NONE
  REAL(DP), INTENT(IN) :: a,x
  REAL(DP), OPTIONAL, INTENT(OUT) :: gln
  REAL(DP) :: dgser_s
  INTEGER(I4), PARAMETER :: ITMAX=100
  REAL(DP), PARAMETER :: EPS=epsilon(x)
  INTEGER(I4) :: n
  REAL(DP) :: ap,del,summ
  if (x == 0.0_dp) then
     dgser_s=0.0_dp
     RETURN
  end if
  ap=a
  summ=1.0_dp/a
  del=summ
  do n=1,ITMAX
     ap=ap+1.0_dp
     del=del*x/ap
     summ=summ+del
     if (abs(del) < abs(summ)*EPS) exit
  end do
  if (n > ITMAX) call nrerror('a too large, ITMAX too small in dgser_s')
  if (present(gln)) then
     gln=gammln(a)
     dgser_s=summ*exp(-x+a*log(x)-gln)
  else
     dgser_s=summ*exp(-x+a*log(x)-gammln(a))
  end if
END FUNCTION dgser_s

FUNCTION dgser_v(a,x,gln)
  USE mo_kind, only: dp, i4, lgt
  USE mo_nrutil, ONLY : assert_eq,nrerror
  use mo_nr, ONLY : gammln
  IMPLICIT NONE
  REAL(DP), DIMENSION(:), INTENT(IN) :: a,x
  REAL(DP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln
  REAL(DP), DIMENSION(size(a)) :: dgser_v
  INTEGER(I4), PARAMETER :: ITMAX=100
  REAL(DP), PARAMETER :: EPS=epsilon(x)
  INTEGER(I4) :: n
  REAL(DP), DIMENSION(size(a)) :: ap,del,summ
  LOGICAL(LGT), DIMENSION(size(a)) :: converged,zero
  n=assert_eq(size(a),size(x),'dgser_v')
  zero=(x == 0.0_dp)
  where (zero) dgser_v=0.0_dp
  ap=a
  summ=1.0_dp/a
  del=summ
  converged=zero
  do n=1,ITMAX
     where (.not. converged)
        ap=ap+1.0_dp
        del=del*x/ap
        summ=summ+del
        converged = (abs(del) < abs(summ)*EPS)
     end where
     if (all(converged)) exit
  end do
  if (n > ITMAX) call nrerror('a too large, ITMAX too small in dgser_v')
  if (present(gln)) then
     if (size(gln) < size(a)) call &
          nrerror('dgser_v: Not enough space for gln')
     gln=gammln(a)
     where (.not. zero) dgser_v=summ*exp(-x+a*log(x)-gln)
  else
     where (.not. zero) dgser_v=summ*exp(-x+a*log(x)-gammln(a))
  end if
END FUNCTION dgser_v


PROGRAM SOR2
  ! This program demonstrates the parallelization of a program that solves
  ! the 2D Laplace equation using the successive over-relaxtion (SOR) method.
  ! In this example, the zebra SOR method is used.

  USE grid
  IMPLICIT NONE
  INCLUDE 'mpif.h'

  ! MPI variables
  INTEGER ierr

  ! Count variables
  INTEGER :: r, c, step

  ! Math variables
  REAL(KIND=8) :: omega, temp, err1, err2, eps

  CALL initialize()

  ! Initialization of the problem
  DO r=0, rows+1
    DO c=0, localCols+1
!      x(r,c) = r + c*(rows+2) + myrank*(rows+2)*localCols
      x(r,c) = MOD(r + c + myrank*localCols, 2)
    END DO
  END DO

  omega = 1.0
  eps   = 0.001

  CALL printGrid("Initial configuration")

  ! The main loop
  DO step = 1, 300
    err1 = 0.0

    ! Update first half
    CALL synchronize(0)
    DO c = 1+even, localCols, 2
      DO r = 1, rows
        temp = 0.25 * (x(r,c-1) + x(r-1,c) + x(r+1,c) + x(r,c+1)) - x(r,c)
        x(r,c) = x(r,c) + omega * temp
        IF (abs(temp) > err1) err1 = abs(temp)
      ENDDO
    ENDDO

    CALL printGrid("After first update")

    ! Update second half
    CALL synchronize(1)
    DO c = 1+odd, localCols, 2
      DO r = 1, rows
        temp = 0.25 * (x(r,c-1) + x(r-1,c) + x(r+1,c) + x(r,c+1)) - x(r,c)
        x(r,c) = x(r,c) + omega * temp
        IF (abs(temp) > err1) err1 = abs(temp)
      ENDDO
    ENDDO

    CALL printGrid("After second update")

    CALL MPI_ALLREDUCE(err1, err2, 1, MPI_REAL8, MPI_MAX, MPI_COMM_WORLD, ierr)
    err1 = err2
    IF (myrank == 0) THEN
      write(*,*) "step: ", step
      write(*,*) "error: ", err1
    ENDIF
    IF (err1 <= eps) exit
  ENDDO

  CALL finalize()
END


module Utilities

!***********************************************************************
  !
  ! This  moudule contains helper functions/subroutines used throughout the
  ! program
  !
!***********************************************************************

  use Constants
  implicit none

  ! Interface for swap procedure
  interface swap
      module procedure swap_int
      module procedure swap_real
  end interface

contains

    !:.........................................................................:

    real function kron(x)
        !
        !  Calculates the Kronecker delta
        !
        !  Record of revisions:
        !      Date       Programmer          Description of change
        !      ====       ==========          =====================
        !    01/01/12     K. Holcomb           Original Code
        !

        ! Data dictionary: calling arguments
        real, intent(in) :: x ! Input number

        if (x .gt. 0.0) then
            kron = 1.0
        else
            kron = 0.0
        endif

    end function kron

    !:.........................................................................:

    real function roundtoN(x, N)
        !
        !  Rounds to N decimal places
        !
        !  Record of revisions:
        !      Date       Programmer          Description of change
        !      ====       ==========          =====================
        !    01/01/12     K. Holcomb           Original Code
        !

        ! Data dictionary: calling arguments
        real,    intent(in) :: x ! Input number
        integer, intent(in) :: N ! Decimal places to round to

        ! Data dictionary: local variables
        real :: factor ! Factor for rounding

        ! Get factor
        factor = 10.0**N

        ! Round to N
        roundtoN = float(int(x* factor + 0.5))/factor

    end function roundtoN

    !:.........................................................................:

    subroutine stddev(array, arith_mean, std_deviation, missing)
        !
        !  Computs mean and standard deviation of an array, ignoring values
        !   equal to missing
        !
        !  Record of revisions:
        !      Date       Programmer          Description of change
        !      ====       ==========          =====================
        !    01/01/12     K. Holcomb           Original Code
        !

        ! Data dictionary: calling arguments
        real, dimension(:), intent(in)  :: array         ! Input array
        real,               intent(out) :: arith_mean    ! Arithmetic mean
        real,               intent(out) :: std_deviation ! Standard deviation
        real, optional,     intent(in)  :: missing       ! Flag for missing values

        ! Data dictionary: local variables
        real    :: sqr_sum ! Squared sum
        integer :: nelems  ! Number of elements in array

        if (present(missing)) then

            ! Count how many items in the array aren't equal to missing
            nelems = count(array .ne. missing)

            ! Get mean, masking missing values
            arith_mean = sum(array, mask = array .ne. missing)/float(nelems)

            ! Get standard deviation, maasking missing values
            sqr_sum = sum(array**2, mask = array .ne. missing)
        else

            ! Use whol array
            nelems = size(array)
            arith_mean = sum(array)/float(nelems)
            sqr_sum = sum(array**2)
        endif

        ! Check for 0.0
        if (nelems == 0) then
            std_deviation = 0.0
            return
        endif

        ! Calculate sample standard deviation
        std_deviation = sqrt((sqr_sum - nelems*arith_mean**2)/(nelems - 1))

    end subroutine stddev

    !:.........................................................................:

    subroutine sort(array, length)
        !
        !  Sorts a character arry in alphabetical order.
        !  Sorts using Shell sort with lexigraphical sorting
        !
        !  Record of revisions:
        !      Date       Programmer          Description of change
        !      ====       ==========          =====================
        !    01/01/12     K. Holcomb           Original Code
        !

        ! Data dictionary: calling arguments
        character(len = *), dimension(length), intent(inout) :: array  ! Input array
        integer,                               intent(in)    :: length ! Length of array

        ! Data dictionary: local variables
        character(len = MAX_NLEN) :: temp  ! Temporary character
        integer                   :: inc   ! Gap size
        integer                   :: lower ! Lower bound of array
        integer                   :: upper ! Upper bound of array
        integer                   :: i, j  ! Looping indices

        lower = lbound(array, 1)
        upper = ubound(array, 1)

        inc = length/2

        ! We continue until the stride is the lower bound
        do while (inc > 0)
            do i = inc + lower, upper
                temp = adjustl(array(i))
                j = i
                ! Cannot use j>inc .and. array(j-inc)>temp if it doesn't
                ! short-circuit
                do while (j > inc)
                    if (array(j - inc) > temp) then
                        array(j) = array(j - inc)
                        j = j - inc
                    else
                        exit
                    endif
                enddo
                array(j) = temp
            enddo

            if (inc == 2) then
                inc = 1
            else
                inc = int(real(inc)/2.2)
            endif
        enddo

    end subroutine sort

    !:.........................................................................:

    subroutine merge_index(A, Ai)
        !
        !  Sorts input real array A and also returns array with un-sorted array
        !   locations of sorted array.
        !
        !  Record of revisions:
        !      Date       Programmer          Description of change
        !      ====       ==========          =====================
        !    06/01/20     A. C. Foster        Original Code
        !

        ! Data dictionary: calling arguments
        real,    dimension(:), intent(inout) :: A  ! Input array
        integer, dimension(:), intent(out)   :: Ai ! Array of sorted indices

        ! Data dictionary: local variables
        real,    dimension((size(A) + 1)/2) :: work  ! Working array
        integer, dimension((size(A) + 1)/2) :: worki ! Working array - indices
        integer                             :: n     ! Size of A
        integer                             :: i     ! Looping index

        ! Create the index array
        n = size(A)
        Ai = (/(i, i = 1,n)/)

        ! Sort the array
        call MergeSort(A, Ai, work, worki)

    end subroutine merge_index

    !:.........................................................................:

    recursive subroutine MergeSort(A, Ai, work, worki)
        !
        !  Sorts input array A and also returns array with un-sorted array
        !   locations of sorted array.
        !
        !  Record of revisions:
        !      Date       Programmer          Description of change
        !      ====       ==========          =====================
        !    06/01/20     A. C. Foster        Original Code
        !    01/25/21     A. C. Foster        Updated to a use a recursive
        !                                        subroutine
        !

        implicit none

        ! Data dictionary: calling arguments
        real,    dimension(:), intent(inout) :: A     ! Array to sort
        real,    dimension(:), intent(inout) :: work  ! Working array
        integer, dimension(:), intent(inout) :: Ai    ! Array indices
        integer, dimension(:), intent(inout) :: worki ! Working array - indices

        ! Data dictionary: local variables
        integer :: half ! Half the size of the array

        ! Get half the size of A
        half = (size(A) + 1)/2

        if (size(A) < 2) then
            ! We are done
            continue
        else if (size(A) == 2) then

            ! Compare sizes
            if (A(1) > A(2)) then
                ! Swap so that they are sorted
                call swap(A(1), A(2))
                call swap(Ai(1), Ai(2))
            end if
        else
            ! Still too big - split in two
            call MergeSort(A(:half), Ai(:half), work, worki)
            call MergeSort(A(half+1:), Ai(half+1:), work, worki)
            if (A(half) > A(half + 1)) then
                work(1:half) = A(1:half)
                worki(1:half) = Ai(1:half)
                call merge(work(1:half), A(half+1:), A, worki(1:half),         &
                    Ai(half+1:), Ai)
            end if
        end if
    end subroutine MergeSort

    !:.........................................................................:

    subroutine swap_real(x, y)
        !
        !  Helper subroutine to swap x and y
        !
        !  Record of revisions:
        !      Date       Programmer          Description of change
        !      ====       ==========          =====================
        !    01/25/21     A. C. Foster        Original Code
        !

        implicit none

        ! Data dictionary: calling arguments
        real, intent(inout) :: x, y ! Values to swap

        ! Data dictionary: local variables
        real :: tmp ! Temporary variable

        tmp = x
        x = y
        y = tmp

    end subroutine swap_real

    !:.........................................................................:

    subroutine swap_int(x, y)
        !
        !  Helper subroutine to swap x and y
        !
        !  Record of revisions:
        !      Date       Programmer          Description of change
        !      ====       ==========          =====================
        !    01/25/21     A. C. Foster        Original Code
        !

        implicit none

        ! Data dictionary: calling arguments
        integer, intent(inout) :: x, y ! Values to swap

        ! Data dictionary: local variables
        integer :: tmp ! Temporary variable

        tmp = x
        x = y
        y = tmp

    end subroutine swap_int

    !:.........................................................................:

    subroutine merge(A, B, C, Ai, Bi, Ci)
        !
        !  Merges arrays A and B, along with their accompanying array index
        !   locations
        !
        !  Record of revisions:
        !      Date       Programmer          Description of change
        !      ====       ==========          =====================
        !    06/01/20     A. C. Foster        Original Code
        !    01/25/21     A. C. Foster        Updated to a use a recursive
        !                                       call

        implicit none

        ! Data dictionary: calling arguments
        real,    dimension(:), intent(in)    :: A   ! 1st array to merge
        real,    dimension(:), intent(in)    :: B   ! 2nd array to merge
        integer, dimension(:), intent(in)    :: Ai  ! Indices of array A
        integer, dimension(:), intent(in)    :: Bi  ! Indices of array B
        real,    dimension(:), intent(inout) :: C   ! Merged array
        integer, dimension(:), intent(inout) :: Ci  ! Merged index array

        ! Data dictionary: local variables
        integer :: i ! Looping index (A)
        integer :: j ! Looping index (B)
        integer :: k ! Looping index (C)

        if (size(A) + size(B) > size(C)) stop

        i = 1
        j = 1
        do k = 1, size(C)
            if (i <= size(A) .and. j <= size(B)) then
                ! We are still looking through arrays

                if (A(i) <= B(j)) then
                    ! Next value is from array A
                    Ci(k) = Ai(i)
                    C(k) = A(i)
                    i = i + 1
                else
                    ! Next value is from array B
                    Ci(k) = Bi(j)
                    C(k) = B(j)
                    j = j + 1
                end if

            else if (i <= size(A)) then
                ! We've stepped through all of B
                Ci(k) = Ai(i)
                C(k) = A(i)
                i = i + 1
            else if (j <= size(B)) then
                ! We've stepped through all of A
                Ci(k) = Bi(j)
                C(k) = B(j)
                j = j + 1
            end if
        end do
    end subroutine merge

end module Utilities


program even_fib

        implicit none

        integer :: first, second, tmp, maximum, sumx

        sumx = 0
        first = 1
        second = 1
        maximum = 4000000

        do
                tmp = first + second

                if (tmp > MAXIMUM) then
                        exit
                end if

                if(mod(tmp, 2) == 0) then
                        sumx = sumx + tmp
                end if

                first = second
                second = tmp

        end do

        print *, sumx

end program even_fib


! Copyright (c) 2015 Alex Kramer <kramer.alex.kramer@gmail.com>
! See the LICENSE.txt file in the top-level directory of this distribution.
!
! This module includes an assortment of common numerical routines
module numerics
  use globvars, only: dp, sp, ip

  implicit none

  private

  public :: numerics_factorial
  public :: numerics_binomial_coeff

  public :: numerics_linspace
  interface numerics_linspace
     module procedure numerics_linspace_dp
     module procedure numerics_linspace_sp
  end interface numerics_linspace

  public :: numerics_linspace_index
  interface numerics_linspace_index
     module procedure numerics_linspace_index_dp
     module procedure numerics_linspace_index_sp
  end interface numerics_linspace_index

  public :: numerics_beta
  interface numerics_beta
     module procedure numerics_beta_dp
     module procedure numerics_beta_sp
  end interface

  public :: numerics_d1
  interface numerics_d1
     ! Calculate the 1st derivative of an array-valued function with respect to
     ! a real-valued coordinate grid with constant spacing.
     !
     ! This uses a three-point finite-difference estimate:
     !
     !   f'(x) ~= ( f(x + dx) - f(x - dx) ) / ( 2 dx )
     !
     ! See documentation for specific module procedures for more details.
     module procedure numerics_d1_real_dp
     module procedure numericS_d1_real_sp
     module procedure numerics_d1_cmplx_dp
     module procedure numerics_d1_cmplx_sp
  end interface numerics_d1

  public :: numerics_d2
  interface numerics_d2
     ! Calculate the 2nd derivative of an array-valued function with respect to
     ! a real-valued coordinate grid with constant spacing.
     !
     ! This uses a three-point finite difference estimate:
     !
     !   f''(x) ~= (f(x - dx) - 2 f(x) + f(x + dx)) / (dx**2)
     !
     ! See documentation for specific module procedures for more details.
     module procedure numerics_d2_real_dp
     module procedure numerics_d2_real_sp
     module procedure numerics_d2_cmplx_dp
     module procedure numerics_d2_cmplx_sp
  end interface numerics_d2

  public :: numerics_rk4
  interface numerics_rk4
     ! 4th-order Runge-Kutta propagator for the first order system of
     ! differential equations dy/dt = f(y, t)
     !
     ! See documentation for specific module procedures for more details.
     module procedure numerics_rk4_real_dp
     module procedure numerics_rk4_real_sp
     module procedure numerics_rk4_cmplx_dp
     module procedure numerics_rk4_cmplx_sp
  end interface numerics_rk4

  public :: numerics_cmplx_phase
  interface numerics_cmplx_phase
     ! Calculate the phase of a complex number z = A exp(i phi)
     !
     ! See documentation for specific module procedures for more details.
     module procedure numerics_cmplx_phase_dp
     module procedure numerics_cmplx_phase_sp
  end interface numerics_cmplx_phase

  public :: numerics_trapz
  interface numerics_trapz
     ! Trapezoidal integration scheme:
     !
     ! int_a^b f(x) dx ~= dx / 2 \sum_{k=1}^N ( f(i_k) + f(i_{k+1}) )
     !
     ! See documentation for specific module procedures for more details
     module procedure numerics_trapz_dp
     module procedure numerics_trapz_sp
  end interface numerics_trapz

contains

   subroutine numerics_linspace_dp(x_min, x_max, x_arr, dx)
     ! Populate an array with linearly-spaced values between x_min and x_max
     !
     ! x_min :: minimum array value
     ! x_max :: maximum array value
     ! x_arr(:) :: array to populate, must already be allocated
     ! dx :: step size of `x_arr(:)`, given its size and `x_min`, `x_max`
    real(dp), intent(in) :: x_min, x_max
    real(dp), intent(out) :: x_arr(:)
    real(dp), intent(out) :: dx

    include "./numerics_src/linspace.src"
  end subroutine numerics_linspace_dp

  subroutine numerics_linspace_sp(x_min, x_max, x_arr, dx)
    ! Duplicate of numerics_linspace_dp for single precision reals
    real(sp), intent(in) :: x_min, x_max
    real(sp), intent(out) :: x_arr(:)
    real(sp), intent(out) :: dx

    include "./numerics_src/linspace.src"
  end subroutine numerics_linspace_sp

  integer(ip) function numerics_linspace_index_dp(x_val, x_arr) result(val)
    ! Get the array index of a value within an array of linearly spaced
    ! increasing values
    !
    ! If the value is outside the lower bound of the array, -1 is returned
    ! If the value is outside the upper bound of the array, 0 is returned
    !
    ! x_val :: value to index
    ! x_arr :: range to fit
    real(dp), intent(in) :: x_val
    real(dp), intent(in) :: x_arr(:)

    integer(ip), parameter :: fp = dp

    include "./numerics_src/linspace_index.src"
  end function numerics_linspace_index_dp

  integer(ip) function numerics_linspace_index_sp(x_val, x_arr) result(val)
    ! Duplicate of numericsc_linspace_index_dp, but for single precision real
    ! values
    real(sp), intent(in) :: x_val
    real(sp), intent(in) :: x_arr(:)

    integer(ip), parameter :: fp = sp

    include "./numerics_src/linspace_index.src"
  end function numerics_linspace_index_sp

  subroutine numerics_d1_real_dp(arr, d_arr, dx)
    ! Calculate the 1st derivative of a double-precision real array-valued
    ! function with respect to a real-valued coordinate grid with constant
    ! grid spacing.
    !
    ! arr :: function array
    ! d_arr :: array to populate with 1st derivative values
    ! dx :: coordinate spacing
    real(dp), intent(in) :: arr(:)
    real(dp), intent(out) :: d_arr(:)
    real(dp), intent(in) :: dx

    integer(ip), parameter :: fp = dp

    include "./numerics_src/d1.src"
  end subroutine numerics_d1_real_dp

  subroutine numerics_d1_real_sp(arr, d_arr, dx)
    real(sp), intent(in) :: arr(:)
    real(sp), intent(out) :: d_arr(:)
    real(sp), intent(in) :: dx

    integer(ip), parameter :: fp = sp

    include "./numerics_src/d1.src"
  end subroutine numerics_d1_real_sp

  subroutine numerics_d1_cmplx_dp(arr, d_arr, dx)
    ! Duplication of numerics_d1_real_dp, but for double precision complex types
    !
    ! Once Fortran 2008 support is here, we can get rid of the duplicated code
    ! and instead use the numerics_d1_real method on the real and imaginary
    ! parts separately:
    !   call subroutine numerics_d1_real(arr%re, d_arr%re, dx)
    !   call subroutine numerics_d1_real(arr%im, d_arr%im, dx)
    complex(dp), intent(in) :: arr(:)
    complex(dp), intent(out) :: d_arr(:)
    real(dp), intent(in) :: dx

    integer(ip), parameter :: fp = dp

    include "./numerics_src/d1.src"
  end subroutine numerics_d1_cmplx_dp

  subroutine numerics_d1_cmplx_sp(arr, d_arr, dx)
    ! Duplication of numerics_d1_real_dp, but for single precision complex types
    complex(sp), intent(in) :: arr(:)
    complex(sp), intent(out) :: d_arr(:)
    real(sp), intent(in) :: dx

    integer(ip), parameter :: fp = sp

    include "./numerics_src/d1.src"
  end subroutine numerics_d1_cmplx_sp

  subroutine numerics_d2_real_dp(arr, d2_arr, dx)
    ! Calculate the 2nd derivative of a complex array-valued function with
    ! respect to a real-valued coordinate with constant spacing:
    !
    ! arr :: function array
    ! d2_arr :: array to populate with 2nd derivative values
    ! dx :: coordinate spacing
    real(dp), intent(in) :: arr(:)
    real(dp), intent(inout) :: d2_arr(:)
    real(dp), intent(in) :: dx

    integer(ip), parameter :: fp = dp

    include "./numerics_src/d2.src"
  end subroutine numerics_d2_real_dp

  subroutine numerics_d2_real_sp(arr, d2_arr, dx)
    ! Duplicate of numerics_d2_real_sp, but for single precision reals
    real(sp), intent(in) :: arr(:)
    real(sp), intent(inout) :: d2_arr(:)
    real(sp), intent(in) :: dx

    integer(ip), parameter :: fp = sp

    include "./numerics_src/d2.src"
  end subroutine numerics_d2_real_sp

  subroutine numerics_d2_cmplx_dp(arr, d2_arr, dx)
    ! Duplicate of numerics_d2_real_dp, but for double precision complex types
    complex(dp), intent(in) :: arr(:)
    complex(dp), intent(inout) :: d2_arr(:)
    real(dp), intent(in) :: dx

    integer(ip), parameter :: fp = dp

    include "./numerics_src/d2.src"
  end subroutine numerics_d2_cmplx_dp

  subroutine numerics_d2_cmplx_sp(arr, d2_arr, dx)
    ! Duplicate of numerics_d2_real_dp, but for single precision complex types
    complex(sp), intent(in) :: arr(:)
    complex(sp), intent(inout) :: d2_arr(:)
    real(sp), intent(in) :: dx

    integer(ip), parameter :: fp = sp

    include "./numerics_src/d2.src"
  end subroutine numerics_d2_cmplx_sp

  subroutine numerics_rk4_real_dp(f, y, t, dt)
    ! 4th order Runge-Kutta propagator for the first order system of differential
    ! equations dy/dt = f(t, y)
    !
    ! f :: differential equation dy/dt = f(y, t) that returns values of the same
    !   dimension as y
    ! y :: current state array
    ! t :: current time parameter
    ! dt :: time step
    !
    ! Note that the state array y is overwritten during propagation.
    real(dp), intent(inout) :: y(:)
    real(dp), intent(in) :: t
    real(dp), intent(in) :: dt

    real(dp), dimension(size(y)) :: k1, k2, k3, k4

    ! Explicit interface for external differential equation system
    interface

       pure function f(y, t) result(val)
         import dp
         real(dp), intent(in) :: y(:)
         real(dp), intent(in) :: t
         real(dp) :: val(size(y))
       end function f

    end interface

    include "./numerics_src/rk4.src"
  end subroutine numerics_rk4_real_dp

  subroutine numerics_rk4_real_sp(f, y, t, dt)
    ! Duplicate of numerics_rk4_real_dp, but for single precision reals
    real(sp), intent(inout) :: y(:)
    real(sp), intent(in) :: t
    real(sp), intent(in) :: dt

    real(sp), dimension(size(y)) :: k1, k2, k3, k4

    interface

       pure function f(y, t) result(val)
         import sp
         real(sp), intent(in) :: y(:)
         real(sp), intent(in) :: t
         real(sp) :: val(size(y))
       end function f

    end interface

    include "./numerics_src/rk4.src"
  end subroutine numerics_rk4_real_sp

  subroutine numerics_rk4_cmplx_dp(f, y, t, dt)
    ! Duplicate of numerics_rk4_real_dp, but for double precision complex numbers
    complex(dp), intent(inout) :: y(:)
    real(dp), intent(in) :: t
    real(dp), intent(in) :: dt

    complex(dp), dimension(size(y)) :: k1, k2, k3, k4

    interface

       pure function f(y, t) result(val)
         import dp
         complex(dp), intent(in) :: y(:)
         real(dp), intent(in) :: t
         complex(dp) :: val(size(y))
       end function f

    end interface

    include "./numerics_src/rk4.src"
  end subroutine numerics_rk4_cmplx_dp

  subroutine numerics_rk4_cmplx_sp(f, y, t, dt)
    ! Duplicate of numerics_rk4_real_dp, but for single precision complex numbers
    complex(sp), intent(inout) :: y(:)
    real(sp), intent(in) :: t
    real(sp), intent(in) :: dt

    complex(sp), dimension(size(y)) :: k1, k2, k3, k4

    interface

       pure function f(y, t) result(val)
         import sp
         complex(sp), intent(in) :: y(:)
         real(sp), intent(in) :: t
         complex(sp) :: val(size(y))
       end function f

    end interface

    include "./numerics_src/rk4.src"
  end subroutine numerics_rk4_cmplx_sp

  pure real(dp) function numerics_cmplx_phase_dp(z) result(val)
    ! Get the phase of a complex number z = A exp(i phi), where A determines the
    ! magnitude, and phi determines the phase angle.
    !
    ! z :: complex number
    complex(dp), intent(in) :: z

    include "./numerics_src/cmplx_phase.src"

  end function numerics_cmplx_phase_dp

  pure real(sp) function numerics_cmplx_phase_sp(z) result(val)
    ! Duplicate of numerics_cmplx_phase_sp, but for single precision numbers
    complex(sp), intent(in) :: z

    include "./numerics_src/cmplx_phase.src"

  end function numerics_cmplx_phase_sp

  pure real(dp) function numerics_trapz_dp(f_arr, dx) result(val)
    ! Trapezoidal integration scheme
    !
    ! f_arr :: array-valued function to integrate
    ! dx :: integration step
    real(dp), intent(in) :: f_arr(:)
    real(dp), intent(in) :: dx

    integer(ip) :: i_x
    real(dp) :: trapz_cnst

    trapz_cnst = dx / 2.0_dp
    val = 0.0_dp

    include "./numerics_src/trapz.src"
  end function numerics_trapz_dp

  pure real(sp) function numerics_trapz_sp(f_arr, dx) result(val)
    ! Duplicate of numerics_trapz for single precision reals
    real(sp), intent(in) :: f_arr(:)
    real(sp), intent(in) :: dx

    integer(ip) :: i_x
    real(sp) :: trapz_cnst

    trapz_cnst = dx / 2.0_sp
    val = 0.0_sp

    include "./numerics_src/trapz.src"
  end function numerics_trapz_sp

  pure integer(ip) function numerics_factorial(n) result(val)
    ! Factorial function
    !
    ! We use Fortran 2003's built in gamma-function implementation for this
    integer(ip), intent(in) :: n

    val = int(gamma( 1.0_dp * (n + 1) ), kind=ip)
  end function numerics_factorial

  pure real(dp) function numerics_beta_dp(x, y) result(val)
    ! Beta function for double precision real values
    !
    ! x :: x > 0
    ! y :: y > 0
    real(dp), intent(in) :: x
    real(dp), intent(in) :: y

    include "./numerics_src/beta.src"
  end function numerics_beta_dp

  pure real(sp) function numerics_beta_sp(x, y) result(val)
    ! Duplicate of numerics_beta_dp, but for single precision values
    real(sp), intent(in) :: x
    real(sp), intent(in) :: y

    include "./numerics_src/beta.src"
  end function numerics_beta_sp

  pure integer(ip) function numerics_binomial_coeff(n, k) result(val)
    ! Binomial coefficient (n, k) = n! / ( k! (n - k)! )
    integer(ip), intent(in) :: n
    integer(ip), intent(in) :: k

    val = numerics_factorial(n) / &
         ( numerics_factorial(k) * numerics_factorial(n - k) )
  end function numerics_binomial_coeff

end module numerics


    program demo_merge_bits
    use,intrinsic :: iso_fortran_env,  only : int8, int16, int32, int64
    implicit none
    integer(kind=int16) :: if_one,if_zero,msk
    character(len=*),parameter :: fmt='(*(g0, 1X))'

       ! basic usage
       print *,'MERGE_BITS( 5,10,41) should be 3.=>',merge_bits(5,10,41)
       print *,'MERGE_BITS(13,18,22) should be 4.=>',merge_bits(13,18,22)

       ! use some values in base2 illustratively:
       if_one =int(b'1010101010101010',kind=int16)
       if_zero=int(b'0101010101010101',kind=int16)

       msk=int(b'0101010101010101',kind=int16)
       print '("should get all zero bits =>",b16.16)', &
       & merge_bits(if_one,if_zero,msk)

       msk=int(b'1010101010101010',kind=int16)
       print '("should get all ones bits =>",b16.16)', &
       & merge_bits(if_one,if_zero,msk)

       ! using BOZ values
       print fmt, &
       & merge_bits(32767_int16,    o'12345',         32767_int16), &
       & merge_bits(o'12345'   , 32767_int16, b'0000000000010101'), &
       & merge_bits(32767_int16,    o'12345',             z'1234')

       ! a do-it-yourself equivalent for comparison and validation
       print fmt, &
       & ior(iand(32767_int16, 32767_int16),                   &
       &   iand(o'12345', not(32767_int16))),                  &

       & ior(iand(o'12345', int(o'12345', kind=int16)),        &
       &   iand(32767_int16, not(int(o'12345', kind=int16)))), &

       & ior(iand(32767_int16, z'1234'),                       &
       &   iand(o'12345', not(int( z'1234', kind=int16))))

    end program demo_merge_bits