! test_diff.f90 --
!     Test (not exhausitvely, alas) the module for automatic
!     differentation
!
!     Define a non-trivial function and show that we can
!     evaluate both the value and the first derivative without having to
!     go through mathematics ourselves.
!
!     Also find a root of some equation via Newton-Raphson
!

module find_a_root
    use automatic_differentiation

contains
!
! g may not be an internal routine, hence the module
!
type(AUTODERIV) function g( x )
    type(AUTODERIV), intent(in)  :: x

    g = x ** 2 - 2.0
end function g

end module

program test_diff
    use automatic_differentiation
    use find_a_root

    implicit none

    type(AUTODERIV)  :: x, root
    integer          :: i
    logical          :: found

    do i = 1,20
        x = derivvar( 0.2 * (i-1) )
        write( *, * ) f(x), df(x%v)
    enddo

    x = derivvar( 3.0 )
    call find_root( g, x, 1.0e-6_wp, root, found )
    write(*,*) 'Equation: x**2 - 2 = 0'
    write(*,*) 'Root: ', root%v, ' - expected: ', sqrt(2.0_wp)

    write(*,*) 'Elementary functions: '
    x = derivvar(0.0)
    write(*,*) 'x = ', x
    write(*,*) 'exp(x)  = ', exp(x)
    write(*,*) 'sin(x)  = ', sin(x)
    write(*,*) 'asin(x) = ', asin(x)
    write(*,*) 'sinh(x) = ', sinh(x)
    write(*,*) 'cos(x)  = ', cos(x)
    write(*,*) 'acos(x) = ', acos(x)
    write(*,*) 'cosh(x) = ', cosh(x)
    write(*,*) 'tan(x)  = ', tan(x)
    write(*,*) 'atan(x) = ', atan(x)
    write(*,*) 'tanh(x) = ', tanh(x)

    x = derivvar(1.0)
    write(*,*) 'x = ', x
    write(*,*) 'log(x)  = ', log(x)
    write(*,*) 'exp(x)  = ', exp(x)

contains
!
! The AUTODERIV function and a function that implements the
! first derivative directly.
!
type(AUTODERIV) function f( x )
    type(AUTODERIV), intent(in)  :: x

    f = x ** 3 + 2.0 * x ** 2 - x + 3.0
end function f

real(wp) function df( x )
    real(wp) :: x

    df = 3.0 * x ** 2 + 4.0 * x  - 1.0
end function df

end program


! Name = ARPIT KUMAR JAIN  ROLL No = 180122009
! Code for Question 1 Radial Schrodinger Equation --> Second Order ODEs (R" = -2R'/d - 2ER - 2R/d)

MODULE precision
    IMPLICIT NONE

    ! dp = double precisiona
    INTEGER, PARAMETER:: dp = SELECTED_REAL_KIND(12)
END MODULE precision

! h  --> step size = 0.0005
MODULE constants
    USE precision
    IMPLICIT NONE

    REAL(KIND = dp):: h = 0.0005
    REAL(KIND = dp):: dinitial = 0.0005, Rinitial = 0.000001, vinitial = -1000.0
END MODULE constants

PROGRAM Radial_Schrodinger_Equation
    USE precision
    USE constants
    IMPLICIT NONE

    ! d --> Distance from center ==> basically small r (radius)
    ! R0 --> value at starting point
    ! v0 --> value of R' at starting point
    ! Enrg --> Energy
    ! R1 --> new value of R
    ! v1 --> new value of v
    REAL(KIND = dp):: d, R0, v0, Enrg, R1, v1

    ! i --> iterator,, Nt --> number of iteration or Grid Points
    INTEGER:: i, j, Nt

    Nt = 10000
    Enrg = -0.52_dp ! Initial value of energy

    ! ****************Propagating Runge-Kutta 4 Method Solution*******************

    ! Take energy from -0.52 to -0.48 ==> 5 energy levels with ΔE = 0.01
    OPEN(UNIT = 21, FILE = 'E-0.52.txt')
    OPEN(UNIT = 22, FILE = 'E-0.51.txt')
    OPEN(UNIT = 23, FILE = 'E-0.50.txt')
    OPEN(UNIT = 24, FILE = 'E-0.49.txt')
    OPEN(UNIT = 25, FILE = 'E-0.48.txt')
    DO j = 1, 5
        d = dinitial
        R0 = Rinitial
        v0 = vinitial
        DO i = 1, Nt
            CALL RK4_Method(d, R0, v0, R1, v1, Enrg)
            WRITE(20+j, 5) d, R1, abs(d*R1)**2.0_dp
            5 FORMAT(f9.6, 3x, f9.6, 3x, f9.6)

            ! Update values for next itration
            R0 = R1
            v0 = v1
            d = d + h
        ENDDO
        Enrg = Enrg + 0.01_dp
    ENDDO
    CLOSE(21)
    CLOSE(22)
    CLOSE(23)
    CLOSE(24)
    CLOSE(25)

    CONTAINS
    SUBROUTINE RK4_Method(d, R0, v0, R1, v1, Enrg)
        USE precision
        USE constants
        IMPLICIT NONE

        REAL(KIND = dp):: d, R0, v0, R1, v1, Enrg
        REAL(KIND = dp):: s1R, s2R, s3R, s4R, s1v, s2v, s3v, s4v

        s1R = h * dR_by_dd(d, R0, v0)
        s1v = h * dv_by_dd(d, R0, v0, Enrg)

        s2R = h * dR_by_dd(d + h/2.0_dp, R0 + s1R/2.0_dp, v0 + s1v/2.0_dp)
        s2v = h * dv_by_dd(d + h/2.0_dp, R0 + s1R/2.0_dp, v0 + s1v/2.0_dp, Enrg)

        s3R = h * dR_by_dd(d + h/2.0_dp, R0 + s2R/2.0_dp, v0 + s2v/2.0_dp)
        s3v = h * dv_by_dd(d + h/2.0_dp, R0 + s2R/2.0_dp, v0 + s2v/2.0_dp, Enrg)

        s4R = h * dR_by_dd(d + h, R0 + s3R, v0 + s3v)
        s4v = h * dv_by_dd(d + h, R0 + s3R, v0 + s3v, Enrg)

        R1 = R0 + (s1R + 2.0_dp * s2R + 2.0_dp * s3R + s4R)/6.0_dp
        v1 = v0 + (s1v + 2.0_dp * s2v + 2.0_dp * s3v + s4v)/6.0_dp
    END SUBROUTINE RK4_Method

    FUNCTION dR_by_dd(d, R, v)
        IMPLICIT NONE

        REAL(KIND = dp):: dR_by_dd, d, R, v

        ! No change in d and R
        d = d
        R = R

        ! R' = v
        dR_by_dd = v
        RETURN
    END FUNCTION dR_by_dd

    FUNCTION dv_by_dd(d, R, v, Enrg)
        IMPLICIT NONE

        REAL(KIND = dp):: dv_by_dd, d, R, v, Enrg

        ! v' = -2v/d - 2ER - 2R/d
        dv_by_dd = (-2.0_dp*v)/d - 2.0_dp * Enrg * R - 2.0_dp*R/d
        RETURN
    END FUNCTION dv_by_dd

END PROGRAM Radial_Schrodinger_Equation


MODULE trend_line
IMPLICIT NONE
REAL :: x_sum = 0., x2_sum = 0., x3_sum = 0., x4_sum = 0., y_sum = 0., &
  xy_sum = 0., x2y_sum = 0.
CONTAINS
  SUBROUTINE cumul_trend_sums(x, y)
  IMPLICIT NONE
  REAL, INTENT(IN) :: x, y
  x_sum   = x_sum + x
  x2_sum  = x2_sum + x**2
  x3_sum  = x3_sum + x**3
  x4_sum  = x4_sum + x**4
  y_sum   = y_sum + y
  xy_sum  = xy_sum + x * y
  x2y_sum = x2y_sum + y * x**2
  END SUBROUTINE cumul_trend_sums

  SUBROUTINE build_matrix(n, a, b)
  REAL, DIMENSION(3,3), INTENT(OUT) :: a
  REAL, DIMENSION(3), INTENT(OUT) :: b
  INTEGER, INTENT(IN) :: n
  a(1,1) = REAL(n)
  a(1,2) = x_sum
  a(1,3) = x2_sum
  a(2,1) = x_sum
  a(2,2) = x2_sum
  a(2,3) = x3_sum
  a(3,1) = x2_sum
  a(3,2) = x3_sum
  a(3,3) = x4_sum

  b(1) = y_sum
  b(2) = xy_sum
  b(3) = x2y_sum
  END SUBROUTINE build_matrix

END MODULE trend_line

SUBROUTINE simul(a, b, ndim, n, error)
IMPLICIT NONE
INTEGER, INTENT(IN) :: ndim
REAL, INTENT(INOUT), DIMENSION(ndim, ndim) :: a
REAL, INTENT(INOUT), DIMENSION(ndim) :: b
INTEGER, INTENT(IN) :: n
INTEGER, INTENT(OUT) :: error
REAL, PARAMETER :: EPSILON = 1.0E-6
REAL :: factor, temp
INTEGER :: irow, ipeak, jrow, kcol

! Process n times to get all equations...
mainloop: DO irow = 1, n
  ! Find peak pivot for column irow in rows irow to n
  ipeak = irow
  max_pivot: DO jrow = irow + 1, n
    IF (ABS(a(jrow,irow)) > ABS(a(ipeak,irow))) THEN
      ipeak = jrow
    END IF
  END DO max_pivot

  ! Check for singular equations.
  singular: IF(ABS(a(ipeak,irow)) < EPSILON) THEN
    error = 1
    RETURN
  END IF singular

  ! Otherwise, if ipeak /= irow, swap equations irow & ipeak
  swap_eqn: IF (ipeak /= irow) THEN
    DO kcol = 1, n
      temp           = a(ipeak, kcol)
      a(ipeak, kcol) = a(irow, kcol)
      a(irow, kcol)  = temp
    END DO
    temp     = b(ipeak)
    b(ipeak) = b(irow)
    b(irow)  = temp
  END IF swap_eqn

  ! Multiply equation irow by -a(jrow, irow)/a(irow, irow)
  ! and add it to eqn jrow (for all eqns except irow itself).
  eliminate: DO jrow = 1, n
    IF (jrow /= irow) THEN
      factor = -a(jrow, irow) / a(irow, irow)
      DO kcol = 1, n
        a(jrow, kcol) = a(irow, kcol) * factor + a(jrow, kcol)
      END DO
      b(jrow) = b(irow) * factor + b(jrow)
    END IF
  END DO eliminate
END DO mainloop

divide: DO irow = 1, n
  b(irow)       = b(irow) / a(irow, irow)
  a(irow, irow) = 1
END DO divide

! Set error flag to 0 and return
error = 0
END SUBROUTINE simul

PROGRAM least_squares_2nd_ord
USE trend_line
IMPLICIT NONE
INTEGER, PARAMETER :: MAX_SIZE = 1000
REAL, DIMENSION(3, 3) :: a
REAL, DIMENSION(3) :: b
REAL :: x, y
INTEGER :: error
CHARACTER(len=20) :: file_name
INTEGER :: i, j, n, istat
CHARACTER(len=80) :: msg

WRITE(*, "('Enter the file name containing the data:')")
READ(*, '(A20)') file_name

! Open input data file. Status is OLD because the input data must
! already exist.
OPEN (UNIT=1, FILE=file_name, STATUS='OLD', ACTION='READ', &
      IOSTAT=istat, IOMSG=msg)

! Was the OPEN successful?
fileopen: IF(istat == 0) THEN
  ! The file was opened successfully, so read the number of
  ! measurements in the file.
  READ(1, *) n
  ! If the number of equ is <= MAX_SIZE, read them in
  ! and process them.
  size_ok: IF (n <= MAX_SIZE) THEN
    DO i = 1, n
      x = 0.
      y = 0.
      READ(1, *) x, y
      CALL cumul_trend_sums(x, y)
    END DO
    CALL build_matrix(n, a, b)
    ! Display coefficients.
    WRITE(*, "(/,'Coefficients before call:')")
    DO i = 1, 3
      WRITE(*, "(1X,7F11.4)") (a(i, j), j = 1, 3), b(i)
    END DO

    ! Solve equations
    CALL simul(a, b, 3, 3, error)

    ! Check for error.
    error_check: IF (error /= 0) THEN
      WRITE(*, 1010)
      1010 FORMAT(/'Zero pivot encountered!', &
                  //'There is no unique solution to this system.')
    ELSE error_check
      ! No errors. Display coefficients.
      WRITE(*, "(/,'Coefficients after call:')")
      DO i = 1, 3
        WRITE(*, "(1X,7F11.4)") (a(i, j), j = 1, 3), b(i)
      END DO
      ! Write the final answer.
      WRITE(*, "(/,'The solutions are:')")
      DO i = 1, 3
        WRITE(*,"(2X,'X(',I2,') = ',F16.6)") i, b(i)
      END DO
    END IF error_check
  END IF size_ok
ELSE fileopen
  ! Else file open failed. Tell user.
  WRITE(*, 1020) msg
  1020 FORMAT('File open failed: ', A)
END IF fileopen

END PROGRAM least_squares_2nd_ord


!  Sets up integration points for
!  Gaussian quadrature using Laguerre polynomials
SUBROUTINE gauss_laguerre(x,w,n,alf)
  IMPLICIT NONE
  INTEGER :: MAXIT
  INTEGER, INTENT(IN) :: n
  REAL(KIND=8) :: EPS
  REAL(KIND=8), INTENT(IN) :: alf
  REAL(KIND=8), INTENT(INOUT) :: w(n),x(n)
  INTEGER :: i,its,j
  REAL(KIND=8) :: ai,gammln, nn
  REAL(KIND=8) :: p1,p2,p3,pp,z,z1

  maxit = 10; eps = 3.E-14
  nn = n
  DO i=1,n
     IF(i == 1)THEN
        z=(1.+alf)*(3.+.92*alf)/(1.+2.4*n+1.8*alf)
     ELSE IF(i == 2)THEN
        z=z+(15.+6.25*alf)/(1.+9.0*alf+2.5*n)
     ELSE
        ai=i-2
        z=z+((1.+2.55*ai)/(1.9*ai)+1.26*ai*alf/(1.+3.5*ai))* &
          (z-x(i-2))/(1.+.3*alf)
     ENDIF
     DO its=1,MAXIT
        p1=1.d0
        p2=0.d0
        DO  j=1,n
           p3=p2
           p2=p1
           p1=((2*j-1+alf-z)*p2-(j-1+alf)*p3)/j
        ENDDO
        pp=(n*p1-(n+alf)*p2)/z
        z1=z
        z=z1-p1/pp
        IF(ABS(z-z1) <= eps) GOTO 1
     ENDDO
     PAUSE 'too many iterations in gaulag'
1    x(i)=z
     w(i)=-EXP(gammln(alf+nn)-gammln(nn))/(pp*n*p2)
     write(*,*) x(i), w(i)
  ENDDO

END SUBROUTINE gauss_laguerre

REAL(KIND =8) FUNCTION gammln(xx)
  REAL(KIND=8), INTENT(IN) :: xx
  INTEGER :: j
  REAL(KIND=8) :: ser,tmp,x,y
  REAL(KIND=8), DIMENSION(6) :: cof(6)
  cof(1)=76.18009172947146; cof(2)=-86.50532032941677
  cof(3)=24.01409824083091; cof(4)=-1.231739572450155
  cof(5)= .1208650973866179E-2; cof(6) = -.5395239384953E-5
  x=xx
  y=x
  tmp=x+5.5
  tmp=(x+0.5)*LOG(tmp)-tmp
  ser=1.000000000190015
  DO j=1,6
     y=y+1.0
     ser=ser+cof(j)/y
  ENDDO
  gammln = tmp+LOG(2.5066282746310005*ser/x)

END FUNCTION gammln


! This routine calculates if there is an intersection point or segment
! between two linear segments, given by 4 x:y coordinates
!
! The code was written by means of the Algorithm proposed in
! http://local.wasp.uwa.edu.au/~pbourke/geometry/lineline2d/
! By Paul Bourke
!
! Basically you have four outcomes:
!
! 0) Segments do not cross, ergo no intersection
! 1) Segments are parallel, but not coinciding, ergo no intersection
! 2) Segments cross eachother, indicating an intersection point
! 3) Segments are parallel and coinciding, which has four separate cases:
!
!      a    b c     d
!      ------ -------   no intersection
!
!      a    b c     d
!      ------.-------   one intersection point if b=c
!
!      a   cb   d
!      ----==----       one intersection Segment(!) (c,b)
!
!      a c    d  b
!      ___________      one intersection Segment(!) (c,d)
!        ------
!
! Input: the four coordinates of the two segments: a and b define the first,
!        and c and d define the second segment.
!
! Output: sect, which is (0=no intersection), (1=parallel), (2=intersection point)
!          and (3=intersection segment)
!         cross(2,2) array:
!          if sect is 0 or 1 cross(2,2) equals 0.0d0
!          if sect is 2, cross(1,1:2) contains the intersection point
!          if sect is 3, cross(1,1:2) and cross(2,1:2) contains the intersection segment
!
! 20081114: Frank Everdij, Delft University of Technology
!

