    program demo_max
    implicit none
    real :: arr1(4)= [10.0,11.0,30.0,-100.0]
    real :: arr2(5)= [20.0,21.0,32.0,-200.0,2200.0]

      !! this is simple enough because it is not being called elementally
      !! because all arguments are scalar
      !!

      write(*,*)'scalars:',max(10.0,11.0,30.0,-100.0)

      !!
      !! this is all max(3) could do before it became an elemental
      !! function and is the most intuitive
      !! except that it can take an arbitrary number of options,
      !! which is not common in Fortran without
      !! declaring a lot of optional parameters.
      !!
      !! That is it unless you want to use the elemental features of max(3)!

      !! Error: Intrinsic    max    at (1) must have at least two arguments
      !!write(*,*)max(arr1)
      !! This does not work because it is like trying to return
      !! [(max(arr1(i)),i=1,size(arr1))]
      !! so it is trying to take the max of a single value.
      !! To find the largest element of an array
      !! call maxloc(3) or maxval(3).

      !! Error: Different shape for arguments 'a1' and 'a2' for intrinsic
      !! 'max' at (1) on dimension 1 (4 and 5)
      !!write(*,*)max(arr1,arr2)
      !! but this will return an array of
      !! [(max(arr1(N),arr2(N),N=1,size(arr1))]

      write(*,*)max(arr1,arr2(1:4))

      !! so this works only if all the arrays are the same size and
      !! you want an array of the largest Nth elements
      !! from the input arrays.
      !! maybe you wanted to do maxval([arr1,arr2]) or
      !! equivalently max(maxval(arr1),maxval(arr2))
      !! to find the single largest element in both arrays?

      !! compares all scalars to each member of array and
      !! returns array of size arr2

      write(*,*)'scalars and array:',max(10.0,11.0,30.0,-100.0,arr2)

      !! Error: Different shape for arguments 'a5' and 'a6'
      !! for intrinsic 'max' at (1) on dimension 1 (5 and 4)
      !! write(*,*)'scalars and array:',max(10.0,11.0,30.0,-100.0,arr2,arr1)
      !! as the same reason above when arrays are used
      !! (without scalar values) all the arrays must be the same size

      write(*,*)'scalars and array:',&
      & max(40.0,11.0,30.0,-100.0,arr2(:4),arr1)
    end program demo_max


      subroutine r8mktricub(x,nx,y,ny,z,nz,f,nf2,nf3,
     >                    ibcxmin,bcxmin,ibcxmax,bcxmax,inb1x,
     >                    ibcymin,bcymin,ibcymax,bcymax,inb1y,
     >                    ibczmin,bczmin,ibczmax,bczmax,inb1z,
     >                    ilinx,iliny,ilinz,ier)
c
c  setup a tricubic spline; store coefficients in compact form
c  (as per suggestion of L. Zakharov, PPPL, Feb. 1999)
C  8 coeffs per (x,y,z) grid point:
C          f,fxx,fyy,fzz,fxxyy,fxxzz,fyyzz,fxxyyzz
C
C  dmc -- modified Feb 2004 -- rewritten to compute coefficients
C  directly rather than by conversion from the non-compact representation
C  (to reduce cpu and memory cost)
C
C
C  input:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      integer nx                        ! length of x vector
      integer ny                        ! length of y vector
      integer nz                        ! length of z vector
      REAL*8 x(nx)                        ! x vector, strict ascending
      REAL*8 y(ny)                        ! y vector, strict ascending
      REAL*8 z(nz)                        ! z vector, strict ascending
c
      integer nf2                       ! 2nd dim. of f array, nf2.ge.nx
      integer nf3                       ! 3rd dim. of f array, nf3.ge.ny
c
c  input/output:
c
      REAL*8 f(8,nf2,nf3,nz)              ! data and spline coefficients
c
C  on input:  f(1,i,j,k) = f(x(i),y(j),z(k))
C  on output:  f(1,i,j,k) unchanged
C              f(2,i,j,k) = d2f/dx2(x(i),y(j),z(k))
C              f(3,i,j,k) = d2f/dy2(x(i),y(j),z(k))
C              f(4,i,j,k) = d2f/dz2(x(i),y(j),z(k))
C              f(5,i,j,k) = d4f/dx2dy2(x(i),y(j),z(k))
C              f(6,i,j,k) = d4f/dx2dz2(x(i),y(j),z(k))
C              f(7,i,j,k) = d4f/dy2dz2(x(i),y(j),z(k))
C              f(8,i,j,k) = d6f/dx2dy2dz2(x(i),y(j),z(k))
C
C  there is a rather Hermite like interpolation formula to go with
C  this-- see evtricub.for.  Also the bicubic formula is given in
C  mkbicubw.for; the tricubic formula is precisely analogous.
C
C  boundary condition data
C  inputs:
      integer inb1x                     ! 1st dim of xmin & xmax bc arrays
      integer inb1y                     ! 1st dim of ymin & ymax bc arrays
      integer inb1z                     ! 1st dim of zmin & zmax bc arrays
C
      integer ibcxmin,ibcxmax           ! BC type flag @xmin, xmax
      integer ibcymin,ibcymax           ! BC type flag @ymin, ymax
      integer ibczmin,ibczmax           ! BC type flag @zmin, zmax
C
      REAL*8 bcxmin(inb1x,nz),bcxmax(inb1x,nz) ! xmin & xmax BC data, ny x nz
      REAL*8 bcymin(inb1y,nz),bcymax(inb1y,nz) ! ymin & ymax BC data, nx x nz
      REAL*8 bczmin(inb1z,ny),bczmax(inb1z,ny) ! zmin & zmax BC data, nx x ny
c
c  where BC data is not required, dummy scalars may be passed.
C  the ibc* flags determine whether BC data isneeded.
c
c  BC data:  bcxmin & bcxmax:  BC vs. y,z @xmin,xmax
C            bcymin & bcymax:  BC vs. x,z @ymin,ymax
C            bczmin & bczmax:  BC vs. x,y @zmin,zmax
C
c   ibcxmin -- indicator for boundary condition at xmin=x(1):
c    bcxmin(...) -- boundary condition data
c     =-1 -- use periodic boundary condition
c     =0 -- use "not a knot"
c     =1 -- match slope, specified at x(1),y(iy),z(iz) by bcxmin(iy,iz)
c     =2 -- match 2nd derivative, specified at x(1),y(iy),z(iz)
c           by bcxmin(iy,iz
c     =3 -- boundary condition is slope=0 (df/dx=0) at x(1), all y(j)
c     =4 -- boundary condition is d2f/dx2=0 at x(1), all y(j)
c     =5 -- df/dx BC from 1st divided difference
c     =6 -- d2f/dx2 BC from 2nd divided difference (parabolic fit)
c     =7 -- d3f/dx3 BC from 3rd divided difference (cubic fit)
c   ***NOTE bcxmin(...) referenced ONLY if ibcxmin=1 or ibcxmin=2
c
c   ibcxmax -- indicator for boundary condition at x(nx):
c    bcxmax(...) -- boundary condition data
c     (interpretation as with ibcxmin, bcxmin)
c     NOTE:  if ibcxmin=-1 then the periodic BC applies on both sides
c            and ibcxmax, bcxmax are ignored.
c   inb1x -- 1st dimension of bcxmin, bcxmax: if ibcxmin or ibcxmax .gt. 0
c            this must be .ge. ny.
c
c   interpretation of ibcymin,bcymin,ibcymax,bcymax,inb1y
c     is same as with ibcxmin,...
c
c   interpretation of ibczmin,bczmin,ibczmax,bczmax,inb1z
c     is same as with ibcxmin,...
c
c   the explicit bdy condition arrays are referenced only if the
c     corresponding "ibc" flag values are set to 1 or 2.
c
c  output:
      integer ilinx                     ! x vector equal spacing flag
      integer iliny                     ! y vector equal spacing flag
      integer ilinz                     ! z vector equal spacing flag
c
c   ilinx -- =1 on output if x(nx) pts are nearly evenly spaced (tol=1e-3)
c   iliny -- =1 on output if y(ny) evenly spaced (tol=1e-3)
c   ilinz -- =1 on output if z(nz) evenly spaced (tol=1e-3)
c
      integer ier                       ! exit code
c   ier -- completion code, 0 for normal
c
C-----------------------------------------------------
c  workspace **dynamic allocation**
C  f90 dynamic array
C
      REAL*8, dimension(:,:,:), allocatable :: fbicub ! bicubic subsection
      REAL*8, dimension(:,:), allocatable :: fwk ! work array
      REAL*8, dimension(:), allocatable :: bcx1,bcx2,bcy1,bcy2 ! BCs for mkbicub
c
      REAL*8, dimension(:,:,:,:), allocatable :: fcorr ! correction spline
      REAL*8, dimension(:,:), allocatable :: bcc1,bcc2 ! correction BCs
c
      integer iflg,ierx,iery,ierz
      integer ix,iy,iz
c
      REAL*8 ztol
      REAL*8 zbc1,zbc2,hz
      integer ibc1,ibc2
c
      data ztol/1.0E-3_r8/
c-----------------------------------------------------
c
      ier=0
c
      iflg=0
c
c  check z bdy condition "linearity"
c
      if(ibczmin.ne.-1) then
         if((ibczmin.eq.1).or.(ibczmin.eq.2)) then
            do iy=1,ny
               do ix=1,nx
                  if(bczmin(ix,iy).ne.0.0_r8) iflg=1
               enddo
            enddo
         endif
         if((ibczmax.eq.1).or.(ibczmax.eq.2)) then
            do iy=1,ny
               do ix=1,nx
                  if(bczmax(ix,iy).ne.0.0_r8) iflg=1
               enddo
            enddo
         endif
      endif
c
      if(nx.lt.2) then
         write(6,'('' ?mktricub:  at least 2 x points required.'')')
         ier=1
      endif
      if(ny.lt.2) then
         write(6,'('' ?mktricub:  need at least 2 y points.'')')
         ier=1
      endif
      if(nz.lt.2) then
         write(6,'('' ?mktricub:  need at least 2 z points.'')')
         ier=1
      endif
c
      if((ibcxmin.eq.1).or.(ibcxmax.eq.1).or.(ibcxmin.eq.2).or.
     >   (ibcxmax.eq.2)) then
         if(inb1x.lt.ny) then
            ier=1
            write(6,
     >'('' ?mktricub:  1st dim of bcxmin/max arrays .lt. ny'')')
         endif
      endif
c
      if((ibcymin.eq.1).or.(ibcymax.eq.1).or.(ibcymin.eq.2).or.
     >   (ibcymax.eq.2)) then
         if(inb1y.lt.nx) then
            ier=1
            write(6,
     >'('' ?mktricub:  1st dim of bcymin/max arrays .lt. nx'')')
         endif
      endif
c
      if((ibczmin.eq.1).or.(ibczmax.eq.1).or.(ibczmin.eq.2).or.
     >   (ibczmax.eq.2)) then
         if(inb1z.lt.nx) then
            ier=1
            write(6,
     >'('' ?mktricub:  1st dim of bczmin/max arrays .lt. nx'')')
         endif
      endif
c
      call ibc_ck(ibcxmin,'mktricub','xmin',-1,7,ier)
      if(ibcxmin.ge.0) call ibc_ck(ibcxmax,'mktricub','xmax',0,7,ier)
c
      call ibc_ck(ibcymin,'mktricub','ymin',-1,7,ier)
      if(ibcymin.ge.0) call ibc_ck(ibcymax,'mktricub','ymax',0,7,ier)
c
      call ibc_ck(ibczmin,'mktricub','zmin',-1,7,ier)
      if(ibczmax.ge.0) call ibc_ck(ibczmax,'mktricub','zmax',0,7,ier)
c
c  check ilinx & x vector
c
      call r8splinck(x,nx,ilinx,ztol,ierx)
      if(ierx.ne.0) ier=2
c
      if(ier.eq.2) then
         write(6,'('' ?mktricub:  x axis not strict ascending'')')
      endif
c
c  check iliny & y vector
c
      call r8splinck(y,ny,iliny,ztol,iery)
      if(iery.ne.0) ier=3
c
      if(ier.eq.3) then
         write(6,'('' ?mktricub:  y axis not strict ascending'')')
      endif
c
c  check ilinz & z vector
c
      call r8splinck(z,nz,ilinz,ztol,ierz)
      if(ierz.ne.0) ier=4
c
      if(ier.eq.4) then
         write(6,'('' ?mktricub:  z axis not strict ascending'')')
      endif
c
      if(ier.ne.0) return
c
c------------------------------------
c  1.  compute (x,y) bicubic splines using mkbicub
c
      allocate(fbicub(4,nx,ny))
      allocate(bcx1(ny),bcx2(ny),bcy1(nx),bcy2(nx))
      bcx1=0.0; bcx2=0.0; bcy1=0.0; bcy2=0.0_r8
c
      do iz=1,nz
         if(ibcxmin.ne.-1) then
            if((ibcxmin.eq.1).or.(ibcxmin.eq.2)) then
               bcx1(1:ny)=bcxmin(1:ny,iz)
            endif
            if((ibcxmax.eq.1).or.(ibcxmax.eq.2)) then
               bcx2(1:ny)=bcxmax(1:ny,iz)
            endif
         endif
         if(ibcymin.ne.-1) then
            if((ibcymin.eq.1).or.(ibcymin.eq.2)) then
               bcy1(1:nx)=bcymin(1:nx,iz)
            endif
            if((ibcymax.eq.1).or.(ibcymax.eq.2)) then
               bcy2(1:nx)=bcymax(1:nx,iz)
            endif
         endif
c
         fbicub(1,1:nx,1:ny) = f(1,1:nx,1:ny,iz)
c
         call r8mkbicub(x,nx,y,ny,fbicub,nx,
     >      ibcxmin,bcx1,ibcxmax,bcx2,
     >      ibcymin,bcy1,ibcymax,bcy2,
     >      ilinx,iliny,ier)
         if(ier.ne.0) return
c
         f(2:3,1:nx,1:ny,iz) = fbicub(2:3,1:nx,1:ny)  ! fxx, fyy
         f(5,1:nx,1:ny,iz) = fbicub(4,1:nx,1:ny)      ! fxxyy
c
      enddo
c
      deallocate(fbicub,bcx1,bcx2,bcy1,bcy2)
c
c  2.  homogeneous spline in z direction; inhomogeneous BC imposed later
c      if necessary
c
      zbc1=0.0_r8
      zbc2=0.0_r8
      ibc1=ibczmin
      ibc2=ibczmax
      if(iflg.eq.1) then
         if((ibczmin.eq.1).or.(ibczmin.eq.2)) ibc1=0
         if((ibczmax.eq.1).or.(ibczmax.eq.2)) ibc2=0
      endif
c
      allocate(fwk(2,nz))
c
      do iy=1,ny
         do ix=1,nx

            fwk(1,1:nz) = f(1,ix,iy,1:nz)
            call r8mkspline(z,nz,fwk,
     >         ibc1,zbc1,ibc2,zbc2,ilinz,ier)
            if(ier.ne.0) return
            f(4,ix,iy,1:nz) = fwk(2,1:nz) ! fzz

            fwk(1,1:nz) = f(2,ix,iy,1:nz)
            call r8mkspline(z,nz,fwk,
     >         ibc1,zbc1,ibc2,zbc2,ilinz,ier)
            if(ier.ne.0) return
            f(6,ix,iy,1:nz) = fwk(2,1:nz) ! fxxzz

            fwk(1,1:nz) = f(3,ix,iy,1:nz)
            call r8mkspline(z,nz,fwk,
     >         ibc1,zbc1,ibc2,zbc2,ilinz,ier)
            if(ier.ne.0) return
            f(7,ix,iy,1:nz) = fwk(2,1:nz) ! fyyzz

            fwk(1,1:nz) = f(5,ix,iy,1:nz)
            call r8mkspline(z,nz,fwk,
     >         ibc1,zbc1,ibc2,zbc2,ilinz,ier)
            if(ier.ne.0) return
            f(8,ix,iy,1:nz) = fwk(2,1:nz) ! fxxyyzz

         enddo
      enddo
c
      deallocate(fwk)
c
      if(iflg.eq.1) then
c
c  3. inhomogeneous BC correction
c
         allocate(fwk(2,max(nx,ny,nz)))
         allocate(bcc1(nx,ny),bcc2(nx,ny))
         allocate(fcorr(4,nx,ny,nz))
c
c  correction BCs
c
         do iy=1,ny
            do ix=1,nx
               bcc1(ix,iy)=0.0_r8
               if(ibczmin.eq.1) then
                  hz=z(2)-z(1)
                  bcc1(ix,iy)=(f(1,ix,iy,2)-f(1,ix,iy,1))/hz +
     >               hz*(-2*f(4,ix,iy,1)-f(4,ix,iy,2))/6
                  bcc1(ix,iy)=bczmin(ix,iy)-bcc1(ix,iy)
               else if(ibczmin.eq.2) then
                  bcc1(ix,iy)=bczmin(ix,iy)-f(4,ix,iy,1)
               endif
            enddo
         enddo
c
         do iy=1,ny
            do ix=1,nx
               bcc2(ix,iy)=0.0_r8
               if(ibczmax.eq.1) then
                  hz=z(2)-z(1)
                  bcc2(ix,iy)=(f(1,ix,iy,2)-f(1,ix,iy,1))/hz +
     >               hz*(-2*f(4,ix,iy,1)-f(4,ix,iy,2))/6
                  bcc2(ix,iy)=bczmax(ix,iy)-bcc2(ix,iy)
               else if(ibczmax.eq.2) then
                  bcc2(ix,iy)=bczmax(ix,iy)-f(4,ix,iy,1)
               endif
            enddo
         enddo
c
         fwk(1,1:nz)=0.0_r8  ! values are all zero, only BC is set...
         do iy=1,ny
            do ix=1,nx
               call r8mkspline(z,nz,fwk,
     >            ibczmin,bcc1(ix,iy),ibczmax,bcc2(ix,iy),ilinz,ier)
               if(ier.ne.0) return
               fcorr(1,ix,iy,1:nz)=fwk(2,1:nz)  ! fzz-correction
            enddo
         enddo
c
c  higher order corrections
c
         zbc1=0.0_r8
         zbc2=0.0_r8
c
         do iz=1,nz
            do iy=1,ny
               fwk(1,1:nx)=fcorr(1,1:nx,iy,iz)
               call r8mkspline(x,nx,fwk,
     >            ibcxmin,zbc1,ibcxmax,zbc2,ilinx,ier)
               if(ier.ne.0) return
               fcorr(2,1:nx,iy,iz)=fwk(2,1:nx)  ! fxxzz-correction
            enddo
         enddo
c
         do iz=1,nz
            do ix=1,nx
               fwk(1,1:ny)=fcorr(1,ix,1:ny,iz)
               call r8mkspline(y,ny,fwk,
     >            ibcymin,zbc1,ibcymax,zbc2,iliny,ier)
               if(ier.ne.0) return
               fcorr(3,ix,1:ny,iz)=fwk(2,1:ny)  ! fyyzz-correction

               fwk(1,1:ny)=fcorr(2,ix,1:ny,iz)
               call r8mkspline(y,ny,fwk,
     >            ibcymin,zbc1,ibcymax,zbc2,iliny,ier)
               if(ier.ne.0) return
               fcorr(4,ix,1:ny,iz)=fwk(2,1:ny)  ! fxxyyzz-correction
            enddo
         enddo
c
c  apply correction
c
         do iz=1,nz
            do iy=1,ny
               do ix=1,nx
                  f(4,ix,iy,iz)=f(4,ix,iy,iz)+fcorr(1,ix,iy,iz)
                  f(6,ix,iy,iz)=f(6,ix,iy,iz)+fcorr(2,ix,iy,iz)
                  f(7,ix,iy,iz)=f(7,ix,iy,iz)+fcorr(3,ix,iy,iz)
                  f(8,ix,iy,iz)=f(8,ix,iy,iz)+fcorr(4,ix,iy,iz)
               enddo
            enddo
         enddo
c
         deallocate(fwk,fcorr,bcc1,bcc2)
c
      endif
c
c  that's all
c
      return
      end


module alimento

contains

subroutine evolui_tempo(tf, T_inicial, Raio, H, ka, rho, Cp, h_convec, eps, T_esteira, T_paredes, T_ar, T_ambiente,T)

    implicit none
    integer, parameter :: nr = 60
    integer, parameter :: nh = 30
    real, dimension(nh,nr), intent(in) :: T_inicial
    real, intent(in) :: tf, Raio, H, ka, rho, Cp, h_convec, eps
    real, intent(in) :: T_esteira, T_paredes, T_ar, T_ambiente
    real, dimension(nh,nr), intent(out) :: T
    real:: sigma, alpha, dr, dh, dt
    integer :: nt, i, j, k, l, m
    REAL, PARAMETER :: pi = 3.1415927

    real, dimension(nr) :: r
    real, dimension(nh,nr) :: Tc

    dt = 0.05
    sigma = 5.67032e-8
    alpha = ka/(rho*Cp)
    dr = Raio/(nr + 1)
    dh = H/(nh + 1)
    nt = int(tf/dt)

    do i = 1, int(nh)
        do j = 1, int(nr)
            T(i,j) = T_inicial(i,j)
            Tc(i,j) = T_inicial(i,j)
        enddo
    enddo

    do i = 1, nr
        T(1,i) = T_esteira
        r(i) = i*Raio/nr
    enddo

    do k = 1, nt

        do i = 1, int(nh)
            do j = 1, int(nr)
                Tc(i,j) = T(i,j)
            enddo
        enddo

        do i = 2, int(nh) -1
            do j = 2, int(nr) -1
                T(i,j) = Tc(i,j) + dt*alpha*( &
                (  Tc(i,j+1) - 2*Tc(i,j) + T(i,j-1)  )/dr**2 + &
                ( Tc(i+1,j) - 2*Tc(i,j) + T(i-1,j)  )/dh**2 + &
                ( Tc(i,j+1) - Tc(i,j-1) )/(dr* r(j)) )
            enddo
        enddo

        do i = 1, int(nr)
            T(nh,i) = T(nh-1,i) + dr*eps*sigma*(T_paredes**4 - T(nh,i)**4)&
                      + dr*h_convec*( T_ar - T(nh,i))
        enddo

        do i = 1, int(nh)
            T(i,nr) = T(i,nr-1) + dr*eps*sigma*(T_paredes**4 - T(i,nr)**4)&
                      + dr*h_convec*( T_ar - T(i,nr))
        enddo

        do i = 1, int(nh)
            T(i,1) = T(i,2)
        enddo
    enddo

end subroutine evolui_tempo

end module alimento


c     Do the shuffling using as little memory as possible.
      program day22
        integer*8 p(2), modulo, inverse, mult
        character*4 command
        integer*8 val, x(2), v(2), i, j, r, n, d
        data x/2*0/, v/2*1/

        p(1) = 10007
        p(2) = 1193157*10**8 + 17514047
        r = 1017415*10**8 + 82076661

 1      read(*,*,end=2) command, val
        do 3 j = 1,2
        if (command .eq. 'cut') then
           x(j) = modulo(x(j) + v(j) * val, p(j))

        else if (command .eq. 'new') then
           v(j) = p(j) - v(j)
           x(j) = modulo(x(j) + v(j), p(j))
        else if (command .eq. 'incr') then
           v(j) = mult(v(j), inverse(val, p(j)), p(j))
        end if
 3      continue
        go to 1

c     Part one - find the index of 2019
 2      v(1) = inverse(v(1), p(1))
        x(1) = mult(-x(1), v(1), p(1))
        n = modulo(2019 * v(1) + x(1), p(1))
        write(*,*) n

c     Part two - find the 2020th value after many iterations
        n = 2020
        call geom(x(2), v(2), r, p(2))
        d = mult(v(2), n, p(2))
        d = modulo(x(2) + d, p(2))
        write(*,*) d
      end

      subroutine geom(x, v, r, p)
        integer*8 x, v, r, p, a, b, mult, inverse, modexp

        a = modexp(v, r, p)
        b = modulo(a-1, p)
        b = mult(b, x, p)
        b = mult(b, inverse(v-1, p), p)

        x = b
        v = a
        return
      end

c     a*b mod p by repeated addition
      integer*8 function mult(a, b, p)
        integer*8 a, b, p, x, y, m
        m = 0
        x = a
        y = b
        do 1 while(y.ne.0)
           if (mod(y, 2).eq.1) then
              m = mod(m + x, p)
           end if
           y = y / 2
           if (x.lt.p-x) then
              x = x * 2
           else
              x = x - (p - x)
           end if
 1      continue
        mult = m
        return
      end

c     A version of mod that handles negatives correctly
      integer*8 function modulo(a, b)
        integer*8 a, b
        modulo = mod(a, b)
        if (modulo.lt.0) then
           modulo = modulo + b
        end if
        return
      end

c     b^e mod m by repeated squaring
      integer*8 function modexp(b, e, m)
        integer*8 b, e, m
        integer*8 c, x, mult, g
        c = mod(b, m)
        x = e
        g = 1
        do 1 while(x.gt.0)
           if (mod(x, 2).eq.1) then
              g = mult(g, c, m)
           end if
           c = mult(c, c, m)
           x = x / 2
 1      continue
        modexp = g
        return
      end

c     Get the modular inverse (1 / a mod m)
      integer*8 function inverse(a, m)
        integer*8 a, m, q, p
        integer*8 t0, t1, r0, r1

        t0 = 0
        t1 = 1
        r0 = m
        r1 = a

        do 1 while (r1 .ne. 0)
           q = r0 / r1

           p = t1
           t1 = t0 - q * t1
           t0 = p

           p = r1
           r1 = r0 - q * r1
           r0 = p
 1      continue

        if (t0 .lt. 0) then
           inverse = t0 + m
        else
           inverse = t0
        end if
        return
      end


program problem85
  implicit none
  integer :: besti,bestj,best,temp,i,j

  best=huge(best)
  besti=0
  bestj=0

  do i=1,100
     do j=1,100
        temp=score(i,j)
        if (abs(temp-2000000)<best) then
           besti=i
           bestj=j
           best=abs(temp-2000000)
        end if
     end do
  end do

  print *, best,besti*bestj

contains

  pure function score(x,y)
    implicit none
    integer, intent(in) :: x,y
    integer             :: u,v,i,j,score

    score=0
    do i=1,x
       u=(x+1-i)
       do j=1,y
          v=(y+1-j)
          score=score+(u*v)
       end do
    end do

  end function score

end program problem85


! { dg-do run }
! PR46842 wrong results with MATMUL(..., TRANSPOSE (func ()))
implicit none
call sub()
contains
   subroutine sub()
      real, dimension(2,2) :: b
      b = 1.0
      b = matmul(b,transpose(func()))
      if (any(b.ne.reshape((/ 4.0, 4.0, 6.0, 6.0 /),[2,2]) )) print *, b
   end subroutine

   function func() result(res)
      real, dimension(2,2) :: res
      res = reshape([1,2,3,4], [2,2])
   end function
end


! explicit_euler.f95
! subroutine to compute explicit Euler solution of kinetic equations
! July 2014

subroutine solve( N_t, N_c, N_s, w_0, w_f, T_s, logA, E, nu, beta, w_s )

    implicit none

    ! inputs/outputs
    integer, intent(in)                 :: N_t      ! number of time steps
    integer, intent(in)                 :: N_c      ! number of components
    integer, intent(in)                 :: N_s      ! number of solution values
    real, intent(in), dimension(N_c)    :: w_0
    real, intent(in)                    :: w_f
    real, intent(in), dimension(N_s)    :: T_s
    real, intent(in), dimension(N_c-1)  :: logA
    real, intent(in), dimension(N_c-1)  :: E
    real, intent(in), dimension(N_c-1)  :: nu
    real, intent(in)                    :: beta
    real, intent(out), dimension(N_s)   :: w_s

    ! local variables
    integer                 :: i, j, k
    real, dimension(N_c-1)  :: r
    real, dimension(N_c)    :: w
    real                    :: dT
    real                    :: T

    w = w_0
    dT = (T_s(N_s) - T_s(1))/N_t
    T = T_s(1)
    w_s(1) = 1.
    k = 2

    do j = 2, N_t

        ! compute weight fractions at time step j

        r(1)    = 10.**logA(1)*w(1)*exp(-E(1)/(8.314*T))/beta
        r(1)    = min(r(1), w(1)/dT)
        w(1)    = w(1) - dT*r(1)

        do i = 2, N_c - 1

            r(i) = 10.**logA(i)*w(i)*exp(-E(i)/(8.314*T))/beta
            r(i) = min(r(i), w(i)/dT + nu(i-1)*r(i-1))
            w(i) = w(i) - dT*(r(i) - nu(i-1)*r(i-1))

        end do

        w(N_c) = min(w_f, w(N_c) - dT*(-nu(N_c-1)*r(N_c-1)))

        ! update temperature
        T = T + dT

        ! store solution weights if necessary
        if ( (T >= T_s(k)).and.((T-dT) < T_s(k)) ) then

            w_s(k) = sum(w)
            k = k + 1

        end if

    end do

end subroutine solve


      SUBROUTINE DG01MD( INDI, N, XR, XI, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the discrete Fourier transform, or inverse transform,
C     of a complex signal.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     INDI    CHARACTER*1
C             Indicates whether a Fourier transform or inverse Fourier
C             transform is to be performed as follows:
C             = 'D':  (Direct) Fourier transform;
C             = 'I':  Inverse Fourier transform.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of complex samples.  N must be a power of 2.
C             N >= 2.
C
C     XR      (input/output) DOUBLE PRECISION array, dimension (N)
C             On entry, this array must contain the real part of either
C             the complex signal z if INDI = 'D', or f(z) if INDI = 'I'.
C             On exit, this array contains either the real part of the
C             computed Fourier transform f(z) if INDI = 'D', or the
C             inverse Fourier transform z of f(z) if INDI = 'I'.
C
C     XI      (input/output) DOUBLE PRECISION array, dimension (N)
C             On entry, this array must contain the imaginary part of
C             either z if INDI = 'D', or f(z) if INDI = 'I'.
C             On exit, this array contains either the imaginary part of
C             f(z) if INDI = 'D', or z if INDI = 'I'.
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     If INDI = 'D', then the routine performs a discrete Fourier
C     transform on the complex signal Z(i), i = 1,2,...,N. If the result
C     is denoted by FZ(k), k = 1,2,...,N, then the relationship between
C     Z and FZ is given by the formula:
C
C                     N            ((k-1)*(i-1))
C            FZ(k) = SUM ( Z(i) * V              ),
C                    i=1
C                                     2
C     where V = exp( -2*pi*j/N ) and j  = -1.
C
C     If INDI = 'I', then the routine performs an inverse discrete
C     Fourier transform on the complex signal FZ(k), k = 1,2,...,N. If
C     the result is denoted by Z(i), i = 1,2,...,N, then the
C     relationship between Z and FZ is given by the formula:
C
C                    N             ((k-1)*(i-1))
C            Z(i) = SUM ( FZ(k) * W              ),
C                   k=1
C
C     where W = exp( 2*pi*j/N ).
C
C     Note that a discrete Fourier transform, followed by an inverse
C     discrete Fourier transform, will result in a signal which is a
C     factor N larger than the original input signal.
C
C     REFERENCES
C
C     [1] Rabiner, L.R. and Rader, C.M.
C         Digital Signal Processing.
C         IEEE Press, 1972.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires 0( N*log(N) ) operations.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997.
C     Supersedes Release 2.0 routine DG01AD by R. Dekeyser, State
C     University of Gent, Belgium.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Complex signals, digital signal processing, fast Fourier
C     transform.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, HALF, ONE, TWO, EIGHT
      PARAMETER         ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,
     $                    TWO = 2.0D0, EIGHT = 8.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         INDI
      INTEGER           INFO, N
C     .. Array Arguments ..
      DOUBLE PRECISION  XI(*), XR(*)
C     .. Local Scalars ..
      LOGICAL           LINDI
      INTEGER           I, J, K, L, M
      DOUBLE PRECISION  PI2, TI, TR, WHELP, WI, WR, WSTPI, WSTPR
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ATAN, DBLE, MOD, SIN
C     .. Executable Statements ..
C
      INFO = 0
      LINDI = LSAME( INDI, 'D' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LINDI .AND. .NOT.LSAME( INDI, 'I' ) ) THEN
         INFO = -1
      ELSE
         J = 0
         IF( N.GE.2 ) THEN
            J = N
C           WHILE ( MOD( J, 2 ).EQ.0 ) DO
   10       CONTINUE
            IF ( MOD( J, 2 ).EQ.0 ) THEN
               J = J/2
               GO TO 10
            END IF
C           END WHILE 10
         END IF
         IF ( J.NE.1 ) INFO = -2
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'DG01MD', -INFO )
         RETURN
      END IF
C
C     Inplace shuffling of data.
C
      J = 1
C
      DO 30 I = 1, N
         IF ( J.GT.I ) THEN
            TR = XR(I)
            TI = XI(I)
            XR(I) = XR(J)
            XI(I) = XI(J)
            XR(J) = TR
            XI(J) = TI
         END IF
         K = N/2
C        REPEAT
   20    IF ( J.GT.K ) THEN
            J = J - K
            K = K/2
            IF ( K.GE.2 ) GO TO 20
         END IF
C        UNTIL ( K.LT.2 )
         J = J + K
   30 CONTINUE
C
C     Transform by decimation in time.
C
      PI2 = EIGHT*ATAN( ONE )
      IF ( LINDI ) PI2 = -PI2
C
      I = 1
C
C     WHILE ( I.LT.N ) DO
C
   40 IF ( I.LT.N ) THEN
         L = 2*I
         WHELP = PI2/DBLE( L )
         WSTPI = SIN( WHELP )
         WHELP = SIN( HALF*WHELP )
         WSTPR = -TWO*WHELP*WHELP
         WR = ONE
         WI = ZERO
C
         DO 60 J = 1, I
C
            DO 50 K = J, N, L
               M = K + I
               TR = WR*XR(M) - WI*XI(M)
               TI = WR*XI(M) + WI*XR(M)
               XR(M) = XR(K) - TR
               XI(M) = XI(K) - TI
               XR(K) = XR(K) + TR
               XI(K) = XI(K) + TI
   50       CONTINUE
C
            WHELP = WR
            WR = WR + WR*WSTPR - WI*WSTPI
            WI = WI + WHELP*WSTPI + WI*WSTPR
   60    CONTINUE
C
         I = L
         GO TO 40
C        END WHILE 40
      END IF
C
      RETURN
C *** Last line of DG01MD ***
      END


     program demo_lglin
     use M_calcomp
     implicit none
     ! based on concepts of CALIFORNIA COMPUTER PRODUCTS, 1968
     character(len=50) :: ibcd
     integer           :: i, k
     integer           :: inteq
     real              :: a
     real              :: angl
     real              :: angle(19)
     real              :: bang
     real              :: beta
     real              :: r(19)
     real              :: theta
     real              :: x
     real              :: xx
     real              :: xa,ya, xb,yb, xc,yc, xd,yd
     real              :: xar(8)= [ 1.00, 2.00, 3.00, 4.00, 5.00, 6.00       , 0.0, 0.0 ]
     real              :: yar(8)= [ 250.0, 110.0, 500.0, 900.0, 200.0, 140.0 , 0.0, 1.0 ]
        call plots(0.0,10.0,0.0,10.0)
     ! DRAW FRAME
        call plot(7.0,0.0,2)
        call plot(7.0,9.0,2)
        call plot(0.0,9.0,2)
        call plot(0.0,0.0,2)
     ! DRAW COMMENTS
        ibcd='USING SCALG, LGAXS, AND LGLIN SUBROUTINES'
        call symbol(0.7,8.25,0.14,ibcd,inteq,0.0,42)
        ibcd='USING POLAR SUBROUTINE'
        call symbol(0.7,3.80,0.14,ibcd,inteq,0.0,22)
     ! AXIS IS DRAWN
        ibcd='ALTITUDE'
        call axis(1.0,4.75,ibcd,-8,5.0,0.0,0.0,25.0)
        call scalg(yar,3.0,6,1)
        ibcd='TEMPERATURE'
        call lgaxs(1.0,4.75,ibcd,11,3.0,90.0,yar(7),yar(8))
        call scale(xar,5.0,6,1)
        call plot(1.0,4.75,-3)
        call lglin(xar,yar,6,1,0,1,1)
        call plot(-1.0,-4.75,-3)
     ! POLAR SUBROUTINE IS USED
        x=0.0
        do k=1,19
           theta=x*0.0174533
           r(k)=2.0*(1.0-cos(theta))
           angle(k)=theta
           x=x+10.0
        enddo
        call plot(5.0,0.75,-3)
        call polar(r,angle,19,1,0,1,0.0,1.0)
        angl =30.0
        a=1.0
        do  i=1,5
           theta=angl *0.0174533
           xa=cos(theta)
           ya=sin(theta)
           call plot(xa,ya,3)
           xb=1.1*xa
           yb=1.1*ya
           call plot(xb,yb,2)
           xc=xb+0.05*xa
           yc=yb+0.05*ya
           if((i-3).gt.0)then
              a=1.5
           endif
           beta=1.570797-theta
           xd=xc-0.105*a*cos(beta)
           yd=yc+0.105*a*sin(beta)
           bang=270.0+angl
           call number(xd,yd,0.105,angl, bang,-1)
           angl =angl +30.0
        enddo
        xx=0.0
        do i=1,19
           angle(i) = xx*0.0174533
           r(i) = 1.0
           xx=xx+10.0
        enddo
        call polar(r,angle,19,1,0,1,0.0,1.0)
        call plot(-5.0,-0.75,-3)
     ! AXIS IS DRAWN
        ibcd=''
        call axis(1.0,0.75,ibcd,-1,4.0,0.0,4.0,-1.0)
        call axis(5.0,0.75,ibcd,-1,1.0,0.0,0.0,1.0)
        ibcd='RADIUS=2*(1-COS(ANGLE))'
        call symbol(3.75,3.5,0.09,ibcd,inteq,0.0,23)
        call plot(11.0,0.0,999)
     end program demo_lglin


: prime? HERE + C@ 0= ;
: composite! HERE + 1 SWAP C! ;

: sieve
  HERE OVER ERASE
  2
  BEGIN
    2DUP DUP * >
  WHILE
    DUP prime? IF
      2DUP DUP * DO
        I composite!
      DUP +LOOP
    THEN
    1+
  REPEAT
  DROP
  1 SWAP 2 DO I prime? IF DROP I THEN LOOP .
;

: main 10000 sieve ;


	subroutine tuiep3 (xa, ya, x, y, dy)
C
C  Evaluate a cubic polynomial interpolation function at X.
C       xa(klo) <= x <= xa(klo+1)
C  This routine was copied with slight modifications from the POLINT
C  subroutine in Numerical Recipes by Press, Flannery, Teukolsky and
C  Vetterling.
C
C  XA		i: array of four independent-variable values
C  YA		i: array of four dependent-variable values
C  X		i: the independent variable
C  Y		o: the result of interpolations
C  DY		o: an estimate of the error of interpolation
C
CH  Phil Hodge, 18-Apr-1988  Subroutine copied from Numerical Recipes POLINT.
C
	double precision xa(4), ya(4), x, y, dy
C--
	integer n
C					four-point interpolation
	parameter (n = 4)

	double precision c(n), d(n), dif, dift, den
	double precision ho, hp, w
	integer i, m, ns

	do 10 i = 1, n
	    if (x .eq. xa(i)) then
		y = ya(i)
		return
	    endif
 10	continue

	ns = 1
	dif = abs (x - xa(1))

	do 20 i = 1, n
	    dift = abs (x - xa(i))
	    if (dift .lt. dif) then
		ns = i
		dif = dift
	    endif
	    c(i) = ya(i)
	    d(i) = ya(i)
 20	continue

	y = ya(ns)
	ns = ns - 1

	do 40 m = 1, n-1

	    do 30 i = 1, n-m
		ho = xa(i) - x
		hp = xa(i+m) - x
		w = c(i+1) - d(i)
		den = w / (ho - hp)
		d(i) = hp * den
		c(i) = ho * den
 30	    continue

	    if (2*ns .lt. n-m) then
		dy = c(ns+1)
	    else
		dy = d(ns)
		ns = ns - 1
	    endif
	    y = y + dy
 40	continue

	return
	end


program weather_average

  use mod_arrays, only: denan, normalize, &
    operator(.denan.), operator(.normalize.)
  use mod_average, only: average, operator(.average.)
  use mod_weather_data, only: weather_data

  implicit none

  type(weather_data) :: dataset
  character(len=4), parameter :: cities(*) = &
    ['EGLL', 'LAX ', 'LYBE', 'MIA ', 'MMMX', &
     'NYC ', 'OIII', 'SEA ', 'SKBO', 'ZGSZ']
  integer :: n
  integer, parameter :: nm = size(cities)
  real :: temperature(nm), humidity(nm), wind_speed(nm), clear_sky(nm)
  real :: temperature_score(nm), humidity_score(nm),&
          wind_score(nm), clear_score(nm), total_score(nm)

  ! Read data and compute the averages
  do n = 1, nm
    dataset = weather_data('data/processed/' // trim(cities(n)) // '.csv')
    temperature(n) = .average. (.denan. dataset % temperature)
    humidity(n) = .average. (.denan. dataset % humidity)
    wind_speed(n) = .average. (.denan. dataset % wind_speed)
    clear_sky(n) = .average. dataset % clear_sky
  end do

  ! Compute scores
  temperature_score = .normalize. temperature ! the higher the better
  humidity_score = 1 - .normalize. humidity ! the lower the better
  wind_score = .normalize. wind_speed ! the higher the better
  clear_score = .normalize. clear_sky ! the higher the better
  total_score = (temperature_score + humidity_score &
    + wind_score + clear_score) / 4

  ! Generate the score table
  print *, 'City | Temp. | Humidity | Wind  | Clear | Total'
  print *, 'Code | Score | Score    | Score | Score | Score'
  print *, '-----+-------+----------+-------+-------+------'
  do n = 1, nm
    write(*,'(1x, a4, 3x, 5(f4.2, 5x))') cities(n), temperature_score(n),&
      humidity_score(n), wind_score(n), clear_score(n), total_score(n)
  end do

end program weather_average


PROGRAM time_random_normal
IMPLICIT NONE

INTERFACE
  FUNCTION random_normal() RESULT (ran_norm)
    IMPLICIT NONE
    REAL :: ran_norm
  END FUNCTION random_normal

  SUBROUTINE gasdev_s(harvest)
    IMPLICIT NONE
    REAL, INTENT(OUT) :: harvest
  END SUBROUTINE gasdev_s
END INTERFACE

INTEGER              :: i, k, start(8), finish(8)
REAL                 :: x, time_taken
INTEGER, ALLOCATABLE :: seed(:)

!     Set the random number seed.

CALL RANDOM_SEED(size=k)
ALLOCATE (seed(k))
CALL RANDOM_SEED(get=seed)
WRITE(*, *)'Old random number seeds: ', seed

WRITE(*, '(1x, a, i4, a)') 'Enter ', k, ' integers as random number seeds: '
READ(*, *) seed
CALL RANDOM_SEED(put=seed)

!     Generate 10 million random normals using TOMS 712

CALL DATE_AND_TIME( VALUES=start )
DO i = 1, 10000000
  x = random_normal()
END DO
CALL DATE_AND_TIME( VALUES=finish )
time_taken = 3600.*(finish(5) - start(5)) + 60.*(finish(6) - start(6)) +  &
             (finish(7) - start(7)) + 0.001*(finish(8) - start(8))
WRITE(*, '(a, f8.2, a)') ' Time taken using TOMS 712 = ', time_taken, ' sec.'

!     Generate 10 million random normals using NR

CALL DATE_AND_TIME( VALUES=start )
DO i = 1, 10000000
  CALL gasdev_s(x)
END DO
CALL DATE_AND_TIME( VALUES=finish )
time_taken = 3600.*(finish(5) - start(5)) + 60.*(finish(6) - start(6)) +  &
             (finish(7) - start(7)) + 0.001*(finish(8) - start(8))
WRITE(*, '(a, f8.2, a)') ' Time taken using Num. Rec.= ', time_taken, ' sec.'

STOP
END PROGRAM time_random_normal

FUNCTION random_normal() RESULT (ran_norm)

! Adapted from the following Fortran 77 code
!      ALGORITHM 712, COLLECTED ALGORITHMS FROM ACM.
!      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
!      VOL. 18, NO. 4, DECEMBER, 1992, PP. 434-435.

!  The function random_normal() returns a normally distributed pseudo-random
!  number with zero mean and unit variance.   This version uses the default
!  uniform random number generator which is in your fortran library.

!  The algorithm uses the ratio of uniforms method of A.J. Kinderman
!  and J.F. Monahan augmented with quadratic bounding curves.

!  Fortran 90 version by Alan Miller (alan @ mel.dms.csiro.au)

IMPLICIT NONE
REAL :: ran_norm

!     Local variables
REAL, PARAMETER :: s = 0.449871, t = -0.386595, a = 0.19600, b = 0.25472,   &
                   half = 0.5, r1 = 0.27597, r2 = 0.27846
REAL            :: u, v, x, y, q

!     Generate P = (u,v) uniform in rectangle enclosing acceptance region

DO
  CALL RANDOM_NUMBER(u)
  CALL RANDOM_NUMBER(v)
  v = 1.7156 * (v - half)

!     Evaluate the quadratic form
  x = u - s
  y = ABS(v) - t
  q = x**2 + y*(a*y - b*x)

!     Accept P if inside inner ellipse
  IF (q < r1) EXIT
!     Reject P if outside outer ellipse
  IF (q > r2) CYCLE
!     Reject P if outside acceptance region
  IF (v**2 < -4.0*LOG(u)*u**2) EXIT
END DO

!     Return ratio of P's coordinates as the normal deviate
ran_norm = v/u
RETURN

END FUNCTION random_normal

SUBROUTINE gasdev_s(harvest)
! Numerical Recipes routine for generating a single normal random deviate,
! adapted to use the compiler's random number generator.

IMPLICIT NONE
REAL, INTENT(OUT) :: harvest

! Local variables
REAL          :: rsq, v1, v2
REAL, SAVE    :: g
LOGICAL, SAVE :: gaus_stored = .false.

IF (gaus_stored) THEN
   harvest = g
   gaus_stored = .false.
ELSE
   DO
      CALL RANDOM_NUMBER(v1)
      CALL RANDOM_NUMBER(v2)
      v1 = 2.0*v1 - 1.0
      v2 = 2.0*v2 - 1.0
      rsq = v1**2 + v2**2
      if (rsq > 0.0 .and. rsq < 1.0) EXIT
   END DO
   rsq = SQRT(-2.0*LOG(rsq)/rsq)
   harvest = v1*rsq
   g = v2*rsq
   gaus_stored = .true.
END IF

RETURN
END SUBROUTINE gasdev_s


PROGRAM A6Q2
!--
! Determines the next permutation of the array A.
!--
IMPLICIT NONE
INTEGER, DIMENSION(:), ALLOCATABLE :: An
INTEGER :: n, check, invokenum, idx
LOGICAL :: permcheck

PRINT *, "Determines the next possible permutation of A, if there is one"
DO
	PRINT *, "Please enter the length of the array A (0 to stop)"
    READ *, n
    IF (n .eq. 0) STOP
    ALLOCATE(An(n), STAT=check)
    IF (check .ne. 0) THEN
      	PRINT *, "Allocation for array A was unseccessfull"
    ELSE
      	PRINT *, "Please enter the data for array A"
        READ *, An
		PRINT *, "How many permutations would you like to cycle through?"
        READ *, invokenum
        DO idx = 1, invokenum
			permcheck = NextPerm(An, n)
            PRINT *, "Permutation", idx
            IF (permcheck) THEN
              	PRINT "(1X, I2, 15I3)", An
            ELSE
              	PRINT *, "No further permutations are available"
            END IF
        END DO
        DEALLOCATE(An)
    END IF
END DO

CONTAINS
!- Do the next array shift
LOGICAL FUNCTION NextPerm(A,n)
INTEGER, DIMENSION(n), INTENT(INOUT) :: A
INTEGER :: n
INTEGER :: x, idxX, n0, n1, tmp
LOGICAL :: possibleperm

x = A(n)
idxX = n
n1 = n
n0 = n - 1
possibleperm = .false.
DO WHILE (n0 .gt. 0)
	IF (A(n1) .gt. A(n0) .and. A(n0) .gt. x) idxX = n1
    IF (A(n0) .lt. A(n1)) THEN
      	x = A(idxX)
        tmp = A(n0)
        A(n0) = x
        A(idxX) = tmp
        possibleperm = .true.
        n0 = 0
    ELSE
      	n1 = n0
        n0 = n0 - 1
    END IF
END DO
IF (possibleperm) CALL SelectionSort(A, n1, n)
NextPerm = possibleperm

END FUNCTION NextPerm
!- Sort the required set of A
SUBROUTINE SelectionSort(A, i, j)
INTEGER, DIMENSION(j), INTENT(INOUT) :: A
INTEGER, INTENT(IN) :: i, j
INTEGER :: min_idx, h, k, tmp

h = i
DO WHILE (h .lt. j)
  	min_idx = h
    	DO k = h,j
        	IF (A(min_idx) .gt. A(k)) min_idx = k
        END DO
	tmp = A(h)
    A(h) = A(min_idx)
    A(min_idx) = tmp
	h = h + 1
END DO

END SUBROUTINE SelectionSort
END PROGRAM


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! ZARCG43 (Zomplex Auxiliary Routine Compute Givens generators 4->3)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the generator for a Givens rotation represented
! by 3 real numbers: the real and imaginary parts of a complex cosine
! and a scrictly real sine. The first column is constructed to be
! parallel with the complex vector [A,B]^T. The (4->3) refers to the
! 4 double inputs and 3 double outputs (excluding the norm).
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  AR, AI          REAL(8)
!                    real and imaginary part of the first component
!                    of the complex vector [A,B]^T
!
!  BR, BI          REAL(8)
!                    real and imaginary part of the second component
!                    of the complex vector [A,B]^T
!
! OUTPUT VARIABLES:
!
!  CR, CI          REAL(8)
!                    on exit contains the generators for the cosine
!                    component of the Givens rotation
!
!  S               REAL(8)
!                    on exit contains the generators for the sine
!                    component of the Givens rotation
!
!  NRM             REAL(8)
!                    on exit contains the norm of the vector [A,B]^T
!
!  INFO            INTEGER
!                    INFO = 0 implies successful computation
!                    INFO = -1 implies AR is invalid
!                    INFO = -2 implies AI is invalid
!                    INFO = -3 implies BR is invalid
!                    INFO = -4 implies BI is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine ZARCG43(AR,AI,BR,BI,CR,CI,S,NRM,INFO)

  implicit none

  ! input variables
  integer, intent(inout) :: INFO
  real(8), intent(in) :: AR, AI, BR, BI
  real(8), intent(inout) :: CR, CI, S, NRM

  ! compute variables
  real(8) :: sr, si, temp

  ! initialize INFO
  INFO = 0

  ! print error in debug mode
  if (DEBUG) then

    ! check AR
    call DARNAN(AR,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"AR is invalid",INFO,-1)
      return
    end if
    call DARINF(AR,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"AR is invalid",INFO,-1)
      return
    end if

    ! check AI
    call DARNAN(AI,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"AI is invalid",INFO,-2)
      return
    end if
    call DARINF(AI,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"AI is invalid",INFO,-2)
      return
    end if

    ! check BR
    call DARNAN(BR,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"BR is invalid",INFO,-3)
      return
    end if
    call DARINF(BR,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"BR is invalid",INFO,-3)
      return
    end if

    ! check BI
    call DARNAN(BI,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"BI is invalid",INFO,-4)
      return
    end if
    call DARINF(BI,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"BI is invalid",INFO,-4)
      return
    end if

  end if

  ! compute NRM
  CR = abs(AR)
  CI = abs(AI)
  sr = abs(BR)
  si = abs(BI)

  ! exit if nrm is zero
  if ((CR.EQ.0).AND.(CI.EQ.0).AND.(sr.EQ.0).AND.(si.EQ.0)) then
    nrm = 0d0
    CR = 1d0
    CI = 0d0
    S = 0d0
    return
  end if

  ! find maximum value
  NRM = CR
  if (CI > NRM) then
    NRM = CI
  end if
  if (sr > NRM) then
    NRM = sr
  end if
  if (si > NRM) then
    NRM = si
  end if

  ! scale
  CR = CR/NRM
  CI = CI/NRM
  sr = sr/NRM
  si = si/NRM

  ! NRM
  NRM = NRM*sqrt(CR*CR + CI*CI + sr*sr + si*si)

  ! update Generators
  CR = AR/NRM
  CI = AI/NRM
  sr = BR/NRM
  si = BI/NRM

  ! check si
  if (abs(si) .EQ. 0d0) then
    S = sr
    return
  end if

  ! compute phase
  if (abs(sr) > abs(si)) then
    S = abs(sr)*sqrt(1d0+abs(si/sr)**2)
  else
    S = abs(si)*sqrt(1d0+abs(sr/si)**2)
  end if
  sr = sr/S
  si = si/S

  ! update CR and CI
  temp = CR*sr + CI*si
  CI = -CR*si + CI*sr
  CR = temp

end subroutine ZARCG43


!*********************************************************************
!
! This benchmark test program is measuring a cpu performance
! of floating point operation by a Poisson equation solver.
!!
! If you have any question, please ask me via email.
! written by Ryutaro HIMENO, November 26, 2001.
! Version 3.0
! ----------------------------------------------
! Ryutaro Himeno, Dr. of Eng.
! Head of Computer Information Division,
! RIKEN (The Institute of Pysical and Chemical Research)
! Email : himeno@postman.riken.go.jp
! ---------------------------------------------------------------
! You can adjust the size of this benchmark code to fit your target
! computer. In that case, please chose following sets of
! (mimax,mjmax,mkmax):
! small : 65,33,33
! small : 129,65,65
! midium: 257,129,129
! large : 513,257,257
! ext.large: 1025,513,513
! This program is to measure a computer performance in MFLOPS
! by using a kernel which appears in a linear solver of pressure
! Poisson eq. which appears in an incompressible Navier-Stokes solver.
! A point-Jacobi method is employed in this solver as this method can
! be easyly vectrized and be parallelized.
! ------------------
! Finite-difference method, curvilinear coodinate system
! Vectorizable and parallelizable on each grid point
! No. of grid points : imax x jmax x kmax including boundaries
! ------------------
! A,B,C:coefficient matrix, wrk1: source term of Poisson equation
! wrk2 : working area, OMEGA : relaxation parameter
! BND:control variable for boundaries and objects ( = 0 or 1)
! P: pressure
! -------------------
! -------------------
! "use portlib" statement on the next line is for Visual fortran
! to use UNIX libraries. Please remove it if your system is UNIX.
! -------------------
! use portlib
!
MODULE pres
REAL(kind=4), DIMENSION(:,:,:), ALLOCATABLE :: p
END MODULE pres

!
MODULE mtrx
REAL(kind=4), ALLOCATABLE :: a(:,:,:,:), b(:,:,:,:), c(:,:,:,:)
END MODULE mtrx

!
MODULE bound
REAL(kind=4), DIMENSION(:,:,:), ALLOCATABLE :: bnd
END MODULE bound

!
MODULE work
REAL(kind=4), ALLOCATABLE :: wrk1(:,:,:), wrk2(:,:,:)
END MODULE work

!
MODULE others
INTEGER :: mimax, mjmax, mkmax
INTEGER :: imax, jmax, kmax
REAL(kind=4), PARAMETER :: omega = 0.8
END MODULE others

!
!
PROGRAM HimenoBMTxp_F90
USE others
!
IMPLICIT NONE
!
INTEGER :: nn
INTEGER :: ic, icr, icm
REAL(kind=4) :: flop, xmflops2, score, gosa
REAL(kind=8) :: cpu0, cpu1, cpu, dt
  ! ttarget specifys the measuring period in sec
REAL(kind=4), PARAMETER :: ttarget = 60.0
REAL(kind=8), EXTERNAL :: second
!
CALL readparam()
!
!! Initializing matrixes
CALL initmem()
CALL initmt()
PRINT *, ' mimax=',mimax,' mjmax=',mjmax,' mkmax=',mkmax
PRINT *, ' imax=',imax,' jmax=',jmax,' kmax=',kmax
!
CALL system_clock(ic,icr,icm)
dt = 1.0 / real(icr,8)
PRINT '(2x,a,e10.5)', 'Time measurement accuracy : ',dt
!! Start measuring
!
nn = 3
PRINT *, ' Start rehearsal measurement process.'
PRINT *, ' Measure the performance in 3 times.'
!
cpu0 = second()
!! Jacobi iteration
CALL jacobi(nn,gosa)
!
cpu1 = second()
cpu = (cpu1 - cpu0) * dt
flop = real(kmax - 2,4) * real(jmax - 2,4) * real(imax - 2,4) * 34.0
IF (cpu .NE. 0.0) xmflops2 = flop / real(cpu,4) * 1.0e-6 * real(nn,4)
PRINT *, '  MFLOPS:',xmflops2,'  time(s):',cpu,gosa
!
!! end the test loop
nn = int(ttarget / (cpu / 3.0))
PRINT *, 'Now, start the actual measurement process.'
PRINT *, 'The loop will be excuted in',nn,' times.'
PRINT *, 'This will take about one minute.'
PRINT *, 'Wait for a while.'
!
!! Jacobi iteration
cpu0 = second()
!! Jacobi iteration
CALL jacobi(nn,gosa)
!
cpu1 = second()
cpu = (cpu1 - cpu0) * dt
IF (cpu .NE. 0.0) xmflops2 = flop * 1.0e-6 / real(cpu,4) * real(nn,4)
!
!!!      xmflops2=nflop/cpu*1.0e-6*float(nn)
!
PRINT *, ' Loop executed for ',nn,' times'
PRINT *, ' Gosa :',gosa
PRINT *, ' MFLOPS:',xmflops2,'  time(s):',cpu
score = xmflops2 / 82.84
PRINT *, ' Score based on Pentium III 600MHz :',score
!
!  pause
!   stop
END PROGRAM HimenoBMTxp_F90

!
!
SUBROUTINE readparam()
!
USE others
!
IMPLICIT NONE
!
CHARACTER(len=10) :: size
!
PRINT *, 'Select Grid-size:'
!  print *,'For example:'
PRINT *, 'Grid-size= '
PRINT *, '           XS (64x32x32)'
PRINT *, '           S  (128x64x64)'
PRINT *, '           M  (256x128x128)'
PRINT *, '           L  (512x256x256)'
PRINT *, '           XL (1024x512x512)'
!  print *,' Grid-size = '
!  read(*,*) size
size = "M"
CALL grid_set(size)
!
imax = mimax - 1
jmax = mjmax - 1
kmax = mkmax - 1
!
RETURN
END SUBROUTINE readparam

!
!
SUBROUTINE grid_set(size)
USE others
IMPLICIT NONE
CHARACTER(len=10), INTENT(IN) :: size
!
SELECT CASE(size)
CASE ("xs")
mimax = 65
mjmax = 33
mkmax = 33
CASE ("XS")
mimax = 65
mjmax = 33
mkmax = 33
CASE ("s")
mimax = 129
mjmax = 65
mkmax = 65
CASE ("S")
mimax = 129
mjmax = 65
mkmax = 65
CASE ("m")
mimax = 257
mjmax = 129
mkmax = 129
CASE ("M")
mimax = 257
mjmax = 129
mkmax = 129
CASE ("l")
mimax = 513
mjmax = 257
mkmax = 257
CASE ("L")
mimax = 513
mjmax = 257
mkmax = 257
CASE ("xl")
mimax = 1025
mjmax = 513
mkmax = 513
CASE ("XL")
mimax = 1025
mjmax = 513
mkmax = 513
CASE DEFAULT
PRINT *, 'Invalid input character !!'
STOP
END SELECT
!
RETURN
END SUBROUTINE grid_set

!
!
!**************************************************************
SUBROUTINE initmt()
!**************************************************************
USE pres
USE mtrx
USE bound
USE work
USE others
!
IMPLICIT NONE
!
INTEGER :: i, j, k
!
!  a=0.0
!  b=0.0
!  c=0.0
!  p=0.0
!  wrk1=0.0
!  wrk2=0.0
!  bnd=0.0
!_KZ start
!$omp parallel
!$omp do
!_KZ end
DO k = 1, mkmax
DO j = 1, mjmax
DO i = 1, mimax
a(i,j,k,1) = 0.0
a(i,j,k,2) = 0.0
a(i,j,k,3) = 0.0
a(i,j,k,4) = 0.0
b(i,j,k,1) = 0.0
b(i,j,k,2) = 0.0
b(i,j,k,3) = 0.0
c(i,j,k,1) = 0.0
c(i,j,k,2) = 0.0
c(i,j,k,3) = 0.0
p(i,j,k) = 0.0
wrk1(i,j,k) = 0.0
wrk2(i,j,k) = 0.0
bnd(i,j,k) = 0.0
END DO
END DO
END DO
!_KZ start
!$omp end do
!$omp end parallel
!_KZ end
!
!  a(1:imax,1:jmax,1:kmax,1:3)=1.0
!  a(1:imax,1:jmax,1:kmax,4)=1.0/6.0
!  c(1:imax,1:jmax,1:kmax,:)=1.0
!  bnd(1:imax,1:jmax,1:kmax)=1.0
!  do k=1,kmax
!     p(:,:,k)=real((k-1)*(k-1),4)/real((kmax-1)*(kmax-1),4)
!  enddo
!_KZ start
!$omp parallel
!$omp do
!_KZ end
DO k = 1, kmax
DO j = 1, jmax
DO i = 1, imax
a(i,j,k,1) = 1.0
a(i,j,k,2) = 1.0
a(i,j,k,3) = 1.0
a(i,j,k,4) = 1.0 / 6.0
b(i,j,k,1) = 0.0
b(i,j,k,2) = 0.0
b(i,j,k,3) = 0.0
c(i,j,k,1) = 1.0
c(i,j,k,2) = 1.0
c(i,j,k,3) = 1.0
p(i,j,k) = real((k - 1) * (k - 1),4) / real((kmax - 1) * (kmax - 1),4)
wrk1(i,j,k) = 0.0
wrk2(i,j,k) = 0.0
bnd(i,j,k) = 1.0
END DO
END DO
END DO
!_KZ start
!$omp end do
!$omp end parallel
!_KZ end
!
RETURN
END SUBROUTINE initmt

!
!*************************************************************
SUBROUTINE initmem()
!*************************************************************
USE pres
USE mtrx
USE bound
USE work
USE others
!
IMPLICIT NONE
!
allocate( p(mimax,mjmax,mkmax) )
allocate( a(mimax,mjmax,mkmax,4),b(mimax,mjmax,mkmax,3),c(mimax,mjmax,mkmax,3) )
allocate( bnd(mimax,mjmax,mkmax) )
allocate( wrk1(mimax,mjmax,mkmax),wrk2(mimax,mjmax,mkmax) )
!
RETURN
END SUBROUTINE initmem

!
!*************************************************************
SUBROUTINE jacobi(nn,gosa)
USE pres
USE mtrx
USE bound
USE work
USE others
IMPLICIT NONE
INTEGER, INTENT(IN) :: nn
REAL(kind=4), INTENT(INOUT) :: gosa
INTEGER :: i, j, k, loop
REAL(kind=4) :: s0, ss
!
!
DO loop = 1, nn
gosa = 0.0
!_KZ start
!$omp parallel
!$omp do
!_KZ end
DO k = 2, kmax - 1
DO j = 2, jmax - 1
DO i = 2, imax - 1
s0 = a(i,j,k,1) * p(i + 1,j,k) + a(i,j,k,2) * p(i,j + 1,k) + a(i,j,k,3) * p(i,j,k + 1) + b(i,j,k,1) * (p(i + 1,j + 1,k) - p(i + 1,j - 1,k) - p(i - 1,j + 1,k) + p(i - 1,j - 1,k)) + b(i,j,k,2) * (p(i,j + 1,k + 1) - p(i,j - 1,k + 1) - p(i,j + 1,k - 1) + p(i,j - 1,k - 1)) + b(i,j,k,3) * (p(i + 1,j,k + 1) - p(i - 1,j,k + 1) - p(i + 1,j,k - 1) + p(i - 1,j,k - 1)) + c(i,j,k,1) * p(i - 1,j,k) + c(i,j,k,2) * p(i,j - 1,k) + c(i,j,k,3) * p(i,j,k - 1) + wrk1(i,j,k)
ss = (s0 * a(i,j,k,4) - p(i,j,k)) * bnd(i,j,k)
gosa = gosa + ss * ss
wrk2(i,j,k) = p(i,j,k) + omega * ss
END DO
END DO
END DO
!_KZ start
!$omp end do
!$omp end parallel
!_KZ end
!
!     p(2:imax-1,2:jmax-1,2:kmax-1)= &
!          wrk2(2:imax-1,2:jmax-1,2:kmax-1)
!_KZ start
!$omp parallel
!$omp do
!_KZ end
DO k = 2, kmax - 1
DO j = 2, jmax - 1
DO i = 2, imax - 1
p(i,j,k) = wrk2(i,j,k)
END DO
END DO
END DO
!_KZ start
!$omp end do
!$omp end parallel
!_KZ end
!
END DO
!! End of iteration
RETURN
END SUBROUTINE jacobi

!
!
!
 FUNCTION second() result(rtime)
!
IMPLICIT NONE
!
INTEGER :: ic, ir, im
REAL(kind=8) :: rtime
!
CALL system_clock(ic,ir,im)
!
rtime = real(ic,8)
!
END  FUNCTION second


MODULE spline1_mod
!-------------------------------------------------------------------------------
!SPLINE1-SPLINE interpolation in 1d
!
!SPLINE1_MOD is an F90 module of cubic interpolating spline routines in 1d
!
!References:
!
!  Forsythe, Malcolm, Moler, Computer Methods for Mathematical
!    Computations, Prentice-Hall, 1977, p.76
!  Engeln-Muellges, Uhlig, Numerical Algorithms with Fortran, Springer,
!    1996, p.251
!  W.A.Houlberg, P.I.Strand, D.McCune 8/2001
!  W.A.Houlberg, F90 free form 8/2004
!
!Contains PUBLIC routines:
!
!  SPLINE1_FIT         -get the coefficients
!  SPLINE1_EVAL        -evaluate the spline
!  SPLINE1_INTERP      -interpolate from one grid to another
!  SPLINE1_INTEG       -integrate the spline fit
!
!Comments:
!
!  Spline interpolation routines are C2 (f, f', and f'' are continuous)
!
!  The modernization of the code structure into an F90 module takes advantage of
!    some of the more attractive features of F90:
!    -use of KIND for precision declarations
!    -optional arguments for I/O
!    -generic names for all intrinsic functions
!    -compilation using either free or fixed form
!    -no common blocks or other deprecated Fortran features
!    -dynamic and automatic alocation of variables
!    -array syntax for vector operations
!-------------------------------------------------------------------------------
USE spec_kind_mod
IMPLICIT NONE

!-------------------------------------------------------------------------------
! Private procedures
!-------------------------------------------------------------------------------
PRIVATE :: &
  SPLINE1_SEARCH         !find the indices that bracket an abscissa value
                         !  called from SPLINE1_EVAL

!-------------------------------------------------------------------------------
! Public procedures
!-------------------------------------------------------------------------------
CONTAINS

SUBROUTINE SPLINE1_FIT(n,x,f, &
                       K_BC1,K_BCN)
!-------------------------------------------------------------------------------
!SPLINE1_FIT gets the coefficients for a 1d cubic interpolating spline
!
!References:
!  Forsythe, Malcolm, Moler, Computer Methods for Mathematical
!    Computations, Prentice-Hall, 1977, p.76
!  Engeln-Muellges, Uhlig, Numerical Algorithms with Fortran, Springer,
!    1996, p.251
!  W.A.Houlberg, P.I.Strand, D.McCune 8/2001
!  D.McCune, W.A.Houlberg 3/2004
!  W.A.Houlberg, F90 free form 8/2004
!
!Comments:
!  For x(i).le.x.le.x(i+1)
!    s(x) = f(1,i) + f(2,i)*(x-x(i)) + f(3,i)*(x-x(i))**2/2!
!          +f(4,i)*(x-x(i))**3/3!
!  The cubic spline is twice differentiable (C2)
!  The BCs default to not-a-knot conditions, K_BC1=0 and K_BCN=0
!  Two errors fixed in 3/2004 version:
!    Logic for not-a-knot on f(3,1) and f(3,n) after back substitution
!    Treatment of asymmetrix coefficient matrix for s''=0 BC
!  For s''=0 the off-diagonal elements nearest the corners are not symmetric,
!    i.e., el(1,2) /= el(2,1) and el(n-1,n) /= el(n,n-1).  The correct values:
!    el(1,2)=0, el(2,1)=x(2)-x(1), el(n,n-1)=0, el(n-1,n)=x(n)-x(n-1) are fixed
!    by adding variables to hold the el21 and elnn1 values.
!-------------------------------------------------------------------------------

!Declaration of input variables
INTEGER, INTENT(IN) :: &
  n                      !number of data points or knots [>=2]

REAL(KIND=rspec), INTENT(IN) :: &
  x(:)                   !abscissas of the knots in increasing order [arb]

!Declaration of input/output variables
REAL(KIND=rspec), INTENT(INOUT) :: &
  f(:,:)                 !ordinates of the knots [arb]
                         !f(2,1)=input value of s'(x1) for K_BC1=1 [arb]
                         !f(2,n)=input value of s'(xn) for K_BCN=1 [arb]
                         !f(3,1)=input value of s''(x1) for K_BC1=2 [arb]
                         !f(3,n)=input value of s''(xn) for K_BCN=2 [arb]
                         !f(2,i)=output s'(x(i)) [arb]
                         !f(3,i)=output s''(x(i)) [arb]
                         !f(4,i)=output s'''(x(i)) [arb]

!Declaration of optional input variables
INTEGER, INTENT(IN), OPTIONAL :: &
  K_BC1,               & !option for BC at x(1) [-]
                         !=-1 periodic, ignore K_BCN
                         !=0 not-a-knot (default)
                         !=1 s'(x1) = input value of f(2,1)
                         !=2 s''(x1) = input value of f(3,1)
                         !=3 s'(x1) = 0.0
                         !=4 s''(x1) = 0.0
                         !=5 match first derivative to first 2 points
                         !=6 match second derivative to first 3 points
                         !=7 match third derivative to first 4 points
                         !=else use not-a-knot
  K_BCN                  !option for boundary condition at x(n) [-]
                         !=0 not-a-knot (default)
                         !=1 s'(x1) = input value of f(2,1)
                         !=2 s''(x1) = input value of f(3,1)
                         !=3 s'(x1) = 0.0
                         !=4 s''(x1) = 0.0
                         !=5 match first derivative to first 2 points
                         !=6 match second derivative to first 3 points
                         !=7 match third derivative to first 4 points
                         !=else use knot-a-knot

!-------------------------------------------------------------------------------
!Declaration of local variables
INTEGER :: &
  i,ib,imax,imin,kbc1,kbcn

REAL(KIND=rspec) :: &
  a1,an,b1,bn,el21,elnn1,hn,q,t,wk(1:n)

!-------------------------------------------------------------------------------
!Initialization
!-------------------------------------------------------------------------------
!Set left BC option, and leftmost node
!Default to not-a-knot
kbc1=0

!Otherwise use requested value
IF(PRESENT(K_BC1)) THEN

  IF(K_BC1 >= -1 .AND. &
     K_BC1 <= 7) kbc1=K_BC1

ENDIF

!Include first node for all but not-a-knot
imin=1

!Not-a-knot condition removes first node
IF(kbc1 == 0) imin=2

!Set left BC values
!Default for not-a-knot
a1=0
b1=0

IF(kbc1 == 1) THEN

  !First derivative specified
  a1=f(2,1)

ELSEIF(kbc1 == 2) THEN

  !Second derivative specified
  b1=f(3,1)

ELSEIF(kbc1 == 5) THEN

  !Match first derivative to first two points
  a1=(f(1,2)-f(1,1))/(x(2)-x(1))

ELSEIF(kbc1 == 6) THEN

  !Match second derivative to first three points
  b1=2*((f(1,3)-f(1,2))/(x(3)-x(2))-(f(1,2)-f(1,1))/(x(2)-x(1)))/(x(3)-x(1))

ENDIF

!Set right BC option, and rightmost node
!Default to not-a-knot
kbcn=0

!Otherwise use requested value
IF(PRESENT(K_BCN)) THEN

  IF(K_BCN >= -1 .AND. &
     K_BCN <= 7) kbcn=K_BCN

ENDIF

!Include last node for all but not-a-knot
imax=n

!Not-a-knot condition removes last node
IF(kbcn == 0) imax=n-1

!Set right BC values
!Default for not-a-knot
an=0
bn=0

IF(kbcn == 1) THEN

  !First derivative specified
  an=f(2,n)

ELSEIF(kbcn == 2) THEN

  !Second derivative specified
  bn=f(3,n)

ELSEIF(kbcn == 5) THEN

  !Match first derivative to last two points
  an=(f(1,n)-f(1,n-1))/(x(n)-x(n-1))

ELSEIF(kbcn == 6) THEN

  !Match second derivative to first three points
  bn=2*((f(1,n)-f(1,n-1))/(x(n)-x(n-1)) &
     -(f(1,n-1)-f(1,n-2))/(x(n-1)-x(n-2)))/(x(n)-x(n-2))

ENDIF

!Clear derivatives, f(2:4,1:n), and work array
f(2:4,1:n)=0
wk(1:n)=0

!-------------------------------------------------------------------------------
!Evaluate coefficients
!-------------------------------------------------------------------------------
!Two and three nodes are special cases
IF(n == 2) THEN

  !Coefficients for n=2
  f(2,1)=(f(1,2)-f(1,1))/(x(2)-x(1))
  f(3,1)=0
  f(4,1)=0
  f(2,2)=f(2,1)
  f(3,2)=0
  f(4,2)=0

!Set up tridiagonal system for A*y=B where y(i) are the second
!  derivatives at the knots
!  f(2,i) are the diagonal elements of A
!  f(4,i) are the off-diagonal elements of A
!  f(3,i) are the B elements/3, and will become c/3 upon solution

ELSEIF(n > 2) THEN

  f(4,1)=x(2)-x(1)
  f(3,2)=(f(1,2)-f(1,1))/f(4,1)

  DO i=2,n-1 !Over nodes

    f(4,i)=x(i+1)-x(i)
    f(2,i)=2*(f(4,i-1)+f(4,i))
    f(3,i+1)=(f(1,i+1)-f(1,i))/f(4,i)
    f(3,i)=f(3,i+1)-f(3,i)

  ENDDO !Over nodes

  !Save elements for non-symmetric matrix cases
  el21=f(4,1)
  elnn1=f(4,n-1)

!Apply left BC
  IF(kbc1 == -1) THEN

    !Periodic
    f(2,1)=2*(f(4,1)+f(4,n-1))
    f(3,1)=(f(1,2)-f(1,1))/f(4,1)-(f(1,n)-f(1,n-1))/f(4,n-1)
    wk(1)=f(4,n-1)
    wk(2:n-3)=0
    wk(n-2)=f(4,n-2)
    wk(n-1)=f(4,n-1)

  ELSEIF((kbc1 == 1) .OR. &
         (kbc1 == 3) .OR. &
         (kbc1 == 5)) THEN

    !First derivative conditions
    f(2,1)=2*f(4,1)
    f(3,1)=(f(1,2)-f(1,1))/f(4,1)-a1

  ELSEIF((kbc1 == 2) .OR. (kbc1 == 4) .OR. (kbc1 == 6)) THEN

    !Second derivative conditions
    f(2,1)=2*f(4,1)
    f(3,1)=f(4,1)*b1/3
    f(4,1)=0

  ELSEIF(kbc1 == 7) THEN

    !Third derivative condition
    f(2,1)=-f(4,1)
    f(3,1)=f(3,3)/(x(4)-x(2))-f(3,2)/(x(3)-x(1))
    f(3,1)=f(3,1)*f(4,1)**2/(x(4)-x(1))

  ELSE

    !Not-a-knot condition
    f(2,2)=f(4,1)+2*f(4,2)
    f(3,2)=f(3,2)*f(4,2)/(f(4,1)+f(4,2))

  ENDIF

  !Apply right BC
  IF((kbcn == 1) .OR. &
     (kbcn == 3) .OR. &
     (kbcn == 5)) THEN

    !First derivative conditions
    f(2,n)=2*f(4,n-1)
    f(3,n)=-(f(1,n)-f(1,n-1))/f(4,n-1)+an

  ELSEIF((kbcn == 2) .OR. &
         (kbcn == 4) .OR. &
         (kbcn == 6)) THEN

    !Second derivative conditions
    f(2,n)=2*f(4,n-1)
    f(3,n)=f(4,n-1)*bn/3
    elnn1=0

  ELSEIF(kbcn == 7) THEN

    !Third derivative condition
    f(2,n)=-f(4,n-1)
    f(3,n)=f(3,n-1)/(x(n)-x(n-2))-f(3,n-2)/(x(n-1)-x(n-3))
    f(3,n)=-f(3,n)*f(4,n-1)**2/(x(n)-x(n-3))

  ELSEIF(kbc1 /= -1) THEN

    !Not-a-knot condition
    f(2,n-1)=2*f(4,n-2)+f(4,n-1)
    f(3,n-1)=f(3,n-1)*f(4,n-2)/(f(4,n-1)+f(4,n-2))

  ENDIF

  !Limit solution for only three points in domain
  IF(n == 3) THEN

    f(3,1)=0
    f(3,n)=0

  ENDIF

  !Solve system of equations for second derivatives at the knots
  IF(kbc1 == -1) THEN

    !Periodic BC - requires special treatment at ends
    !Forward elimination
    DO i=2,n-2 !Over nodes in forward elimination

      t=f(4,i-1)/f(2,i-1)
      f(2,i)=f(2,i)-t*f(4,i-1)
      f(3,i)=f(3,i)-t*f(3,i-1)
      wk(i)=wk(i)-t*wk(i-1)
      q=wk(n-1)/f(2,i-1)
      wk(n-1)=-q*f(4,i-1)
      f(2,n-1)=f(2,n-1)-q*wk(i-1)
      f(3,n-1)=f(3,n-1)-q*f(3,i-1)

    ENDDO !Over nodes in forward elimination

    !Correct the n-1 element
    wk(n-1)=wk(n-1)+f(4,n-2)

    !Complete the forward elimination
    !wk(n-1) and wk(n-2) are the off-diag elements of the lower corner
    t=wk(n-1)/f(2,n-2)
    f(2,n-1)=f(2,n-1)-t*wk(n-2)
    f(3,n-1)=f(3,n-1)-t*f(3,n-2)

    !Back substitution
    f(3,n-1)=f(3,n-1)/f(2,n-1)
    f(3,n-2)=(f(3,n-2)-wk(n-2)*f(3,n-1))/f(2,n-2)

    DO ib=3,n-1 !Over nodes in back substitution

      i=n-ib
      f(3,i)=(f(3,i)-f(4,i)*f(3,i+1)-wk(i)*f(3,n-1))/f(2,i)

    ENDDO !Over nodes in back substitution

    f(3,n)=f(3,1)

  ELSE

    !Non-periodic BC
    !Forward elimination
    !For not-a-knot and s''=0 BCs the off-diagonal end elements are not equal
    DO i=imin+1,imax !Over nodes in forward elimination

      IF((i == n-1) .AND. &
         (imax == n-1)) THEN

        t=(f(4,i-1)-f(4,i))/f(2,i-1)

      ELSE

        IF(i == 2) THEN

          t=el21/f(2,i-1)

        ELSEIF(i == n) THEN

          t=elnn1/f(2,i-1)

        ELSE

          t=f(4,i-1)/f(2,i-1)

        ENDIF

      ENDIF

      IF((i == imin+1) .AND. &
         (imin == 2)) THEN

        f(2,i)=f(2,i)-t*(f(4,i-1)-f(4,i-2))

      ELSE

        f(2,i)=f(2,i)-t*f(4,i-1)

      ENDIF

      f(3,i)=f(3,i)-t*f(3,i-1)

    ENDDO !Over nodes in forward elimination

    !Back substitution
    f(3,imax)=f(3,imax)/f(2,imax)

    DO ib=1,imax-imin !Over nodes in back substitution

      i=imax-ib

      IF((i == 2) .AND. &
         (imin == 2)) THEN

        f(3,i)=(f(3,i)-(f(4,i)-f(4,i-1))*f(3,i+1))/f(2,i)

      ELSE

        f(3,i)=(f(3,i)-f(4,i)*f(3,i+1))/f(2,i)

      ENDIF

    ENDDO !Over nodes in back substitution

    !Reset d array to step size
    f(4,1)=x(2)-x(1)
    f(4,n-1)=x(n)-x(n-1)

    !Set f(3,1) for not-a-knot; 5 changed to 7 in 3/2004
    IF((kbc1 <= 0) .OR. &
       (kbc1 > 7)) THEN

      f(3,1)=(f(3,2)*(f(4,1)+f(4,2))-f(3,3)*f(4,1))/f(4,2)

    ENDIF

    !Set f(3,n) for not-a-knot; 5 changed to 7 in 3/2004
    IF((kbcn <= 0) .OR. &
       (kbcn > 7)) THEN

      f(3,n)=f(3,n-1)+(f(3,n-1)-f(3,n-2))*f(4,n-1)/f(4,n-2)

    ENDIF

  ENDIF

  !f(3,i) is now the sigma(i) of the text and f(4,i) is the step size
  !Compute polynomial coefficients
  DO i=1,n-1 !Over nodes

    f(2,i)=(f(1,i+1)-f(1,i))/f(4,i)-f(4,i)*(f(3,i+1)+2*f(3,i))
    f(4,i)=(f(3,i+1)-f(3,i))/f(4,i)
    f(3,i)=6*f(3,i)
    f(4,i)=6*f(4,i)

  ENDDO !Over nodes

  IF(kbc1 == -1) THEN

    !Periodic BC
    f(2,n)=f(2,1)
    f(3,n)=f(3,1)
    f(4,n)=f(4,1)

  ELSE

    !All other BCs
    hn=x(n)-x(n-1)
    f(2,n)=f(2,n-1)+hn*(f(3,n-1)+hn*f(4,n-1)/2)
    f(3,n)=f(3,n-1)+hn*f(4,n-1)
    f(4,n)=f(4,n-1)

    IF((kbcn == 1) .OR. &
       (kbcn == 3) .OR. &
       (kbcn == 5)) THEN

      !First derivative BC
      f(2,n)=an

    ELSEIF((kbcn == 2) .OR. &
           (kbcn == 4) .OR. &
           (kbcn == 6)) THEN

      !Second derivative BC
      f(3,n)=bn

    ENDIF

  ENDIF

ENDIF

END SUBROUTINE SPLINE1_FIT

SUBROUTINE SPLINE1_EVAL(k_vopt,n,u,x,f, &
                        i, &
                        value)
!-------------------------------------------------------------------------------
!SPLINE1_EVAL evaluates the cubic spline function and its derivatives
!
!References:
!  W.A.Houlberg, P.I. Strand, D.McCune 8/2001
!  W.A.Houlberg, F90 free form 8/2004
!
!Comments:
!  s=f(1,i)+f(2,i)*dx+f(3,i)*dx**2/2!+f(4,i)*dx**3/3!
!  s'=f(2,i)+f(3,i)*dx+f(4,i)*dx**2/2!
!  s''=f(3,i)+f(4,i)*dx
!    where dx=u-x(i) and x(i).lt.u.lt.x(i+1)
!  If u <= x(1) then i=1 is used
!  If u >= x(n) then i=n is used
!-------------------------------------------------------------------------------

!Declaration of input variables
INTEGER, INTENT(IN) :: &
  k_vopt(:),           & !k_vopt(1)=calculate the function [0=off]
                         !k_vopt(2)=calculate the first derivative [0=off]
                         !k_vopt(3)=calculate the second derivative [0=off]
  n                      !number of data points [-]

REAL(KIND=rspec), INTENT(IN) :: &
  u,                   & !abscissa at which the spline is to be evaluated [arb]
  f(:,:),              & !array containing the data ordinates [arb]
  x(:)                   !array containing the data abcissas [arb]

!Declaration of input/output variables
INTEGER, INTENT(INOUT) :: &
  i                      !in=guess for target lower bound if 1<i<n [-]
                         !out=target lower bound [-]

!Declaration of output variables
REAL(KIND=rspec), INTENT(OUT) :: &
  value(:)               !ordering is a subset of the sequence under k_vopt [arb]
                         !value(1)=function or lowest order derivative requested [arb]
                         !value(2)=next order derivative requested [arb]
                         !value(3)=second derivative if all k_vopt are non-zero [arb]

!-------------------------------------------------------------------------------
!Declaration of local variables
INTEGER :: &
  j

REAL(KIND=rspec) :: &
  dx

!-------------------------------------------------------------------------------
!Find target cell
!-------------------------------------------------------------------------------
CALL SPLINE1_SEARCH(x,n,u, &
                    i)

!-------------------------------------------------------------------------------
!Set values outside of range to endpoints
!-------------------------------------------------------------------------------
IF(i <= 0) THEN

  i=1
  dx=0

ELSEIF(i >= n) THEN

  i=n
  dx=0

ELSE

 dx=u-x(i)

ENDIF

!-------------------------------------------------------------------------------
!Evaluate spline
!-------------------------------------------------------------------------------
j=0

!Value
IF(k_vopt(1) /= 0) THEN

  j=j+1
  value(j)=f(1,i)+dx*(f(2,i)+dx/2*(f(3,i)+f(4,i)*dx/3))

ENDIF

!First derivative
IF(k_vopt(2) /= 0) THEN

  j=j+1
  value(j)=f(2,i)+dx*(f(3,i)+f(4,i)*dx/2)

ENDIF

!Second derivative
IF(k_vopt(3) /= 0) THEN

  j=j+1
  value(j)=f(3,i)+dx*f(4,i)

ENDIF

END SUBROUTINE SPLINE1_EVAL

SUBROUTINE SPLINE1_INTERP(k_vopt,n0,x0,f,n1,x1,value, &
                          iflag,message, &
                          K_BC1,K_BCN)
!-------------------------------------------------------------------------------
!SPLINE1_INTERP performs a spline interpolation from the x0 mesh to the x1 mesh
!
!References:
!  W.A.Houlberg, P.I.Strand, D.McCune 8/2001
!  W.A.Houlberg, F90 free form 8/2004
!-------------------------------------------------------------------------------

!Declaration of input variables
INTEGER, INTENT(IN) :: &
  k_vopt(:),           & !option for output values
                         !k_vopt(1)=calculate the function [0=off]
                         !k_vopt(2)=calculate the first derivative [0=off]
                         !k_vopt(3)=calculate the second derivative [0=off]
  n0,                  & !number of source abscissas [-]
  n1                     !number of target abscissas [-]

REAL(KIND=rspec), INTENT(IN) :: &
  x0(:),               & !source abscissas (in increasing order) [arb]
  x1(:)                  !target abscissas (in increasing order) [arb]

!Declaration of input/output variables
REAL(KIND=rspec), INTENT(INOUT) :: &
  f(:,:)                 !f(1,n0)=input source values [arb]
                         !f(2,1)=input value of s'(x1) for K_BC1=1 [arb]
                         !f(2,n0)=input value of s'(xn) for K_BCN=1 [arb]
                         !f(3,1)=input value of s''(x1) for K_BC1=2 [arb]
                         !f(3,n0)=input value of s''(xn) for K_BCN=2 [arb]
                         !f(4,n)=output arrays of n0 spline coefficients
                         !f(2,i)=output s'(x0(i))/1!
                         !f(3,i)=output s''(x0(i))/2!
                         !f(4,i)=output s'''(x0(i))/3!

!Declaration of output variables
CHARACTER(len=*), INTENT(OUT) :: &
  message                !warning or error message [character]

INTEGER, INTENT(OUT) :: &
  iflag                  !error and warning flag [-]
                         !=-1 warning
                         !=0 none
                         !=1 error

REAL(KIND=rspec), INTENT(OUT) :: &
  value(:,:)             !ordering is a subset of the sequence under k_vopt [arb]
                         !value(1,j)=function or lowest order derivative requested [arb]
                         !value(2,j)=next order derivative requested [arb]
                         !value(3,j)=second derivative if all k_vopt are non-zero [arb]

!Declaration of optional input variables
INTEGER, INTENT(IN), OPTIONAL :: &
  K_BC1,               & !option for BC at x0(1) [-]
                         !=-1 periodic, ignore K_BCN
                         !=0 not-a-knot (default)
                         !=1 s'(x1) = input value of f(2,1)
                         !=2 s''(x1) = input value of f(3,1)
                         !=3 s'(x1) = 0.0
                         !=4 s''(x1) = 0.0
                         !=5 match first derivative to first 2 points
                         !=6 match second derivative to first 3 points
                         !=7 match third derivative to first 4 points
                         !=else use not-a-knot
  K_BCN                  !option for boundary condition at x0(n0) [-]
                         !=0 not-a-knot (default)
                         !=1 s'(x1) = input value of f(2,1)
                         !=2 s''(x1) = input value of f(3,1)
                         !=3 s'(x1) = 0.0
                         !=4 s''(x1) = 0.0
                         !=5 match first derivative to first 2 points
                         !=6 match second derivative to first 3 points
                         !=7 match third derivative to first 4 points
                         !=else use knot-a-knot

!-------------------------------------------------------------------------------
!Declaration of local variables
INTEGER :: &
  i,j

!-------------------------------------------------------------------------------
!Initialization
!-------------------------------------------------------------------------------
!If no target values are requested, return
IF(n1 <= 0) THEN

  iflag=-1
  message='SPLINE1_INTERP/WARNING(1):no points in output array'
  GOTO 9999

ENDIF

!Make sure there are at least two nodes in the input grid
IF(n0 < 2) THEN

  iflag=1
  message='SPLINE1_INTERP/ERROR(2):<2 points in source array'
  GOTO 9999

ENDIF

!-------------------------------------------------------------------------------
!Get spline coefficients
!-------------------------------------------------------------------------------
IF(PRESENT(K_BC1) .AND. &
   PRESENT(K_BCN)) THEN

  CALL SPLINE1_FIT(n0,x0,f, &
                   K_BC1=K_BC1, &
                   K_BCN=K_BCN)

  ELSEIF(PRESENT(K_BC1)) THEN

    CALL SPLINE1_FIT(n0,x0,f, &
                     K_BC1=K_BC1)

  ELSEIF(PRESENT(K_BCN)) THEN

    CALL SPLINE1_FIT(n0,x0,f, &
                     K_BCN=K_BCN)

  ELSE

    CALL SPLINE1_FIT(n0,x0,f)

ENDIF

!-------------------------------------------------------------------------------
!Interpolate onto x1 mesh
!-------------------------------------------------------------------------------
i=1

DO j=1,n1 !Over nodes

  CALL SPLINE1_EVAL(k_vopt,n0,x1(j),x0,f,i,value(1:3,j))

ENDDO !Over nodes

!-------------------------------------------------------------------------------
!Cleanup and exit
!-------------------------------------------------------------------------------
 9999 CONTINUE

END SUBROUTINE SPLINE1_INTERP

SUBROUTINE SPLINE1_INTEG(k_order,n0,x0,f,n1,x1, &
                         value,iflag,message)
!-------------------------------------------------------------------------------
!SPLINE1_INTEG evaluates the integral f(x)*x**k_order, where f(x) is a cubic
!  spline function and k_order is 0 or 1
!
!References:
!  Forsythe, Malcolm, Moler, Computer Methods for Mathematical
!    Computations, Prentice-Hall (1977) 76
!  W.A.Houlberg, P.I.Strand, D.McCune 8/2001
!  W.A.Houlberg, F90 free form 8/2004
!-------------------------------------------------------------------------------

!Declaration of input variables
INTEGER, INTENT(IN) :: &
  k_order,             & !exponent in integral (s(x)*x**k_order) [-]
                         !=0 or 1 only
  n0,                  & !number of source nodes [-]
  n1                     !number of output nodes (may be 1) [-]

REAL(KIND=rspec), INTENT(IN) :: &
  x0(:),               & !source abcissas [arb]
  x1(:),               & !output abcissas at which the integral is wanted [arb]
  f(:,:)                 !f(1,n0)=source ordinates [arb]
                         !f(2-4,n0)=spline coefficients computed by SPLINE1_FIT [arb]

!Declaration of output variables
CHARACTER(len=*), INTENT(OUT) :: &
  message                !warning or error message [character]

INTEGER, INTENT(OUT) :: &
  iflag                  !error and warning flag [-]
                         !=-1 warning
                         !=0 none
                         !=1 error

REAL(KIND=rspec), INTENT(OUT) :: &
  value(:)               !integral of f(x)*x**k_order from x0(1) to x1(i) [arb]

!-------------------------------------------------------------------------------
!Declaration of local variables
INTEGER :: &
  i,j,ido,jdo

REAL(KIND=rspec) :: &
  add,dx,sum,xnew,xold

!-------------------------------------------------------------------------------
!Initialization
!-------------------------------------------------------------------------------
!If no target values are requested, return
IF(n1 <= 0) GOTO 9999

value(1:n1)=0

!Integral value
sum=0

!Source index and abscissa
j=1
xold=x0(j)

!-------------------------------------------------------------------------------
!Integrate over target abscissas
!-------------------------------------------------------------------------------
DO i=1,n1 !Over target abscissas

  !Find dx to next source or target abscissa
  ido=0

  DO WHILE(ido == 0) !Over source abscissas

    IF(x1(i) < x0(j+1)) THEN

      !Hit target abscissa
      xnew=x1(i)
      ido=1
      jdo=0

    ELSEIF(x1(i) == x0(j+1)) THEN

      !Hit both source and target abscissas
      xnew=x1(i)
      ido=1
      jdo=1

    ELSEIF(x1(i) > x0(j+1)) THEN

      !Hit source abscissa
      xnew=x0(j+1)
      ido=0
      jdo=1

    ENDIF

    !Integrate over dx
    dx=xnew-xold

    IF(k_order == 1) THEN

      !Integral x s(x)dx
      add= dx*(xold*f(1,j) &
          +dx*((xold*f(2,j)+f(1,j))/2 &
          +dx*((xold*f(3,j)/2+f(2,j))/3 &
          +dx*((xold*f(4,j)/3+f(3,j))/8 &
          +dx*f(4,j)/30))))

    ELSE

      !Integral s(x)dx
      add=dx*(f(1,j)+dx*(f(2,j)+dx*(f(3,j)+dx*f(4,j)/4)/3)/2)

    ENDIF

    !Add increment and update endpoint
    sum=sum+add
    xold=xnew

    !Check whether to increment source index
    IF(jdo == 1) j=j+1

    !Check whether target index is in range
    IF(j > n0) THEN

      iflag=1
      message='LINEAR1_INTEG/ERROR:target node out of range'
      GOTO 9999

    ENDIF

    !Set integral value
    value(i)=sum

  ENDDO !Over source abscissas

ENDDO !Over target abscissas

!-------------------------------------------------------------------------------
!Cleanup and exit
!-------------------------------------------------------------------------------
9999 CONTINUE

END SUBROUTINE SPLINE1_INTEG

SUBROUTINE SPLINE1_SEARCH(x,n,xl, &
                          jlo)
!-------------------------------------------------------------------------------
!SPLINE1_SEARCH is a correlated table search routine to find the indices of the
!  array x that bound xl
!
!References:
!  W.A.Houlberg, P.I.Strand, D.McCune 8/2001
!
!Comments:
!  This is similar to the Numerical Recipes routine HUNT
!-------------------------------------------------------------------------------

!Declaration of input variables
INTEGER, INTENT(IN) :: &
  n                      !number of abscissas [-]

REAL(KIND=rspec), INTENT(IN) :: &
  xl,                  & !target value [arb]
  x(:)                   !monotonically increasing array of abscissas [arb]

!Declaration of input/output variables
INTEGER, INTENT(INOUT) :: &
  jlo                    !input starting lower index [-]
                         !<1     binary search
                         !=1,n-1 use value
                         !>n-1   binary search
                         !output starting lower index [-]
                         !=0     xl < x(1)
                         !=1     x(1) <= xl <= x(2)
                         !=2,n-1 x(jlo) < xl <= x(jlo+1)
                         !=n     x(jlo) > x(n)

!-------------------------------------------------------------------------------
!Declaration of local variables
INTEGER :: &
  inc,jhi,jmid

!-------------------------------------------------------------------------------
!Check lower end of array, first two points
!-------------------------------------------------------------------------------
IF(xl < x(1)) THEN

  !Target is below node 1
  jlo=0

ELSEIF(xl <= x(2)) THEN

  !Target is between nodes 1 and 2 inclusive
  jlo=1

!-------------------------------------------------------------------------------
!Check middle range
!-------------------------------------------------------------------------------
ELSEIF(xl <= x(n)) THEN

  !Target is between nodes 2 and n
  IF(jlo < 1 .OR. &
     jlo > (n-1)) THEN

    !jlo from previous call is unusable
    jlo=2
    jhi=n

  !Bracket target value
  ELSE

    !Start with jlo from previous call
    inc=1

    IF(xl > x(jlo)) THEN

      !Search up
      jhi=jlo+1

      DO WHILE(xl > x(jhi))

        inc=2*inc
        jlo=jhi
        jhi=MIN(jlo+inc,n)

      ENDDO

    ELSE

      !Search down
      jhi=jlo
      jlo=jlo-1

      DO WHILE(xl <= x(jlo))

        inc=inc+inc
        jhi=jlo
        jlo=MAX(jlo-inc,1)

      ENDDO

    ENDIF

  ENDIF

  !Bisection
  DO WHILE(jhi-jlo > 1)

    jmid=(jhi+jlo)/2

    IF(xl > x(jmid)) THEN

      jlo=jmid

    ELSE

      jhi=jmid

    ENDIF

  ENDDO

!-------------------------------------------------------------------------------
!Target is above node n
!-------------------------------------------------------------------------------
ELSE

  jlo=n

ENDIF

END SUBROUTINE SPLINE1_SEARCH

END MODULE spline1_mod