      SUBROUTINE V_SPLINE(k_bc1,k_bcn,n,x,f,wk)
!***********************************************************************
!V_SPLINE evaluates 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, D.McCune 3/2000
!Input:
!  k_bc1-option for BC at x1 = x(1)
!       =-1 periodic, ignore k_bcn
!       =0 not-a-knot
!       =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 xn = x(n)
!       =0 not-a-knot
!       =1 s'(xn) = input value of f(2,n)
!       =2 s''(xn) = input value of f(3,n)
!       =3 s'(xn) = 0.0
!       =4 s''(xn) = 0.0
!       =5 match first derivative to last 2 points
!       =6 match second derivative to lasst 3 points
!       =7 match third derivative to last 4 points
!       =else use knot-a-knot
!  n-number of data points or knots-(n.ge.2)
!  x(n)-abscissas of the knots in strictly increasing order
!  f(1,i)-ordinates of the knots
!  f(2,1)-input value of s'(x1) for k_bc1=1
!  f(2,n)-input value of s'(xn) for k_bcn=1
!  f(3,1)-input value of s''(x1) for k_bc1=2
!  f(3,n)-input value of s''(xn) for k_bcn=2
!  wk(n)-scratch work area for periodic BC
!Output:
!  f(2,i)=s'(x(i))
!  f(3,i)=s''(x(i))
!  f(4,i)=s'''(x(i))
!Comments:
!  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! for x(i).le.x.le.x(i+1)
!  W_SPLINE can be used to evaluate the spline and its derivatives
!  The cubic spline is twice differentiable (C2)
!
!  modifications -- dmc 18 Feb 2010:
!    Deal with n.lt.4 -- the general tridiagonal spline method
!    does not have the right formulation for n.eq.3 "not a knot" or periodic
!    boundary conditions, nor for n.eq.2 with any boundary conditions.
!
!    Apply boundary conditions even for n=2, when the "spline" is really
!    just a single cubic polynomial.
!    In this case, several boundary condition (BC) options are mapped to
!      BC option 5, 1st divided difference.  If 5 is used on both sides
!      of an n=2 "spline" you get a linear piece which is what the old
!      code always gave, regardless of BC option settings.  The following
!      BC controls are mapped to 5:
!        periodic (-1)
!        not a knot (0) (for n=2 no grid point exists for knot location).
!        option (5) is preserved
!        options 6 and 7 -- mapped to (5); higher divided differences
!          need n>2; in fact 7 needs n>3; for n=3 option 6 is substituted.
!
!    The boundary condition screening is done at the start of the code;
!    passed controls k_bc1 and k_bcn are mapped to i_bc1 and i_bcn.
!
!    ALSO: for n=3, "not a knot" from both left and right needs special
!      interpretation, since the 2 boundary conditions overlap.  The
!      chosen interpretation is a parabolic fit to the 3 given data points.
!      and so f''' = 0 and f'' = constant.  If "not a knot" is used on
!      one side only, the solution is a single cubic piece and special
!      code is also needed.
!    ALSO: for n=3, "periodic" boundary condition needs special code; this
!      is added.
!
!  bugfixes -- dmc 24 Feb 2004:
!    (a) fixed logic for not-a-knot:
!          !    Set f(3,1) for not-a-knot
!                    IF(k_bc1.le.0.or.k_bc1.gt.7) THEN ...
!        instead of
!          !    Set f(3,1) for not-a-knot
!                    IF(k_bc1.le.0.or.k_bc1.gt.5) THEN ...
!        and similarly for logic after cmt
!          !    Set f(3,n) for not-a-knot
!        as required since k_bc*=6 and k_bc*=7 are NOT not-a-knot BCs.
!
!    (b) the BCs to fix 2nd derivative at end points did not work if that
!        2nd derivative were non-zero.  The reason is that in those cases
!        the off-diagonal matrix elements nearest the corners are not
!        symmetric; i.e. elem(1,2).ne.elem(2,1) and
!        elem(n-1,n).ne.elem(n,n-1) where I use "elem" to refer to
!        the tridiagonal matrix elements.  The correct values for the
!        elements is:   elem(1,2)=0, elem(2,1)=x(2)-x(1)
!                       elem(n,n-1)=0, elem(n-1,n)=x(n)-x(n-1)
!        the old code in effect had these as all zeroes.  Since this
!        meant the wrong set of linear equations was solved, the
!        resulting spline had a discontinuity in its 1st derivative
!        at x(2) and x(n-1).  Fixed by introducing elem21 and elemnn1
!        to represent the non-symmetric lower-diagonal values.  Since
!        elem21 & elemnn1 are both on the lower diagonals, logic to
!        use them occurs in the non-periodic forward elimination loop
!        only.  DMC 24 Feb 2004.
!***********************************************************************
      IMPLICIT NONE
!Declaration of input variables
      INTEGER        k_bc1,                   k_bcn,
     &               n
      REAL           x(*),                    wk(*),
     &               f(4,*)
!Declaration in local variables
      INTEGER        i,                       ib,
     &               imax,                    imin
      REAL           a1,                      an,
     &               b1,                      bn,
     &               q,                       t,
     &               hn
      REAL           elem21,                  elemnn1    ! (dmc)

      integer :: i_bc1,i_bcn  ! screened BC controls

      integer :: iord1,iord2  ! used for n=2 only
      real :: h,f0,fh         ! used for n=2,3 only
      real :: h1,h2,h3,dels   ! used for n=3 special cases
      real :: f1,f2,f3,aa,bb  ! used for n=3

      integer :: i3knots      ! for n=3, number of not-a-knot BCs
      integer :: i3perio      ! for n=3, periodic BC

!------------------------------------------------------------
!  screen the BC options (DMC Feb. 2010...)

      i_bc1=k_bc1
      i_bcn=k_bcn

      if((i_bc1.lt.-1).or.(i_bc1.gt.7)) i_bc1=0  ! outside [-1:7] -> not-a-knot
      if((i_bcn.lt.0).or.(i_bcn.gt.7)) i_bcn=0   ! outside [0:7] -> not-a-knot

      if(i_bc1.eq.-1) i_bcn=-1  ! periodic BC

      i3knots=0
      i3perio=0
      if(n.eq.3) then
         i_bc1=min(6,i_bc1)
         i_bcn=min(6,i_bcn)
         if(i_bc1.eq.0) i3knots = i3knots + 1
         if(i_bcn.eq.0) i3knots = i3knots + 1
         if(i_bc1.eq.-1) i3perio = 1
      endif

      if(n.eq.2) then
         if(i_bc1.eq.-1) then
            i_bc1=5
            i_bcn=5
         endif
         if((i_bc1.eq.0).or.(i_bc1.gt.5)) i_bc1=5
         if((i_bcn.eq.0).or.(i_bcn.gt.5)) i_bcn=5

         if((i_bc1.eq.1).or.(i_bc1.eq.3).or.(i_bc1.eq.5)) then
            iord1=1  ! 1st derivative match on LHS
         else
            iord1=2  ! 2nd derivative match on LHS
         endif

         if((i_bcn.eq.1).or.(i_bcn.eq.3).or.(i_bcn.eq.5)) then
            iord2=1  ! 1st derivative match on RHS
         else
            iord2=2  ! 2nd derivative match on RHS
         endif
      endif

!Set default range
      imin=1
      imax=n