subroutine intersect(a,b,c,d,sect,cross)

implicit none

real(8),parameter :: epsilon = 1.0d-10
real(8),dimension(2),intent(in) :: a,b,c,d

integer,intent(out) :: sect
real(8),intent(out) :: cross(2,2)
!--
real(8),dimension(2) :: aa, bb, cc, dd, sw
real(8) :: denom, ua, ub
integer :: first, second

cross=0.0d0
sect=0

! Compute denominator and line numerators for the two segments
!
denom = ( d(2)-c(2) )*( b(1)-a(1) )-( d(1)-c(1) )*( b(2)-a(2) )
ua    = ( d(1)-c(1) )*( a(2)-c(2) )-( d(2)-c(2) )*( a(1)-c(1) )
ub    = ( b(1)-a(1) )*( a(2)-c(2) )-( b(2)-a(2) )*( a(1)-c(1) )

! If denom is zero, then the segments are Parallel (sect=1)
!
if (abs(denom) < epsilon) then

  sect=1

! If the numerators are both zero the segments coincide
!
  if ((abs(ua) < epsilon) .and. (abs(ub) < epsilon)) then
    ua=abs(b(1)-a(1))
    ub=abs(b(2)-a(2))

! Determine whether we will be looking at x or y coordinates to avoid
! pure vertical/horizontal degenerate cases
!
    if (ua>ub) then
      first=1
      second=2
    else
      first=2
      second=1
    endif
    aa=a
    bb=b
    cc=c
    dd=d

! Some sorting needed
!
    if (aa(first)>bb(first)) then
      sw=aa
      aa=bb
      bb=sw
    endif
    if (cc(first)>dd(first)) then
      sw=cc
      cc=dd
      dd=sw
    endif
    if (aa(first)>cc(first)) then
      sw=aa
      aa=cc
      cc=sw
      sw=bb
      bb=dd
      dd=sw
    endif

! Decision time, handle each coinciding case separately
!
    if (bb(first)<cc(first)) then
      sect=0
    else if (abs(bb(first)-cc(first)) < epsilon) then
      sect=2
      cross(1,1:2)=bb(1:2)
    else if (dd(first)>bb(first)) then
      sect=3
      cross(1,1:2)=cc(1:2)
      cross(2,1:2)=bb(1:2)
    else
      sect=3
      cross(1,1:2)=cc(1:2)
      cross(2,1:2)=dd(1:2)
    endif
  end if

else

! The segments are not parallel/coinciding so compute the (virtual) intersection point
!
  ua=ua/denom
  ub=ub/denom

! Final check: if the segment numerators both lie in the interval [0...1] then
! the intersection point is real and we compute its coordinates.
!
  if((ua >= 0.0d0) .and. (ua <= 1.0d0) .and. (ub >= 0.0d0) .and. (ub <= 1.0d0)) then
    sect=2
    cross(1,1:2)=a(1:2)+ua*(b(1:2)-a(1:2))
  endif
endif

return

end subroutine intersect


PROGRAM Trig

  REAL pi, dtor, rtod, radians, degrees

  pi = 4.0 * ATAN(1.0)
  dtor = pi / 180.0
  rtod = 180.0 / pi
  radians = pi / 4.0
  degrees = 45.0

  WRITE(*,*) SIN(radians), SIN(degrees*dtor)
  WRITE(*,*) COS(radians), COS(degrees*dtor)
  WRITE(*,*) TAN(radians), TAN(degrees*dtor)
  WRITE(*,*) ASIN(SIN(radians)), ASIN(SIN(degrees*dtor))*rtod
  WRITE(*,*) ACOS(COS(radians)), ACOS(COS(degrees*dtor))*rtod
  WRITE(*,*) ATAN(TAN(radians)), ATAN(TAN(degrees*dtor))*rtod

END PROGRAM Trig


      SUBROUTINE slCS2C (A, B, V)
*+
*     - - - - -
*      C S 2 C
*     - - - - -
*
*  Spherical coordinates to direction cosines (single precision)
*
*  Given:
*     A,B      real      spherical coordinates in radians
*                           (RA,Dec), (long,lat) etc.
*
*  Returned:
*     V        real(3)   x,y,z unit vector
*
*  The spherical coordinates are longitude (+ve anticlockwise looking
*  from the +ve latitude pole) and latitude.  The Cartesian coordinates
*  are right handed, with the x axis at zero longitude and latitude, and
*  the z axis at the +ve latitude pole.
*
*  Last revision:   22 July 2004
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    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.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      REAL A,B,V(3)

      REAL COSB

      COSB = COS(B)

      V(1) = COS(A)*COSB
      V(2) = SIN(A)*COSB
      V(3) = SIN(B)

      END


! Preprocessor definitions
! Centered, backward and forward index for the x-dimension
#define ix      2:(x_dim-1)
#define ix_m    1:(x_dim-2)
#define ix_p    3:x_dim
! Centered, backward and forward index for the y-dimension
#define iy      2:(y_dim-1)
#define iy_m    1:(y_dim-2)
#define iy_p    3:y_dim

! Usage from Python:
! step_upwind(dx, dy, dt, u, v, C)
subroutine step_upwind(dx, dy, dt, u, v, C, C_new, x_dim, y_dim)
    implicit none
    ! Arguments
    integer                 :: x_dim, y_dim
    real, intent(in)        :: dx, dy, dt
    real, intent(in)        :: C(x_dim, y_dim), u(x_dim, y_dim), v(x_dim, y_dim)
    real, intent(out)       :: C_new(x_dim, y_dim)

    ! Local variables
    real, dimension(x_dim - 2, y_dim - 2) :: x_term, y_term

    !---------------
    ! Begin program
    !---------------

    x_term(:,:) = (&
        MAX(u(ix,iy), 0.) * (C(ix,iy) - C(ix_m,iy)) +&
        MIN(u(ix,iy), 0.) * (C(ix_p,iy) - C(ix,iy)) &
        )/dx

    y_term(:,:) = (&
        MAX(v(ix,iy), 0.) * (C(ix,iy) - C(ix,iy_m)) +&
        MIN(v(ix,iy), 0.) * (C(ix,iy_p) - C(ix,iy)) &
        )/dy

    C_new(ix,iy) = -(x_term + y_term)*dt + C(ix,iy)

end subroutine

! Usage from Python:
! step_leapfrog(dx, dy, dt, u, v, C)
subroutine step_leapfrog(dx, dy, dt, u, v, C, x_dim, y_dim)
    implicit none
    ! Arguments
    integer                 :: x_dim, y_dim
    real, intent(in)        :: dx, dy, dt
    real, intent(in)        :: u(x_dim, y_dim), v(x_dim, y_dim)
    real, intent(inout)     :: C(x_dim, y_dim, 2)
    !f2py intent(in,out)    :: C

    ! Local variabless
    real                    :: C_new(x_dim, y_dim)

    !---------------
    ! Begin program !
    !---------------

    ! Initialize only the boundaries
    C_new(:,1) = 0.
    C_new(:,y_dim) = 0.
    C_new(1,:) = 0.
    C_new(x_dim,:) = 0.

    ! Step
    C_new(ix,iy) = (                                                           &
        - u(ix,iy) * ( C(ix_p,iy,2) - C(ix_m,iy,2) ) / (2 * dx)                &
        - v(ix,iy) * ( C(ix,iy_p,2) - C(ix,iy_m,2) ) / (2 * dy)                &
        ) * 2 *dt + C(ix,iy,1)

    ! Switch out the old result
    C(:,:,1) = C(:,:,2)
    C(:,:,2) = C_new

end subroutine


 ! ==============================================================
 ! Copyright © 2020 Intel Corporation
 !
 ! SPDX-License-Identifier: MIT
 ! =============================================================
 !
 ! [DESCRIPTION]
 ! This program computes the integral (area under the curve) of a user-supplied
 ! function over an interval in a stepwise fashion. The interval is split into
 ! segments, and at each segment position the area of a rectangle is computed
 ! whose height is the value of sine at that point and the width is the segment
 ! width.  The areas of the rectangles are then summed.
 !
 ! The process is repeated with smaller and smaller width rectangles, more
 ! closely approximating the true value.
 !
 ! The source for this program also demonstrates recommended Fortran
 ! coding practices.
 !
 ! Compile the sample several times using different optimization options.
 !
 ! Read the Intel(R) Fortran Compiler Documentation for more information about these options.
 !
 ! Some of these automatic optimizations use features and options
 ! that can restrict program execution to specific architectures.
 !
 ! [COMPILE]
 ! Use the one of the following compiler options:
 !
 ! Windows*: /O1, /O2, /O3
 !
 ! Linux* and macOS*: -O1, -O2, -O3
 !

program int_sin
implicit none

! Create a value DP that is the "kind" number of a double precision value
! We will use this value in our declarations and constants.
integer, parameter :: DP = kind(0.0D0)

! Declare a named constant for pi, specifying the kind type
real(DP), parameter :: pi = 3.141592653589793238_DP

! Declare interval begin and end
real(DP), parameter :: interval_begin = 0.0_DP
real(DP), parameter :: interval_end   = 2.0_DP * pi

real(DP) :: step, sum, x_i
integer :: N, i, j
real clock_start, clock_finish

write (*,'(A)') "  "
write (*,'(A)') "    Number of    | Computed Integral |"
write (*,'(A)') " Interior Points |                   |"
call cpu_time (clock_start)

do j=2,26
  write (*,'(A)') "--------------------------------------"
  N = 2**j
  ! Compute stepsize for N-1 internal rectangles
  step = (interval_end - interval_begin) / real(N,DP);

  ! Approximate 1/2 area in first rectangle: f(x0) * (step/2)
  sum = INTEG_FUNC(interval_begin) * (step / 2.0_DP)

  do i=1,N-1
    x_i = real(i,DP) * step
    ! Apply midpoint rule:
    ! Given length = f(x), compute the area of the
    ! rectangle of width step
    sum = sum + (INTEG_FUNC(x_i) * step)
    end do

  ! Add approximate area in last rectangle for f(xN) * (step/2)
  sum = sum + (INTEG_FUNC(interval_end) * (step / 2.0_DP))

  write (*,'(T5,I10,T18,"|",2X,1P,E14.7,T38,"|")') N, sum
  end do

call cpu_time(clock_finish)
write (*,'(A)') "--------------------------------------"
write (*,'(A)') "  "
write (*,*) "CPU Time = ",(clock_finish - clock_start), " seconds"

contains

! Function to integrate
real(DP) function INTEG_FUNC (x)
  real(DP), intent(IN) :: x

  INTEG_FUNC = abs(sin(x))
  return
end function INTEG_FUNC

end program int_sin


program guess_the_number
 implicit none

 integer                          :: guess
 real                             :: r
 integer                          :: i, clock, count, n
 integer,dimension(:),allocatable :: seed

 real,parameter :: rmax = 10

!initialize random number generator:
 call random_seed(size=n)
 allocate(seed(n))
 call system_clock(count)
 seed = count
 call random_seed(put=seed)
 deallocate(seed)

!pick a random number between 1 and rmax:
 call random_number(r)          !r between 0.0 and 1.0
 i = int((rmax-1.0)*r + 1.0)    !i between 1 and rmax

!get user guess:
 write(*,'(A)') 'I''m thinking of a number between 1 and 10.'
 do   !loop until guess is correct
	write(*,'(A)',advance='NO') 'Enter Guess: '
	read(*,'(I5)') guess
	if (guess==i) exit
	write(*,*) 'Sorry, try again.'
 end do

 write(*,*) 'You''ve guessed my number!'

end program guess_the_number


      FUNCTION golden(ax,bx,cx,f,tol,xmin)
      REAL golden,ax,bx,cx,tol,xmin,f,R,C
      EXTERNAL f
      PARAMETER (R=.61803399,C=1.-R)
      REAL f1,f2,x0,x1,x2,x3
      x0=ax
      x3=cx
      if(abs(cx-bx).gt.abs(bx-ax))then
        x1=bx
        x2=bx+C*(cx-bx)
      else
        x2=bx
        x1=bx-C*(bx-ax)
      endif
      f1=f(x1)
      f2=f(x2)
1     if(abs(x3-x0).gt.tol*(abs(x1)+abs(x2)))then
        if(f2.lt.f1)then
          x0=x1
          x1=x2
          x2=R*x1+C*x3
          f1=f2
          f2=f(x2)
        else
          x3=x2
          x2=x1
          x1=R*x2+C*x0
          f2=f1
          f1=f(x1)
        endif
      goto 1
      endif
      if(f1.lt.f2)then
        golden=f1
        xmin=x1
      else
        golden=f2
        xmin=x2
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/golden.for


! $UWHPSC/codes/openmp/pisum2.f90
! Computes pi using OpenMP.
! Compare to $UWHPSC/codes/mpi/pisum1.f90

program pisum2

    use omp_lib
    implicit none
    real(kind=8) :: pi,pisum,pisum_thread,x,dx
    integer :: n, nthreads, points_per_thread,thread_num
    integer :: i,istart,iend

    ! Specify number of threads to use:
    nthreads = 1       ! need this value in serial mode
    !$ nthreads = 8
    !$ call omp_set_num_threads(nthreads)
    !$ print "('Using OpenMP with ',i3,' threads')", nthreads

    print *, "Input n ... "
    read *, n

    ! First do with parallel do loop ...
    ! ----------------------------------

    print *, "WITH OMP PARALLEL DO LOOP:"
    dx = 1.d0 / n
    pisum = 0.d0
    !$omp parallel do reduction(+: pisum) &
    !$omp             private(x)
    do i=1,n
        x = (i-0.5d0) * dx
        pisum = pisum + 1.d0 / (1.d0 + x**2)
        enddo
    pi = 4.d0 * dx * pisum
    print *, 'The approximation to pi = ', pi

    ! Now do with parallel blocks of code...
    ! --------------------------------------

    print *, "WITH OMP PARALLEL:"

    ! Determine how many points to handle with each thread.
    ! Note that dividing two integers and assigning to an integer will
    ! round down if the result is not an integer.
    ! This, together with the min(...) in the definition of iend below,
    ! insures that all points will get distributed to some thread.
    points_per_thread = (n + nthreads - 1) / nthreads
    print *, "points_per_thread = ",points_per_thread

    dx = 1.d0 / real(n, kind=8)
    pisum = 0.d0

    !$omp parallel private(i,pisum_thread,x, &
    !$omp                  istart,iend,thread_num)

    thread_num = 0     ! needed in serial mode
    !$ thread_num = omp_get_thread_num()    ! unique for each thread

    ! Determine start and end index for the set of points to be
    ! handled by this thread:
    istart = thread_num * points_per_thread + 1
    iend = min((thread_num+1) * points_per_thread, n)

    !$omp critical
    print 201, thread_num, istart, iend
    !$omp end critical
201 format("Thread ",i2," will take i = ",i6," through i = ",i6)

    pisum_thread = 0.d0
    do i=istart,iend
        x = (i-0.5d0)*dx
        pisum_thread = pisum_thread + 1.d0 / (1.d0 + x**2)
        enddo

    ! update global pisum with value from each thread:
    !$omp critical
      pisum = pisum + pisum_thread
    !$omp end critical

    !$omp end parallel

    pi = 4.d0 * dx * pisum

    print *, 'The approximation to pi = ', pi

end program pisum2


!==============================================================
! Uniform circular motion in polar coordinates
! Author: Devansh Shukla
!--------------------------------------------------------------
program CircularMotion_Polar
    ! Program to compute motion of a particle moving in a circle with uniform velocity in polar coordinates.

    implicit none
    real*8, parameter :: PI = 3.141593
    real*8 :: R=0.0, omega=0.0, theta0=0.0, theta, x, y
    real*8 :: t0=0.0, tf=0.0, dt=0.0, t=0.0
    character(len=*), parameter :: fmt1 = "(F10.6, x, F10.6, x, F10.6, x, F10.6, x, F10.6)"

    theta(t) = theta0 + omega*(t-t0)
    x(t) = R*cos(theta(t))
    y(t) = R*sin(theta(t))

    open(UNIT=8, FILE="CirclePolar.dat")

    ! Input
    print *, "Enter angular velocity(omega) and radius (R)"
    read *, omega, R
    if (omega .le. 0.0) stop "Illegal  value of omega"
    if (R .le. 0.0) stop "Illegal value of R"

    print *, "Enter the value of theta0"
    read *, theta0

    print *, "Enter t0, tf, dt"
    read *, t0, tf, dt
    if (dt .le. 0.0) stop "Illegal value of dt"

    print *, "----------------------------------------------------------"
    print "(x,A,F10.4)", "omega =", omega
    print "(x,A,F10.4)", "T =", 2.0*PI / omega
    print "(x,A,F10.4,F10.4,F10.4)", "theta0 =", theta0
    print "(x,A,F10.4)", "R =", R
    print "(x,A,F10.4,F10.4,F10.4)", "t0, tf, dt =", t0, tf, dt
    print *, "----------------------------------------------------------"

    write (8, *) "# t0=", t0
    write (8, *) "# t R theta x y"
    print "(xA10,A10,xA10,A10,A10)", "time", "R", "theta(t)", "x(t)", "y(t)"
    ! Computing
    t = t0
    do while (t <= tf)
        write (*, fmt1) t, R, theta(t), x(t), y(t)
        write (8, fmt1) t, R, theta(t), x(t), y(t)
        t = t + dt
    enddo
    print *, "----------------------------------------------------------"
    close(8)

end program CircularMotion_Polar


! Define types for Cartesian geometry, and define functions for distance and
! calculating slope and intercept.
MODULE cartesian_tools
IMPLICIT NONE

TYPE :: point
  REAL :: x
  REAL :: y
END TYPE point

TYPE :: line
  REAL :: m
  REAL :: b
END TYPE line
CONTAINS
  REAL FUNCTION dist(p1, p2)
  IMPLICIT NONE
  TYPE (point), INTENT(IN) :: p1, p2
  dist = SQRT((p2%x - p1%x)**2 + (p2%y - p1%y)**2)
  END FUNCTION dist

  TYPE (line) FUNCTION connect(p1, p2)
  IMPLICIT NONE
  TYPE (point), INTENT(IN) :: p1, p2
  REAL :: m, b
  IF (p1%x == p2%x .AND. p1%y == p2%y) THEN
    connect = line(0, 0)
  ELSE
    m = (p2%y - p1%y) / (p2%x - p1%x)
    b = p1%y - m * p1%x
    connect = line(m, b)
  END IF
  END FUNCTION
END MODULE cartesian_tools

PROGRAM cartesian
USE cartesian_tools
IMPLICIT NONE
TYPE (point) :: p1, p2, p3
TYPE (line) :: p_line

p1 = point(0.,0.)
p2 = point(1.,2.)
p3 = p2
WRITE(*, *) dist(p1, p2)
WRITE(*, *) dist(p2, p3)
WRITE(*, *) connect(p1, p2)
WRITE(*, *) connect(p2, p3)

END PROGRAM cartesian


      PROGRAM xspline
C     driver for routine spline
      INTEGER N
      REAL PI
      PARAMETER(N=20,PI=3.141593)
      INTEGER i
      REAL yp1,ypn,x(N),y(N),y2(N)
      write(*,*) 'Second-derivatives for sin(x) from 0 to PI'
C     generate array for interpolation
      do 11 i=1,20
        x(i)=i*PI/N
        y(i)=sin(x(i))
11    continue
C     calculate 2nd derivative with SPLINE
      yp1=cos(x(1))
      ypn=cos(x(N))
      call spline(x,y,N,yp1,ypn,y2)
C     test result
      write(*,'(t19,a,t35,a)') 'spline','actual'
      write(*,'(t6,a,t17,a,t33,a)') 'angle','2nd deriv','2nd deriv'
      do 12 i=1,N
        write(*,'(1x,f8.2,2f16.6)') x(i),y2(i),-sin(x(i))
12    continue
      END

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


program test

      implicit none

      integer :: year, golden_number, epacts

      year = 2018

      print *, golden_number(year)

      print *, epacts(year)

end program test

function golden_number(year)

      implicit none

      integer :: year, golden_number

      golden_number = modulo(year + 1, 19)

end function golden_number

function epacts(year)

        implicit none

        integer :: year, golden_number, epacts, arg

        arg = 11 * golden_number(year) + 18

        epacts = modulo(arg, 30)

end function epacts


subroutine ComputeDG82(DG82, lmax, m, theta0)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This routine will compute the kernel of Grunbaum et al. 1982
!	that commutes with the space concentration kernel. This
!	kernel is tridiagonal and has simple expressions for
!	its elements. Note that this kernel is multiplied by -1 in
!	comparison to Grunbaum et al. in order that the eigenvectors
!	will be listed in the same order as the eigenvectors of the
!	equivalent space concentration matrix Dllm. While the eigenfunctions
!	of this kernel correspond to the eigenvalues of Dllm, the eigenvalues
!	do NOT!
!
!	Calling Parameters
!		IN
!			lmax:		Maximum spherical harmonic degree.
!			theta0:		Angular radius of spherical cap IN RADIANS.
!			m:		Angular order to concentration problem.
!		OUT
!			D0G82:		Symmetric tridiagonal kernel with a maximum size of lmax+1 by lmax+1.
!
!	Dependencies:	none
!
!	Written by Mark Wieczorek (June 2004)
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none

	real*8, intent(out) ::	DG82(:,:)
	real*8, intent(in) ::	theta0
	integer, intent(in) :: 	lmax, m
	real*8 ::		x
	integer ::		i, n

	n = lmax + 1 - abs(m)

	if(n<1) then
		print*, "Error --- ComputeDG82"
		print*, "abs(M) must be less than or equal to LMAX"
		print*, "Input values of l and m are ", lmax, m
		stop
	elseif (size(DG82(1,:)) < n .or. size(DG82(:,1)) < n) then
		print*, "Error --- ComputeDG82"
		print*, "DG82 must be dimensioned as (LMAX-abs(M)+1,LMAX-abs(M)+1) where LMAX and M are ", lmax, m
		print*, "Input array is dimensioned as ", size(DG82(1,:)), size(DG82(:,1))
		stop
	endif

	DG82 = 0.0d0

	x = cos(theta0)

	DG82(1,1) = x * dble(1+m) * dble(m)

	do i=2, n, 1
		DG82(i,i) = x * dble(i+m) * dble(i+m-1)
		DG82(i,i-1) = - sqrt(dble(i-1+m)**2 - dble(m)**2) * &
			( dble(i-1+m)**2 - dble(lmax+1)**2 ) / &
			sqrt(4.0d0*dble(i-1+m)**2 - 1.0d0)
		DG82(i-1,i) = DG82(i,i-1)
	enddo

end subroutine ComputeDG82


! Program to test the real->integer conversion routines.
program intrinsic_integer
  implicit none

  call test (0.0, (/0, 0, 0, 0/))
  call test (0.3, (/0, 1, 0, 0/))
  call test (0.7, (/0, 1, 0, 1/))
  call test (-0.3, (/-1, 0, 0, 0/))
  call test (-0.7, (/-1, 0, 0, -1/))
contains
subroutine test(val, res)
  real :: val
  integer, dimension(4) :: res

  if ((floor(val) .ne. res(1)) .or. (ceiling(val) .ne. res(2)) &
      .or. (int(val) .ne. res(3)) .or. (nint(val) .ne. res(4))) call abort
end subroutine
end program


SUBROUTINE random_Zipf(a, r, setup)
! Generate a random deviate (r) from the Zipf (or Zeta) distribution.
! If setup = .TRUE. (or local variable b < 0), two local variables (b and
! const) are set/reset for future calls, otherwise it is assumed that
! the value of a is unchanged since the last call.

! The value of a must be > 1.0 (NOT CHECKED)