!Set first and second BC values
      a1=0.0
      b1=0.0
      an=0.0
      bn=0.0
      IF(i_bc1.eq.1) THEN
        a1=f(2,1)
      ELSEIF(i_bc1.eq.2) THEN
        b1=f(3,1)
      ELSEIF(i_bc1.eq.5) THEN
        a1=(f(1,2)-f(1,1))/(x(2)-x(1))
      ELSEIF(i_bc1.eq.6) THEN
        b1=2.0*((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
      IF(i_bcn.eq.1) THEN
        an=f(2,n)
      ELSEIF(i_bcn.eq.2) THEN
        bn=f(3,n)
      ELSEIF(i_bcn.eq.5) THEN
        an=(f(1,n)-f(1,n-1))/(x(n)-x(n-1))
      ELSEIF(i_bcn.eq.6) THEN
        bn=2.0*((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 f(2:4,n)
      f(2,n)=0.0
      f(3,n)=0.0
      f(4,n)=0.0
      IF(n.eq.2) THEN
        if((i_bc1.eq.5).and.(i_bcn.eq.5)) then
!Coefficients for n=2 (this was the original code)
           f(2,1)=(f(1,2)-f(1,1))/(x(2)-x(1))
           f(3,1)=0.0
           f(4,1)=0.0
           f(2,2)=f(2,1)
           f(3,2)=0.0
           f(4,2)=0.0
        else if((iord1.eq.1).and.(iord2.eq.1)) then
           ! LHS: match a1 for 1st deriv; RHS: match an for 1st deriv.
           f(2,1)=a1
           f(2,2)=an
           h = (x(2)-x(1))
           f0 = f(1,1)
           fh = f(1,2)

           ! setting xx = x-x(1),
           ! f = c1*xx**3 + c2*xx**2 + a1*xx + f0
           !   -->  c1*h**3   + c2*h**2 = fh - f0 - a1*h
           !   and  3*c1*h**2 + 2*c2*h  = an - a1
           ! f' = 3*c1*xx*2 + 2*c2*xx + a1
           ! f'' = 6*c1*xx + 2*c2
           ! f''' = 6*c1

           ! solve 2x2 system for c1 -> f(4,1)/6 and c2 -> f(3,1)/2

           f(3,1) = (3*(fh-f0)/(h*h) - (2*a1 + an)/h)*2       ! 2*c2
           f(4,1) = (-2*(fh-f0)/(h*h*h) + (a1 + an)/(h*h))*6  ! 6*c1

           f(4,2) = f(4,1)
           f(3,2) = f(4,1)*h + f(3,1)

        else if((iord1.eq.1).and.(iord2.eq.2)) then
           ! LHS: match a1 for 1st deriv; RHS: match bn for 2nd deriv.
           f(2,1)=a1
           f(3,2)=bn
           h = (x(2)-x(1))
           f0 = f(1,1)
           fh = f(1,2)

           ! setting xx = x-x(1),
           ! f = c1*xx**3 + c2*xx**2 + a1*xx + f0
           !   -->  c1*h**3   + c2*h**2 = fh - f0 - a1*h
           !   and  6*c1*h    + 2*c2    = bn
           ! f' = 3*c1*xx*2 + 2*c2*xx + a1
           ! f'' = 6*c1*xx + 2*c2
           ! f''' = 6*c1

           ! solve 2x2 system for c1 -> f(4,1)/6 and c2 -> f(3,1)/2

           f(3,1) = (-bn/4 + 3*(fh-f0)/(2*h*h) - 3*a1/(2*h))*2       ! 2*c2
           f(4,1) = (bn/(4*h) - (fh-f0)/(2*h*h*h) + a1/(2*h*h))*6    ! 6*c1

           f(4,2) = f(4,1)
           f(2,2) = f(4,1)*h*h/2 + f(3,1)*h + a1
        else if((iord1.eq.2).and.(iord2.eq.1)) then
           ! LHS: match b1 for 2nd deriv; RHS: match an for 1st deriv.
           f(3,1)=b1
           f(2,2)=an
           h = (x(2)-x(1))
           f0 = f(1,1)
           fh = f(1,2)

           ! setting xx = x-x(1),
           ! f = c1*xx**3 + (b1/2)*xx**2 + c3*xx + f0
           !   -->  c1*h**3   + c3*h = fh - f0 - b1*h**2/2
           !   and  3*c1*h**2 + c3   = an - b1*h
           ! f' = 3*c1*xx*2 + b1*xx + c3
           ! f'' = 6*c1*xx + b1
           ! f''' = 6*c1

           ! solve 2x2 system for c1 -> f(4,1)/6 and c2 -> f(3,1)/2

           f(2,1) = 3*(fh-f0)/(2*h) - b1*h/4 - an/2                  ! c3
           f(4,1) = (an/(2*h*h) - (fh-f0)/(2*h*h*h) - b1/(4*h))*6    ! 6*c1

           f(4,2) = f(4,1)
           f(3,2) = f(4,1)*h + f(3,1)
        else if((iord1.eq.2).and.(iord2.eq.2)) then
           ! LHS: match b1 for 2nd deriv; RHS: match bn for 2nd deriv.
           f(3,1)=b1
           f(3,2)=bn
           h = (x(2)-x(1))
           f0 = f(1,1)
           fh = f(1,2)

           ! setting xx = x-x(1),
           ! f = c1*xx**3 + (b1/2)*xx**2 + c3*xx + f0
           !   -->  c1*h**3   + c3*h = fh - f0 - b1*h**2/2
           !   and  6*c1*h           = bn - b1
           ! f' = 3*c1*xx*2 + b1*xx + c3
           ! f'' = 6*c1*xx + b1
           ! f''' = 6*c1

           ! solve 2x2 system for c1 -> f(4,1)/6 and c2 -> f(3,1)/2

           f(2,1) = (fh-f0)/h -b1*h/3 -bn*h/6                 ! c3
           f(4,1) = (bn-b1)/h                                 ! 6*c1

           f(4,2) = f(4,1)
           f(2,2) = f(4,1)*h*h/2 + b1*h + f(2,1)
        endif

      ELSE IF(i3perio.eq.1) then
!Special case: nx=3 periodic spline
         h1=x(2)-x(1)
         h2=x(3)-x(2)
         h=h1+h2

         dels=(f(1,3)-f(1,2))/h2 - (f(1,2)-f(1,1))/h1

         f(2,1)= (f(1,2)-f(1,1))/h1 + (h1*dels)/h
         f(3,1)= -6*dels/h
         f(4,1)= 12*dels/(h1*h)

         f(2,2)= (f(1,3)-f(1,2))/h2 - (h2*dels)/h
         f(3,2)= 6*dels/h
         f(4,2)= -12*dels/(h2*h)

         f(2,3)=f(2,1)
         f(3,3)=f(3,1)
         f(4,3)=f(4,1)

      ELSE IF(i3knots.eq.2) then
!Special case: nx=3, not-a-knot on both sides
         h1=x(2)-x(1)
         h2=x(3)-x(2)
         h=h1+h2
                                ! this is just a quadratic fit through 3 pts
         f1=f(1,1)-f(1,2)
         f2=f(1,3)-f(1,2)

!  quadratic around origin at (x(2),f(1,2))
!          aa*h1**2 - bb*h1 = f1
!          aa*h2**2 + bb*h2 = f2

         aa = (f2*h1 + f1*h2)/(h1*h2*h)
         bb = (f2*h1*h1 - f1*h2*h2)/(h1*h2*h)

         f(4,1:3)=0.0   ! f''' = 0 (quadratic polynomial)
         f(3,1:3)=2*aa  ! f'' = const

         f(2,1)=bb-2*aa*h1
         f(2,2)=bb
         f(2,3)=bb+2*aa*h2

      ELSE IF(i3knots.eq.1) then
!Special cases: nx=3, not-a-knot on single side
         if((i_bc1.eq.1).or.(i_bc1.eq.3).or.(i_bc1.eq.5)) then
                                ! f' LHS condition; not-a-knot RHS
!  a1 = f' LHS BC
            h2=x(2)-x(1)
            h3=x(3)-x(1)

            f2=f(1,2)-f(1,1)
            f3=f(1,3)-f(1,1)

!  find cubic aa*xx**3 + bb*xx**2 + a1*xx
!    satisfying aa*h2**3 + bb*h2**2 + a1*h2 = f2
!           and aa*h3**3 + bb*h3**2 + a1*h3 = f3

            aa=a1/(h2*h3) + f3/(h3*h3*(h3-h2)) - f2/(h2*h2*(h3-h2))
            bb=-a1*(h3*h3-h2*h2)/(h2*h3*(h3-h2))
     >           + f2*h3/(h2*h2*(h3-h2)) - f3*h2/(h3*h3*(h3-h2))

            f(2,1)=a1
            f(3,1)=2*bb
            f(4,1)=6*aa

            f(2,2)=3*aa*h2*h2 + 2*bb*h2 + a1
            f(3,2)=6*aa*h2 + 2*bb
            f(4,2)=6*aa

            f(2,3)=3*aa*h3*h3 + 2*bb*h3 + a1
            f(3,3)=6*aa*h3 + 2*bb
            f(4,3)=6*aa

         else if((i_bc1.eq.2).or.(i_bc1.eq.4).or.(i_bc1.eq.6)) then
                                ! f'' LHS condition; not-a-knot RHS
!  b1 = f'' LHS BC
            h2=x(2)-x(1)
            h3=x(3)-x(1)

            f2=f(1,2)-f(1,1)
            f3=f(1,3)-f(1,1)

!  find cubic aa*xx**3 + (b1/2)*xx**2 + bb*xx
!    satisfying aa*h2**3 + bb*h2 = f2 -(b1/2)*h2**2
!           and aa*h3**3 + bb*h3 = f3 -(b1/2)*h3**2

            aa= -(b1/2)*(h3-h2)/(h3*h3-h2*h2)
     >           -f2/(h2*(h3*h3-h2*h2)) + f3/(h3*(h3*h3-h2*h2))
            bb= -(b1/2)*h2*h3*(h3-h2)/(h3*h3-h2*h2)
     >           +f2*h3*h3/(h2*(h3*h3-h2*h2))
     >           -f3*h2*h2/(h3*(h3*h3-h2*h2))

            f(2,1)=bb
            f(3,1)=b1
            f(4,1)=6*aa

            f(2,2)=3*aa*h2*h2 + b1*h2 + bb
            f(3,2)=6*aa*h2 + b1
            f(4,2)=6*aa

            f(2,3)=3*aa*h3*h3 + b1*h3 + bb
            f(3,3)=6*aa*h3 + b1
            f(4,3)=6*aa

         else if((i_bcn.eq.1).or.(i_bcn.eq.3).or.(i_bcn.eq.5)) then
                                ! f' RHS condition; not-a-knot LHS
!  an = f' RHS BC
            h2=x(2)-x(3)
            h3=x(1)-x(3)

            f2=f(1,2)-f(1,3)
            f3=f(1,1)-f(1,3)

!  find cubic aa*xx**3 + bb*xx**2 + an*xx
!    satisfying aa*h2**3 + bb*h2**2 + an*h2 = f2
!           and aa*h3**3 + bb*h3**2 + an*h3 = f3

            aa=an/(h2*h3) + f3/(h3*h3*(h3-h2)) - f2/(h2*h2*(h3-h2))
            bb=-an*(h3*h3-h2*h2)/(h2*h3*(h3-h2))
     >           + f2*h3/(h2*h2*(h3-h2)) - f3*h2/(h3*h3*(h3-h2))

            f(2,3)=an
            f(3,3)=2*bb
            f(4,3)=6*aa

            f(2,2)=3*aa*h2*h2 + 2*bb*h2 + an
            f(3,2)=6*aa*h2 + 2*bb
            f(4,2)=6*aa

            f(2,1)=3*aa*h3*h3 + 2*bb*h3 + an
            f(3,1)=6*aa*h3 + 2*bb
            f(4,1)=6*aa

         else if((i_bcn.eq.2).or.(i_bcn.eq.4).or.(i_bcn.eq.6)) then
                                ! f'' RHS condition; not-a-knot LHS
!  bn = f'' RHS BC
            h2=x(2)-x(3)
            h3=x(1)-x(3)

            f2=f(1,2)-f(1,3)
            f3=f(1,1)-f(1,3)

!  find cubic aa*xx**3 + (bn/2)*xx**2 + bb*xx
!    satisfying aa*h2**3 + bb*h2 = f2 -(bn/2)*h2**2
!           and aa*h3**3 + bb*h3 = f3 -(bn/2)*h3**2

            aa= -(bn/2)*(h3-h2)/(h3*h3-h2*h2)
     >           -f2/(h2*(h3*h3-h2*h2)) + f3/(h3*(h3*h3-h2*h2))
            bb= -(bn/2)*h2*h3*(h3-h2)/(h3*h3-h2*h2)
     >           +f2*h3*h3/(h2*(h3*h3-h2*h2))
     >           -f3*h2*h2/(h3*(h3*h3-h2*h2))

            f(2,3)=bb
            f(3,3)=bn
            f(4,3)=6*aa

            f(2,2)=3*aa*h2*h2 + bn*h2 + bb
            f(3,2)=6*aa*h2 + bn
            f(4,2)=6*aa

            f(2,1)=3*aa*h3*h3 + bn*h3 + bb
            f(3,1)=6*aa*h3 + bn
            f(4,1)=6*aa

         endif
      ELSE IF(n.gt.2) THEN
!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
        f(4,1)=x(2)-x(1)
        f(3,2)=(f(1,2)-f(1,1))/f(4,1)
        DO i=2,n-1
          f(4,i)=x(i+1)-x(i)
          f(2,i)=2.0*(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
!
!  (dmc): save now:
!
        elem21=f(4,1)
        elemnn1=f(4,n-1)
!
!  BC's
!    Left
        IF(i_bc1.eq.-1) THEN
          f(2,1)=2.0*(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)
          DO i=2,n-3
            wk(i)=0.0
          ENDDO
          wk(n-2)=f(4,n-2)
          wk(n-1)=f(4,n-1)
        ELSEIF(i_bc1.eq.1.or.i_bc1.eq.3.or.i_bc1.eq.5) THEN
          f(2,1)=2.0*f(4,1)
          f(3,1)=(f(1,2)-f(1,1))/f(4,1)-a1
        ELSEIF(i_bc1.eq.2.or.i_bc1.eq.4.or.i_bc1.eq.6) THEN
          f(2,1)=2.0*f(4,1)
          f(3,1)=f(4,1)*b1/3.0
          f(4,1)=0.0  ! upper diagonal only (dmc: cf elem21)
        ELSEIF(i_bc1.eq.7) THEN
          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:
          imin=2
          f(2,2)=f(4,1)+2.0*f(4,2)
          f(3,2)=f(3,2)*f(4,2)/(f(4,1)+f(4,2))
        ENDIF
!    Right
        IF(i_bcn.eq.1.or.i_bcn.eq.3.or.i_bcn.eq.5) THEN
          f(2,n)=2.0*f(4,n-1)
          f(3,n)=-(f(1,n)-f(1,n-1))/f(4,n-1)+an
        ELSEIF(i_bcn.eq.2.or.i_bcn.eq.4.or.i_bcn.eq.6) THEN
          f(2,n)=2.0*f(4,n-1)
          f(3,n)=f(4,n-1)*bn/3.0
!xxx          f(4,n-1)=0.0  ! dmc: preserve f(4,n-1) for back subst.
          elemnn1=0.0  !  lower diaganol only (dmc)
        ELSEIF(i_bcn.eq.7) THEN
          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(i_bc1.ne.-1) THEN         ! not a knot:
          imax=n-1
          f(2,n-1)=2.0*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
        IF(i_bc1.eq.-1) THEN
!Solve system of equations for second derivatives at the knots
!  Periodic BC
!    Forward elimination
          DO i=2,n-2
            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
!    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
            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
          f(3,n)=f(3,1)
        ELSE
!  Non-periodic BC
!    Forward elimination
!    For Not-A-Knot BC the off-diagonal end elements are not equal
          DO i=imin+1,imax
            IF((i.eq.n-1).and.(imax.eq.n-1)) THEN
              t=(f(4,i-1)-f(4,i))/f(2,i-1)
            ELSE
              if(i.eq.2) then
                 t=elem21/f(2,i-1)
              else if(i.eq.n) then
                 t=elemnn1/f(2,i-1)
              else
                 t=f(4,i-1)/f(2,i-1)
              endif
            ENDIF
            IF((i.eq.imin+1).and.(imin.eq.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
!    Back substitution
          f(3,imax)=f(3,imax)/f(2,imax)
          DO ib=1,imax-imin
            i=imax-ib
            IF((i.eq.2).and.(imin.eq.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
!    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
          IF(i_bc1.le.0.or.i_bc1.gt.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
          IF(i_bcn.le.0.or.i_bcn.gt.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
          f(2,i)=
     >        (f(1,i+1)-f(1,i))/f(4,i)-f(4,i)*(f(3,i+1)+2.0*f(3,i))
          f(4,i)=(f(3,i+1)-f(3,i))/f(4,i)
          f(3,i)=6.0*f(3,i)
          f(4,i)=6.0*f(4,i)
        ENDDO
        IF(i_bc1.eq.-1) THEN
          f(2,n)=f(2,1)
          f(3,n)=f(3,1)
          f(4,n)=f(4,1)
        ELSE
           hn=x(n)-x(n-1)
           f(2,n)=f(2,n-1)+hn*(f(3,n-1)+0.5*hn*f(4,n-1))
           f(3,n)=f(3,n-1)+hn*f(4,n-1)
           f(4,n)=f(4,n-1)
           IF(i_bcn.eq.1.or.i_bcn.eq.3.or.i_bcn.eq.5) THEN
              f(2,n)=an
           ELSE IF(i_bcn.eq.2.or.i_bcn.eq.4.or.i_bcn.eq.6) THEN
              f(3,n)=bn
           ENDIF
        ENDIF
      ENDIF
      RETURN
      END


subroutine solve_cubic(a,b,c,lambda)
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!********************************************************************
! SUBROUTINE solve_cubic(a,b,c,lambda)                              *
!                                                                   *
! Accepts the coefficients a,b and c of the monic cubic polynomial  *
! x**3 + a*x**2 + b*x + c = 0 and returns its three roots in the    *
! vector lambda. It is assumed that the roots are real. The         *
! intended application is the computation of eigenvalues of real,   *
! symmetric tensors - which justifies the assumption.               *
!                                                                   *
! Author : Sai Rapaka                                               *
!                                                                   *
!********************************************************************

implicit none
integer ii,j
double precision, dimension(3)           :: lambda
double precision                         :: a,b,c, tmp
double precision                         :: aa, bb
double precision                         :: P, Q, D
complex                                  :: i, zeta, t1, t2

aa = a/3.0d0
bb = b/3.0d0

P = bb - aa*aa
Q = c/2.0d0 + aa**3 - 1.5d0*aa*bb
D = Q**2 + P**3

i = cmplx(0.0d0, 1.0d0)
zeta = -0.5d0 + i*sqrt(3.0d0)/2.0d0
t1 = (Q - i*sqrt(abs(D)))**(1.0d0/3.0d0)
t2 = (Q + i*sqrt(abs(D)))**(1.0d0/3.0d0)

lambda(1) = -real(aa + t1 + t2)
lambda(2) = -real(aa + zeta*t1 + zeta*zeta*t2)
lambda(3) = -real(aa + zeta*zeta*t1 + zeta*t2)

! First sort the eigenvectors into increasing order
do ii=1,3
  do j=ii+1,3
    if(lambda(ii).gt.lambda(j)) then
      tmp = lambda(ii)
      lambda(ii) = lambda(j)
      lambda(j) = tmp
    endif
  enddo
enddo

end subroutine solve_cubic


PROGRAM NumericalDifferentiation
    IMPLICIT NONE
    REAL:: x, h
    READ(*, *) x

    h = 0.1
    WRITE(*, *) h, f(x+h), (f(x+h) - f(x))/h, h/(2*x*x)

    h = 0.05
    WRITE(*, *) h, f(x+h), (f(x+h) - f(x))/h, h/(2*x*x)

    h = 0.01
    WRITE(*, *) h, f(x+h), (f(x+h) - f(x))/h, h/(2*x*x)

    h = 0.001
    WRITE(*, *) h, f(x+h), (f(x+h) - f(x))/h, h/(2*x*x)

    CONTAINS
    REAL FUNCTION f(x)
        IMPLICIT NONE
        REAL:: x
        f = log(x)
        RETURN
    END FUNCTION f
END PROGRAM NumericalDifferentiation

Numerical Differentiation and Jacobi Method of Diagonalization/1.f90


SUBROUTINE phi_linear_3D(H,k,angle,x,y,z,d,omega,time,grav,phix,phiy,phiz,phi,phit)
!
USE Precision
IMPLICIT NONE
!
REAL(KIND=long), INTENT(IN)  :: H,k,angle,x,y,z,d,omega,time,grav
REAL(KIND=long), INTENT(OUT) :: phix,phiy,phiz
REAL(KIND=long), INTENT(OUT), OPTIONAL :: phi,phit
! REAL(KIND=long), OPTIONAL :: y,phi,phiyy !Boundary fitted ?
! Local variables
REAL(KIND=long) :: kx, ky, k_omegat, sink_omegat, cosk_omegat, temp1, temp2
!
!
kx=k*cos(angle)
ky=k*sin(angle)
!
k_omegat=kx*x+ky*y-omega*time
sink_omegat = sin(k_omegat)
cosk_omegat = cos(k_omegat)
!
temp1 = COSH(k*(z+d))/COSH(k*d)
temp2 = H*0.5d0*grav/omega
!
phiz = temp2*sink_omegat*temp1*k*tanh(k*(z+d))
phix = temp2*kx*cosk_omegat*temp1
phiy = temp2*ky*cosk_omegat*temp1
!
IF(present(phit)) THEN
    phit = -temp2*omega*cosk_omegat*temp1
ENDIF
IF(present(phi)) THEN
    phi  =  temp2*sink_omegat*temp1
ENDIF

END SUBROUTINE phi_linear_3D


MODULE QuadratureModule

  USE KindModule, ONLY: &
    DP

  IMPLICIT NONE
  PRIVATE

  REAL(DP), PUBLIC, DIMENSION(1:1) :: xG1, wG1 ! 1-Point Gauss
  REAL(DP), PUBLIC, DIMENSION(1:2) :: xG2, wG2 ! 2-Point Gauss
  REAL(DP), PUBLIC, DIMENSION(1:3) :: xG3, wG3 ! 3-Point Gauss
  REAL(DP), PUBLIC, DIMENSION(1:4) :: xG4, wG4 ! 4-Point Gauss
  REAL(DP), PUBLIC, DIMENSION(1:5) :: xG5, wG5 ! 5-Point Gauss

  REAL(DP), PUBLIC, DIMENSION(1:1) :: xL1, wL1 ! 1-Point Lobatto (Gauss)
  REAL(DP), PUBLIC, DIMENSION(1:2) :: xL2, wL2 ! 2-Point Lobatto
  REAL(DP), PUBLIC, DIMENSION(1:3) :: xL3, wL3 ! 3-Point Lobatto
  REAL(DP), PUBLIC, DIMENSION(1:4) :: xL4, wL4 ! 4-Point Lobatto
  REAL(DP), PUBLIC, DIMENSION(1:5) :: xL5, wL5 ! 5-Point Lobatto

  PUBLIC :: &
    InitializeQuadratures, &
    GetQuadrature

CONTAINS

  SUBROUTINE InitializeQuadratures

    ! Quadratures Defined on [-0.5, 0.5]

    !**********************************************
    ! 1-Point Gaussian Quadrature
    !**********************************************

    xG1(1) = 0.0_DP

    wG1(1) = 1.0_DP

    !**********************************************
    ! 2-Point Gaussian Quadrature
    !**********************************************

    xG2(1) = - SQRT( 1.0_DP / 12.0_DP )
    xG2(2) = + SQRT( 1.0_DP / 12.0_DP )

    wG2(1) = 0.5_DP
    wG2(2) = 0.5_DP

    !**********************************************
    ! 3-Point Gaussian Quadrature
    !**********************************************

    xG3(1) = - SQRT( 15.0_DP ) / 10.0_DP
    xG3(2) = 0.0_DP
    xG3(3) = + SQRT( 15.0_DP ) / 10.0_DP

    wG3(1) = 5.0_DP / 18.0_DP
    wG3(2) = 8.0_DP / 18.0_DP
    wG3(3) = 5.0_DP / 18.0_DP

    !**********************************************
    ! 4-Point Gaussian Quadrature
    !**********************************************

    xG4(1) = - SQRT( (3.0_DP+2.0_DP*SQRT(6.0_DP/5.0_DP)) / 7.0_DP ) / 2.0_DP
    xG4(2) = - SQRT( (3.0_DP-2.0_DP*SQRT(6.0_DP/5.0_DP)) / 7.0_DP ) / 2.0_DP
    xG4(3) = + SQRT( (3.0_DP-2.0_DP*SQRT(6.0_DP/5.0_DP)) / 7.0_DP ) / 2.0_DP
    xG4(4) = + SQRT( (3.0_DP+2.0_DP*SQRT(6.0_DP/5.0_DP)) / 7.0_DP ) / 2.0_DP

    wG4(1) = ( 18.0_DP - SQRT( 30.0_DP ) ) / 72.0_DP
    wG4(2) = ( 18.0_DP + SQRT( 30.0_DP ) ) / 72.0_DP
    wG4(3) = ( 18.0_DP + SQRT( 30.0_DP ) ) / 72.0_DP
    wG4(4) = ( 18.0_DP - SQRT( 30.0_DP ) ) / 72.0_DP

    !**********************************************
    ! 5-Point Gaussian Quadrature
    !**********************************************

    xG5(1) = - SQRT( 245.0_DP + 14.0_DP * SQRT( 70.0_DP ) ) / 21.0_DP / 2.0_DP
    xG5(2) = - SQRT( 245.0_DP - 14.0_DP * SQRT( 70.0_DP ) ) / 21.0_DP / 2.0_DP
    xG5(3) = 0.0_DP
    xG5(4) = - xG5(2)
    xG5(5) = - xG5(1)

    wG5(1) = ( 322.0_DP - 13.0_DP * SQRT( 70.0_DP ) ) / 900.0_DP / 2.0_DP
    wG5(2) = ( 322.0_DP + 13.0_DP * SQRT( 70.0_DP ) ) / 900.0_DP / 2.0_DP
    wG5(3) = 128.0_DP / 225.0_DP / 2.0_DP
    wG5(4) = wG5(2)
    wG5(5) = wG5(1)

    !**********************************************
    ! 1-Point Gauss-Lobatto Quadrature
    !**********************************************

    xL1(1) = 0.0_DP

    wL1(1) = 1.0_DP

    !*************************************************
    ! 2-Point Gauss-Lobatto Quadrature
    !*************************************************

    xL2(1) = - 0.5_DP
    xL2(2) = + 0.5_DP

    wL2(1) = 0.5_DP
    wL2(2) = 0.5_DP

    !*************************************************
    ! 3-Point Gauss-Lobatto Quadrature
    !*************************************************

    xL3(1) = - 0.5_DP
    xL3(2) =   0.0_DP
    xL3(3) =   0.5_DP

    wL3(1) = 1.0_DP / 6.0_DP
    wL3(2) = 2.0_DP / 3.0_DP
    wL3(3) = 1.0_DP / 6.0_DP

    !*************************************************
    ! 4-Point Gauss-Lobatto Quadrature
    !*************************************************

    xL4(1) = - 0.5_DP
    xL4(2) = - SQRT( 5.0_DP ) / 10.0_DP
    xL4(3) =   SQRT( 5.0_DP ) / 10.0_DP
    xL4(4) =   0.5_DP

    wL4(1) = 1.0_DP / 12.0_DP
    wL4(2) = 5.0_DP / 12.0_DP
    wL4(3) = 5.0_DP / 12.0_DP
    wL4(4) = 1.0_DP / 12.0_DP

    !*************************************************
    ! 5-Point Gauss-Lobatto Quadrature
    !*************************************************

    xL5(1) = - 0.5_DP
    xL5(2) = - SQRT( 21.0_DP ) / 14.0_DP
    xL5(3) =   0.0_DP
    xL5(4) =   SQRT( 21.0_DP ) / 14.0_DP
    xL5(5) =   0.5_DP

    wL5(1) =  1.0_DP /  20.0_DP
    wL5(2) = 49.0_DP / 180.0_DP
    wL5(3) = 32.0_DP /  90.0_DP
    wL5(4) = 49.0_DP / 180.0_DP
    wL5(5) =  1.0_DP /  20.0_DP

  END SUBROUTINE InitializeQuadratures

  SUBROUTINE GetQuadrature( nQ, xQ, wQ, QuadratureName_Option )

    INTEGER, INTENT(in)                    :: nQ
    REAL(DP), DIMENSION(nQ), INTENT(inout) :: xQ, wQ
    CHARACTER(LEN=*), INTENT(in), OPTIONAL    :: QuadratureName_Option

    CHARACTER(32) :: QuadratureName

    CALL InitializeQuadratures

    IF( PRESENT( QuadratureName_Option ) )THEN
      QuadratureName = TRIM( QuadratureName_Option )
    ELSE
      QuadratureName = 'Gaussian'
    END IF

    SELECT CASE ( TRIM( QuadratureName ) )
      CASE ( 'Gaussian' )
        SELECT CASE ( nQ )
          CASE ( 1 )
            xQ = xG1; wQ = wG1
          CASE ( 2 )
            xQ = xG2; wQ = wG2
          CASE ( 3 )
            xQ = xG3; wQ = wG3
          CASE ( 4 )
            xQ = xG4; wQ = wG4
          CASE ( 5 )
            xQ = xG5; wQ = wG5
          CASE DEFAULT
            WRITE(*,*)
            WRITE(*,'(A5,A45,I2.2)') &
              '', 'Gaussian Quadrature Not Implemented for nQ = ', nQ
            STOP
        END SELECT
      CASE ( 'Lobatto' )
        SELECT CASE ( nQ )
          CASE ( 1 )
            xQ = xL1; wQ = wL1
          CASE ( 2 )
            xQ = xL2; wQ = wL2
          CASE ( 3 )
            xQ = xL3; wQ = wL3
          CASE ( 4 )
            xQ = xL4; wQ = wL4
          CASE ( 5 )
            xQ = xL5; wQ = wL5
          CASE DEFAULT
            WRITE(*,*)
            WRITE(*,'(A5,A44,I2.2)') &
              '', 'Lobatto Quadrature Not Implemented for nQ = ', nQ
            STOP
         END SELECT
      CASE DEFAULT
        WRITE(*,*)
        WRITE(*,'(A5,A28,A)') &
          '', 'Quadrature Not Implemented: ', TRIM( QuadratureName )
    END SELECT

  END SUBROUTINE GetQuadrature

END MODULE QuadratureModule


cc Copyright (C) 2009: Zydrunas Gimbutas and Hong Xiao
cc Contact: Zydrunas Gimbutas <gimbutas@cims.nyu.edu>
cc          Hong Xiao <hxiao@ucdavis.edu>
cc
cc This software is being released under a modified FreeBSD license
cc (see COPYING in home directory).
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c       D_4 symmetric quadratures for smooth functions on a square
c
c       All weights are positive and inside the square
c
c       Input:
c
c       n - the degree of the quadrature (must not exceed 21)
c
c       Output:
c
c       fort.11 - quadrature nodes and weights
c       fort.12 - quadrature nodes in gnuplot compatible format
c       fort.14 - square as contructed in gnuplot compatible format
c
c       in gnuplot:
c
c       plot 'fort.14' w l, 'fort.12'
c
c
c
        implicit real *8 (a-h,o-z)
        real *8 rnodes(2,1000),weights(1000)
        real *8 rints(1000),z(2),pols(1000)
        real *8 work(100000)
c
c
        call prini(6,13)
c
c       SET ALL PARAMETERS
c
        PRINT *, 'ENTER mmax (1..21)'
        READ *, mmax
c
        call prinf('mmax=*',mmax,1)
c
c

c
c       ... retrieve the quadrature rule
c
        call squaresymq(mmax,rnodes,weights,numnodes)
c
        call prinf('nummodes=*',numnodes,1)
        call prin2('rnodes=*',rnodes,2*numnodes)
        call prin2('weights=*',weights,numnodes)
c
        d=0
        do i=1,numnodes
        d=d+weights(i)
        enddo
c
        call prin2('sum of weights=*',d,1)
c
c       ... plot the square
c
        write(14,*) -1,-1
        write(14,*) +1,-1
        write(14,*) +1,+1
        write(14,*) -1,+1
        write(14,*) -1,-1
        write(14,*)
c
c
c       ... dump the nodes into a file
c
        write(11,*) numnodes
        do i=1,numnodes
        write(11,1020) rnodes(1,i),rnodes(2,i),weights(i)
        write(12,*) rnodes(1,i),rnodes(2,i)
        enddo
 1010   format(i2)
 1020   format(4(e21.15,2x))
c

c
c       construct the matrix of values of the orthogonal polynomials
c       at the user-provided nodes
c
        npols=(mmax+1)*(mmax+2)/2
c
c
        do 1200 j=1,npols
        rints(j)=0
 1200 continue
c
c
        do 2400 i=1,numnodes
c
        z(1)=rnodes(1,i)
        z(2)=rnodes(2,i)
c
        call lege2eva(mmax,z,pols,work)
c
        do 2200 j=1,npols
c
        rints(j)=rints(j)+weights(i)*pols(j)

 2200 continue

 2400 continue
c
c
        call prin2('rints=*',rints,npols)
c
        area=4.0d0
c
        d=0
        d=(rints(1)-sqrt(area))**2
        do i=2,npols
        d=d+rints(i)**2
        enddo
c
        d=sqrt(d)/npols
c
        call prin2('error=*',d,1)
c
        stop
        end
c
c
c


program test_ieee_arithmetic
use, intrinsic :: ieee_arithmetic
implicit none
character (len=20) :: fmt = "(a16,*(l9))"
integer, parameter :: wp = kind(1.0) ! same output for wp = kind(1.0d0)
real(kind=wp)      :: z,vec(6),NaN,t
z = 0.0_wp
t = tiny(z)
vec = [z/z,z/1.0_wp,-z/1.0_wp,1.0_wp/z,-1.0_wp/z,t/10]
print*,ieee_value(0.0,ieee_positive_inf),1.0/z ! 2 ways of geting +Inf
NaN = ieee_value(0.0,ieee_quiet_nan) ! get NaN
print*,"NaN == NaN?",NaN == NaN ! demonstrate that NaN /= NaN
print*
print "(19x,*(a9))","0.0/0.0","0.0/1.0","-0.0/1.0","1.0/0.0","-1.0/0.0","tiny/10"
print fmt,"ieee_is_nan"     ,ieee_is_nan(vec)
print fmt,"ieee_is_negative",ieee_is_negative(vec)
print fmt,"ieee_is_finite"  ,ieee_is_finite(vec)
print fmt,"ieee_is_normal"  ,ieee_is_normal(vec)
end program test_ieee_arithmetic
! gfortran output:
!         Infinity         Infinity
! NaN == NaN? F
!
!                      0.0/0.0  0.0/1.0 -0.0/1.0  1.0/0.0 -1.0/0.0  tiny/10
!      ieee_is_nan        T        F        F        F        F        F
! ieee_is_negative        F        F        T        F        T        F
!   ieee_is_finite        F        T        T        F        F        T
!   ieee_is_normal        F        T        T        F        F        F


program prod_escalar

implicit none

integer:: n, i
real, allocatable:: v(:), w(:)
real:: pe1, pe2, pe3

print*, 'Dame o tamano dos vectores'
read*, n

print*, 'O orde do sistema e '
print*, n

allocate(v(n), w(n))

print*,
print*, 'Introduce o vector v'
read*, v

print*, 'O vector v e:'
print*, v

print*,
print*, 'Introduce o vector w'
read*, w

print*, 'O vector w e:'
print*, w

pe1 = dot_product(v,w)

pe2 = 0
do i=1,n
  pe2 = pe2 + v(i)*w(i)
end do

pe3 = sum(v*w)

print*,
print*, 'Produto escalar 1: ', pe1
print*, 'Produto escalar 2: ', pe2
print*, 'Produto escalar 3: ', pe3

end program


function compute_pi(segments)
  implicit none

  integer, intent(in) :: segments
  real*8 :: compute_pi

  real*8 :: polygon_edge_length_squared
  integer :: polygon_sides
  integer :: i

  polygon_edge_length_squared = 2.0
  polygon_sides = 2
  do i = 1, segments
    polygon_edge_length_squared = -sqrt(1 - polygon_edge_length_squared / 4) * 2 + 2
    polygon_sides = polygon_sides * 2
  end do
  compute_pi = sqrt(polygon_edge_length_squared) * polygon_sides
  return
end function


!===============================================================================
program spherical_mean
!===============================================================================
! Reads in (lon, colat) angles from stdin and computes the mean direction.
! Input and output in degrees

use statistical

implicit none

integer, parameter :: rs = 8
integer, parameter :: nmax = 100000
real(rs), parameter :: pi = 4._rs*atan2(1._rs, 1._rs)
real(rs), parameter :: rad = pi/180._rs, deg = 180._rs/pi
real(rs), dimension(nmax) :: lon, colat
real(rs), allocatable, dimension(:) :: x, y, z
real(rs) :: mean(3), meanlon, meancolat
integer :: n, i, iostat = 0

i = 1
do while (iostat == 0)
   read(*,*,iostat=iostat) lon(i), colat(i)
   if (iostat < 0) then
      n = i - 1
      exit
   else if (iostat > 0) then
      write(0,'(a)') 'sph_mean: Problem reading lon,colat from stdin'
      stop
   endif
   if (colat(i) < 0._rs .or. colat(i) > 180._rs) then
      write(0,'(a)') 'sph_mean: Error: colat is outside range (0, 180) degrees'
      stop
   endif
   i = i + 1
   if (i > nmax) then
      write(0,'(a,i0)') 'sph_mean: Reached compiled nmax limit of ',nmax
      write(0,'(a)') 'Skipping remaining points...'
   endif
enddo

write(*,'(a,i0,a)') 'Got ',n,' pairs from stdin'

allocate(x(n), y(n), z(n))

! Convert to x,y,z
lon(1:n) = rad*lon(1:n)
colat(1:n) = rad*colat(1:n)
x(1:n) = sin(colat(1:n))*cos(lon(1:n))
y(1:n) = sin(colat(1:n))*sin(lon(1:n))
z(1:n) = cos(colat(1:n))

mean = sph_mean(x, y, z)

! Convert back to lon, colat
meancolat = deg*acos(mean(3))
meanlon = deg*atan2(mean(2),mean(1))

write(*,*) meanlon, meancolat

end program spherical_mean
!-------------------------------------------------------------------------------


C monte carlo estimate Pi
C always double precision for R
C compile using R CMD SHLIB mc_pi_r.f
C23456789
      subroutine mc_pi_r(pi)
        double precision pi
        k = 0
        do 10 i=1,1000000
          x = rand()
          y = rand()
          if(x**2 + y**2 .lt. 1.0) k=k+1
 10     continue
        pi = real(k) / 1000000 * 4
      end subroutine mc_pi_r


SUBROUTINE eta_nonlinear_3D(k,angle,x,y,omega,time,n_four_modes,yy,eta,etax,etay,etaxx,etayy,etat)
!
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
IMPLICIT NONE
INTEGER :: n_four_modes
REAL(KIND=long), INTENT(IN)  :: k,angle,x,y,omega,time,yy(n_four_modes)
REAL(KIND=long), INTENT(OUT) :: eta,etax,etay
REAL(KIND=long), INTENT(OUT) :: etaxx,etayy,etat
! REAL(KIND=long), OPTIONAL :: y,etay,etayy !Boundary fitted ?
! Local variables
REAL(KIND=long) :: kx, ky, k_omegat, cosk_omegat, sink_omegat, km
INTEGER    :: m
!
!
kx=cos(angle)
ky=sin(angle)
!
!kx = k*x-omega*time
k_omegat=kx*k*x+ky*k*y-omega*time
km=DBLE(n_four_modes)
cosk_omegat=half*yy(n_four_modes)*cos(km*k_omegat)
sink_omegat=half*yy(n_four_modes)*sin(km*k_omegat)
!
eta   = cosk_omegat
!
etax  = -km*kx*sink_omegat
etaxx = -(km*kx)**2*cosk_omegat
etay  = -km*ky*sink_omegat
etayy = -(km*ky)**2*cosk_omegat
!
etat  = omega*km*sink_omegat
!FIXME optimizaton of loops (GD)
DO  m=1,n_four_modes-1
   km=DBLE(m)
   cosk_omegat=yy(m)*cos(km*k_omegat)
   sink_omegat=yy(m)*sin(km*k_omegat)
   ! Non-dimensional eta and derivatives
   eta  = eta   + cosk_omegat
   !
   etax = etax  - km*kx*sink_omegat
   etaxx= etaxx - (km*kx)**2*cosk_omegat
   etay = etay  - km*ky*sink_omegat
   etayy= etayy - (km*ky)**2*cosk_omegat
   !
   etat = etat  + omega*km*sink_omegat
ENDDO

END SUBROUTINE eta_nonlinear_3D


C***BEGIN PROLOGUE  DWEB
C***REFER TO  DDASPK
C***DATE WRITTEN   950914   (YYMMDD)
C
C***AUTHORS  A. C. Hindmarsh, P. N. Brown
C            Lawrence Livermore National Laboratory
C            L-316, P.O. Box 808
C            Livermore, CA 94551, USA
C
C***DESCRIPTION
C
C-----------------------------------------------------------------------
C Example program for DDASPK.
C DAE system derived from ns-species interaction PDE in 2 dimensions.
C
C This is the double precision version.
C-----------------------------------------------------------------------
C
C This program solves a DAE system that arises from a system
C of partial differential equations.  The PDE system is a food web
C population model, with predator-prey interaction and diffusion on
C the unit square in two dimensions.  The dependent variable vector is
C
C         1   2        ns
C   c = (c , c , ..., c  )
C
C and the PDEs are as follows..
C
C     i               i      i
C   dc /dt  =  d(i)*(c    + c   )  +  R (x,y,c)  (i=1,...,ns/2)
C                     xx     yy        i
C
C                     i      i
C   0       =  d(i)*(c    + c   )  +  R (x,y,c)  (i=(ns/2)+1,...,ns)
C                     xx     yy        i
C
C where
C                  i          ns         j
C   R (x,y,c)  =  c *(b(i) + sum a(i,j)*c )
C    i                       j=1
C
C The number of species is ns = 2*np, with the first np being prey and
C the last np being predators.  The coefficients a(i,j), b(i), d(i) are
C
C   a(i,i) = -a  (all i)
C   a(i,j) = -g  (i .le. np, j .gt. np)
C   a(i,j) =  e  (i .gt. np, j .le. np)
C   b(i) =  b*(1 + alpha*x*y + beta*sin(4*pi*x)*sin(4*pi*y))  (i .le. np)
C   b(i) = -b*(1 + alpha*x*y + beta*sin(4*pi*x)*sin(4*pi*y))  (i .gt. np)
C   d(i) = dprey  (i .le. np)
C   d(i) = dpred  (i .gt. np)
C
C The various scalar parameters are set in subroutine setpar.
C
C The boundary conditions are.. normal derivative = 0.
C A polynomial in x and y is used to set the initial conditions.
C
C The PDEs are discretized by central differencing on a MX by MY mesh.
C
C The DAE system is solved by DDASPK with three different method options:
C (1) direct band method for the linear systems (internal Jacobian),
C (2) preconditioned Krylov method for the linear systems, without
C     block-grouping in the reaction-based factor, and
C (3) preconditioned Krylov method for the linear systems, with
C     block-grouping in the reaction-based factor.
C
C In the Krylov cases, the preconditioner is the product of two factors:
C (a) The spatial factor uses a fixed number of Gauss-Seidel iterations
C based on the diffusion terms only.
C (b) The reaction-based factor is a block-diagonal matrix based on
C the partial derivatives of the interaction terms R only.
C With block-grouping, only a subset of the ns by ns blocks are computed.
C An integer flag, JPRE, is set in the main program to specify whether
C the preconditioner is to use only one of the two factors or both,
C and in which order.
C
C The reaction-based preconditioner factor is set up and solved in
C seven subroutines --
C   DMSET2, DRBDJA, DRBDPS  in the case of no block-grouping, and
C   DGSET2, GSET1, DRBGJA, DRBGPS  in the case of block-grouping.
C These routines are provided separately for general use on problems
C arising from reaction-transport systems.
C
C Two output files are written.. one with the problem description and
C performance statistics on unit LOUT = 9, and one with solution
C profiles at selected output times on unit LCOUT = 10.
C The solution file is written only in the case of the direct method.
C-----------------------------------------------------------------------
C Note.. in addition to the main program and subroutines given below,
C this program requires the BLAS routine DAXPY.
C-----------------------------------------------------------------------
C References
C [1] Peter N. Brown and Alan C. Hindmarsh,
C     Reduced Storage Matrix Methods in Stiff ODE Systems,
C     J. Appl. Math. & Comp., 31 (1989), pp. 40-91.
C [2] Peter N. Brown, Alan C. Hindmarsh, and Linda R. Petzold,
C     Using Krylov Methods in the Solution of Large-Scale Differential-
C     Algebraic Systems, SIAM J. Sci. Comput., 15 (1994), pp. 1467-1488.
C [3] Peter N. Brown, Alan C. Hindmarsh, and Linda R. Petzold,
C     Consistent Initial Condition Calculation for Differential-
C     Algebraic Systems, LLNL Report UCRL-JC-122175, August 1995;
C     submitted to SIAM J. Sci. Comp.
C-----------------------------------------------------------------------
C***ROUTINES CALLED
C   SETPAR, DGSET2, CINIT, DDASPK, OUTWEB
C
C***END PROLOGUE  DWEB
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      EXTERNAL RESWEB, JACRS, PSOLRS
C
C Set output unit numbers for main output and tabulated solution.
      DATA LOUT/9/, LCOUT/10/
C
C Dimension solution arrays and work arrays.
C
C When INFO(12) = 0, with INFO(5) = 0, INFO(6) = 1:
C    The length required for RWORK is
C              50 + (2*ML+MU+11)*NEQ + 2*(NEQ/(ML+MU+1) + 1) .
C    For MX = MY = (even number) and ML = MU = NS*MX, this length is
C              50 + (3*NS*MX + 11)*NEQ + MY .
C    The length required for IWORK is  40 + 2*NEQ .
C
C When INFO(12) = 1:
C    The length required for RWORK is
C              91 + 19*NEQ + LENWP = 91 + 19*NEQ + NS*NS*NGRP .
C    The length required for IWORK is
C              40 + NEQ + LENIWP = 40 + NEQ + NS*NGRP .
C
C The dimensions for the various arrays are set below using parameters
C   MAXN    which must be .ge. NEQ = NS*MX*MY,
C   MAXS    which must be .ge. NS,
C   MAXM    which must be .ge. MAX(MX,MY).
C
      PARAMETER (MAXS = 2, MAXM = 20, MAXN = 800,
     1           LRW = 50 + (3*MAXS*MAXM + 11)*MAXN + MAXM,
     2           LIW = 40 + 2*MAXN)
C
      DIMENSION CC(MAXN), CCPRIME(MAXN), RWORK(LRW), IWORK(LIW),
     1          INFO(20), RPAR(MAXN), IPAR(2)
C
C The COMMON blocks /PPAR1/ and /PPAR2/ contain problem parameters.
C
      COMMON /PPAR1/ AA, EE, GG, BB, DPREY, DPRED
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY, ALPH, BETA, FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
C Open output files.
      OPEN(UNIT=LOUT,FILE='wdout',STATUS='unknown')
      OPEN(UNIT=LCOUT,FILE='wccout',STATUS='unknown')
C
C Call SETPAR to set basic problem parameters.
      CALL SETPAR
C
C Set remaining problem parameters.
      NEQ = NS*MX*MY
      MXNS = MX*NS
      DX = AX/REAL(MX-1)
      DY = AY/REAL(MY-1)
      DO 10 I = 1,NS
        COX(I) = DIFF(I)/DX**2
 10     COY(I) = DIFF(I)/DY**2
C
      WRITE(LOUT,20)NS
 20   FORMAT(//' Example program for DDASPK package'//
     1   ' Food web problem with NS species, NS =',I4/
     2   ' Predator-prey interaction and diffusion on a 2-D square'/)
      WRITE(LOUT,30) AA,EE,GG,BB,DPREY,DPRED, ALPH,BETA
 30   FORMAT(' Matrix parameters..  a =',E12.4,'   e =',E12.4,
     1   '   g =',E12.4/21x,' b parameter =',E12.4//
     2   ' Diffusion coefficients.. dprey =',E12.4,'   dpred =',E12.4//
     3   ' Rate parameters alpha =',E12.4,' and beta =',E12.4/)
      WRITE(LOUT,40) MX,MY,NEQ
 40   FORMAT(' Mesh dimensions (MX,MY) =',2I4,
     1   5x,' Total system size is NEQ =',I7/)
C
C Here set the flat initial guess for the predators.
      PREDIC = 1.0D5
C
C Set remaining method parameters for DDASPK.
C These include the INFO array and tolerances.
C
      DO 50 I = 1,20
 50     INFO(I) = 0
C
C Here set INFO(11) = 1, indicating I.C. calculation requested.
      INFO(11) = 1
C
C Here set INFO(14) = 1 to get the computed initial values.
      INFO(14) = 1
C
C Here set INFO(15) = 1 to signal that a preconditioner setup routine
C is to be called in the Krylov case.
      INFO(15) = 1
C
C Here set INFO(16) = 1 to get alternative error test (on the
C differential variables only).
      INFO(16) = 1
C
C Here set the tolerances.
      RTOL = 1.0D-5
      ATOL = RTOL
C
      WRITE(LOUT,70)RTOL,ATOL,INFO(11),PREDIC,INFO(16)
 70   FORMAT(' Tolerance parameters.. RTOL =',E10.2,'   ATOL =',E10.2//
     1   ' Internal I.C. calculation flag INFO(11) =',I2,
     2   '   (0 = off, 1 = on)'/
     3   ' Predator I.C. guess =',E10.2//
     4   ' Alternate error test flag INFO(16) =',I2,
     5        '  (0 = off, 1 = on)')
C
C Set NOUT = number of output times.
      NOUT = 18
C
C Loop over method options:
C METH = 0 means use INFO(12) = 0 (direct)
C METH = 1 means use INFO(12) = 1 (Krylov) without block-grouping in
C          the reaction-based factor in the preconditioner.
C METH = 2 means use INFO(12) = 1 (Krylov) with block-grouping in
C          the reaction-based factor in the preconditioner.
C A block-grouping flag JBG, communicated through IPAR, is set to
C 0 (no block-grouping) or 1 (use block-grouping) with METH = 1 or 2.
C Reset INFO(1) = 0 and INFO(11) = 1.
C
      DO 300 METH = 0,2
      INFO(12) = MIN(METH,1)
      INFO(1) = 0
      INFO(11) = 1
      JBG = METH - 1
      IPAR(2) = JBG
C
      WRITE(LOUT,80)INFO(12)
 80   FORMAT(//80('.')//
     1   ' Linear solver method flag INFO(12) =',I2,
     2   '   (0 = direct, 1 = Krylov)'/)
C
C In the case of the direct method, set INFO(6) = 1 to signal a banded
C Jacobian, set IWORK(1) = IWORK(2) = MX*NS, the half-bandwidth, and
C call SETID to set the IWORK segment ID indicating the differential
C and algebraic components.
      IF (INFO(12) .EQ. 0) THEN
        INFO(6) = 1
        IWORK(1) = MXNS
        IWORK(2) = MXNS
        CALL SETID (MX, MY, NS, NP, 40, IWORK)
        WRITE(LOUT,90)MXNS
 90     FORMAT(' Difference-quotient banded Jacobian,'
     1         ' half-bandwidths =',I4)
        ENDIF
C
C In the case of the Krylov method, set and print various
C preconditioner parameters.
      IF (INFO(12) .EQ. 1) THEN
C First set the preconditioner choice JPRE.
C  JPRE = 1 means reaction-only (block-diagonal) factor A_R
C  JPRE = 2 means spatial factor (Gauss-Seidel) A_S
C  JPRE = 3 means A_S * A_R
C  JPRE = 4 means A_R * A_S
C Use IPAR to communicate JPRE to the preconditioner solve routine.
        JPRE = 3
        IPAR(1) = JPRE
        WRITE(LOUT,100)JPRE
 100    FORMAT(' Preconditioner flag is JPRE =',I3/
     1      '  (1 = reaction factor A_R, 2 = spatial factor A_S,',
     2      ' 3 = A_S*A_R, 4 = A_R*A_S )'/)
C Here call DMSET2 if JBG = 0, or DGSET2 if JBG = 1, to set the 2-D
C mesh parameters and block-grouping data, and the IWORK segment ID
C indicating the differential and algebraic components.
        IF (JBG .EQ. 0) THEN
          CALL DMSET2 (MX, MY, NS, NP, 40, IWORK)
          WRITE(LOUT,110)
 110      FORMAT(' No block-grouping in reaction factor')
          ENDIF
        IF (JBG .EQ. 1) THEN
          NXG = 5
          NYG = 5
          NG = NXG*NYG
          CALL DGSET2 (MX, MY, NS, NP, NXG, NYG, 40, IWORK)
          WRITE(LOUT,120)NG,NXG,NYG
 120      FORMAT(' Block-grouping in reaction factor'/
     1           ' Number of groups =',I5,
     2           '   (NGX by NGY, NGX =',I3,',  NGY =',I3,')')
          ENDIF
        ENDIF
C
C Set the initial T and TOUT, and call CINIT to set initial values.
      T = 0.0D0
      TOUT = 1.0D-8
      CALL CINIT (CC, CCPRIME, PREDIC, RPAR)
C
      NLI = 0
      NNI = 0
C
      WRITE(LOUT,140)
 140  FORMAT(//'   t',7X,'NSTEP  NRE  NNI  NLI  NPE  NQ',4X,
     1   'H',10X,'AVLIN')
C
C Loop over output times, call DDASPK, and print performance data.
C The first call, with IOUT = 0, is to calculate initial values only.
C After the first call, reset INFO(11) = 0 and the initial TOUT.
C
      DO 200 IOUT = 0,NOUT
C
       CALL DDASPK (RESWEB, NEQ, T, CC, CCPRIME, TOUT, INFO, RTOL, ATOL,
     1            IDID, RWORK,LRW, IWORK,LIW, RPAR, IPAR, JACRS, PSOLRS)
C
        NST = IWORK(11)
        NRE = IWORK(12)
        NPE = IWORK(13)
        NNIDIF = IWORK(19) - NNI
        NNI = IWORK(19)
        NLIDIF = IWORK(20) - NLI
        NLI = IWORK(20)
        NQU = IWORK(8)
        HU = RWORK(7)
        AVLIN = 0.0D0
        IF (NNIDIF .GT. 0) AVLIN = REAL(NLIDIF)/REAL(NNIDIF)
C
        IF (METH .EQ. 0) THEN
          IMOD3 = IOUT - 3*(IOUT/3)
          IF (IMOD3 .EQ. 0) CALL OUTWEB (T, CC, NS, MX, MY, LCOUT)
          ENDIF
C
        WRITE(LOUT,150)T,NST,NRE,NNI,NLI,NPE,NQU,HU,AVLIN
 150    FORMAT(E10.2,I5,I6,3I5,I4,E11.2,F9.4)
C
        IF (IDID .LT. 0) THEN
          WRITE(LOUT,160)T
 160      FORMAT(//' Final time reached =',E12.4//)
          GO TO 210
          ENDIF
C
        IF (TOUT .GT. 0.9D0) TOUT = TOUT + 1.0D0
        IF (TOUT .LT. 0.9D0) TOUT = TOUT*10.0D0
        IF (IOUT .EQ. 0) THEN
          INFO(11) = 0
          TOUT = 1.0D-8
          NLI = 0
          NNI = 0
          ENDIF
 200    CONTINUE
C
 210  CONTINUE
      LENRW = IWORK(18)
      LENIW = IWORK(17)
      NST = IWORK(11)
      NRE = IWORK(12)
      NPE = IWORK(13)
      NNI = IWORK(19)
      NLI = IWORK(20)
      NPS = IWORK(21)
      IF (NNI .GT. 0) AVLIN = REAL(NLI)/REAL(NNI)
      NCFN = IWORK(15)
      NCFL = IWORK(16)
      WRITE(LOUT,220) LENRW,LENIW,NST,NRE,NPE,NPS,NNI,NLI,AVLIN,
     1               NCFN,NCFL
 220   FORMAT(//' Final statistics for this run..'/
     1   ' RWORK size =',I8,'   IWORK size =',I6/
     2   ' Number of time steps            =',I5/
     3   ' Number of residual evaluations  =',I5/
     4   ' Number of Jac. or prec. evals.  =',I5/
     5   ' Number of preconditioner solves =',I5/
     6   ' Number of nonlinear iterations  =',I5/
     7   ' Number of linear iterations     =',I5/
     8   ' Average Krylov subspace dimension =',F8.4/
     9   I3,' nonlinear conv. failures,',i5,' linear conv. failures')
C
 300   CONTINUE

      STOP
C------  End of main program for DWEB example program ------------------
      END

      SUBROUTINE SETPAR
C-----------------------------------------------------------------------
C This routine sets the basic problem parameters, namely
C AX, AY, NS, MX, MY,  problem coefficients ACOEF, BCOEF, DIFF,
C ALPH, BETA, using parameters NP, AA, EE, GG, BB, DPREY, DPRED.
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MAXS = 2)
      COMMON /PPAR1/ AA, EE, GG, BB, DPREY, DPRED
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY, ALPH, BETA, FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
      AX = 1.0D0
      AY = 1.0D0
      NP = 1
      MX = 20
      MY = 20
      AA = 1.0D0
      EE = 1.0D4
      GG = 0.5D-6
      BB = 1.0D0
      DPREY = 1.0D0
      DPRED = 0.05D0
      ALPH = 50.0D0
      BETA = 100.0D0
      NS = 2*NP
      DO 20 J = 1,NP
        DO 10 I = 1,NP
          ACOEF(NP+I,J) = EE
          ACOEF(I,NP+J) = -GG
 10       CONTINUE
        ACOEF(J,J) = -AA
        ACOEF(NP+J,NP+J) = -AA
        BCOEF(J) = BB
        BCOEF(NP+J) = -BB
        DIFF(J) = DPREY
        DIFF(NP+J) = DPRED
 20     CONTINUE
      PI = 3.141592653589793D0
      FPI = 4.0D0*PI
C
      RETURN
C------------  End of Subroutine SETPAR  -------------------------------
      END

      SUBROUTINE SETID (MX, MY, NS, NSD, LID, IWORK)
C-----------------------------------------------------------------------
C This routine sets the ID array in IWORK, indicating which components
C are differential and which are algebraic.
C-----------------------------------------------------------------------
      DIMENSION IWORK(*)
C
      NSDP1 = NSD + 1
      DO 40 JY = 1,MY
        I00 = MX*NS*(JY-1) + LID
        DO 30 JX = 1,MX
          I0 = I00 + NS*(JX-1)
          DO 10 I = 1,NSD
 10         IWORK(I0+I) = 1
          DO 20 I = NSDP1,NS
 20         IWORK(I0+I) = -1
 30       CONTINUE
 40     CONTINUE
C
      RETURN
C------------  End of Subroutine SETID  --------------------------------
      END

      SUBROUTINE CINIT (CC, CCPRIME, PREDIC, RPAR)
C-----------------------------------------------------------------------
C This routine computes and loads the vectors of initial values.
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION CC(*), CCPRIME(*), RPAR(*)
      PARAMETER (MAXS = 2)
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY, ALPH, BETA, FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
C Load CC.
      NPP1 = NP + 1
      DO 30 JY = 1,MY
        Y = REAL(JY-1)*DY
        ARGY = 16.0D0*Y*Y*(AY-Y)*(AY-Y)
        IYOFF = MXNS*(JY-1)
        DO 20 JX = 1,MX
          X = REAL(JX-1)*DX
          ARGX = 16.0D0*X*X*(AX-X)*(AX-X)
          IOFF = IYOFF + NS*(JX-1)
          FAC = 1.0D0 + ALPH*X*Y + BETA*SIN(FPI*X)*SIN(FPI*Y)
          DO 10 I = 1,NP
 10         CC(IOFF + I) = 10.0D0 + REAL(I)*ARGX*ARGY
          DO 15 I = NPP1,NS
 15         CC(IOFF + I) = PREDIC
 20       CONTINUE
 30     CONTINUE
C
C Load CCPRIME.
      T = 0.0D0
      CALL FWEB (T, CC, CCPRIME, RPAR)
      DO 60 JY = 1,MY
        IYOFF = MXNS*(JY-1)
        DO 50 JX = 1,MX
          IOFF = IYOFF + NS*(JX-1)
          DO 40 I = NPP1,NS
 40         CCPRIME(IOFF+I) = 0.0D0
 50     CONTINUE
 60   CONTINUE
C
      RETURN
C------------  End of Subroutine CINIT  --------------------------------
      END

      SUBROUTINE OUTWEB (T, C, NS, MX, MY, LUN)
C-----------------------------------------------------------------------
C This routine prints the values of the individual species densities
C at the current time T, to logical unit LUN.
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION C(NS,MX,MY)
C
      WRITE(LUN,10) T
 10   FORMAT(/1X,79('-')/30X,'At time t = ',E16.8/1X,79('-') )
C
      DO 40 I = 1,NS
        WRITE(LUN,20) I
 20     FORMAT(' the species c(',i2,') values are ')
        DO 30 JY = MY,1,-1
          WRITE(LUN,25) (C(I,JX,JY),JX=1,MX)
 25       FORMAT(6(1X,G12.6))
 30       CONTINUE
        WRITE(LUN,35)
 35     FORMAT(1X,79('-'),/)
 40     CONTINUE
C
      RETURN
C------------  End of Subroutine OUTWEB  -------------------------------
      END

      SUBROUTINE RESWEB (T, U, UPRIME, CJ, DELTA, IRES, RPAR, IPAR)
C-----------------------------------------------------------------------
C This routine computes the residual vector, using Subroutine FWEB
C for the right-hand sides.
C-----------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION U(*),UPRIME(*),DELTA(*),RPAR(*),IPAR(*)
      PARAMETER (MAXS = 2)
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY, ALPH, BETA, FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
      CALL FWEB (T, U, DELTA, RPAR)
C
      DO 30 JY = 1,MY
         IYOFF = MXNS*(JY-1)
         DO 20 JX = 1,MX
            IC0 = IYOFF + NS*(JX-1)
            DO 10 I = 1,NS
               ICI = IC0 + I
               IF (I .GT. NP) THEN
                  DELTA(ICI) = -DELTA(ICI)
               ELSE
                  DELTA(ICI) = UPRIME(ICI) - DELTA(ICI)
               ENDIF
 10         CONTINUE
 20      CONTINUE
 30   CONTINUE
C
      RETURN
C------------  End of Subroutine RESWEB  -------------------------------
      END

      SUBROUTINE FWEB (T, CC, CRATE, RPAR)
C-----------------------------------------------------------------------
C This routine computes the right-hand sides of all the equations
C and returns them in the array CRATE.
C The interaction rates are computed by calls to WEBR, and these are
C saved in RPAR(1),...,RPAR(NEQ) for use later in preconditioning.
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION CC(*), CRATE(*), RPAR(*)
      PARAMETER (MAXS = 2)
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY, ALPH, BETA, FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
      DO 60 JY = 1,MY
        IYOFF = MXNS*(JY-1)
        IDYU = MXNS
        IF (JY .EQ. MY) IDYU = -MXNS
        IDYL = MXNS
        IF (JY .EQ. 1) IDYL = -MXNS
        DO 40 JX = 1,MX
          IC = IYOFF + NS*(JX-1) + 1
C Get interaction rates at one point (X,Y).
          CALL WEBR (T, JX, JY, CC(IC), RPAR(IC))
          IDXU = NS
          IF (JX .EQ. MX) IDXU = -NS
          IDXL = NS
          IF (JX .EQ. 1) IDXL = -NS
          DO 20 I = 1,NS
            ICI = IC + I - 1
C Do differencing in Y.
            DCYLI = CC(ICI) - CC(ICI-IDYL)
            DCYUI = CC(ICI+IDYU) - CC(ICI)
C Do differencing in X.
            DCXLI = CC(ICI) - CC(ICI-IDXL)
            DCXUI = CC(ICI+IDXU) - CC(ICI)
C Collect terms and load CRATE elements.
            CRATE(ICI) = COY(I)*(DCYUI - DCYLI) + COX(I)*(DCXUI - DCXLI)
     1                  + RPAR(ICI)
 20         CONTINUE
 40       CONTINUE
 60    CONTINUE
      RETURN
C------------  End of Subroutine FWEB  ---------------------------------
      END

      SUBROUTINE WEBR (T, JX, JY, C, CRATE)
C-----------------------------------------------------------------------
C This routine computes one block of the interaction term R of the
C system, namely block (JX,JY), for use in preconditioning.
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION C(*), CRATE(*)
      PARAMETER (MAXS = 2)
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY, ALPH, BETA, FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
      Y = REAL(JY-1)*DY
      X = REAL(JX-1)*DX
      DO 10 I = 1,NS
 10     CRATE(I) = 0.0D0
      DO 15 J = 1,NS
        CALL DAXPY (NS, C(J), ACOEF(1,J), 1, CRATE, 1)
 15     CONTINUE
      FAC = 1.0D0 + ALPH*X*Y + BETA*SIN(FPI*X)*SIN(FPI*Y)
      DO 20 I = 1,NS
 20     CRATE(I) = C(I)*(BCOEF(I)*FAC + CRATE(I))
      RETURN
C------------  End of Subroutine WEBR  ---------------------------------
      END

      SUBROUTINE JACRS(RES, IRES, NEQ, T, CC, CCPRIME, REWT, SAVR, WK,
     1                  H, CJ, WP, IWP, IER, RPAR, IPAR)
C-----------------------------------------------------------------------
C This routine interfaces to Subroutine DRBGJA or Subroutine DRBGJA,
C depending on the flag JBG = IPAR(2), to generate and preprocess the
C block-diagonal Jacobian corresponding to the reaction term R.
C If JBG = 0, we call DRBDJA, with no block-grouping.
C If JBG = 1, we call DRBGJA, and use block-grouping.
C Array RPAR, containing the current R vector, is passed to DRBDJA and
C DRBGJA as argument R0, consistent with the loading of RPAR in FWEB.
C The external name WEBR is passed, as the routine which computes the
C individual blocks of the R vector.
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      EXTERNAL WEBR
      DIMENSION CC(*), CCPRIME(*), REWT(*), SAVR(*), WK(*), WP(*),
     1          IWP(*), RPAR(*), IPAR(*)
C
      JBG = IPAR(2)
      IF (JBG .EQ. 0) THEN
          CALL DRBDJA (T, CC, RPAR, WEBR, WK, REWT, CJ, WP, IWP, IER)
        ELSE
          CALL DRBGJA (T, CC, RPAR, WEBR, WK, REWT, CJ, WP, IWP, IER)
        ENDIF
C
      RETURN
C------------  End of Subroutine JACRS  --------------------------------
      END

      SUBROUTINE PSOLRS (NEQ, T, CC, CCPRIME, SAVR, WK, CJ, WT, WP, IWP,
     1                   B, EPLIN, IER, RPAR, IPAR)
C-----------------------------------------------------------------------
C This routine applies the inverse of a product preconditioner matrix
C to the vector in the array B.  Depending on the flag JPRE, this
C involves a call to GS, for the inverse of the spatial factor, and/or
C a call to DRBDPS or DRBGPS for the inverse of the reaction-based
C factor (CJ*I_d - dR/dy).  The latter factor uses block-grouping
C (with a call to DRBGPS) if JBG = 1, and does not (with a call to
C DRBDPS) if JBG = 0.  JBG is communicated as IPAR(2).
C The array B is overwritten with the solution.
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION CC(*), CCPRIME(*), SAVR(*), WK(*), WP(*), IWP(*), B(*),
     1          RPAR(*), IPAR(*)
C
      JPRE = IPAR(1)
      IER = 0
      HL0 = 1.0D0/CJ
C
      JBG = IPAR(2)
C
      IF (JPRE .EQ. 2 .OR. JPRE .EQ. 3) CALL GS (NEQ, HL0, B, WK)
C
      IF (JPRE .NE. 2 ) THEN
        IF (JBG .EQ. 0) CALL DRBDPS (B, WP, IWP)
        IF (JBG .EQ. 1) CALL DRBGPS (B, WP, IWP)
        ENDIF
C
      IF (JPRE .EQ. 4) CALL GS (NEQ, HL0, B, WK)
C
      RETURN
C------------  End of Subroutine PSOLRS  -------------------------------
      END

      SUBROUTINE GS (N, HL0, Z, X)
C-----------------------------------------------------------------------
C This routine provides the inverse of the spatial factor for a
C product preconditoner in an NS-species reaction-diffusion problem.
C It performs ITMAX = 5 Gauss-Seidel iterations to compute an
C approximation to (A_S)-inverse * Z, where A_S = I - hl0*Jd, and Jd
C represents the diffusion contributions to the Jacobian.
C The solution is vector returned in Z.
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION Z(*), X(*)
      PARAMETER (MAXS = 2)
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY, ALPH, BETA, FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
      DATA ITMAX/5/
C
      DIMENSION BETA1(MAXS), GAMMA1(MAXS), BETA2(MAXS), GAMMA2(MAXS),
     1          DINV(MAXS)
C
C-----------------------------------------------------------------------
C Write matrix as A = D - L - U.
C Load local arrays BETA, BETA2, GAMMA1, GAMMA2, and DINV.
C-----------------------------------------------------------------------
      DO 10 I = 1,NS
        ELAMDA = 1.0D0/(1.0D0 + 2.0D0*HL0*(COX(I) + COY(I)))
        BETA1(I) = HL0*COX(I)*ELAMDA
        BETA2(I) = 2.0D0*BETA1(I)
        GAMMA1(I) = HL0*COY(I)*ELAMDA
        GAMMA2(I) = 2.0D0*GAMMA1(I)
        DINV(I) = ELAMDA
 10     CONTINUE
C-----------------------------------------------------------------------
C Begin iteration loop.
C Load array X with (D-inverse)*Z for first iteration.
C-----------------------------------------------------------------------
      ITER = 1
C Zero X in all its components, since X is added to Z at the end.
      DO 15 II = 1,N
 15      X(II) = 0.0d0
C
      DO 50 JY = 1,MY
        IYOFF = MXNS*(JY-1)
        DO 40 JX = 1,MX
          IC = IYOFF + NS*(JX-1)
          DO 30 I = 1,NS
            ICI = IC + I
            X(ICI) = DINV(I)*Z(ICI)
            Z(ICI) = 0.0D0
 30         CONTINUE
 40       CONTINUE
 50     CONTINUE
      GO TO 160
C-----------------------------------------------------------------------
C Calculate (D-inverse)*U*X.
C-----------------------------------------------------------------------
 70   CONTINUE
      ITER = ITER + 1
      JY = 1
        JX = 1
        IC = NS*(JX-1)
        DO 75 I = 1,NS
          ICI = IC + I
 75       X(ICI) = BETA2(I)*X(ICI+NS) + GAMMA2(I)*X(ICI+MXNS)
        DO 85 JX = 2,MX-1
          IC = NS*(JX-1)
          DO 80 I = 1,NS
            ICI = IC + I
 80         X(ICI) = BETA1(I)*X(ICI+NS) + GAMMA2(I)*X(ICI+MXNS)
 85       CONTINUE
        JX = MX
        IC = NS*(JX-1)
        DO 90 I = 1,NS
          ICI = IC + I
 90       X(ICI) = GAMMA2(I)*X(ICI+MXNS)
      DO 115 JY = 2,MY-1
        IYOFF = MXNS*(JY-1)
          JX = 1
          IC = IYOFF
          DO 95 I = 1,NS
            ICI = IC + I
 95         X(ICI) = BETA2(I)*X(ICI+NS) + GAMMA1(I)*X(ICI+MXNS)
          DO 105 JX = 2,MX-1
            IC = IYOFF + NS*(JX-1)
            DO 100 I = 1,NS
              ICI = IC + I
 100          X(ICI) = BETA1(I)*X(ICI+NS) + GAMMA1(I)*X(ICI+MXNS)
 105        CONTINUE
          JX = MX
          IC = IYOFF + NS*(JX-1)
          DO 110 I = 1,NS
            ICI = IC + I
 110        X(ICI) = GAMMA1(I)*X(ICI+MXNS)
 115      CONTINUE
      JY = MY
      IYOFF = MXNS*(JY-1)
        JX = 1
        IC = IYOFF
        DO 120 I = 1,NS
          ICI = IC + I
 120      X(ICI) = BETA2(I)*X(ICI+NS)
        DO 130 JX = 2,MX-1
          IC = IYOFF + NS*(JX-1)
          DO 125 I = 1,NS
            ICI = IC + I
 125      X(ICI) = BETA1(I)*X(ICI+NS)
 130      CONTINUE
        JX = MX
        IC = IYOFF + NS*(JX-1)
        DO 135 I = 1,NS
          ICI = IC + I
 135      X(ICI) = 0.0D0
C-----------------------------------------------------------------------
C Calculate (I - (D-inverse)*L)*X.
C-----------------------------------------------------------------------
 160  CONTINUE
      JY = 1
        DO 175 JX = 2,MX-1
          IC = NS*(JX-1)
          DO 170 I = 1,NS
            ICI = IC + I
 170        X(ICI) = X(ICI) + BETA1(I)*X(ICI-NS)
 175      CONTINUE
        JX = MX
        IC = NS*(JX-1)
        DO 180 I = 1,NS
          ICI = IC + I
 180      X(ICI) = X(ICI) + BETA2(I)*X(ICI-NS)
      DO 210 JY = 2,MY-1
        IYOFF = MXNS*(JY-1)
          JX = 1
          IC = IYOFF
          DO 185 I = 1,NS
            ICI = IC + I
 185        X(ICI) = X(ICI) + GAMMA1(I)*X(ICI-MXNS)
          DO 200 JX = 2,MX-1
            IC = IYOFF + NS*(JX-1)
            DO 195 I = 1,NS
              ICI = IC + I
              X(ICI) = (X(ICI) + BETA1(I)*X(ICI-NS))
     1             + GAMMA1(I)*X(ICI-MXNS)
 195          CONTINUE
 200        CONTINUE
            JX = MX
            IC = IYOFF + NS*(JX-1)
            DO 205 I = 1,NS
              ICI = IC + I
              X(ICI) = (X(ICI) + BETA2(I)*X(ICI-NS))
     1             + GAMMA1(I)*X(ICI-MXNS)
 205          CONTINUE
 210        CONTINUE
      JY = MY
      IYOFF = MXNS*(JY-1)
        JX = 1
        IC = IYOFF
        DO 215 I = 1,NS
          ICI = IC + I
 215      X(ICI) = X(ICI) + GAMMA2(I)*X(ICI-MXNS)
        DO 225 JX = 2,MX-1
          IC = IYOFF + NS*(JX-1)
          DO 220 I = 1,NS
            ICI = IC + I
            X(ICI) = (X(ICI) + BETA1(I)*X(ICI-NS))
     1           + GAMMA2(I)*X(ICI-MXNS)
 220        CONTINUE
 225      CONTINUE
        JX = MX
        IC = IYOFF + NS*(JX-1)
        DO 230 I = 1,NS
          ICI = IC + I
          X(ICI) = (X(ICI) + BETA2(I)*X(ICI-NS))
     1         + GAMMA2(I)*X(ICI-MXNS)
 230      CONTINUE
C-----------------------------------------------------------------------
C Add increment X to Z.
C-----------------------------------------------------------------------
      DO 300 I = 1,N
 300    Z(I) = Z(I) + X(I)
C
      IF (ITER .LT. ITMAX) GO TO 70
      RETURN
C------------  End of Subroutine GS  -----------------------------------
      END


program Sierpinski_carpet
  implicit none

  call carpet(4)

contains

function In_carpet(a, b)
  logical :: in_carpet
  integer, intent(in) :: a, b
  integer :: x, y

  x = a ; y = b
  do
    if(x == 0 .or. y == 0) then
      In_carpet = .true.
      return
    else if(mod(x, 3) == 1 .and. mod(y, 3) == 1) then
      In_carpet = .false.
      return
    end if
    x = x / 3
    y = y / 3
  end do
end function

subroutine Carpet(n)
  integer, intent(in) :: n
  integer :: i, j

  do i = 0, 3**n - 1
    do j = 0, 3**n - 1
      if(In_carpet(i, j)) then
        write(*, "(a)", advance="no") "#"
      else
        write(*, "(a)", advance="no") " "
      end if
    end do
    write(*,*)
  end do
end subroutine Carpet
end program Sierpinski_carpet


program factorial_function
    use, intrinsic :: iso_fortran_env, only : i8 => INT64
    implicit none
    integer(kind=i8), parameter :: n_min = 0_i8, n_max = 10_i8
    integer(kind=i8) :: n

    do n = n_min, n_max
        print *, n, factorial(n)
    end do

contains

    integer(kind=i8) function factorial(n)
        use, intrinsic :: iso_fortran_env, only : i8 => INT64
        implicit none
        integer(kind=i8), intent(in) :: n
        integer(kind=i8) :: factor
        factorial  = 1_i8
        do factor = 2_i8, n
            factorial = factorial*factor
        end do
    end function factorial

end program factorial_function


      SUBROUTINE RK4(NEQ,YY,YYP,DT)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!! fourth order Runge-Kutta algorithm from Hoover's SPAM book
!!!! YYN hold intermediate positions and velocities
!!!! YPN hold derivatives at intermediate times
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      IMPLICIT NONE
      INTEGER :: I,NEQ
      INTEGER, PARAMETER :: double = SELECTED_REAL_KIND(15,99)
      REAL(kind = double) :: DT
      REAL(kind = double), DIMENSION(NEQ) :: YY,YYP
      REAL(kind = double), DIMENSION(NEQ) :: YY1,YY2,YY3,YY4
      REAL(kind = double), DIMENSION(NEQ) :: YP1,YP2,YP3,YP4

      DO I = 1,NEQ
        YY1(I) = YY(I)
      END DO
      CALL RHS(YY1,YP1)

      DO I = 1,NEQ
        YY2(I) = YY(I) + 0.5D00*DT*YP1(I)
      END DO
      CALL RHS(YY2,YP2)

      DO I = 1,NEQ
        YY3(I) = YY(I) + 0.5D00*DT*YP2(I)
      END DO
      CALL RHS(YY3,YP3)

      DO I = 1,NEQ
        YY4(I) = YY(I) + DT*YP3(I)
      END DO
      CALL RHS(YY4,YP4)

      DO I = 1,NEQ
        YYP(I) = (YP1(I) + 2.0D00*(YP2(I)+YP3(I))+YP4(I))/6.0D00
      END DO

      DO I = 1,NEQ
         YY(I) = YY(I) + DT*YYP(I)
      END DO

      END SUBROUTINE


      subroutine solve_rs(f,b)
c
c      solve 4x4 system b*x = f
c      replaces x in place of f
c
      implicit none
      integer              :: i,j
      real, dimension(4,4)      :: b
      real, dimension(4)        :: f
c
      real     :: d1,d2,d3,d4

      b(1,1)     = 1./b(1,1)
      b(1,2)     = b(1,2)*b(1,1)
      b(1,3)     = b(1,3)*b(1,1)
      b(1,4)     = b(1,4)*b(1,1)
c
      b(2,2)     = 1./(b(2,2) -b(2,1)*b(1,2))
      b(2,3)     = (b(2,3)-b(2,1)*b(1,3))*b(2,2)
      b(2,4)     = (b(2,4)-b(2,1)*b(1,4))*b(2,2)
      b(3,2)     = b(3,2)-b(3,1)*b(1,2)
      b(3,3)     = 1./(b(3,3) -b(3,1)*b(1,3) - b(3,2)*b(2,3))
      b(3,4)     = (b(3,4) -b(3,1)*b(1,4) -b(3,2)*b(2,4))*b(3,3)
      b(4,2)     = b(4,2) -b(4,1)*b(1,2)
      b(4,3)     = b(4,3) -b(4,1)*b(1,3) -b(4,2)*b(2,3)
      b(4,4)     = 1./(b(4,4)-b(4,1)*b(1,4)-b(4,2)*b(2,4)-b(4,3)*b(3,4))
c
c            fwd substitution
c
      d1         = f(1)*b(1,1)
      d2         = (f(2) -b(2,1)*d1)*b(2,2)
      d3         = (f(3) -b(3,1)*d1-b(3,2)*d2)*b(3,3)
      d4         = (f(4) -b(4,1)*d1-b(4,2)*d2-b(4,3)*d3)*b(4,4)
c
c            bwd substitution
c
      f(4)       = d4
      f(3)       = d3 -b(3,4) *f(4)
      f(2)       = d2 -b(2,3)*f(3)-b(2,4)*f(4)
      f(1)       = d1-b(1,2)*f(2)-b(1,3)*f(3)- b(1,4)*f(4)
c
      return
c
      end


Subroutine inv(A, n, ans, ierr)
	Implicit None

	Integer, Intent(In) :: n
	Double Precision, Dimension(n, n), Intent(InOut) :: A
	Double Precision, Dimension(n, n), Intent(Out) :: ans
	Integer, Intent(Out) :: ierr
	Double Precision, Dimension(n, n) :: tmp, tmp2
	Double Precision :: tmp_det

	Integer :: i, j, p, q

	ierr = 0

	Call det(A, n, tmp_det)
	If (tmp_det .EQ. 0.0) Then
		ierr = 1
		ans = 0.0
		Return
	End If

	Call minors(A, n, tmp)
	Call trans(tmp, n, tmp2)

	Do i = 1, n
		Do j = 1, n
			ans(i, j) = (-1) ** (i+j) * tmp2(i, j) / tmp_det
		End Do
	End Do
End Subroutine inv


*       This program calculate the solution for the
*       diferintial equation:
*       dy/dx=-xy<    y(x=0)=1
*       the solution is : y= exp(-x^2/2)

        Func(x,y)=-x*y
20      write(*,*)'Enter step size (.le.0 to stop )'
        Read(*,*)H
        if(H.LE.0)stop
        Nstep=3.0/H
        Y=1.0
        do 10 IX=0,Nstep-1
        X=IX*H
        Y=Y+H*func(x,y)
        Diff=exp(-0.5*(x+H)**2)-y
        Write(*,*)IX,X+H,Y,Diff
10      continue
        go to 20
        End

last28-52009/Example/solution od differintial equation- example 1/solution od differintial equation- example 1.f


submodule (mod_integration) smod_integration
    implicit none

contains

    module subroutine gaussquad(N, x, w)
        integer,  intent(in)                :: N
        real(wp), intent(out), dimension(N) :: x, w

        select case (N)
        case (1)
            x = [ 0._wp ]
            w = [ 2._wp ]

        case (2)
            x = [ -0.5773502691896257_wp, &
                0.5773502691896257_wp ]
            w = [ 1._wp, &
                1._wp ]

        case (3)
            x = [ -0.7745966692414834_wp, &
                0._wp, &
                0.7745966692414834_wp ]
            w = [ 0.5555555555555556_wp, &
                0.8888888888888888_wp, &
                0.5555555555555556_wp ]

        case (4)
            x = [ -0.8611363115940526_wp, &
                -0.3399810435848563_wp, &
                0.3399810435848563_wp, &
                0.8611363115940526_wp ]
            w = [ 0.3478548451374538_wp, &
                0.6521451548625461_wp, &
                0.6521451548625461_wp, &
                0.3478548451374538_wp ]

        case (5)
            x = [ -0.9061798459386640_wp, &
                -0.5384693101056831_wp, &
                0._wp, &
                0.5384693101056831_wp, &
                0.9061798459386640_wp ]
            w = [ 0.2369268850561891_wp, &
                0.4786286704993665_wp, &
                0.5688888888888889_wp, &
                0.4786286704993665_wp, &
                0.2369268850561891_wp ]

        case default

            ! call lgwt(-1._wp, 1._wp, N, x, w)
            ! call cgwt(N, x, w)
            call gaussquad_rosetta(N, x, w)

        end select

        return
    end subroutine gaussquad

    subroutine lgwt(a, b, num_pts, x, w)

        !*  This function is a fortran90 port of the matlab function,
        !   lgwt.m The source code of lgwt.m was originally found at:
        !   http://www.mathworks.com/matlabcentral/fileexchange/4540

        ! Variables in/out
        integer, intent(in)   :: num_pts
        real(wp), intent(in)  :: a, b
        real(wp), intent(out) :: x(:), w(:)

        ! Local variables
        integer:: ii, jj, N, N1, N2
        ! real(wp), parameter:: eps=sqrt(epsilon(1.0_wp))
        real(wp), parameter                       :: eps=1d-10
        real(wp), dimension(:),     allocatable   :: xu, array1, y, y0, Lpp
        real(wp), dimension(:, :),  allocatable   :: L, Lp
        real(wp), parameter                       :: pi = 4.0_wp*datan(1.0_wp)

        N = num_pts - 1
        N1 = N + 1
        N2 = N + 2

        ! Allocate and initialize arrays
        allocate(xu(N1), array1(N1), y(N1), y0(N1))
        allocate(L(N1, N2), Lp(N1, N2), Lpp(N1))

        L = 0.0_wp
        Lp = 0.0_wp

        call linspace(-1.0_wp, 1.0_wp, xu)

        array1 = [ (ii, ii = 0, N) ]
        ! Initial guess of the roots of the Legendre polynomial of order N
        y = cos((2.0_wp * dble(array1) + 1.0_wp) * &
            pi / (2.0_wp * dble(N) + 2.0_wp)) + &
            (0.27_wp/dble(N1)) * sin(pi*xu*dble(N)/dble(N2))

        y0 = 2.0_wp

        outer: do
            L(:, 1) = 1.0_wp
            Lp(:, 1) = 0.0_wp

            L(:, 2) = y
            Lp(:, 2) = 1.0_wp

            inner: do jj = 2, N1
                L(:, jj+1) = ( &
                    (2.0_wp*dble(jj)-1.0_wp) * y * L(:, jj) - &
                    dble(jj-1) * L(:, jj-1)) &
                    / dble(jj)
            enddo inner

            Lpp = dble(N2) * (L(:,N1) - y * L(:,N2)) &
                / (1.0_wp - y**2.0_wp)

            y0 = y
            y = y0 - L(:,N2)/Lpp

            if ( norm2(y-y0) < eps ) then
                exit outer
            endif
        enddo outer

        x = ( a*(1.0_wp-y) + b*(1.0_wp+y) ) / 2.0_wp
        w = ( b-a ) / ((1.0_wp - y**2.0_wp)*Lpp**2.0_wp) * &
            (dble(N2) / dble(N1))**2.0_wp

        return
    end subroutine lgwt

    subroutine cgwt(num_pts, x, w)

        ! This function determines the points and weights associated
        ! with Chebyshev-Gauss quadrature

        ! Variables in/out
        integer, intent(in) :: num_pts
        real(wp), intent(out), dimension(:) :: x, w

        ! Local variables
        integer:: ii
        real(wp), parameter:: pi = 4._wp*datan(1._wp)

        x = cos( (dble(2*[( ii, ii=1,num_pts )]-1) )/dble(2*num_pts) * pi)

        w = pi/dble(num_pts) / ((1.0_wp - x**2._wp)**(-0.5_wp))

        ! print*, x
        ! print*, w
        ! stop
        return
    end subroutine cgwt

    subroutine gaussquad_rosetta(n, r1, r2)

        ! This code was originally found at the following website:
        !  http://rosettacode.org/wiki/Numerical_integration/Gauss-Legendre_Quadrature#Fortran

        integer,  intent(in)    :: n
        real(wp), intent(out)   :: r1(n), r2(n)

        integer                 :: k
        real(wp), parameter     :: pi = 4._wp*atan(1._wp)
        real(wp)                :: x, f, df, dx
        integer                 :: i,  iter
        real(wp), allocatable   :: p0(:), p1(:), tmp(:)

        p0 = [1._wp]
        p1 = [1._wp, 0._wp]

        do k = 2, n
            tmp = ((2*k-1)*[p1,0._wp]-(k-1)*[0._wp, 0._wp,p0])/k
            p0 = p1; p1 = tmp
        enddo

        outer: do i = 1, n
            x = cos(pi*(i-0.25_wp)/(n+0.5_wp))
            inner: do iter = 1, 10
                f = p1(1); df = 0._wp
                deep: do k = 2, size(p1)
                    df = f + x*df
                    f  = p1(k) + x * f
                enddo deep
                dx =  f / df
                x = x - dx
                if (abs(dx)<10*epsilon(dx)) exit
            enddo inner
            r1(i) = x
            r2(i) = 2/((1-x**2)*df**2)
        enddo outer
        return
    end subroutine gaussquad_rosetta

end submodule


!
! ej9a.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
program ej9a
use precision, pr => dp

implicit none
integer                 :: i, j, k, n
real(pr), parameter     :: h = 0.001_pr
real(pr)                :: alpha, t0, tf, t, e
real(pr), dimension(:)  :: xi(4), xi_1(4), k1(4), k2(4), k3(4), k4(4), x0(4)

open(unit=10, file='ej9a_e100.dat', status='UNKNOWN', action='WRITE')
write(10, *) "#  t   q1   q2   p1   p2   e"

e = 100._pr
x0 = (/ 2._pr, 0._pr, 0._pr, sqrt(2._pr*e - 4._pr) /)
alpha = 0.05_pr
t0 = 0._pr
tf = 200._pr
n = int((tf-t0)/h)
print *, n
t = 0._pr
xi = x0
do i =1, n
    xi_1 = xi
    k1 = h * f(xi_1, alpha)
    k2 = h * f(xi_1 + k1*0.5_pr, alpha)
    k3 = h * f(xi_1 + k2*0.5_pr, alpha)
    k4 = h * f(xi_1 + k3, alpha)

    xi = xi_1 + (k1 + 2._pr * k2 + 2._pr * k3 + k4) / 6._pr
    t = t0 + i * h

    e = 0.5_pr*(xi(1)*xi(1) + xi(2)*xi(2) + xi(3)*xi(3) + xi(4)*xi(4)) + &
        & alpha * xi(1)*xi(1)*xi(2)*xi(2)

    write(10, *) t, xi(1), xi(2), xi(3), xi(4), e
end do

contains

function f(x, alpha)
integer(pr), parameter :: n = 4
real (pr) :: f(n)
real (pr), intent(in) :: x(n), alpha

    f(1) = x(3)
    f(2) = x(4)
    f(3) = -x(1) - alpha*x(1)*x(2)*x(2)
    f(4) = -x(2) - alpha*x(1)*x(1)*x(2)

end function f

end program ej9a


program factorial_recursive_function
    use, intrinsic :: iso_fortran_env, only : i8 => INT64
    implicit none
    integer(kind=i8), parameter :: n_min = 0_i8, n_max = 10_i8
    integer(kind=i8) :: n

    do n = n_min, n_max
        print *, n, factorial(n)
    end do

contains

    recursive function factorial(n) result(fac)
        use, intrinsic :: iso_fortran_env, only : i8 => INT64
        implicit none
        integer(kind=i8), intent(in) :: n
        integer(kind=i8) :: fac
        if (n == 0) then
            fac  = 1_i8
        else
            fac = n*factorial(n - 1)
        end if
    end function factorial

end program factorial_recursive_function


subroutine iterate(a, s, pi)
    integer, parameter       :: dp=kind(0.d0)
    real(dp), intent(inout)  :: a, s, pi

    pi = pi + (s * (4_dp / (a * (2_dp + (a *(a + 3_dp))))))
    s = -s
    a = a + 2
end subroutine iterate

function calculate(iters) result(res)
    external iterate
    integer, intent(in)      :: iters
    integer, parameter       :: dp=kind(0.d0)
    real(dp)                 :: res
    real(dp)                 :: a, s, pi
    integer                  :: v

    pi = 3_dp
    a = 2_dp
    s = 1_dp
    do v = 1, iters
        call iterate(a, s, pi)
    end do

    res = pi
end function calculate

program nilakanthaPi
    implicit none
    integer, parameter       :: dp=kind(0.d0)
    real(dp)                 :: pi
    real(dp), external       :: calculate

    pi = calculate(150000)

    print *, "pi =", pi
end program nilakanthaPi


program Trapezoidal_Rule

    implicit none

    real :: a,b,h,s,Integration
    integer :: n,i
    real,parameter :: pi=3.14

    print*,"TRAPEZOIDAL RULE"
    print*,"Function : y=sin(x)"

    print*,"Enter lower limit(in degrees) :"
    read*,a
    a=a*pi/180  !Converting degrees to radians

    print*,"Enter upper limit(in degrees) :"
    read*,b
    b=b*pi/180  !Converting degrees to radians

    print*,"Enter number of iterations :"
    read*,n

    h=(b-a)/n
    s=0.5*(f(a)+f(b))

    do i=1,(n-1)
        s=s+f(a+i*h)
    end do

    Integration=h*s
    print*,"Answer of Integration : ",Integration

end program

function f(x)
    implicit none
    real :: f   ! Dummy Variable
    real :: x   ! Local Variable
    f=sin(x)
end function


!---------------------------------------------------------------------------
! This is a fortran90 program to evaluate the 2 dimension laplace equation:
!   Fxx + Fyy = 0
!   {F(Xi+1,Yj)-2*(Fxi,Yj)+F(Xi-1,Yj)}/dX^2 +
!   {F(Xi,Yj+1)-2*F(Xi,Yj)+F(Xi,Yj-1)}/dY^2 = 0
!   for 1/2 >= {x,y} >= 0
!
! The boundary conditions are:
!   f(x=0,y) = 0
!   f(x,y=0) = 0
!   f(x=1/2,y) = 200y
!   f(x,y=1/2) = 200x
! In this example the boundary condition represents temperature in degC.
!
! Mapping:
!   i,j goes from 1 to N-1
!   i,j at the edges (0 and N) are constrained by the boundary conditions
!
! 2017-03-15
!      - working now, 171 iterations needed
!
! 2017-03-06
!      - Initial try.
!      - jacobi method:
!        1. fill f square with boundary conditions,
!        2. iterate through each interior square, where:
!           U(i,j) = (1/4)*{(U(i-1,j)+U(i+1,j)+U(i,j-1)+U(i,j+1)}
!        3. how many iterations does it take to converge?
!        4. compare error.
!      - based on professor xxx's code,
!      - written by xxx.
!---------------------------------------------------------------------------

program part3_jacobi_10
  implicit none

  integer, parameter :: N=10,NM1=N-1,M=NM1*NM1

  real ALX,ALY,dx,dy
  real tolerance, error2, error

  real, dimension (0:N,0:N)  :: F,Fold,Fexact
  real, dimension (0:N)      :: X,Y

  integer i,j,k,iter

  open (2, file = 'part3_jacobi_10.out')

  tolerance = 1.0e-4
  error=0; error2=0

  ALX = 0.5 ! boundary
  ALY = 0.5
  dx = ALX/N ! discretize
  dy = ALY/N
  do i=0,N,1
     X(i) = i*dx
     Y(i) = i*dy
  enddo

  ! setup Fexact matrix
  do i=0,N,1
     do j=0,N,1
        Fexact(i,j) = 400*X(i)*Y(j) ! exact solution
     enddo
  enddo

  ! setup F matrix, boundary conditions
  F=0
  do i=0,N,1
     F(i,0) = 0
     F(0,i) = 0
     F(N,i) = 200*Y(i)
     F(i,N) = 200*X(i)
  enddo

  ! iterate using Jacobi method
  Fold = F
  do iter=1,200,1
     do i=1,NM1,1
        do j=1,N-1,1
           F(i,j) = 0.25*( &
                          Fold(i-1,j) + Fold(i+1,j) + &
                          Fold(i,j-1) + Fold(i,j+1)   &
                         )
        enddo
     enddo

     ! calculate error
     error2 = 0
     do i=1,NM1,1
        do j=1,NM1,i
           error2 = error2 + (F(i,j) - Fold(i,j))**2
        enddo
     enddo
     error = sqrt(error2)/NM1 ! this calculates the L2 norm error / #elements
     write(2,*), iter, 'l2 norm error / #elements:',  error

     Fold = F
     if (error.le.tolerance) goto 1000
  enddo
1000 continue

  ! write F and Fexact to output
  write(2,*), 'F:'
  do i=0,N,1
     write(2,*) (F(i,j),j=0,N)
  enddo
  write(2,*), 'Fexact:'
  do i=0,N,1
     write(2,*) (Fexact(i,j),j=0,N)
  enddo

end program


program laplace_mc

    use problem_description, only: utrue,nx,ny,ax,ay,dx,dy
    use random_util, only: init_random_seed
    use mc_walk, only: random_walk, many_walks, nwalks

    implicit none
    integer :: i,i0,j0,max_steps,seed1,n_mc,n_success,n_total
    real(kind=8) :: x0,y0,u_true,u_mc,u_sum_old,u_sum_new, u_mc_total,error

    open(unit=25, file='mc_laplace_error.txt', status='unknown')

    x0 = 0.9d0
    y0 = 0.6d0
    i0 = nint((x0-ax)/dx)
    j0 = nint((y0-ay)/dy)

    ! shift (x0,y0) to a grid point if it wasn't already:
    x0 = ax + i0*dx
    y0 = ay + j0*dy

    max_steps = 100*max(nx,ny)
    !max_steps = 10

    nwalks = 0   ! to keep track of calls to random_walk

    u_true = utrue(x0, y0)

    seed1 = 12345   ! or set to 0 for random seed
    call init_random_seed(seed1)

    n_mc = 10
    call many_walks(i0, j0, max_steps, n_mc, u_mc, n_success)

    ! start accumulating totals:
    u_mc_total = u_mc
    n_total = n_success

    ! relative error gives estimate of number of correct digits:
    error = abs(u_mc_total - u_true) / abs(u_true)
    write(25,'(i10,e23.15,e15.6)') n_total, u_mc_total, error
    print '(i10,e23.15,e15.6)', n_total, u_mc_total, error

    ! loop to add successively double the number of points used:

    do i=1,12
        ! compute approximation with new chunk of points
        call many_walks(i0, j0, max_steps, n_mc, u_mc, n_success)

        ! update estimate of u based on doubling number:
        ! but not that not all were successful:
        u_sum_old = u_mc_total * n_total
        u_sum_new = u_mc * n_success
        n_total = n_total + n_success
        u_mc_total = (u_sum_old + u_sum_new) / n_total

        ! relative error:
        error = abs(u_mc_total - u_true) / abs(u_true)

        write(25,'(i10,e23.15,e15.6)') n_total, u_mc_total, error
        print '(i10,e23.15,e15.6)', n_total, u_mc_total, error

        n_mc = 2*n_mc
        enddo

    print '("Final approximation to u(x0,y0): ",es22.14)',u_mc_total
    print '("Total number of random walks: ",i10)',nwalks

end program laplace_mc


!  Program to perform a random walk in 1 dimension
!  Only one walker present

PROGRAM random_walk_1dim
  USE constants
  USE f90library
  IMPLICIT NONE
  INTEGER::  max_trials, number_walks
  REAL(dp):: move_probability
  INTEGER, ALLOCATABLE, DIMENSION(:) :: x_cum, x2_cum

  ! get max trials, number of walks and the probability to move
  CALL  initialise(max_trials, number_walks, move_probability)
  ! allocate memory
  ALLOCATE (x_cum(number_walks), x2_cum(number_walks))
  x_cum = 0; x2_cum = 0
  ! do the Monte Carlo move
  CALL  mc_sampling(max_trials, number_walks, move_probability,x_cum, x2_cum)
  ! Print out results
  CALL  output(max_trials, number_walks, x_cum, x2_cum)
  ! free memory
  DEALLOCATE(x_cum, x2_cum)
END PROGRAM random_walk_1dim

! Read in data from screen

SUBROUTINE initialise(max_trials, number_walks, move_probability)
  USE constants
  IMPLICIT NONE
  INTEGER, INTENT(inout) ::max_trials, number_walks
  REAL(DP) :: move_probability
  WRITE(*,*)'Number of Monte Carlo trials ='
  READ(*,*)  max_trials
  WRITE(*,*) 'Number of attempted walks='
  READ(*,*) number_walks
  WRITE(*,*) 'Move probability='
  READ(*,*)  move_probability
END SUBROUTINE initialise

! Output of expectation values, <x>, <y> and their variances
! <x^2> - <x>^2  and <y^2> - <y>^2

SUBROUTINE output(max_trials, number_walks, x_cum, x2_cum)
  USE constants
  IMPLICIT NONE
  INTEGER :: i
  INTEGER, INTENT(in) :: max_trials, number_walks
  INTEGER, INTENT(in) :: x_cum(number_walks), x2_cum(number_walks)
  REAL(dp) :: xaverage, x2average, y2average, xvariance

  OPEN(UNIT=6, FILE='out.dat')
  DO i =1, number_walks
     xaverage = x_cum(i)/FLOAT(max_trials)
     x2average = x2_cum(i)/FLOAT(max_trials)
     xvariance = x2average - xaverage*xaverage
     WRITE(6,'(I3,2X,3F12.6)') i, xaverage, x2average ,xvariance
  ENDDO
END SUBROUTINE output

! Here we perform the Monte Carlo samplings and moves in 2 dim

SUBROUTINE mc_sampling(max_trials,number_walks, move_probability, x_cum, x2_cum)
  USE constants
  USE f90library
  IMPLICIT NONE
  INTEGER, INTENT(in) :: max_trials,number_walks
  INTEGER, INTENT(inout) :: x_cum(number_walks), x2_cum(number_walks)
  INTEGER :: idum, x, trial, walks
  REAL(dp) :: rantest
  REAL(dp), INTENT(in) :: move_probability
  idum=-1
  ! loop over Monte Carlo trials
  DO trial = 1, max_trials
     x = 0
     ! loop over attempted walks in 2 dimensions
     DO walks = 1, number_walks
        rantest = ran0(idum)
        IF (rantest <= move_probability) THEN
           x = x+1
        ELSE
           x = x-1
        ENDIF
        x_cum(walks) = x_cum(walks)+x
        x2_cum(walks) = x2_cum(walks)+x*x
     ENDDO
  ENDDO
END SUBROUTINE mc_sampling


! Created by EverLookNeverSee@GitHub on 5/31/20
! For more information see FCS/img/Exercise_07.png

program main
    implicit none
    ! declaring variables
    integer :: i, degree
    real :: x, result = 0.0
    real, allocatable, dimension(:) :: P    ! to store polynomial coefficients
    ! specifying polynomial degree using user input
    do
        print *, "Enter degree of the polynomial:"
        read *, degree
        if (degree < 0) then
            print *, "Degree should not be negative!"
            cycle
        end if
        exit
    end do
    ! creating array blocks based on polynomial degree
    allocate(P(degree + 1))
    ! when we have constant(degree of zero) equation
    if (degree == 0) then
        print *, "Please enyter your single value(intercept):"
        read *, P(1)
        result = P(1)
    else    ! for upper degrres of equations
        print *, "Please enter the value of x:"
        read *, x
        print *, "Please enter polynomial coeffs using the form below:"
        print *, "ax**0 +- bx**1 +- cx**2 +- ... +- dx**n"
        do i = 1, size(P)
            print *, "Enter cefficient of x**", i - 1, ":"
            read *, P(i)
        end do
        do i = size(P), 1, -1
            result = result * x + P(i)
        end do
    end if
    ! printing the result
    print *, "Result:", result
end program main


    program demo_modulo
    implicit none
         print *, modulo(17,3)        ! yields 2
         print *, modulo(17.5,5.5)    ! yields 1.0

         print *, modulo(-17,3)       ! yields 1
         print *, modulo(-17.5,5.5)   ! yields 4.5

         print *, modulo(17,-3)       ! yields -1
         print *, modulo(17.5,-5.5)   ! yields -4.5
    end program demo_modulo


module array_functions
  implicit none

contains
  function sumVector(vector) result(vecSum)
    intrinsic :: size
    integer, intent(in) :: vector(:)
    integer vecSum, i

    vecSum = 0
    do i = 1, size(vector)
      vecSum = vecSum + vector(i)
    end do
  end function sumVector

  subroutine sumVectorSub(vector, vecSum)
    integer, intent(in) :: vector(:)
    integer, intent(out) :: vecSum
    integer :: i

    vecSum = 0
    do i = 1, size(vector)
      vecSum = vecSum + vector(i)
    end do
  end subroutine sumVectorSub

  function prodVector(vector) result(vecprod)
    intrinsic :: size
    integer, intent(in) :: vector(:)
    integer vecprod, i

    vecprod = 1
    do i = 1, size(vector)
      vecprod = vecprod*vector(i)
    end do
  end function prodVector

  function minVector(vector) result(vecMin)
    intrinsic :: size
    integer, intent(in) :: vector(:)
    integer vecMin, i

    vecMin = vector(1)
    do i = 2, size(vector)
      if (vecMin > vector(i)) then
        vecMin = vector(i)
      end if
    end do
  end function minVector

  function maxVector(vector) result(vecMax)
    intrinsic :: size
    integer, intent(in) :: vector(:)
    integer vecMax, i

    vecMax = vector(1)
    do i = 2, size(vector)
      if (vecMax < vector(i)) then
        vecMax = vector(i)
      end if
    end do
  end function maxVector

  function dotProd(v, w) result(res)
    intrinsic :: size
    integer, intent(in) :: v(:), w(:)
    integer :: res, i

    res = 0
    do i = 1, size(v)
      res = res + v(i)*w(i)
    end do
  end function dotProd

end module array_functions

program main
  use array_functions
  implicit none
  intrinsic :: dot_product

  ! interface way to write functions
  ! interface
  !   function sumVector(vector) result(vecSum)
  !     integer, intent(in) :: vector(:)
  !     integer :: vecSum
  !   end function sumVector
  ! end interface

  integer, allocatable :: vec(:)
  integer :: status
  integer :: i, ndim, vecSum

  read (*, *) ndim
  allocate (vec(ndim), stat=status)
  write (*, *) "Status ", status

  do i = 1, ndim
    vec(i) = i
  end do

  write (*, *) "Sum of all elements (func)", sumVector(vec)
  call sumVectorSub(vec, vecSum)
  write (*, *) "Sum of all elements (sub)", vecSum
  write (*, *) "Product of all elements ", prodVector(vec)
  write (*, *) "Minimal: ", minVector(vec), "Maximal value: ", maxVector(vec)
  write (*, *) "Dot product ", dotProd(vec, vec), dot_product(vec, vec)

  deallocate(vec, stat=status)
end program main

! interface way to write functions
! function sumVector(vector) result (vecSum)
!   implicit none
!   intrinsic :: size
!   integer, intent(in) :: vector(:)
!   integer vecSum, i

!   vecSum = 0
!   do i = 1, size(vector)
!     vecSum = vecSum + vector(i)
!   end do
! end function sumVector