! Algorithm from page 551 of:
! Devroye, Luc (1986) `Non-uniform random variate generation',
! Springer-Verlag: Berlin.   ISBN 3-540-96305-7 (also 0-387-96305-7)

! Programmer: Alan Miller (amiller @ users,bigpond.net.au)
! Latest revision - 3 February 1998

IMPLICIT NONE
REAL, INTENT(IN)        :: a
INTEGER, INTENT(OUT)    :: r
LOGICAL, INTENT(IN OUT) :: setup

! Local variables
REAL, SAVE      :: b = -1.0, const
REAL            :: t, u, v
REAL, PARAMETER :: one = 1.0

IF (b < 0.0 .OR. setup) THEN
  b = 2.0**(a - one)
  const = -one/(a - one)
  setup = .FALSE.
END IF

DO
  CALL RANDOM_NUMBER(u)
  CALL RANDOM_NUMBER(v)
  r = FLOOR(u**const)
  t = (one + one/r)**(a - one)
  IF (v*r*(t - one)/(b - one) <= t/b) EXIT
END DO

RETURN
END SUBROUTINE random_Zipf

PROGRAM t_random_Zipf
IMPLICIT NONE
INTEGER              :: r, i, nfreq, count, i1
INTEGER, ALLOCATABLE :: freq(:)
REAL, ALLOCATABLE    :: expctd(:)
REAL                 :: a, total
REAL, PARAMETER      :: one = 1.0
LOGICAL              :: setup

INTERFACE
  SUBROUTINE random_Zipf(a, r, setup)
    IMPLICIT NONE
    REAL, INTENT(IN)        :: a
    INTEGER, INTENT(OUT)    :: r
    LOGICAL, INTENT(IN OUT) :: setup
  END SUBROUTINE random_Zipf
END INTERFACE

WRITE(*, *) 'Enter a (> 1.0): '
READ(*, *) a
setup = .TRUE.
! 1/20 = 5%   Store individual frequencies up to last 5%
nfreq = NINT( (20.0/(a - one))**(one/(a-one)) )
ALLOCATE( freq(nfreq), expctd(nfreq) )
freq = 0

! Generate 1000 random deviates from the Zipf distribution

DO i = 1, 1000
  CALL random_Zipf(a, r, setup)
  r = MIN(r, nfreq)
  freq(r) = freq(r) + 1
END DO

! Calculate approximate expected frequencies
total = 0.0
DO i = 1, nfreq-1
  expctd(i) = REAL(i)**(-a)
  total = total + expctd(i)
END DO
expctd(nfreq) = one / ( (a-one)*(nfreq - 0.5)**(a-one) )
total = total + expctd(nfreq)
expctd = expctd * (1000. / total)

WRITE(*, *) '    Range      Obs.freq.  Expctd.freq.'
i = 1
DO
  count = 0
  total = 0
  i1 = i
  DO
    count = count + freq(i)
    total = total + expctd(i)
    IF (total > 25. .OR. i >= nfreq) EXIT
    i = i + 1
  END DO
  IF (i == nfreq) i = 999999
  WRITE(*, '(i6, " - ", i6, i7, "    ", f9.2)') i1, i, count, total
  IF (i == 999999) EXIT
  i = i + 1
END DO

STOP
END PROGRAM t_random_Zipf


module geomutils

    ! module geomutils : functions for querying 2-D and 3-D geometries

    implicit none

    private
    public dist_point_to_segment_2d, is_point_in_quad

contains

     function dist_point_to_segment_2d(x,y,x1,y1,x2,y2)

        ! dist_point_to_segment_2d() : returns the shortest distance from a point p to a line segment.
        !   Based on the method of http://paulbourke.net/geometry/pointlineplane/
        !
        !   Inputs:
        !   =======
        !   x,y         : the coordinates of the point
        !
        !   Output:
        !   =======
        !   x1,y1,x2,y2 : the start and end points of the line segment
        !

        real, intent(in)  :: x,y,x1,y1,x2,y2
        real :: dist_point_to_segment_2d

        real :: u, dx, dy
        real :: x_closest, y_closest

        ! check if points are coincident
        if (x1==x2 .and. y1==y2) then
            write(*,*) 'Error in dist_point_to_segment_2d : Points are coincident!'
            stop
        end if

        dx = x2-x1
        dy = y2-y1

        u = ((x-x1)*dx + (y-y1)*dy) / abs(dx**2 - dy**2)

        if (u < 0) then
            x_closest = x1
            y_closest = y1
        else if (u > 1) then
            x_closest = x2
            y_closest = y2
        else
            x_closest = x1+u*dx
            y_closest = y1+u*dy
        end if

        dist_point_to_segment_2d = ((x_closest-x)**2 + (y_closest-y)**2)**0.5

    end function dist_point_to_segment_2d

    function is_point_in_quad(p_list, p)

        ! is_point_in_quad() : For a quadrilateral whose corners are given in p_list, returns
        !   True if the point p lies within the polygon and False if the point p lies outside of it.
        !   Based on the method of http://paulbourke.net/geometry/polygonmesh/
        !
        !   Inputs:
        !   =======
        !   p_list                     : a (4,3) array of points. expects that p(:,3) = 0 (the z-coordinate is zero)
        !
        !   Outputs:
        !   ========
        !   is_point_in_quad (logical) : .True. if point is inside the quadrilateral, .False. otherwise

        real, intent(in)   :: p_list(4,3)
        real, intent(in)   :: p(3)
        logical            :: is_point_in_quad

        integer, parameter :: nsides = 4
        real               :: p1(3), p2(3)
        real               :: xinters

        integer            :: i, counter

        counter = 0

        p1 = p_list(1,1:3)

        do i=1,nsides
            p2 = p_list(mod(i,nsides)+1,1:3)
            if (p(2) > min(p1(2),p2(2))) then
                if (p(2) <= max(p1(2),p2(2))) then
                    if (p(1) <= max(p1(1),p2(1))) then
                        if (p1(2) /= p2(2)) then
                            xinters = (p(2)-p1(2))*(p2(1)-p1(1))/(p2(2)-p1(2)) + p1(1)
                            if (p1(1) == p2(1) .or. p(1) <= xinters) then
                                counter = counter + 1
                            end if
                        end if
                    end if
                end if
            end if
            p1 = p2
        end do

        if (mod(counter,2) == 0) then
            is_point_in_quad = .False.
        else
            is_point_in_quad = .True.
        end if

    end function is_point_in_quad

end module geomutils


program matsum
  implicit none

  ! Variable declarations
  integer :: a_rows, a_cols, b_rows, b_cols, c_rows, c_cols
  integer :: i, j, k
  integer :: a_io, b_io, c_io, fa_stat, fb_stat, fc_stat
  real *8, allocatable :: a(:), b(:), c(:)
  character *32 :: fa, fb, fc
  logical :: fa_exists, fb_exists, fc_exists

  ! Ask user for matrix dimensions and filename
  print *, "Matrix A filename?"
  read  *, fa
  print *, "Matrix B filename?"
  read  *, fb
  print *, "Matrix C filename?"
  read  *, fc

  ! Check if files exist
  inquire(file = fa, exist = fa_exists)
  inquire(file = fb, exist = fb_exists)
  inquire(file = fc, exist = fc_exists)
  if (.not. fa_exists .or. .not. fb_exists) then
    call exit
  end if

  ! Open files
  open(newunit = a_io, file = fa, action = "read", iostat = fa_stat)
  open(newunit = b_io, file = fb, action = "read", iostat = fb_stat)
  if (fc_exists) then
    open(newunit = c_io, file = fc, status = "replace", action = "write", iostat = fc_stat)
  else
    open(newunit = c_io, file = fc, status = "new", action = "write", iostat = fc_stat)
  end if

  ! Check if files opened correctly
  if (fa_stat /= 0 .or. fb_stat /= 0 .or. fc_stat /= 0) then
    call exit
  end if

  ! Read matrix A
  read(a_io, '(I1, X, I1)') a_rows, a_cols
  allocate(a(a_rows * a_cols))
  read(a_io, *) (a(i), i = 1, a_rows * a_cols)

  ! Read matrix B
  read(b_io, '(I1, X, I1)') b_rows, b_cols
  allocate(b(b_rows * b_cols))
  read(b_io, *) (b(i), i = 1, b_rows * b_cols)

  ! Initialize C matrix
  c_rows = a_rows
  c_cols = b_cols
  allocate(c(c_rows * c_cols))

  ! Compute product
  do i = 0, a_rows - 1
    do j = 0, b_cols - 1
      do k = 0, b_rows - 1
        c(i * c_cols + j + 1) = c(i * c_cols + j + 1) + a(i * a_cols + k + 1) * b(k * b_cols + j + 1)
      end do
    end do
  end do

  ! Write values to file
  write(c_io, '(I1, X, I1)') c_rows, c_cols
  do i = 1, c_rows * c_cols
    write(c_io, '(F17.15, X)', advance = 'no') c(i)
  end do

  ! Close files
  close(a_io)
  close(b_io)
  close(c_io)

  ! Deallocate arrays
  deallocate(a)
  deallocate(b)
  deallocate(c)
end program matsum


module ElementMod
  ! -------------------------------------------------------------------------------------------------------------------
  ! Mai 2018
  ! Maxime Tousignant
  ! maxime.tousignant@polymtl.ca
  ! -------------------------------------------------------------------------------------------------------------------
  ! Description :
  ! Quadrature de Gauss-Legendre de degree 4 pour integrer parfaitement des polynomes de Legendre d'ordre 2.
  ! Notes :
  ! La modification de l'ordre de la quadrature de Gauss ou des fonctions de bases va entrainer des erreurs.
  ! -------------------------------------------------------------------------------------------------------------------

  ! Quadrature de Gauss d'ordre 4 (hard coded)
  integer, parameter                                        :: nGauss     = 4
  double precision, dimension(nGauss), parameter                                                                        &
    :: xiGauss  = (/ -0.3399810435848563d0,  0.3399810435848563d0, -0.8611363115940526d0,  0.8611363115940526d0 /)
  double precision, dimension(nGauss), parameter                                                                        &
    :: wGauss   = (/  0.6521451548625461d0,  0.6521451548625461d0,  0.3478548451374538d0,  0.3478548451374538d0	/)

  ! Fonctions de bases aux pts de gauss (hard coded)
  integer, parameter                                        :: degPsi     = 2
  double precision, dimension(nGauss)                       :: Psi1       = 0.5d0*xiGauss*(xiGauss-1.0d0)
  double precision, dimension(nGauss)                       :: Psi2       = 1.0d0-xiGauss*xiGauss
  double precision, dimension(nGauss)                       :: Psi3       = 0.5d0*xiGauss*(xiGauss+1.0d0)
  double precision, dimension(nGauss)                       :: dPsi1dxi   = xiGauss-0.5d0
  double precision, dimension(nGauss)                       :: dPsi2dxi   = -2.0d0*xiGauss
  double precision, dimension(nGauss)                       :: dPsi3dxi   = xiGauss+0.5d0

  ! Derivees des fonctions de base aux noeuds
  double precision, dimension(1+degPsi)                     :: dPsi1dxi_node  = (/-1.5d0 ,-0.5d0 , 0.5d0 /)
  double precision, dimension(1+degPsi)                     :: dPsi2dxi_node  = (/ 2.0d0 , 0.0d0 ,-2.0d0 /)
  double precision, dimension(1+degPsi)                     :: dPsi3dxi_node  = (/-0.5d0 , 0.5d0 , 1.5d0 /)

end module ElementMod


PROGRAM mfcs

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:11

!     =======================================================
!     Purpose: This program computes the Fresnel integrals
!     C(x) and S(x) using subroutine FCS
!     Input :  x --- Argument of C(x) and S(x)
!     Output:  C --- C(x)
!     S --- S(x)
!     Example:
!     x          C(x)          S(x)
!     -----------------------------------
!     0.0      .00000000      .00000000
!     0.5      .49234423      .06473243
!     1.0      .77989340      .43825915
!     1.5      .44526118      .69750496
!     2.0      .48825341      .34341568
!     2.5      .45741301      .61918176
!     =======================================================

IMPLICIT DOUBLE PRECISION (a-h,o-z)
WRITE(*,*)'Please enter x '
!     READ(*,*) X
x=2.5
WRITE(*,*)'   x          C(x)          S(x)'
WRITE(*,*)' -----------------------------------'
CALL fcs(x,c,s)
WRITE(*,10)x,c,s
10   FORMAT(1X,f5.1,2F15.8)
END PROGRAM mfcs

SUBROUTINE fcs(x,c,s)

!     =================================================
!     Purpose: Compute Fresnel integrals C(x) and S(x)
!     Input :  x --- Argument of C(x) and S(x)
!     Output:  C --- C(x)
!     S --- S(x)
!     =================================================

DOUBLE PRECISION, INTENT(IN OUT)         :: x
DOUBLE PRECISION, INTENT(OUT)            :: c
DOUBLE PRECISION, INTENT(OUT)            :: s
IMPLICIT DOUBLE PRECISION (a-h,o-z)
eps=1.0D-15
pi=3.141592653589793D0
xa=DABS(x)
px=pi*xa
t=.5D0*px*xa
t2=t*t
IF (xa == 0.0) THEN
  c=0.0D0
  s=0.0D0
ELSE IF (xa < 2.5D0) THEN
  r=xa
  c=r
  DO  k=1,50
    r=-.5D0*r*(4.0D0*k-3.0D0)/k/(2.0D0*k-1.0D0) /(4.0D0*k+1.0D0)*t2
    c=c+r
    IF (DABS(r) < DABS(c)*eps) EXIT
  END DO
  15    s=xa*t/3.0D0
  r=s
  DO  k=1,50
    r=-.5D0*r*(4.0D0*k-1.0D0)/k/(2.0D0*k+1.0D0) /(4.0D0*k+3.0D0)*t2
    s=s+r
    IF (DABS(r) < DABS(s)*eps) EXIT
  END DO
ELSE IF (xa < 4.5D0) THEN
  m=INT(42.0+1.75*t)
  su=0.0D0
  c=0.0D0
  s=0.0D0
  f1=0.0D0
  f0=1.0D-100
  DO  k=m,0,-1
    f=(2.0D0*k+3.0D0)*f0/t-f1
    IF (k == INT(k/2)*2) THEN
      c=c+f
    ELSE
      s=s+f
    END IF
    su=su+(2.0D0*k+1.0D0)*f*f
    f1=f0
    f0=f
  END DO
  q=DSQRT(su)
  c=c*xa/q
  s=s*xa/q
ELSE
  r=1.0D0
  f=1.0D0
  DO  k=1,20
    r=-.25D0*r*(4.0D0*k-1.0D0)*(4.0D0*k-3.0D0)/t2
    f=f+r
  END DO
  r=1.0D0/(px*xa)
  g=r
  DO  k=1,12
    r=-.25D0*r*(4.0D0*k+1.0D0)*(4.0D0*k-1.0D0)/t2
    g=g+r
  END DO
  t0=t-INT(t/(2.0D0*pi))*2.0D0*pi
  c=.5D0+(f*DSIN(t0)-g*DCOS(t0))/px
  s=.5D0-(f*DCOS(t0)+g*DSIN(t0))/px
END IF
40   IF (x < 0.0D0) THEN
  c=-c
  s=-s
END IF
RETURN
END SUBROUTINE fcs


! -*- f90 -*-

!###############################################################
!!   SUBROUTINE TO COMPUTE THE KURTOSIS OF AN ARRAY
!###############################################################
subroutine kurtosis(a,nx,ny,nz,krt)
   integer, intent(in) :: nx, ny, nz
   double precision, intent(out):: krt
   double precision, dimension(nx,ny,nz), intent(in) :: a
!f2py intent (in) nx,ny,nz
!f2py intent (in) a
!f2py intent (out) krt
   double precision, dimension(nx,ny,nz) :: temp
   double precision :: tmp, NORM
   NORM=nx*ny*nz
   tmp=sum(a)/NORM; temp=a-tmp
   tmp=sum(temp**2)/NORM
   krt=sum(temp**4)/(NORM*tmp**2)
end subroutine kurtosis

!###############################################################
!!   SUBROUTINE TO COMPUTE SCALE DEPENDENT KURTOSIS OF AN ARRAY
!###############################################################
subroutine sdk(a,axis,nsd,nx,ny,nz,sdkrt)
   integer, intent(in) :: nx,ny,nz,axis,nsd
   double precision, dimension(nx,ny,nz), intent(in) :: a
   double precision, dimension(nsd), intent(out) ::sdkrt
!f2py intent (in) a
!f2py intent (in) nx, ny, nz, axis, nsd
!f2py intent (out) sdkrt
   double precision, dimension(nx,ny,nz) :: tmp
   integer :: ii
   double precision :: rmsval
!
   do ii=1,nsd
      call rollarr(a,axis,ii,tmp,nx,ny,nz)
      rmsval=dsqrt(sum(tmp**2)/(nx*ny*nz))
      if (rmsval .ne. 0) tmp=tmp/rmsval
      call kurtosis(tmp,nx,ny,nz,sdkrt(ii))
   enddo
end subroutine sdk

!###############################################################
!!   FORTRAN EQUIVALENT OF CSHIFT BUT FASTER AS IT DOES NOT
!!   CREATE EXTRA COPIES
!###############################################################
subroutine rollarr(a,axis,inc,ar,nx,ny,nz)
   double precision, dimension(nx,ny,nz), intent(in) :: a
   integer, intent(in) :: nx,ny,nz,axis,inc
   double precision, dimension(nx,ny,nz), intent(out):: ar
!f2py intent (in) a
!f2py intent (in) nx,ny,nz,axis,inc
!f2py intent (out) ar
   integer :: x,y,z,xx,yy,zz
!
   do z=1,nz; do y=1,ny; do x=1,nx
      SELECT CASE (axis+1)
         CASE (1)
            call roll_idx(x,nx,inc,xx); yy=y; zz=z
         CASE (2)
            xx=x; call roll_idx(y,ny,inc,yy); zz=z
         CASE(3)
            xx=x; yy=y; call roll_idx(z,nz,inc,zz)
      END SELECT
      ar(x,y,z) = a(xx,yy,zz)
   enddo; enddo; enddo
end subroutine rollarr

!###############################################################
!!   SUBROUTINE TO ROLL AN INDEX ON PERIODIC GRID
!###############################################################
subroutine roll_idx(x,nx,inc,xx)
   integer, intent(in) :: x,nx,inc
   integer, intent(out):: xx
!f2py intent (in) x,nx,inc
!f2py intent (out) xx
   xx = merge(x+inc, x-nx+inc+1, (x .lt. nx-inc))
!  if (x .lt. nx-inc) then
!     xx=x+inc
!  else
!     xx=x-nx+inc+1
!  endif
end subroutine roll_idx


PROGRAM me1xa

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:10

!       =========================================================
!       Purpose: This program computes the exponential integral
!                E1(x) using subroutine E1XA
!       Input :  x  --- Argument of E1(x)  ( x > 0 )
!       Output:  E1 --- E1(x)
!       Example:
!                  x        E1(x)
!                ----------------------
!                 0.0     .1000000+301
!                 1.0     .2193839E+00
!                 2.0     .4890051E-01
!                 3.0     .1304838E-01
!                 4.0     .3779352E-02
!                 5.0     .1148296E-02
!       =========================================================

DOUBLE PRECISION :: e1,x
WRITE(*,*)'Please enter x '
!        READ(*,*) X
x=5.0
WRITE(*,*)'   x        E1(x)'
WRITE(*,*)' ----------------------'
CALL e1xa(x,e1)
WRITE(*,10)x,e1
10      FORMAT(1X,f5.1,e17.7)
END PROGRAM me1xa

SUBROUTINE e1xa(x,e1)

!       ============================================
!       Purpose: Compute exponential integral E1(x)
!       Input :  x  --- Argument of E1(x)
!       Output:  E1 --- E1(x) ( x > 0 )
!       ============================================

DOUBLE PRECISION, INTENT(IN)             :: x
DOUBLE PRECISION, INTENT(OUT)            :: e1
IMPLICIT DOUBLE PRECISION (a-h,o-z)
IF (x == 0.0) THEN
  e1=1.0D+300
ELSE IF (x <= 1.0) THEN
  e1=-DLOG(x)+((((1.07857D-3*x-9.76004D-3)*x+5.519968D-2)*x  &
      -0.24991055D0)*x+0.99999193D0)*x-0.57721566D0
ELSE
  es1=(((x+8.5733287401D0)*x+18.059016973D0)*x  &
      +8.6347608925D0)*x+0.2677737343D0
  es2=(((x+9.5733223454D0)*x+25.6329561486D0)*x  &
      +21.0996530827D0)*x+3.9584969228D0
  e1=DEXP(-x)/x*es1/es2
END IF
RETURN
END SUBROUTINE e1xa


!----------------------------------------------------------------------*
! SUBROUTINE SVPS1 (Subroutine Vapour Pressure Saturated no. 1)        *
! Authors: Daniel van Kraalingen                                       *
! Date   : 3-Feb-1991, Version: 1.0                                    *
! Purpose: This subroutine calculates saturated vapour pressure and    *
!          slope of saturated vapour pressure. Parameters of the       *
!          formula were fitted on the Goff-Gratch formula used in the  *
!          Smithsonian Handbook of Meteorological Tables. The          *
!          saturated vapour following the Goff-Gratch formula is also  *
!          available as a subroutine. (Note that 1kPa = 10 mbar)       *
!                                                                      *
! FORMAL PARAMETERS:  (I=input,O=output,C=control,IN=init,T=time)      *
! name   type meaning                                     units  class *
! ----   ---- -------                                     -----  ----- *
! TMA     R4  Temperature at which to calculate pressure     C      I  *
! VPS     R4  Saturated vapour pressure                     kPa     O  *
! VPSL    R4  Slope of VPS at TMA                          kPa/C    O  *
!                                                                      *
! Fatal error checks: none                                             *
! Warnings          : TMA < -20, TMA > 50                              *
! Subprograms called: none                                             *
! File usage        : none                                             *
!----------------------------------------------------------------------*

      SUBROUTINE SVPS1 (TMA,VPS,VPSL)
      IMPLICIT NONE
      REAL TMA,VPS,VPSL
      SAVE

      IF (TMA.LT.-20..OR.TMA.GT.50.) WRITE (*,'(A,G12.5,A)') &
         ' WARNING from SVPS1: extreme temperature:',TMA,' d. Celsius'

      VPS  = 0.1*6.10588*EXP (17.32491*TMA/(TMA+238.102))
      VPSL = 238.102*17.32491*VPS/(TMA+238.102)**2

      RETURN
      END


module quadglobal
use qdmodule
implicit none
integer ndebug, ndigits, nerror, nquadl
end module

! program tquadgsq
subroutine f_main

!   David H. Bailey      2004-12-16
!   This is Quad-Double Fortran-90 version.

!   This work was supported by the Director, Office of Science, Division
!   of Mathematical, Information, and Computational Sciences of the
!   U.S. Department of Energy under contract number DE-AC03-76SF00098.

!   This program demonstrates the quadrature routine 'quadgsq', which employs
!   Gaussian quadrature.  The function quadgsq is suitable to integrate
!   a function that is continuous, infinitely differentiable and integrable on a
!   finite open interval.  It can also be used for certain integrals on infinite
!   intervals, by making a suitable change of variable -- see below.  While
!   this routine is usually more efficient than quaderf or quadts for functions
!   that are regular on a closed interval, it is not very effective for
!   functions with a singularity at one or both of the endpoints.

!   The function(s) to be integrated is(are) defined in external function
!   subprogram(s) -- see the sample function subprograms below.  The name(s) of
!   the function subprogram(s) must be included in appropriate type and external
!   statements in the main program.

!   Note that an integral of a function on an infinite interval can be
!   converted to an integral on a finite interval by means of a suitable
!   change of variable.  Example (here the notation "inf" means infinity):

!   Int_0^inf f(t) dt  =  Int_0^1 f(t) dt + Int_1^inf f(t) dt
!                      =  Int_0^1 f(t) dt + Int_0^1 f(1/t)/t^2 dt

!   See examples below.

!   Inputs set in parameter statement below:
!   kdebug Debug level setting.  Default = 2.
!   ndp    Digits of precision.  May not exceed mpipl in file mpmod90.f.
!            In some cases, ndp must be significantly greater than the desired
!            tolerance in the result-- see the examples below.
!   neps   Log10 of the desired tolerance in the result (negative integer).
!   nq1    Max number of phases in quadrature routine; adding 1 increases
!            (possibly doubles) the number of accurate digits in the result,
!            but also roughly doubles the run time and memory.  nq1 > 2.
!   nq2    Space parameter for wk and xk arrays in the calling program.  By
!            default it is set to 8 * 2^nq1.  Increase nq2 if directed by a
!            message produced in initqerf.  Note that the dimension of the
!            wk and xk arrays starts with -1, so the length of these arrays is
!            (nq2+2) * 4 eight-byte words.

use qdmodule
use quadglobal
implicit none
integer i, kdebug, ndp, neps, nq1, nq2, n1
parameter (kdebug = 2, ndp = 64, neps = -64, nq1 = 8, nq2 = 8 * 2 ** nq1 +100)
double precision dplog10q, d1, d2, second, tm0, tm1
type (qd_real) err, quadgsq, fun01, fun02, fun03, fun04, fun05, fun06, fun07, &
  fun08, fun09, fun10, fun11, fun12, fun13, fun14, fun15a, fun15b, &
  t1, t2, t3, t4, wk(-1:nq2), xk(-1:nq2), x1, x2
external quadgsq, fun01, fun02, fun03, fun04, fun05, fun06, fun07, fun08, &
  fun09, fun10, fun11, fun12, fun13, fun14, fun15a, fun15b, second
integer*4 old_cw

call f_fpu_fix_start (old_cw)

ndebug = kdebug
ndigits = ndp
nerror = 0
nquadl = nq1
write (6, 1) ndigits, neps, nquadl
1 format ('Quadgsq test'/'Digits =',i6,'  Epsilon =',i6,'   Quadlevel =',i6)

!   Initialize quadrature tables wk and xk (weights and abscissas).

tm0 = second ()
call initqgsq (nq1, nq2, wk, xk)
tm1 = second ()
if (nerror > 0) stop
write (6, 2) tm1 - tm0
2 format ('Quadrature initialization completed: cpu time =',f12.6)

!   Begin quadrature tests.

write (6, 11)
11 format (/'Continuous functions on finite itervals:'//&
  'Problem 1: Int_0^1 t*log(1+t) dt = 1/4')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgsq (fun01, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
3 format ('Quadrature completed: CPU time =',f12.6/'Result =')
call qdwrite (6, t1)
t2 = 0.25d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1
4 format ('Actual error =',f10.6,'x10^',i5)

write (6, 12)
12 format (/'Problem 2: Int_0^1 t^2*arctan(t) dt = (pi - 2 + 2*log(2))/12')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgsq (fun02, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = (qdpi() - 2.d0 + 2.d0 * log (qdreal (2.d0))) / 12.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 13)
13 format (/'Problem 3: Int_0^(pi/2) e^t*cos(t) dt = 1/2*(e^(pi/2) - 1)')
x1 = 0.d0
x2 = 0.5d0 * qdpi()
tm0 = second ()
t1 = quadgsq (fun03, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = 0.5d0 * (exp (0.5d0 * qdpi()) - 1.d0)
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 14)
14 format (/ &
  'Problem 4: Int_0^1 arctan(sqrt(2+t^2))/((1+t^2)sqrt(2+t^2)) dt = 5*Pi^2/96')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgsq (fun04, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = 5.d0 * qdpi()**2 / 96.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 15)
15 format (/&
  'Continuous functions on finite itervals, but non-diff at an endpoint'// &
  'Problem 5: Int_0^1 sqrt(t)*log(t) dt = -4/9')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgsq (fun05, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = qdreal (-4.d0) / 9.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 16)
16 format (/'Problem 6: Int_0^1 sqrt(1-t^2) dt = pi/4')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgsq (fun06, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = 0.25d0 * qdpi()
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 17)
17 format (/&
  'Functions on finite intervals with integrable singularity at an endpoint.'//&
  'Problem 7: Int_0^1 t/sqrt(1-t^2) dt = 1')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgsq (fun07, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = 1.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 18)
18 format (/'Problem 8: Int_0^1 log(t)^2 dt = 2')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgsq (fun08, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = 2.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 19)
19 format (/'Problem 9: Int_0^(pi/2) log(cos(t)) dt = -pi*log(2)/2')
x1 = 0.d0
x2 = 0.5d0 * qdpi()
tm0 = second ()
t1 = quadgsq (fun09, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = -0.5d0 * qdpi() * log (qdreal (2.d0))
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 20)
20 format (/'Problem 10: Int_0^(pi/2) sqrt(tan(t)) dt = pi*sqrt(2)/2')
x1 = 0.d0
x2 = 0.5d0 * qdpi()
tm0 = second ()
t1 = quadgsq (fun10, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = 0.5d0 * qdpi() * sqrt (qdreal (2.d0))
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 21)
21 format (/&
  'Functions on an infinite interval (requiring a two-step solution'//&
  'Problem 11: Int_0^inf 1/(1+t^2) dt = pi/2')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgsq (fun11, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = 0.5d0 * qdpi()
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 22)
22 format (/'Problem 12: Int_0^inf e^(-t)/sqrt(t) dt = sqrt(pi)')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgsq (fun12, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = sqrt (qdpi())
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 23)
23 format (/'Problem 13: Int_0^inf e^(-t^2/2) dt = sqrt(pi/2)')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgsq (fun13, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = sqrt (0.5d0 * qdpi())
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 24)
24 format (/&
  'Oscillatory functions on an infinite interval.'//&
  'Problem 14: Int_0^inf e^(-t)*cos(t) dt = 1/2')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgsq (fun14, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = 0.5d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 25)
25 format (/'Problem 15: Int_0^inf sin(t)/t = pi/2')
x1 = 0.d0
x2 = qdpi()
tm0 = second ()
t1 = quadgsq (fun15a, x1, x2, nq1, nq2, wk, xk)
x2 = 1.d0 / qdpi()
t2 = quadgsq (fun15b, x1, x2, nq1, nq2, wk, xk)
t3 = t1 + 40320.d0 * t2 - 1.d0 / qdpi() + 2.d0 / qdpi() ** 3 &
  - 24.d0 / qdpi() ** 5 + 720.d0 / qdpi() ** 7
tm1 = second ()
write (6, 3) tm1 - tm0
t4 = 0.5d0 * qdpi()
call decmdq (t4 - t3, d1, n1)
write (6, 4) d1, n1
write (6, 26)
26 format ('Prob 15 error may be 40,000 X higher than estimated error.')

call f_fpu_fix_end (old_cw)
stop
end

function fun01 (t)

!   fun01(t) = t * log(1+t)

use qdmodule
implicit none
type (qd_real) fun01, t

fun01 = t * log (1.d0 + t)
return
end

function fun02 (t)

!   fun02(t) = t^2 * arctan(t)

use qdmodule
implicit none
type (qd_real) fun02, t

fun02 = t ** 2 * atan (t)
return
end

function fun03 (t)

!   fun03(t) = e^t * cos(t)

use qdmodule
implicit none
type (qd_real) fun03, t

fun03 = exp(t) * cos(t)
return
end

function fun04 (t)

!   fun04(t) = arctan(sqrt(2+t^2))/((1+t^2)sqrt(2+t^2))

use qdmodule
implicit none
type (qd_real) fun04, t, t1

t1 = sqrt (2.d0 + t**2)
fun04 = atan(t1)/((1.d0 + t**2)*t1)
return
end

function fun05 (t)

!    fun05(t) = sqrt(t)*log(t)

use qdmodule
implicit none
type (qd_real) fun05, t

fun05 = sqrt (t) * log (t)
return
end

function fun06 (t)

!    fun06(t) = sqrt(1-t^2)

use qdmodule
implicit none
type (qd_real) fun06, t

fun06 = sqrt (1.d0 - t**2)
return
end

function fun07 (t)

!   fun07(t) = t / sqrt(1-t^2)

use qdmodule
implicit none
type (qd_real) fun07, t

fun07 = t / sqrt (1.d0 - t**2)
return
end

function fun08 (t)

!   fun08(t) = log(t)^2

use qdmodule
implicit none
type (qd_real) fun08, t

fun08 = log (t) ** 2
return
end

function fun09 (t)

!   fun09(t) = log (cos (t))

use qdmodule
implicit none
type (qd_real) fun09, t

fun09 = log (cos (t))
return
end

function fun10 (t)

!   fun10(t) = sqrt(tan(t))

use qdmodule
implicit none
type (qd_real) fun10, t

fun10 = sqrt (tan (t))
return
end

function fun11 (t)

!   fun11(t) = 1/(u^2(1+(1/u-1)^2)) = 1/(1 - 2*u + u^2)

use qdmodule
implicit none
type (qd_real) fun11, t

fun11 = 1.d0 / (1.d0 - 2.d0 * t + 2.d0 * t ** 2)
return
end

function fun12 (t)

!   fun12(t) = e^(-(1/t-1)) / sqrt(t^3 - t^4)

use qdmodule
implicit none
type (qd_real) fun12, t, t1

t1 = 1.d0 / t - 1.d0
fun12 = exp (-t1) / sqrt (t ** 3 - t ** 4)
return
end

function fun13 (t)

!   fun13(t) = e^(-(1/t-1)^2/2) / t^2

use qdmodule
implicit none
type (qd_real) fun13, t, t1

t1 = 1.d0 / t - 1.d0
fun13 = exp (-0.5d0 * t1 ** 2) / t ** 2
return
end

function fun14 (t)

!   fun14(t) = e^(-(1/t-1)) * cos (1/t-1) / t^2

use qdmodule
implicit none
type (qd_real) fun14, t, t1

t1 = 1.d0 / t - 1.d0
fun14 = exp (-t1) * cos (t1) / t ** 2
return
end

function fun15a (t)

!   fun15a(t) = sin(t)/t

use qdmodule
use quadglobal
implicit none
type (qd_real) fun15a, t

fun15a = sin (t) / t
return
end

function fun15b (t)

!   fun15b(t) = t^7 * sin(1/t)

use qdmodule
use quadglobal
implicit none
type (qd_real) fun15b, t

if (abs (t) > 1.d-10) then
  fun15b = t**7 * sin (1.d0 / t)
else
  fun15b = 0.d0
endif
return
end

subroutine initqgsq (nq1, nq2, wk, xk)

!   This subroutine initializes the quadrature arays xk and wk for Gaussian
!   quadrature.  It employs a Newton iteration scheme with a dynamic precision
!   level.  The argument nq2, which is the space allocated for wk and xk in
!   the calling program, should be at least 8 * 2^nq1 + 100, although a higher
!   value may be required, depending on precision level.  Monitor the space
!   figure given in the message below during initialization to be certain.
!   David H Bailey    2002-11-04

use qdmodule
use quadglobal
implicit none
integer i, ierror, ik0, is, j, j1, k, n, nq1, nq2, nwp, nws
double precision pi
parameter (pi = 3.141592653589793238d0)
type (qd_real) eps, r, t1, t2, t3, t4, t5, wk(-1:nq2), xk(-1:nq2)
parameter (ik0 = 100)

if (ndebug >= 1) then
  write (6, 1)
1 format ('initqgsq: Gaussian quadrature initialization')
endif

eps = 1.d-64
wk(-1) = dble (nq1)
wk(0) = 0.d0
xk(0) = 0.d0
wk(1) = dble (nq1)
xk(1) = dble (ik0)
i = ik0

do j = 2, ik0
  wk(j) = 0.d0
  xk(j) = 0.d0
enddo

do k = 1, nq1
  if (ndebug >= 2) write (6, *) k, i, nq2
  n = 3 * 2 ** (k + 1)

  do j = 1, n / 2

!   Compute a double precision estimate of the root.

    is = 0
    r = cos ((pi * (j - 0.25d0)) / (n + 0.5d0))

!   Compute the j-th root of the n-degree Legendre polynomial using Newton's
!   iteration.

100 continue

    t1 = 1.d0
    t2 = 0.d0

    do j1 = 1, n
      t3 = t2
      t2 = t1
      t1 = (dble (2 * j1 - 1) * r * t2 - dble (j1 - 1) * t3) / dble (j1)
    enddo

    t4 = dble (n) * (r * t1 - t2) / (r ** 2  - 1.d0)
    t5 = r
    r = r - t1 / t4

!   Once convergence is achieved at nwp = 3, then start doubling (almost) the
!   working precision level at each iteration until full precision is reached.

    if (abs (r - t5) > eps) goto 100

    i = i + 1
    if (i > nq2) goto 110
    xk(i) = r
    t4 = dble (n) * (r * t1 - t2) / (r ** 2  - 1.d0)
    wk(i) = 2.d0 / ((1.d0 - r ** 2) * t4 ** 2)
  enddo

  xk(k+1) = dble (i)
enddo

xk(-1) = dble (i)
if (ndebug >= 2) then
  write (6, 2) i
2 format ('initqerf: Table spaced used =',i8)
endif
goto 130

110 continue

write (6, 3) nq2
3 format ('initqgsq: Table space parameter is too small; value =',i8)
nerror = 92
goto 130

120 continue

nerror = ierror + 100
write (6, 4) nerror
4 format ('initqgsq: Error in quadrature initialization; code =',i5)

130 continue

return
end

function quadgsq (fun, x1, x2, nq1, nq2, wk, xk)

!   This routine computes the integral of the function fun on the interval
!   [0, 1], with up to nq1 iterations, with a target tolerance of eps.
!   wk and xk are precomputed tables of weights and abscissas, each of size
!   nq2 and of type qd_real.  The function fun is not evaluated at x1 or x2.
!   David H. Bailey    2002-11-04

use qdmodule
use quadglobal
implicit none
integer i, ierror, ik0, k, j, n, nds, nq1, nq2
double precision d1, d2, d3, d4, dplog10q
type (qd_real) a, b, c10, quadgsq, eps, eps1, eps2, err, fmx, fun, h, sum, &
  s1, s2, s3, t1, t2, t3, wk(-1:nq2), xk(-1:nq2), x1, x2, xx1, xx2
external fun, dplog10q
parameter (ik0 = 100)

a = 0.5d0 * (x2 - x1)
b = 0.5d0 * (x2 + x1)
s1 = 0.d0
s2 = 0.d0
c10 = 10.d0
eps = 1.d-64
eps1 = 1.d-61
  if (wk(-1) < dble (nq1)) then
  write (6, 1) nq1
1 format ('quadgsq: quadrature arrays have not been initialized; nq1 =',i6)
  nerror = 70
  goto 130
endif

do k = 1, nq1
  n = 3 * 2 ** (k + 1)
  s3 = s2
  s2 = s1
  fmx = 0.d0
  sum = 0.d0
  i = dble (xk(k))

  do j = 1, n / 2
    i = i + 1
    xx1 = - a * xk(i) + b
    xx2 = a * xk(i) + b
    if (xx1 > x1) then
      t1 = fun (xx1)
    else
      t1 = 0.d0
    endif
    if (xx2 < x2 .and. j + k > 2) then
      t2 = fun (xx2)
    else
      t2 = 0.d0
    endif
    sum = sum + wk(i) * (t1 + t2)
    fmx = max (fmx, abs (t1), abs (t2))
  enddo

  s1 =  a * sum
  eps2 = fmx * eps
  d1 = dplog10q (abs (s1 - s2))
  d2 = dplog10q (abs (s1 - s3))
  d3 = dplog10q (eps2) - 1.d0

  if (k <= 2) then
    err = 1.d0
  elseif (d1 .eq. -9999.d0) then
    err = 0.d0
  else
    d4 = min (0.d0, max (d1 ** 2 / d2, 2.d0 * d1, d3))
    err = c10 ** nint (d4)
  endif

!   Output current integral approximation and error estimate, to 56 dp.

  if (ndebug >= 2) then
    write (6, 2) k, nq1, nint (dplog10q (abs (err)))
2   format ('quadgsq: Iteration',i3,' of',i3,'; est error = 10^',i5, &
      '; approx value =')
    call qdwrite (6, s1)
  endif
  if (k >= 3 .and. err < eps1) goto 130
  if (k >= 3 .and. err < eps2) goto 110
enddo

write (6, 3) nint (dplog10q (abs (err))), nquadl
3 format ('quadgsq: Estimated error = 10^',i5/&
  'Increase Quadlevel for greater accuracy. Current Quadlevel =',i4)
if (err > 1.d-20) then
  write (6, 4)
4 format ('quadgsq: Poor results may be due to singularities at endpoints.'/&
  'If so, try the erf or tanh-sinh quadrature routines (Quadtype = 2 or 3).')
endif
goto 130

110 continue

write (6, 5) nint (dplog10q (abs (err))), ndigits
5 format ('quadgsq: Estimated error = 10^',i5/&
  'Increase working prec (Digits) for greater accuracy. Current Digits =',i4)
goto 130

120 continue

nerror = ierror + 100
write (6, 6) nerror
6 format ('quadgsq: Error in quadrature calculation; code =',i5)
s1 = 0.d0

130 continue

quadgsq = s1
return
end

function dplog10q (a)

!   For input MP value a, this routine returns a DP approximation to log10 (a).

use qdmodule
implicit none
integer ia
double precision da, dplog10q, t1
type (qd_real) a

da = a
if (da .eq. 0.d0) then
  dplog10q = -9999.d0
else
  dplog10q = log10 (abs (da))
endif

100 continue
return
end

subroutine decmdq (a, b, ib)

!   For input MP value a, this routine returns DP b and integer ib such that
!   a = b * 10^ib, with 1 <= abs (b) < 10 for nonzero a.

use qdmodule
implicit none
integer ia, ib
double precision da, b, t1, xlt
parameter (xlt = 0.3010299956639812d0)
type (qd_real) a

da = a
if (da .ne. 0.d0) then
  t1 = log10 (abs (da))
  ib = t1
  if (t1 .lt. 0.d0) ib = ib - 1
  b = sign (10.d0 ** (t1 - ib), da)
else
  b = 0.d0
  ib = 0
endif

return
end


        subroutine GETPHIPOINT(
     &           phi
     &           ,freq
     &           ,x
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 phi
      REAL*8 freq(0:1)
      REAL*8 x(0:1)
        phi = sin(freq(0)*x(0))
     &                * sin(freq(1)*x(1))
        return
        end
        subroutine GETLOFPHI(
     &           lofphi
     &           ,ilofphilo0,ilofphilo1
     &           ,ilofphihi0,ilofphihi1
     &           ,freq
     &           ,dx
     &           ,problo
     &           ,probhi
     &           ,aCoef
     &           ,bCoef
     &           ,iboxlo0,iboxlo1
     &           ,iboxhi0,iboxhi1
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer ilofphilo0,ilofphilo1
      integer ilofphihi0,ilofphihi1
      REAL*8 lofphi(
     &           ilofphilo0:ilofphihi0,
     &           ilofphilo1:ilofphihi1)
      REAL*8 freq(0:1)
      REAL*8 dx(0:1)
      REAL*8 problo(0:1)
      REAL*8 probhi(0:1)
      REAL*8 aCoef
      REAL*8 bCoef
      integer iboxlo0,iboxlo1
      integer iboxhi0,iboxhi1
        integer i,j
        REAL*8 x(0:2 -1)
      do j = iboxlo1,iboxhi1
      do i = iboxlo0,iboxhi0
          x(0) = (i+(0.500d0))*dx(0) + problo(0)
          x(1) = (j+(0.500d0))*dx(1) + problo(1)
          call getlofphipoint(lofphi(i,j),freq,x,aCoef,bCoef)
      enddo
      enddo
        return
        end
        subroutine GETLOFPHIPOINT(
     &           lofphi
     &           ,freq
     &           ,x
     &           ,aCoefmult
     &           ,bCoefmult
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 lofphi
      REAL*8 freq(0:1)
      REAL*8 x(0:1)
      REAL*8 aCoefmult
      REAL*8 bCoefmult
        integer dir
        REAL*8 fac,phi, temp
        fac = -(freq(0)**2
     &                  + freq(1)**2)
        fac = fac *(x(0) +x(1))
        phi = (sin(freq(0)*x(0))
     &                 * sin(freq(1)*x(1)))
        lofphi = fac*phi
        temp = 0.0
        do dir=0, 2 -1
           if (dir.eq.0) then
              temp = freq(0)*cos(freq(0)*x(0))
     &                                *sin(freq(1)*x(1))
           else if (dir.eq.1) then
              temp = freq(1)*sin(freq(0)*x(0))
     &                                *cos(freq(1)*x(1))
           endif
           lofphi = lofphi + temp
        enddo
        lofphi = aCoefmult*x(0)*phi + bCoefmult*lofphi
        return
        end
        subroutine GETGRADPHIPOINT(
     &           gradphi
     &           ,freq
     &           ,x
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 gradphi(0:1)
      REAL*8 freq(0:1)
      REAL*8 x(0:1)
        gradphi(0) = freq(0) * cos(freq(0)*x(0)) * sin(freq(1)*x(1))
        gradphi(1) = freq(1) * sin(freq(0)*x(0)) * cos(freq(1)*x(1))
        return
        end


 	Program P3
 	Implicit none
	Real*8 dt, min, max, t, y(5)
c n: number of equations (the 'dimension' of the standard form)
C starting and end points
        min=0.0D0
        max=10.0D0
C time step
        dt=0.1D0
C initial position
        y(1)=1.0D0
C initial velocity
        y(2)=0.0D0
c open file to output
        Open(6, File='p3.dat')
c do n steps of Runga-Kutta algorithm
	Do t=min, max, dt
	  Call rk4(t, dt, y, 2)
          Write (6,*) t, y(1)
	enddo
c
	Close(6)
	Stop
        End
c------------------------end of main program------------------------
c
	Subroutine rk4(t, dt, y, n)
	Implicit none
	Real*8 df, dg, h, t, dt, y(5)
        Real*8 k0, k1, k2, k3
        Real*8 l0, l1, l2, l3
        integer n
        h=dt/2.0D0
        k0 = dt * df(y(1),y(n))
        l0 = dt * dg(y(1),y(n))
        k1 = dt * df(y(1)+h, y(n)+0.5d0*l0)
        l1 = dt * dg(y(1)+0.5d0*k0,y(n)+0.5d0*l0)
        k2 = dt * df(y(1)+0.5d0*k1,y(n)+0.5d0*l1)
        l2 = dt * dg(y(1)+0.5d0*k1,y(n)+0.5d0*l1)
        k3 = dt * df(y(1)+k2,y(n)+l2)
        l3 = dt * dg(y(1)+k2,y(n)+l2)
        y(1) = y(1) + (k0+2*k1+2*k2+k3)/6.0d0
        y(n) = y(n) + (l0+2*l1+2*l2+l3)/6.0d0
	Return
	End

c function which returns the derivatives (RHS)
	Function df(y,z)
C 2 function components: dx/dt = v(t),   dv/dt = -w**2*x(t) -a*v
C the second term is damping term
	Implicit none
c declarations
	Real*8 df, y, z
	df=z
	Return
	End

	Function dg(y,z)
C 2 function components: dx/dt = v(t),   dv/dt = -w**2*x(t) -a*v
C the second term is damping term
	implicit none
c declarations
	Real*8 dg, y, z, omega, alpha
	data omega /3.0d0/
	data alpha /0.5d0/
c
	dg= - omega**2.0d0 * y - alpha * z
	Return
	End


C$Procedure      VNORMG ( Vector norm, general dimension )

      DOUBLE PRECISION FUNCTION VNORMG ( V1, NDIM )

C$ Abstract
C
C      Compute the magnitude of a double precision vector of arbitrary
C      dimension.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C      VECTOR
C
C$ Declarations

      INTEGER            NDIM
      DOUBLE PRECISION   V1 ( NDIM )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C       V1        I     Vector whose magnitude is to be found.
C       NDIM      I     Dimension of V1.
C
C$ Detailed_Input
C
C      V1      This may be any double precision vector or arbitrary
C              size.
C
C$ Detailed_Output
C
C      VNORMG is the magnitude of V1 calculated in a numerically stable
C      way.
C
C$ Parameters
C
C     None.
C
C$ Particulars
C
C      VNORMG finds the component of V1 whose magnitude is the largest.
C      If the absolute magnitude of that component indicates that a
C      numeric overflow would occur when it is squared, or if it
C      indicates that an underflow would occur when squared (falsely
C      giving a magnitude of zero) then the following expression is
C      used:
C
C      VNORMG = V1MAX * MAGNITUDE OF [ (1/V1MAX)*V1 ]
C
C      Otherwise a simpler expression is used:
C
C      VNORMG = MAGNITUDE OF [ V1 ]
C
C      Beyond the logic described above, no further checking of the
C      validity of the input is performed.
C
C$ Examples
C
C      The following table show the correlation between various input
C      vectors V1 and VNORMG:
C
C      NDIM   V1(NDIM)                               VNORMG
C      -----------------------------------------------------------------
C      1      (-7.0D20)                              7.D20
C      3      (1.D0, 2.D0, 2.D0)                     3.D0
C      4      (3.D0, 3.D0, 3.D0, 3.D0)               6.D0
C      5      (5.D0, 12.D0, 0.D0, 0.D0, 0.D0)       13.D0
C      3      (-5.D-17, 0.0D0, 12.D-17)             13.D-17
C
C$ Restrictions
C
C      None.
C
C$ Exceptions
C
C      Error free.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      W.M. Owen       (JPL)
C
C$ Literature_References
C
C      None.
C
C$ Version
C
C-     SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C         Comment section for permuted index source lines was added
C         following the header.
C
C-     SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     norm of n-dimensional vector
C
C-&

      INTEGER               I
      DOUBLE PRECISION      V1MAX
      DOUBLE PRECISION      A

C
C  Determine the maximum component of the vector.
C
      V1MAX = 0.D0

      DO I=1,NDIM

         IF ( DABS(V1(I)) .GT. V1MAX )
     .      V1MAX = DABS(V1(I))

      END DO
C
C  If the vector is zero, return zero; otherwise normalize first.
C  Normalizing helps in the cases where squaring would cause overflow
C  or underflow.  In the cases where such is not a problem it not worth
C  it to optimize further.
C
      IF ( V1MAX .EQ. 0.D0 ) THEN

         VNORMG = 0.D0

      ELSE

         VNORMG = 0.D0

         DO I = 1, NDIM
            A      = V1(I)  / V1MAX
            VNORMG = VNORMG + A*A
         END DO

         VNORMG = V1MAX * DSQRT (VNORMG)

      END IF
C
      RETURN
      END


      PROGRAM TEST

!   This is a sample program using 14th order Runge Kutta to solve ordinary differential
!   equations (initial value problems) to high precision.

!   Subroutine FM_RK14 uses a starting point A, stopping point B, and tolerance TOL.
!   FM_RK14 calls FM_RK14_STEP for the individual steps, adjusting the step size along the
!   way to try to keep the distance between the approximate solution vector S1 and the true
!   solution less than TOL.  TOL should be no smaller than 1.0e-75.

!   Subroutine FM_RK14_COEFFS is called by FM_RK14_STEP to initialize the many coefficients
!   used to define the 14th order Runge Kutta formula.  They are defined with 85-digit
!   accuracy, so accuracy up to about 75 digits can be achieved by these routines.

!   The speed of FM_RK14 drops quickly as the requested precision increases, since more
!   steps (with smaller stepsize) are needed to get from A to B, and also because higher
!   FM precision must be used.

!   For a typical 2014 computer, here are the times for the third-order equation in case 3:

!   TOL     FM precision     time (seconds)
!   1e-20   30                0.18
!   1e-30   40                1.13
!   1e-40   50                7.06
!   1e-50   60               43.91

!   Since RK14 has error O(h^14), the stepsize h needed for a given tol is of order tol^(1/14).
!   That gives a total number of steps proportional to tol^(-1/14) and means that decreasing
!   tol by a factor of 1e+10 will multiply the total number of steps required by about
!   1e-10^(-1/14) = 5.2.

!   The actual time ratios in the table above are 6.3, 6.2, 6.2, slightly more than 5.2,
!   because the time for each step increases as FM precision goes up.

      USE FMZM
      IMPLICIT NONE

!             Set MAXIMUM_ORDER here and in the subroutines to the highest order
!             differential equation to be solved.

      INTEGER, PARAMETER :: MAXIMUM_ORDER = 3
      INTEGER :: N_FUNCTION, N_ORDER
      TYPE (FM) :: A, B, ERR, S(MAXIMUM_ORDER), S1(MAXIMUM_ORDER), TOL
      EXTERNAL :: FM_RK14_F
      REAL :: T1, T2

!             Set the FM precision level to 40 significant digits for cases 1 through 3.

      CALL FM_SET(40)

!             We will use differential equations with known analytic solutions so we can check
!             the accuracy of the result.

!             1.  First-order equation.

!                 y' = -y + 2*sin(x),   y(0) = 0

!                 The right-hand-side function is defined as function number 1
!                 in subroutine FM_RK14_F (at the end of this file).

!                 Since this is a first-order equation, the "state" vector S is just y.

!                 Set tol = 1e-30 and find y(5).

      CALL CPU_TIME(T1)

      N_ORDER = 1
      N_FUNCTION = 1
      A = 0
      B = 5
      S(1) = 0
      TOL = TO_FM(' 1.0e-30 ')

      CALL FM_RK14( A, B, N_ORDER, FM_RK14_F, N_FUNCTION, S, TOL, S1 )

      WRITE (*,*) ' '
      WRITE (*,*) ' Case 1.  y(5) ='
      CALL FM_PRINT(S1(1))
      WRITE (*,*) ' '
      ERR = ABS( (SIN(B) - COS(B) + EXP(-B))  - S1(1) )
      WRITE (*,"(A,ES16.7)") '     Error in the computed solution = ',TO_DP(ERR)

      CALL CPU_TIME(T2)
      WRITE (*,*) ' '
      WRITE (*,"(5X,A,ES12.4,A,F8.2,A)") ' For tolerance = ',TO_DP(TOL),'   time = ',T2-T1,' sec.'
      WRITE (*,*) ' '
      WRITE (*,*) ' '

!             2.  Second-order equation.

!                 y'' = -y' - exp(x)*y + sin(x) - exp(-x)*(sin(x) + cos(x)),
!                 y(0) = 0,  y'(0) = 1.

!                 The right-hand-side function is defined as function number 2
!                 in subroutine FM_RK14_F (at the end of this file).

!                 First reduce this equation to a system of first-order equations.

!                 Let u = y'.  Then u' = y''.  Now for s = ( y, u ) the vector
!                 differential equation is

!                 s' = ( y', u' ) = ( u, -u + exp(x)*y + sin(x) - exp(-x)*(sin(x) + cos(x)) )
!                 s(0) = ( y(0), u(0) ) = ( 0, 1 ).

!                 Find y(2).

      CALL CPU_TIME(T1)

      N_ORDER = 2
      N_FUNCTION = 2
      A = 0
      B = 2
      S(1:2) = (/ 0, 1 /)
      TOL = TO_FM(' 1.0e-30 ')

      CALL FM_RK14( A, B, N_ORDER, FM_RK14_F, N_FUNCTION, S, TOL, S1 )

      WRITE (*,*) ' '
      WRITE (*,*) ' Case 2.  y(2) ='
      CALL FM_PRINT(S1(1))
      WRITE (*,*) "          y'(2) ="
      CALL FM_PRINT(S1(2))
      WRITE (*,*) ' '
      ERR = ABS( (SIN(B)*EXP(-B)) - S1(1) )
      WRITE (*,"(A,ES16.7)") '     Error in the computed y(2) solution = ',TO_DP(ERR)

      CALL CPU_TIME(T2)
      WRITE (*,*) ' '
      WRITE (*,"(5X,A,ES12.4,A,F8.2,A)") ' For tolerance = ',TO_DP(TOL),'   time = ',T2-T1,' sec.'
      WRITE (*,*) ' '
      WRITE (*,*) ' '

!             3.  Third-order equation.

!                 y''' = -y'' -y' - y + ( ( -35x**3 + 2x**2 + 111x + 68 )*cos(6x) +
!                                         ( 210x**3 + 642x**2 + 618x + 186 )*sin(6x) ) / (1+x)**4
!                 y(0) = 1,  y'(0) = -1,  y''(0) = -34.

!                 The right-hand-side function is defined as function number 3
!                 in subroutine FM_RK14_F (at the end of this file).

!                 First reduce this equation to a system of first-order equations.

!                 let u = y' and v = y''.  Then v' = y'''.  Now for s = ( y, u, v ) the vector
!                 differential equation is

!                 s' = ( y', u', v' ) =
!                      ( u , v , -v - u - y +
!                                ( ( -35x**3 + 2x**2 + 111x + 68 )*cos(6x) +
!                                  ( 210x**3 + 642x**2 + 618x + 186 )*sin(6x) ) / (1+x)**4 )
!                 s(0) = ( y(0), u(0), v(0) ) = ( 1, -1, -34 ).

!                 Find y(2).

      CALL CPU_TIME(T1)

      N_ORDER = 3
      N_FUNCTION = 3
      A = 0
      B = 2
      S(1:3) = (/ 1, -1, -34 /)
      TOL = TO_FM(' 1.0e-30 ')

      CALL FM_RK14( A, B, N_ORDER, FM_RK14_F, N_FUNCTION, S, TOL, S1 )

      WRITE (*,*) ' '
      WRITE (*,*) ' Case 3.  y(2) ='
      CALL FM_PRINT(S1(1))
      WRITE (*,*) "          y'(2) ="
      CALL FM_PRINT(S1(2))
      WRITE (*,*) "          y''(2) ="
      CALL FM_PRINT(S1(3))
      WRITE (*,*) ' '
      ERR = ABS( (COS(6*B)/(B+1)) - S1(1) )
      WRITE (*,"(A,ES16.7)") '     Error in the computed y(2) solution = ',TO_DP(ERR)

      CALL CPU_TIME(T2)
      WRITE (*,*) ' '
      WRITE (*,"(5X,A,ES12.4,A,F8.2,A)") ' For tolerance = ',TO_DP(TOL),'   time = ',T2-T1,' sec.'
      WRITE (*,*) ' '
      WRITE (*,*) ' '

!             4.  Solve case 3 again, this time asking for 20 digit accuracy.
!                 For this case we can lower the FM precision level to 30 digits.

      CALL FM_SET(30)

      CALL CPU_TIME(T1)

      N_ORDER = 3
      N_FUNCTION = 3
      A = 0
      B = 2
      S(1:3) = (/ 1, -1, -34 /)
      TOL = TO_FM(' 1.0e-20 ')

      CALL FM_RK14( A, B, N_ORDER, FM_RK14_F, N_FUNCTION, S, TOL, S1 )

      WRITE (*,*) ' '
      WRITE (*,*) ' Case 4.  y(2) ='
      CALL FM_PRINT(S1(1))
      WRITE (*,*) "          y'(2) ="
      CALL FM_PRINT(S1(2))
      WRITE (*,*) "          y''(2) ="
      CALL FM_PRINT(S1(3))
      WRITE (*,*) ' '
      ERR = ABS( (COS(6*B)/(B+1)) - S1(1) )
      WRITE (*,"(A,ES16.7)") '     Error in the computed y(2) solution = ',TO_DP(ERR)

      CALL CPU_TIME(T2)
      WRITE (*,*) ' '
      WRITE (*,"(5X,A,ES12.4,A,F8.2,A)") ' For tolerance = ',TO_DP(TOL),'   time = ',T2-T1,' sec.'
      WRITE (*,*) ' '
      WRITE (*,*) ' '

!             5.  Same as case 4, but use TOL = 1.0e-40.
!                 The FM precision level should be set to at least 10 digits more than TOL.

      CALL FM_SET(50)

      CALL CPU_TIME(T1)

      N_ORDER = 3
      N_FUNCTION = 3
      A = 0
      B = 2
      S(1:3) = (/ 1, -1, -34 /)
      TOL = TO_FM(' 1.0e-40 ')

      CALL FM_RK14( A, B, N_ORDER, FM_RK14_F, N_FUNCTION, S, TOL, S1 )

      WRITE (*,*) ' '
      WRITE (*,*) ' Case 5.  y(2) ='
      CALL FM_PRINT(S1(1))
      WRITE (*,*) "          y'(2) ="
      CALL FM_PRINT(S1(2))
      WRITE (*,*) "          y''(2) ="
      CALL FM_PRINT(S1(3))
      WRITE (*,*) ' '
      ERR = ABS( (COS(6*B)/(B+1)) - S1(1) )
      WRITE (*,"(A,ES16.7)") '     Error in the computed y(2) solution = ',TO_DP(ERR)

      CALL CPU_TIME(T2)
      WRITE (*,*) ' '
      WRITE (*,"(5X,A,ES12.4,A,F8.2,A)") ' For tolerance = ',TO_DP(TOL),'   time = ',T2-T1,' sec.'
      WRITE (*,*) ' '
      WRITE (*,*) ' '

!             6.  Same as case 4, but use TOL = 1.0e-50.

!                 The FM precision level should be set to at least 10 digits more than TOL.

      CALL FM_SET(60)

      CALL CPU_TIME(T1)

      N_ORDER = 3
      N_FUNCTION = 3
      A = 0
      B = 2
      S(1:3) = (/ 1, -1, -34 /)
      TOL = TO_FM(' 1.0e-50 ')

      CALL FM_RK14( A, B, N_ORDER, FM_RK14_F, N_FUNCTION, S, TOL, S1 )

      WRITE (*,*) ' '
      WRITE (*,*) ' Case 6.  y(2) ='
      CALL FM_PRINT(S1(1))
      WRITE (*,*) "          y'(2) ="
      CALL FM_PRINT(S1(2))
      WRITE (*,*) "          y''(2) ="
      CALL FM_PRINT(S1(3))
      WRITE (*,*) ' '
      ERR = ABS( (COS(6*B)/(B+1)) - S1(1) )
      WRITE (*,"(A,ES16.7)") '     Error in the computed y(2) solution = ',TO_DP(ERR)

      CALL CPU_TIME(T2)
      WRITE (*,*) ' '
      WRITE (*,"(5X,A,ES12.4,A,F8.2,A)") ' For tolerance = ',TO_DP(TOL),'   time = ',T2-T1,' sec.'
      WRITE (*,*) ' '
      WRITE (*,*) ' '

      STOP
      END PROGRAM TEST

      SUBROUTINE FM_RK14_F(N_ORDER, N_FUNCTION, X, S, RHS)

!  Compute the right-hand-side function for the vector first-order differential equation
!  s' = f(x,s).

!  N_ORDER is the order of the differential equation.  After reducing the equation to
!          a first-order vector D.E., N_ORDER is the length of vectors S and RHS.
!          (N_ORDER is unused in this sample version)

!  RHS is returned as the right-hand-side vector function of the differential equation,
!  with S as the input vector:  RHS = F(X,S).

!  N_FUNCTION is the function to be evaluated, for cases where a program may solve
!             several different differential equations.

      USE FMZM
      IMPLICIT NONE

      INTEGER, PARAMETER :: MAXIMUM_ORDER = 3
      INTEGER :: N_ORDER, N_FUNCTION
      TYPE (FM) :: X, S(MAXIMUM_ORDER), RHS(MAXIMUM_ORDER)
      TYPE (FM), SAVE :: T1, T2, T3

      IF (N_FUNCTION == 1) THEN

!             y' = -y + 2*sin(x)

          RHS(1) = -S(1) + 2*SIN(X)
      ELSE IF (N_FUNCTION == 2) THEN

!             y'' = -y' - exp(x)*y + sin(x) - exp(-x)*(sin(x) + cos(x))

          RHS(1) = S(2)

!             Note about code-tuning.
!             This is the straight-forward way of coding RHS(2) from the differential equation:

!         RHS(2) = -S(2) - EXP(X)*S(1) + SIN(X) - EXP(-X)*(SIN(X) + COS(X))

!             Using the code above, case 2 in the main program ran in 1.22 seconds.

!             We can speed this up by computing sin(x) once instead of twice for each function
!             evaluation.  Also, doing exp(-x) as 1/exp(x) can save an exponential.
!             More time can be saved by using subroutine FM_COS_SIN, which returns both
!             cos(x) and sin(x) in one call.  FM_COS_SIN computes one of the trig functions,
!             and then gets the other quickly using an identity.

!             Three local variables, T1, T2, T3, are used to save exp(x), cos(x), sin(x).
!             The code below then ran case 2 in 0.75 seconds.

          T1 = EXP(X)
          CALL FM_COS_SIN(X,T2,T3)
          RHS(2) = -S(2) - T1*S(1) + T3 - (T3 + T2) / T1
      ELSE IF (N_FUNCTION == 3) THEN

!             y''' = -y'' -y' - y + ( ( -35x**3 + 2x**2 + 111x + 68 )*cos(6x) +
!                                     ( 210x**3 + 642x**2 + 618x + 186 )*sin(6x) ) / (1+x)**4

          RHS(1) = S(2)
          RHS(2) = S(3)

!             More code-tuning.
!             Original code in case 3:  1.65 seconds.

!         RHS(3) = -S(3) - S(2) - S(1)  +                                           &
!                  ( ( -35*X**3 + 2*X**2 + 111*X + 68 )*COS(6*X) +                  &
!                    ( 210*X**3 + 642*X**2 + 618*X + 186 )*SIN(6*X) )  / (1+X)**4

!             Use FM_COS_SIN as in function 2 above for the trig functions:  1.38 seconds.

!         CALL FM_COS_SIN(6*X,T2,T3)
!         RHS(3) = -S(3) - S(2) - S(1)  +                                     &
!                  ( ( -35*X**3 + 2*X**2 + 111*X + 68 )*T2 +                  &
!                    ( 210*X**3 + 642*X**2 + 618*X + 186 )*T3 )  / (1+X)**4

!             Use Horner's rule for the polynomials:  1.30 seconds.

          CALL FM_COS_SIN(6*X,T2,T3)
          RHS(3) = -S(3) - S(2) - S(1)  +                                     &
                   ( ((( -35*X +   2)*X + 111)*X +  68 )*T2 +                 &
                     ((( 210*X + 642)*X + 618)*X + 186 )*T3 )  / (1+X)**4

      ELSE
          RHS = S(1)
      ENDIF

      END SUBROUTINE FM_RK14_F


! Name: Anantha Rao
! Reg no: 20181044
! This program provides the Runge-Kutta4 Method to solve the differential equation y' = f(x,y)

program rungekutta
    implicit none
    real:: x,y,xwant,h,m1,m2,m3,m4,f
    integer:: niter,i

    x=0.0; y=0.0; xwant=1.57; h=0.01;
    niter=int((xwant-x)/h)
    open(unit=21, file="q1_rk4.dat")

    do i=1,niter
        m1=h*f(x,y)
        m2=h*f(x+0.5*h,y+0.5*m1)
        m3=h*f(x+0.5*h,y+0.5*m2)
        m4=h*f(x+h,y+m3)
        x=x+h
        y=y+(m1+2.0*m2+2.0*m3+m4)*(1/6.0)
        write(21,*) dfloat(i)*h,y
    end do
end program

!define your function here
real function f(x,y)
real:: x,y
f=1+y**2

end function


module maptran

use, intrinsic:: ieee_arithmetic, only: ieee_quiet_nan, ieee_value

implicit none (type, external)
private
public :: pi, ecef2geodetic, geodetic2ecef, aer2enu, enu2aer, aer2ecef, ecef2aer, &
          enu2ecef, ecef2enu, ecef2enuv, aer2geodetic, geodetic2enu, enu2uvw,&
          geodetic2aer,enu2geodetic,degrees,radians, anglesep, &
          lookAtSpheroid, Ellipsoid, &
          haversine

type :: Ellipsoid
  real :: SemimajorAxis, Flattening, SemiminorAxis
end type

real, parameter :: pi = 4 * atan(1.)

type(Ellipsoid), parameter, public :: wgs84Ellipsoid = &
  Ellipsoid(SemimajorAxis=6378137., &
            SemiminorAxis=6378137. * (1 - 1. / 298.2572235630), &
            Flattening = 1. / 298.2572235630)

interface ! aer
module elemental subroutine ecef2aer(x, y, z, lat0, lon0, alt0, az, el, slantRange, spheroid, deg)
real, intent(in) :: x,y,z, lat0, lon0, alt0
type(Ellipsoid), intent(in), optional :: spheroid
logical, intent(in), optional :: deg
real, intent(out) :: az,el, slantRange
end subroutine ecef2aer

module elemental subroutine aer2ecef(az, el, slantRange, lat0, lon0, alt0, x,y,z, spheroid, deg)
real, intent(in) :: az,el, slantRange, lat0, lon0, alt0
type(Ellipsoid), intent(in), optional :: spheroid
logical, intent(in), optional :: deg
real, intent(out) :: x,y,z
end subroutine aer2ecef

module elemental subroutine geodetic2aer(lat, lon, alt, lat0, lon0, alt0, az, el, slantRange, spheroid, deg)
real, intent(in) :: lat,lon,alt, lat0, lon0, alt0
type(Ellipsoid), intent(in), optional :: spheroid
logical, intent(in), optional :: deg
real, intent(out) :: az, el, slantRange
end subroutine geodetic2aer

module elemental subroutine aer2geodetic(az, el, slantRange, lat0, lon0, alt0, lat1, lon1, alt1, spheroid, deg)
real, intent(in) :: az, el, slantRange, lat0, lon0, alt0
type(Ellipsoid), intent(in), optional :: spheroid
logical, intent(in), optional :: deg
real, intent(out) :: lat1,lon1,alt1
end subroutine aer2geodetic

end interface

interface ! ecef

module elemental subroutine ecef2geodetic(x, y, z, lat, lon, alt, spheroid, deg)
real, intent(in) :: x,y,z
type(Ellipsoid), intent(in), optional :: spheroid
logical, intent(in), optional :: deg
real, intent(out) :: lat, lon
real, intent(out), optional :: alt
end subroutine ecef2geodetic

module elemental subroutine geodetic2ecef(llat,llon,alt, x,y,z, spheroid, deg)
real, intent(in) :: llat,llon, alt
real, intent(out) :: x,y,z
type(Ellipsoid), intent(in), optional :: spheroid
logical, intent(in), optional :: deg
end subroutine geodetic2ecef

module elemental subroutine enu2ecef(e, n, u, lat0, lon0, alt0, x, y, z, spheroid, deg)
real, intent(in) :: e,n,u,lat0,lon0,alt0
type(Ellipsoid), intent(in), optional :: spheroid
logical, intent(in), optional :: deg
real, intent(out) :: x,y,z
end subroutine enu2ecef

module elemental subroutine ecef2enu(x, y, z, lat0, lon0, alt0, east, north, up, spheroid, deg)
real, intent(in) :: x,y,z,lat0,lon0,alt0
type(Ellipsoid), intent(in), optional :: spheroid
logical, intent(in), optional :: deg
real, intent(out) :: east,north,up
end subroutine ecef2enu

module elemental subroutine ecef2enuv(u, v, w, llat0, llon0, east, north, up, deg)
real, intent(in) :: u,v,w
real, intent(in) :: llat0,llon0
logical, intent(in), optional :: deg
real, intent(out) :: east, north, up
end subroutine ecef2enuv

end interface

interface ! enu

module elemental subroutine geodetic2enu(lat, lon, alt, lat0, lon0, alt0, east, north, up, spheroid, deg)
real, intent(in) :: lat, lon, alt, lat0, lon0, alt0
type(Ellipsoid), intent(in), optional :: spheroid
logical, intent(in), optional :: deg
real, intent(out) :: east, north, up
end subroutine geodetic2enu

module elemental subroutine enu2geodetic(east, north, up, lat0, lon0, alt0, lat, lon, alt, spheroid, deg)
real, intent(in) :: east, north, up, lat0, lon0, alt0
type(Ellipsoid), intent(in), optional :: spheroid
logical, intent(in), optional :: deg
real, intent(out) :: lat, lon, alt
end subroutine enu2geodetic

module elemental subroutine aer2enu(az, el, slantRange, east, north, up, deg)
real, intent(in) :: az,el  !< not value due to ifort segfault bug
real, intent(in) :: slantRange
logical, intent(in), optional :: deg
real,intent(out) :: east, north,up
end subroutine aer2enu

module elemental subroutine enu2aer(east, north, up, az, elev, slantRange, deg)
real,intent(in) :: east, north, up
logical, intent(in), optional :: deg
real, intent(out) :: az, elev, slantRange
end subroutine enu2aer

module elemental subroutine lookAtSpheroid(lat0, lon0, h0, az, tilt, lat, lon, srange, spheroid, deg)
real, intent(in) :: lat0, lon0, h0, az, tilt
type(Ellipsoid), intent(in), optional :: spheroid
logical, intent(in), optional :: deg
real, intent(out) :: lat, lon, srange
end subroutine lookAtSpheroid

end interface

interface ! utils.f90
module elemental subroutine enu2uvw(east,north,up, llat0,llon0, u,v,w, deg)
real, intent(in) :: east,north,up
real, intent(in) :: llat0,llon0
real, intent(out) :: u,v,w
logical, intent(in), optional :: deg
end subroutine enu2uvw

module elemental real function anglesep(lon0,lat0,lon1,lat1)
real, intent(in) :: lat0,lon0,lat1,lon1
end function anglesep
end interface

contains

elemental real function haversine(theta)
!! theta: angle in RADIANS
real, intent(in) :: theta

haversine =  (1 - cos(theta)) / 2

end function haversine

elemental real function degrees(rad)
real, intent(in) :: rad

degrees = 180 / pi * rad
end function degrees

elemental real function radians(deg)
real, intent(in) :: deg

radians = pi / 180 * deg
end function radians

end module maptran