module comoving_nd_module

  use amrex_error_module
  use amrex_fort_module, only : rt => amrex_real

  contains

! :::
! ::: ----------------------------------------------------------------
! :::

      real(rt) function invEz(H0, Om, a)
        real(rt), intent(in) :: H0, Om, a
        invEz = 1.0d0 / ( H0*dsqrt(Om/a + (1.0d0-Om)*a*a) )
      end function invEz

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine fort_integrate_time_given_a(a0, a1, dt) &
         bind(C, name="fort_integrate_time_given_a")

        use fundamental_constants_module, only: Hubble_const
        use comoving_module             , only: comoving_h, comoving_OmM

        real(rt), intent(in   ) :: a0, a1
        real(rt), intent(  out) :: dt

        real(rt), parameter :: xacc = 1.0d-6
        real(rt) :: H0, Om, prev_soln, h
        integer :: iter, n, j

        H0 = comoving_h*Hubble_const
        Om = comoving_OmM

        prev_soln = -1.0d0
        ! trapezoidal integration
        do iter = 1, 20  ! max allowed iterations

          n  = 2**iter

          h = (a1-a0)/(n-1)

          if (a0 .lt. 1.0d-10) then  ! prevent division by zero in invEz
             dt = 0.5*invEz(H0, Om, a1)
          else
             dt = 0.5*(invEz(H0, Om, a0) + invEz(H0, Om, a1))
          endif

          do j = 1, n-2
             dt = dt + invEz(H0, Om, a0+j*h)
          enddo
          dt = dt*h

          if (iter .gt. 4) then
             if (abs(dt-prev_soln) .le. xacc*abs(prev_soln)) return
          endif
          prev_soln = dt
        enddo

      end subroutine fort_integrate_time_given_a

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine fort_integrate_comoving_a(old_a,new_a,dt) &
         bind(C, name="fort_integrate_comoving_a")

        use fundamental_constants_module, only: Hubble_const
        use comoving_module             , only: comoving_h, comoving_OmM, comoving_type

        implicit none

        real(rt), intent(in   ) :: old_a, dt
        real(rt), intent(  out) :: new_a

        real(rt), parameter :: xacc = 1.0d-8
        real(rt) :: H_0, OmL
        real(rt) :: Delta_t, prev_soln
        real(rt) :: start_a, end_a, start_slope, end_slope
        integer  :: iter, j, nsteps

        if (comoving_h .eq. 0.0d0) then
          new_a = old_a
          return
        endif

        H_0 = comoving_h * Hubble_const
        OmL = 1.d0 - comoving_OmM

        prev_soln = 2.0d0 ! 0<a<1 so a=2 will do as "wrong" solution
        do iter = 1, 11  ! max allowed iterations
          nsteps = 2**(iter-1)
          Delta_t = dt/nsteps
          end_a = old_a

          do j = 1, nsteps
            ! This uses RK2 to integrate the ODE:
            !   da / dt = H_0 * sqrt(OmM/a + OmL*a^2)
            start_a = end_a

            ! Compute the slope at the old time
            if (comoving_type > 0) then
                start_slope = H_0*dsqrt(comoving_OmM / start_a + OmL*start_a**2)
            else
                start_slope = comoving_h
            end if

            ! Compute a provisional value of ln(a) at the new time
            end_a = start_a + start_slope * Delta_t

            ! Compute the slope at the new time
            if (comoving_type > 0) then
                end_slope = H_0*dsqrt(comoving_OmM / end_a + OmL*end_a**2)
            else
                end_slope = comoving_h
            end if

            ! Now recompute a at the new time using the average of the two slopes
            end_a = start_a + 0.5d0 * (start_slope + end_slope) * Delta_t
          enddo

          new_a  = end_a
          if (abs(1.0d0-new_a/prev_soln) .le. xacc) return
          prev_soln = new_a

        enddo

      end subroutine fort_integrate_comoving_a

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine fort_integrate_comoving_a_to_z(old_a,z_value,dt) &
         bind(C, name="fort_integrate_comoving_a_to_z")

        use fundamental_constants_module, only: Hubble_const
        use comoving_module             , only: comoving_h, comoving_OmM, comoving_type

        implicit none

        real(rt), intent(in   ) :: old_a, z_value
        real(rt), intent(inout) :: dt

        real(rt), parameter :: xacc = 1.0d-8
        real(rt) :: H_0, OmL
        real(rt) :: Delta_t
        real(rt) :: start_a, end_a, start_slope, end_slope
        real(rt) :: a_value
        integer  :: j, nsteps

        if (comoving_h .eq. 0.0d0) &
          call amrex_error("fort_integrate_comoving_a_to_z: Shouldn't be setting plot_z_values if not evolving a")

        H_0 = comoving_h * Hubble_const
        OmL = 1.d0 - comoving_OmM

        ! Translate the target "z" into a target "a"
        a_value = 1.d0 / (1.d0 + z_value)

        ! Use lots of steps if we want to nail the z_value
        nsteps = 1024

        ! We integrate a, but stop when a = a_value (or close enough)
        Delta_t = dt/nsteps
        end_a = old_a
        do j = 1, nsteps
            ! This uses RK2 to integrate the ODE:
            !   da / dt = H_0 * sqrt(OmM/a + OmL*a^2)
            start_a = end_a

            ! Compute the slope at the old time
            if (comoving_type > 0) then
                start_slope = H_0*dsqrt(comoving_OmM / start_a + OmL*start_a**2)
            else
                start_slope = comoving_h
            end if

            ! Compute a provisional value of ln(a) at the new time
            end_a = start_a + start_slope * Delta_t

            ! Compute the slope at the new time
            if (comoving_type > 0) then
                end_slope = H_0*dsqrt(comoving_OmM / end_a + OmL*end_a**2)
            else
                end_slope = comoving_h
            end if

            ! Now recompute a at the new time using the average of the two slopes
            end_a = start_a + 0.5d0 * (start_slope + end_slope) * Delta_t

            ! We have crossed from a too small to a too big in this step
            if ( (end_a - a_value) * (start_a - a_value) < 0) then
                dt = ( (  end_a - a_value) * dble(j  ) + &
                       (a_value - start_a) * dble(j+1) ) / (end_a - start_a) * Delta_t
                exit
            end if
        end do

      end subroutine fort_integrate_comoving_a_to_z

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine fort_integrate_comoving_a_to_a(old_a,a_value,dt) &
         bind(C, name="fort_integrate_comoving_a_to_a")

        use fundamental_constants_module, only: Hubble_const
        use comoving_module             , only: comoving_h, comoving_OmM, comoving_type

        implicit none

        real(rt), intent(in   ) :: old_a, a_value
        real(rt), intent(inout) :: dt

        real(rt), parameter :: xacc = 1.0d-8
        real(rt) :: H_0, OmL
        real(rt) :: Delta_t
        real(rt) :: start_a, end_a, start_slope, end_slope
        integer  :: j, nsteps

        real(rt) :: max_dt

        if (comoving_h .eq. 0.0d0) &
          call amrex_error("fort_integrate_comoving_a_to_z: Shouldn't be setting plot_z_values if not evolving a")

        H_0 = comoving_h * Hubble_const
        OmL = 1.d0 - comoving_OmM

        ! Use lots of steps if we want to nail the z_value
!        nsteps = 1024

        ! Use enough steps if we want to be close to the a_value
        nsteps = 2048

        ! We integrate a, but stop when a = a_value (or close enough)
        Delta_t = dt/nsteps
        end_a = old_a
        do j = 1, nsteps
            ! This uses RK2 to integrate the ODE:
            !   da / dt = H_0 * sqrt(OmM/a + OmL*a^2)
            start_a = end_a

            ! Compute the slope at the old time
            if (comoving_type > 0) then
                start_slope = H_0*dsqrt(comoving_OmM / start_a + OmL*start_a**2)
            else
                start_slope = comoving_h
            end if

            ! Compute a provisional value of ln(a) at the new time
            end_a = start_a + start_slope * Delta_t

            ! Compute the slope at the new time
            if (comoving_type > 0) then
                end_slope = H_0*dsqrt(comoving_OmM / end_a + OmL*end_a**2)
            else
                end_slope = comoving_h
            end if

            ! Now recompute a at the new time using the average of the two slopes
            end_a = start_a + 0.5d0 * (start_slope + end_slope) * Delta_t

            ! We have crossed from a too small to a too big in this step
            if ( (end_a - a_value) * (start_a - a_value) < 0) then
                dt = ( (  end_a - a_value) * dble(j  ) + &
                       (a_value - start_a) * dble(j+1) ) / (end_a - start_a) * Delta_t
                exit
            end if
        end do

      end subroutine fort_integrate_comoving_a_to_a
! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine fort_est_maxdt_comoving_a(old_a,dt)

        use fundamental_constants_module, only: Hubble_const
        use comoving_module             , only: comoving_h, comoving_OmM, comoving_type

        implicit none

        real(rt), intent(in   ) :: old_a
        real(rt), intent(inout) :: dt

        real(rt) :: H_0, OmL
        real(rt) :: max_dt

        OmL = 1.d0 - comoving_OmM

        ! This subroutine computes dt based on not changing a by more than 5%
        ! if we use forward Euler integration
        !   d(ln(a)) / dt = H_0 * sqrt(OmM/a^3 + OmL)

        H_0 = comoving_h * Hubble_const

        if (H_0 .ne. 0.0d0) then
           if (comoving_type > 0) then
              max_dt = (0.05d0) / H_0 / dsqrt(comoving_OmM / old_a**3 + OmL)
           else
              max_dt = (0.05d0) / abs(comoving_h)
           end if
           dt = min(dt,max_dt)

        else

           ! dt is unchanged

        end if

      end subroutine fort_est_maxdt_comoving_a

! :::
! ::: ----------------------------------------------------------------
! :::

      ! This might only work for t=0=> a=.00625, although constant canceled
      subroutine fort_est_lindt_comoving_a(old_a,new_a,dt)

        use fundamental_constants_module, only: Hubble_const
        use comoving_module             , only: comoving_h, comoving_OmM, comoving_type

        implicit none

        real(rt), intent(in   ) :: old_a,new_a
        real(rt), intent(inout) :: dt

        real(rt) :: H_0, OmL
        real(rt) :: lin_dt

        OmL = 1.d0 - comoving_OmM

        ! This subroutine computes dt based on not changing a by more than 5%
        ! if we use forward Euler integration
        !   d(ln(a)) / dt = H_0 * sqrt(OmM/a^3 + OmL)

        H_0 = comoving_h * Hubble_const

        ! Could definately be optimized better
        if (H_0 .ne. 0.0d0) then

           lin_dt= ((new_a/(.75**(2/3)*(OmL+ comoving_OmM)**(1/3)))**(.75)  - &
                ((old_a/(.75**(2/3)*(OmL+ comoving_OmM)**(1/3)))**(.75) ) ) /H_0
           dt=lin_dt

        else

           ! dt is unchanged

        end if

      end subroutine fort_est_lindt_comoving_a

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine fort_estdt_comoving_a(old_a,new_a,dt,change_allowed,fixed_da,final_a,dt_modified) &
         bind(C, name="fort_estdt_comoving_a")

        use comoving_module             , only: comoving_h

        implicit none

        real(rt), intent(in   ) :: old_a, change_allowed, fixed_da, final_a
        real(rt), intent(inout) :: dt
        real(rt), intent(  out) :: new_a
        integer , intent(  out) :: dt_modified
        real(rt) a_value
        real(rt) max_dt
        max_dt = dt

        if (comoving_h .ne. 0.0d0) then

           if( fixed_da .le. 0.0d0) then
              ! First call this to make sure dt that we send to integration routine isnt outrageous
              call fort_est_maxdt_comoving_a(old_a,dt)

              ! Initial call to see if existing dt will work
              call fort_integrate_comoving_a(old_a,new_a,dt)

              ! Make sure a isn't growing too fast
              call enforce_percent_change(old_a,new_a,dt,change_allowed)
           else
              ! First call this to make sure dt that we send to integration routine isnt outrageous
              new_a = (old_a +  fixed_da);
              call fort_est_lindt_comoving_a(old_a,new_a,dt)
              call fort_est_maxdt_comoving_a(old_a,dt)

              ! Then integrate old_a to a_value using dt as a guess for the maximum dt
              ! Output dt is based on a fraction of the input dt
              call fort_integrate_comoving_a_to_a(old_a,new_a,dt)
           endif

           ! Make sure we don't go past final_a (if final_a is set)
           if (final_a > 0.0d0) &
              call enforce_final_a(old_a,new_a,dt,final_a)

           dt_modified = 1

        else

           ! dt is unchanged by this call

           dt_modified = 0

        endif

      end subroutine fort_estdt_comoving_a

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine enforce_percent_change(old_a,new_a,dt,change_allowed)

        implicit none

        real(rt), intent(in   ) :: old_a, change_allowed
        real(rt), intent(inout) :: dt
        real(rt), intent(inout) :: new_a

        integer          :: i
        real(rt) :: factor

        factor = ( (new_a - old_a) / old_a ) / change_allowed

        ! Only go into this process if percent change exceeds change_allowed

        if (factor > 1.d0) then

           do i = 1, 100
              factor = ( (new_a - old_a) / old_a ) / change_allowed

              ! Note: 0.99 is just a fudge factor so we don't get bogged down.
              if (factor > 1.d0) then
                 dt = (1.d0 / factor) * dt * 0.99d0
                 call fort_integrate_comoving_a(old_a,new_a,dt)
              else if (i.lt.100) then
                 call fort_integrate_comoving_a(old_a,new_a,dt)
                 ! We're done
                 return
              else
                 call amrex_error("Too many iterations in enforce_percent_change")
              end if
           end do

        else
           ! We don't need to do anything
           return
        end if

      end subroutine enforce_percent_change

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine enforce_final_a(old_a,new_a,dt,final_a)

        implicit none

        real(rt), intent(in   ) :: old_a, final_a
        real(rt), intent(inout) :: dt
        real(rt), intent(inout) :: new_a

        integer  :: i
        real(rt) :: factor
        real(rt), parameter :: eps = 1.d-10

        if (old_a > final_a) then
           call amrex_error("Oops -- old_a > final_a")
        end if

        ! Only go into this process if new_a is past final_a
        if (new_a > final_a) then

           do i = 1, 100
              if ( (new_a > (final_a+eps)) .or. (new_a < final_a) ) then
                 factor = (final_a - old_a) / (new_a - old_a)
                 dt = dt * factor
                 call fort_integrate_comoving_a(old_a,new_a,dt)
              else if (i.lt.100) then
                 ! We're done
                 return
              else
                 call amrex_error("Too many iterations in enforce_final_a")
              end if
           end do

        else
           ! We don't need to do anything
           return
        end if

      end subroutine enforce_final_a

! ! :::
! ! ::: ----------------------------------------------------------------
! ! :::

!       subroutine fort_get_omb(frac) &
!          bind(C, name="fort_get_omb")

!         use comoving_module, only: comoving_OmB, comoving_OmM

!         real(rt) :: frac

!         frac = comoving_OmB / comoving_OmM

!       end subroutine fort_get_omb

! ! :::
! ! ::: ----------------------------------------------------------------
! ! :::

!       subroutine fort_get_omm(omm) &
!          bind(C, name="fort_get_omm")

!         use comoving_module, only: comoving_OmM

!         real(rt) :: omm

!         omm = comoving_OmM

!       end subroutine fort_get_omm

! ! :::
! ! ::: ----------------------------------------------------------------
! ! :::

        subroutine fort_get_hubble(hubble) &
           bind(C, name="fort_get_hubble")

          use comoving_module, only: comoving_h

          real(rt) :: hubble

          hubble = comoving_h

        end subroutine fort_get_hubble

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine fort_set_omb(omb) &
         bind(C, name="fort_set_omb")

        use comoving_module, only: comoving_OmB

        real(rt), intent(in) :: omb

        comoving_OmB = omb

      end subroutine fort_set_omb

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine fort_set_omm(omm) &
         bind(C, name="fort_set_omm")

        use comoving_module, only: comoving_OmM

        real(rt), intent(in) :: omm

        comoving_OmM = omm

      end subroutine fort_set_omm

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine fort_set_hubble(hubble) &
         bind(C, name="fort_set_hubble")

        use comoving_module, only: comoving_h

        real(rt), intent(in) :: hubble

        comoving_h = hubble

      end subroutine fort_set_hubble

end module comoving_nd_module


         SELECT CASE(typeRegression)
         CASE(linreg_id)
            x_cp = x
            y_cp = y
         CASE(logreg_id)
            x_cp = LOG(x)
            y_cp = y
         CASE(expreg_id)
            x_cp = x
            y_cp = LOG(y)
         CASE(potreg_id)
            x_cp = LOG10(x)
            y_cp = LOG10(y)
         END SELECT

         var_x = variance(x_cp)
         var_y = variance(y_cp)
         covar_xy = covariance(x_cp,y_cp)

         a = covar_xy / var_x

         SELECT CASE(typeRegression)
         CASE(expreg_id)
            b = EXP(mean(y_cp) - a*mean(x_cp))
         CASE(potreg_id)
            b = 10**(mean(y_cp) - a*mean(x_cp))
         CASE DEFAULT
            b = mean(y_cp) - a*mean(x_cp)
         END SELECT

         R2 = covar_xy**2/var_x/var_y


module util_mod
  use working_prec_mod, only: ik, rk
  implicit none
  private

  public :: det
  public :: inverse
  public :: trace
  public :: math_cross_product
  public :: math_euclidean_norm
contains

  ! det: returns determinant of 3x3 matrix (sarrus)
  pure real(rk) function det (matrix)
    real(rk), dimension(3,3), intent(in) :: matrix
    det  = matrix(1,1)*matrix(2,2)*matrix(3,3) &
      + matrix(1,2)*matrix(2,3)*matrix(3,1) &
      + matrix(1,3)*matrix(2,1)*matrix(3,2) &
      - matrix(1,3)*matrix(2,2)*matrix(3,1) &
      - matrix(1,1)*matrix(2,3)*matrix(3,2) &
      - matrix(1,2)*matrix(2,1)*matrix(3,3)
  end function det

  pure function inverse(matrix) result (invbox)
    real(rk), intent(in) :: matrix(3,3)
    real(rk)             :: invbox(3,3)
    real(rk)             :: adj(3,3) ! adjunkt

    adj(1,1) = matrix(2,2)*matrix(3,3) - matrix(2,3)*matrix(3,2)
    adj(2,1) = matrix(3,1)*matrix(2,3) - matrix(3,3)*matrix(2,1)
    adj(3,1) = matrix(2,1)*matrix(3,2) - matrix(2,2)*matrix(3,1)
    adj(1,2) = matrix(3,2)*matrix(1,3) - matrix(3,3)*matrix(1,2)
    adj(2,2) = matrix(1,1)*matrix(3,3) - matrix(1,3)*matrix(3,1)
    adj(3,2) = matrix(3,1)*matrix(1,2) - matrix(3,2)*matrix(1,1)
    adj(1,3) = matrix(1,2)*matrix(2,3) - matrix(1,3)*matrix(2,2)
    adj(2,3) = matrix(2,1)*matrix(1,3) - matrix(2,3)*matrix(1,1)
    adj(3,3) = matrix(1,1)*matrix(2,2) - matrix(1,2)*matrix(2,1)

    invbox = 1._rk/det(matrix) * adj
  end function inverse

  pure real(rk) function trace (matrix)
    real(rk), intent(in) :: matrix(3,3)

    trace = ( matrix(1,1) + matrix(2,2) + matrix(3,3) )
  end function trace

  pure function math_cross_product (a, b) result (res)
    real(rk), dimension(3), intent(in) :: a, b
    real(rk), dimension(3) :: res

    res(1) = a(2) * b(3) - a(3) * b(2)
    res(2) = a(3) * b(1) - a(1) * b(3)
    res(3) = a(1) * b(2) - a(2) * b(1)
  end function math_cross_product

  pure function math_euclidean_norm (a) result (a_n)
    real(rk), dimension(:), intent(in) :: a
    real(rk)                           :: a_n

    a_n = sqrt (sum (a**2))
  end function math_euclidean_norm

end module util_mod


program q1
  use utils
  implicit none

  call main()

contains

  subroutine main()
    !! Find roots via Newton's method
    print *
    print "(a)", "1. Roots of cos x - x/5 = 0"
    print "(f18.12)", newton(f1, df1, x0=-4.0, tol=1e-13)
    print "(f18.12)", newton(f1, df1, x0=-2.0, tol=1e-13)
    print "(f18.12)", newton(f1, df1, x0= 1.0, tol=1e-13)
    print *
  end subroutine

  pure function f1(x)
    !! Function for question 1
    real, intent(in) :: x
    real :: f1

    f1 = cos(x) - x/5
  end function

  pure function df1(x)
    !! Derivative of function for question 1
    real, intent(in) :: x
    real :: df1

    df1 = -sin(x) - 1.0 / 5.0
  end function

end program q1


! HOW TO COMPILE THROUGH COMMAND LINE (CMD OR TERMINAL)
! gfortran -c SecondBackwardDif.f95
! gfortran -o SecondBackwardDif SecondBackwardDif.o
!
! The program is open source and can use be to numerical study purpose.
! The program was written by Aulia Khalqillah,S.Si
!
! email: auliakhalqillah.mail@gmail.com
! ==============================================================================
PROGRAM CenterDifference
  IMPLICIT NONE

  REAL :: A,B,H,X,RAWF,F
  REAL,DIMENSION(1000) :: RAWFS,FA,FX,XS,RES

  INTEGER :: I,N
  CHARACTER(len=100) :: FMT

  WRITE(*,*)""
  WRITE(*,*)"---------------------------------------------"
  WRITE(*,*)"BACKWARD DIFFERENCE METHOD - SECOND DERIVATIVE"
  WRITE(*,*)"---------------------------------------------"
  WRITE(*,*) ""
  WRITE(*,"(a)",advance="no") "INSERT INITIAL BOUNDARY:"
  READ *, A
  WRITE(*,"(a)",advance="no") "INSERT FINAL BOUNDARY:"
  READ *, B
  WRITE(*,"(a)",advance="no") "INSERT DATA LENGTH:"
  READ *, N

  FMT = "(a12,a13,a20,a20,a15,a13)"
  WRITE(*,*) ""
  WRITE(*,FMT)"ITER","Data(X)","Raw F(X)","Difference F(X)","Analytic F(X)","RESIDUAL"
  OPEN(10, FILE ='SecondBdiffOut.txt', STATUS='replace')

  ! Residual between two point is calculated
  H = (B-A)/N
  X = A
  I = 1
  DO WHILE (I .le. N)
    RAWF = F(X)
    RAWFS(I) = RAWF ! Save the value
    FX(I) = ((F(X)-(2*F(X-H))+F(X-(2*H)))/(H**2)) ! Second Backward Difference is calculated
    XS(I) = X ! Save the value
    FA(I) = 6*XS(I)  ! Analytic Calculation of Second Difference
    RES(I) = abs(real(FX(I))-real(FA(I))) ! Residual Calculation
    WRITE(*,*) I,XS(I),RAWFS(I),FX(I),FA(I),RES(I)
    WRITE(10,*) I,XS(I),RAWFS(I),FX(I),FA(I),RES(I)
    X = X + H
    I = I + 1
  END DO
END PROGRAM

REAL FUNCTION F(X)
  IMPLICIT NONE
  REAL :: X
  F = X**3
END FUNCTION


c****************************************************************

	subroutine matmat(r_a,r_b,r_c)

c****************************************************************
c**
c**	FILE NAME: matmat.for
c**
c**     DATE WRITTEN: 8/3/90
c**
c**     PROGRAMMER:Scott Hensley
c**
c** 	FUNCTIONAL DESCRIPTION: The subroutine takes two 3x3 matrices
c**     and multiplies them to return another 3x3 matrix.
c**
c**     ROUTINES CALLED:none
c**
c**     NOTES: none
c**
c**     UPDATE LOG:
c**
c*****************************************************************

       	implicit none

c	INPUT VARIABLES:
 	real*8 r_a(3,3),r_b(3,3)              !3x3 matrix

c   	OUTPUT VARIABLES:
        real*8 r_c(3,3)                       !3x3 matrix

c	LOCAL VARIABLES:
	integer i

c  	PROCESSING STEPS:

c       compute matrix product

        do i=1,3
       	  r_c(i,1) = r_a(i,1)*r_b(1,1) + r_a(i,2)*r_b(2,1) +
     +               r_a(i,3)*r_b(3,1)
	  r_c(i,2) = r_a(i,1)*r_b(1,2) + r_a(i,2)*r_b(2,2) +
     +               r_a(i,3)*r_b(3,2)
	  r_c(i,3) = r_a(i,1)*r_b(1,3) + r_a(i,2)*r_b(2,3) +
     +               r_a(i,3)*r_b(3,3)
        enddo

        end


      REAL FUNCTION slBEAR (A1, B1, A2, B2)
*+
*     - - - - -
*      B E A R
*     - - - - -
*
*  Bearing (position angle) of one point on a sphere relative to another
*  (single precision)
*
*  Given:
*     A1,B1    r    spherical coordinates of one point
*     A2,B2    r    spherical coordinates of the other point
*
*  (The spherical coordinates are RA,Dec, Long,Lat etc, in radians.)
*
*  The result is the bearing (position angle), in radians, of point
*  A2,B2 as seen from point A1,B1.  It is in the range +/- pi.  If
*  A2,B2 is due east of A1,B1 the bearing is +pi/2.  Zero is returned
*  if the two points are coincident.
*
*  P.T.Wallace   Starlink   23 March 1991
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  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 A1,B1,A2,B2

      REAL DA,X,Y

      DA=A2-A1
      Y=SIN(DA)*COS(B2)
      X=SIN(B2)*COS(B1)-COS(B2)*SIN(B1)*COS(DA)
      IF (X.NE.0.0.OR.Y.NE.0.0) THEN
         slBEAR=ATAN2(Y,X)
      ELSE
         slBEAR=0.0
      END IF

      END


SUBROUTINE PREENV( X, N )

  ! Forms the pre-envelope of the function
  ! Real( X( N ) ) is the input time series
  ! The output vector is complex
  ! N must be a power of 2 and <16384

  COMPLEX X( N )

  !  Check N is postive and a power of 2

  IF ( N <= 0 ) STOP 'FATAL ERROR in PREENV: N must be positive'

  NT = 2**( INT( LOG10( REAL( N ) ) / 0.30104 ) + 1 )
  IF ( NT /= N ) STOP 'FATAL ERROR in PREENV: N must be a power of 2'

  CALL CFFT( X, N, 1 )     ! forward Fourier transform
  X = X / N                ! scaled appropriately

  IMID            = N / 2
  X( IMID+1 : N ) = 0.0    ! Zero-out the negative spectrum (the upper N/2 positions)

  CALL CFFT( X, N, -1 )    ! inverse Fourier transform

END SUBROUTINE PREENV


! -----------
! Vertical motion under gravity
! -----------------------------
program Vertical
    implicit none
    real :: g   ! acceleration due to gravity
    real :: s   ! displacement
    real :: t   ! time
    real :: u   ! initial speed (m / s)

    ! set values of variable
    g = 9.8
    t = 6.0
    u = 60.0

    ! calculate displacement
    s = u*t - g*(t**2) / 2.0

    ! output results
    write(*, "('[F90] Time = ', f5.2, ', Displacement = ', f5.1)")  t, s

end program Vertical


      MODULE funcs
	  		implicit none
	  CONTAINS
			FUNCTION func(x, y, z)
			REAL func, x, y, z
			func = 1
			RETURN
			END FUNCTION func

			FUNCTION y1(x)
			REAL y1, x
			y1 = -sqrt(4-x**2)
			RETURN
			END FUNCTION y1

			FUNCTION y2(x)
			REAL y2, x
			y2 = sqrt(4-x**2)
			RETURN
			END FUNCTION y2

			FUNCTION z1(x, y)
			REAL z1, x, y
			z1 = -sqrt(4-x**2-y**2)
			RETURN
			END FUNCTION z1

			FUNCTION z2(x, y)
			REAL z2, x, y
			z2 = sqrt(4-x**2-y**2)
			RETURN
			END FUNCTION z2
	  END MODULE funcs

	  MODULE integration
	  		USE funcs
			CONTAINS
			 SUBROUTINE qgaus(func,a,b,ss)
				 REAL a,b,ss,func
				 EXTERNAL func
				 INTEGER j
				 REAL dx,xm,xr
				 real, dimension(5) :: w
				 real, dimension(5) :: x
				 w(1) = 0.2955242247
				 w(2) = 0.2692667193
				 w(3) = 0.2190863625
				 w(4) = 0.1494513491
				 w(5) = 0.0666713443

				 x(1) = 0.1488743389
				 x(2) = 0.4333953941
				 x(3) = 0.6794095682
				 x(4) = 0.8650633666
				 x(5) = 0.9739065285

				 xm=0.5*(b+a)
				 xr=0.5*(b-a)
				 ss=0
				 do j=1,5
				 dx=xr*x(j)
				 ss=ss+w(j)*(func(xm+dx)+func(xm-dx))
				 end do
				 ss=xr*ss
				 return
			 END SUBROUTINE qgaus

			 SUBROUTINE tripleD(x1, x2, ss)
			 REAL x1, x2, ss
			 call qgaus(h, x1, x2, ss)
			 return
			 END SUBROUTINE tripleD

			 FUNCTION f(zz)
			 REAL f, zz, x, y, z
			 COMMON /xyz/ x,y,z
			 z = zz
			 f = func(x,y,z)
			 return
			 END FUNCTION f

			 FUNCTION g(yy)
			 REAL g,yy,x,y,z
			 COMMON /xyz/ x,y,z
			 REAL ss
			 y=yy
			 call qgaus(f,z1(x,y),z2(x,y),ss)
			 g=ss
			 return
			 END FUNCTION g

			 FUNCTION h(xx)
			 REAL h,xx,x,y,z
			 COMMON /xyz/ x,y,z
			 REAL ss
			 x=xx
			 call qgaus(g,y1(x),y2(x),ss)
			 h=ss
			 return
			 END FUNCTION h
	  END MODULE integration

	  PROGRAM CalIntegrator
	  	  USE funcs
		  USE integration
		  implicit none
		  REAL x1, x2, s, pi, ro
		  INTEGER n
		  pi = 3.141592654
		  x1 = -2
		  x2 = 2
		  ro = 0.05
		  call tripleD(x1, x2, s)
		  WRITE (*,*) s*ro
	  END PROGRAM CalIntegrator


module gcd_module
    implicit none

    contains
    integer function gcd(a, b)
        implicit none

        integer, intent(in) :: a, b
        integer :: temp

        if (a<b) then
            temp = a
        else
            temp = b
        end if
        do while (mod(a,temp)/=0 .or. mod(b,temp)/=0)
            temp = temp-1
        end do
        gcd = temp
    end function
end module

program ch1207
    ! Simple User Defined Function
    use gcd_module
    implicit none

    integer :: i, j, result

    print *, 'type in two integers'
    read *, i, j
    result = gcd(i,j)
    print *, 'gcd is ', result
end program


      function distance_lg(x1,y1,z1,x2,y2,z2,ierror)
c
c calculate the distance between two points
c
c  Inputs
c
c   x1,y1,z1 coordinates of first point
c   x1,y2,z2 coordinates of second point
c
c  Outputs
c
c    distance_lg  - distance from point 1 to point 2
c    ierror  -- error flag - 0 means no error
c
c  Change log
c
c  $Log: distance_lg.f,v $
c  Revision 2.00  2007/11/05 19:45:52  spchu
c  Import to CVS
c
CPVCS
CPVCS       Rev 1.0   Wed Mar 01 11:15:20 2000   dcg
CPVCS    Initial revision.
C
      implicit  none
      real*8 x1,y1,z1,x2,y2,z2,distance_lg
      integer ierror
      ierror=0
      distance_lg=sqrt((x1-x2)**2+(y1-y2)**2+(z1-z2)**2)
      return
      end
c
      function sqdistance_lg(x1,y1,z1,x2,y2,z2,ierror)
c
c calculate the square of the distance between two points
c
      implicit  none
      real*8 x1,y1,z1,x2,y2,z2,sqdistance_lg
      integer ierror
      ierror=0
      sqdistance_lg=(x1-x2)**2+(y1-y2)**2+(z1-z2)**2
      return
      end
c
      function dotproduct_lg(x1,y1,z1,x2,y2,z2,x3,y3,z3,ierror)
c
c calculate the dot product of the two vectors 12 and 13
c
      implicit  none
      real*8 x1,y1,z1,x2,y2,z2,x3,y3,z3,dotproduct_lg,
     *   xa,ya,za,xb,yb,zb
      integer ierror
      ierror=0
      xa=x2-x1
      ya=y2-y1
      za=z2-z1
      xb=x3-x1
      yb=y3-y1
      zb=z3-z1
      dotproduct_lg=xa*xb+ya*yb+za*zb
      return
      end
c
      function cos_lg(x1,y1,z1,x2,y2,z2,x3,y3,z3,eps,ierror)
c
c calculate the cosine between the two vectors 12 and 13
c
      implicit  none
      real*8 x1,y1,z1,x2,y2,z2,x3,y3,z3,dot,cos_lg,
     *   xa,ya,za,xb,yb,zb,eps,d1,d2,d
      integer ierror
      ierror=0
      xa=x2-x1
      ya=y2-y1
      za=z2-z1
      xb=x3-x1
      yb=y3-y1
      zb=z3-z1
      dot=xa*xb+ya*yb+za*zb
      d1=sqrt((x1-x2)**2+(y1-y2)**2+(z1-z2)**2)
      d2=sqrt((x1-x3)**2+(y1-y3)**2+(z1-z3)**2)
      d=d1*d2
      if(d.gt.eps) then
        cos_lg=dot/d
        ierror=0
      else
        ierror=1
      endif
      return
      end


program eigenproblem
implicit none

interface
    function random_hermitian(N)
    integer :: N
    complex*16, dimension(1:N,1:N) :: random_hermitian
    end function
end interface

integer :: N, ii, ok
complex*16, allocatable :: org_hermitian(:,:), work(:), eigenvectors(:,:)
real*8,allocatable :: eigenvalues(:), rwork(:), spacings(:)
real*8 :: average_spacing
character (len = 15) :: filename

write(*,*) "How many rows should the hermitian matrix have?"
write(*,*) "Type in the name of the file to store the normalized spacings. Type '' if no storing is desired."
read(*,*) N, filename

allocate(org_hermitian(1:N,1:N))
allocate(eigenvalues(1:N))
allocate(spacings(1:N-1))
allocate(work(1:max(5000,2*N-1)))
allocate(rwork(1:3*N-2))

! generate random hermitian matrix
org_hermitian = random_hermitian(N)

! copy the hermitian matrix to avoid modifying it
eigenvectors = org_hermitian

! Obtain an optimal lwork
call zheev('N','U',N,eigenvectors,N,eigenvalues,work,-1,rwork,ok)
! the first element of work is the optimal lwork
call zheev('N','U',N,eigenvectors,N,eigenvalues,work,min(5000,int(work(1))),rwork,ok)

if (ok.ne.0) stop "Unsuccessful eigenvalue calculation"

! obtaing the normalized spacings
average_spacing = (eigenvalues(N)-eigenvalues(1))/(N-1)
do ii = 1, N-1
    spacings(ii) = (eigenvalues(ii+1)-eigenvalues(ii))/average_spacing
end do

! log or store the normalized spacings
if (filename .ne. '') then
    open(15, file =filename)
    do ii = 1, N-1
        write(15,*) spacings(ii)
    end do
    close(15)
else
    write(*,*) "******SPACINGS******"
    do ii = 1, N-1
        write(*,*) spacings(ii)
    end do
end if

end program eigenproblem

function random_hermitian(N)
! Generates an order N hermitian matrix with random entries x+iy
! where each x and y are uniformly distributed between -1 and 1
implicit none
integer :: N, ii, jj
complex*16, dimension(N,N) :: random_hermitian
real*8, dimension(N,N) :: A, B

    call random_number(A)
    ! rescaling into an element in (-1,1)
    A = 2*A - 1
    call random_number(B)
    ! rescaling into an element in (-1,1)
    B = 2*B - 1

    ! populating the matrix
    do ii = 1,N
        do jj = 1,N
            ! replacing entries in the lower triangle
            if ((jj.gt.ii).and.(ii.lt.N)) then
                A(jj,ii) = A(ii,jj)
                ! The imaginary part is negative, to achieve hermicity
                B(jj,ii) = -B(ii,jj)
            end if
            ! cast into a complex entry
            random_hermitian(ii,jj) = complex(A(ii,jj),B(ii,jj))
        end do
    end do

end function random_hermitian


subroutine shaga1(    s,ngaus,shaga)

!-----------------------------------------------------------------------
!
! This routine evaluates shape functions associated to gauss points
! for 1D : NGAUS = 1, 2, 3, 4, 5
!
!-----------------------------------------------------------------------
  use      typre
  implicit none
  integer(ip), intent(in)  :: ngaus
  real(rp),    intent(in)  :: s
  real(rp),    intent(out) :: shaga(ngaus)
  real(rp)                 :: x1,x2,x3,x4,x5

  if(ngaus==1) then
     shaga(1)=1.0_rp
  else if(ngaus==2) then
     shaga(1)= 0.5_rp*sqrt(3.0_rp)*(1.0_rp/sqrt(3.0_rp)-s)
     shaga(2)= 0.5_rp*sqrt(3.0_rp)*(1.0_rp/sqrt(3.0_rp)+s)
  else if(ngaus==3) then
     shaga(1)= 5.0_rp*(s-sqrt(0.6_rp))*s/6.0_rp
     shaga(2)=-5.0_rp*(s-sqrt(0.6_rp))*(s+sqrt(0.6_rp))/3.0_rp
     shaga(3)= 5.0_rp*(s+sqrt(0.6_rp))*s/6.0_rp

!* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!*                                                           *
!* Shaga con lagrange, en puntos de Gauss tomados de ruqope  *
!*                                                           *
!* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  else if(ngaus==4) then
     x1=-0.861136311594053_rp
     x2=-0.339981043584856_rp
     x3= 0.339981043584856_rp
     x4= 0.861136311594053_rp
     shaga(1)= ((s-x2)*(s-x3)*(s-x4))/((x1-x2)*(x1-x3)*(x1-x4))
     shaga(2)= ((s-x1)*(s-x3)*(s-x4))/((x2-x1)*(x2-x3)*(x2-x4))
     shaga(3)= ((s-x1)*(s-x2)*(s-x4))/((x3-x1)*(x3-x2)*(x3-x4))
     shaga(4)= ((s-x1)*(s-x2)*(s-x3))/((x4-x1)*(x4-x2)*(x4-x3))
  else if(ngaus==5) then
     x1 = -0.906179845938664_rp
     x2 = -0.538469310105683_rp
     x3 =  0.0_rp
     x4 =  0.538469310105683_rp
     x5 =  0.906179845938664_rp
     shaga(1)= ((s-x2)*(s-x3)*(s-x4)*(s-x5))/((x1-x2)*(x1-x3)*(x1-x4)*(x1-x5))
     shaga(2)= ((s-x1)*(s-x3)*(s-x4)*(s-x5))/((x2-x1)*(x2-x3)*(x2-x4)*(x2-x5))
     shaga(3)= ((s-x1)*(s-x2)*(s-x4)*(s-x5))/((x3-x1)*(x3-x2)*(x3-x4)*(x3-x5))
     shaga(4)= ((s-x1)*(s-x2)*(s-x3)*(s-x5))/((x4-x1)*(x4-x2)*(x4-x3)*(x4-x5))
     shaga(5)= ((s-x1)*(s-x2)*(s-x3)*(s-x4))/((x5-x1)*(x5-x2)*(x5-x3)*(x5-x4))
  end if

end subroutine shaga1


!-------------------------------------------------------------------------------
!
! Fortran 2008 example that solves Lotka-Volterra ODE using RK4.
!
! $ gfortran -O2 -std=f2008 -o lotka lotka.f90
! $ ./lotka > output.txt
! $ gnuplot -c plot.plt -p
!
!-------------------------------------------------------------------------------
!
! Functions:
!
!     u(t) >= 0 -   Population size of prey at time t.
!     v(t) >= 0 -   Population size of predator at time t.
!
! Equations:
!
!     d/dt u = u * (alpha - beta * v)
!     d/dt v = -v * (gamma - delta * u)
!
! Model Parameters:
!
!     u         -   Prey population.
!     v         -   Predator population.
!     alpha     -   Reproduction rate of prey.
!     beta      -   Death rate of prey by predator.
!     gamma     -   Death rate of predator.
!     delta     -   Reproduction rate of predator by prey.
!
!-------------------------------------------------------------------------------
program main
    use, intrinsic :: iso_fortran_env, only: wp => real64
    implicit none
    real(kind=wp), parameter :: t_max = 30_wp
    real(kind=wp), parameter :: h     = 0.001_wp
    integer,       parameter :: n     = t_max / h
    integer                  :: i
    real(kind=wp)            :: t(n)  = [ (h * i, i = 1,  n) ]
    real(kind=wp)            :: r(2)
    real(kind=wp)            :: x(n), y(n)

    r = [ 20.0_wp, & ! Initial prey population.
           5.0_wp ]  ! Initial predator population.

    do i = 1, n
        x(i) = r(1)
        y(i) = r(2)

        r = r + rk4(r, t(i), h)

        print '(f15.8, 2(" ", f15.8))', t(i), x(i), y(i)
    end do
contains
    function rk4(r, t, h)
        !! Runge-Kutta 4th order solver.
        real(kind=wp), intent(in) :: r(2)   ! Initial values.
        real(kind=wp), intent(in) :: t      ! Step.
        real(kind=wp), intent(in) :: h      ! Step size.
        real(kind=wp)             :: rk4(2)
        real(kind=wp)             :: k1(2), k2(2), k3(2), k4(2)

        k1 = h * f(r,            t)
        k2 = h * f(r + 0.5 * k1, t + 0.5 * h)
        k3 = h * f(r + 0.5 * k2, t + 0.5 * h)
        k4 = h * f(r + k3,       t + h)

        rk4 = (k1 + (2 * k2) + (2 * k3) + k4) / 6
    end function rk4

    function f(r, t)
        !! Lotka-Volterra ODE.
        !!
        !! Point estimates for model parameters taken from:
        !!     https://www.math.tamu.edu/~phoward/m442/modbasics.pdf
        real(kind=wp), parameter  :: alpha = 0.47_wp
        real(kind=wp), parameter  :: beta  = 0.024_wp
        real(kind=wp), parameter  :: delta = 0.023_wp
        real(kind=wp), parameter  :: gamma = 0.76_wp
        real(kind=wp), intent(in) :: r(2)
        real(kind=wp), intent(in) :: t
        real(kind=wp)             :: f(2)
        real(kind=wp)             :: u, v

        u = r(1)
        v = r(2)

        f(1) =  u * (alpha - beta * v)
        f(2) = -v * (gamma - delta * u)
    end function f
end program main


SUBROUTINE force_gm (GM, r, fx,fy,fz )

! ----------------------------------------------------------------------
! SUBROUTINE: force_gm.f90
! ----------------------------------------------------------------------
! Purpose:
! Acceleration due to the central Earth Gravity Field
!  Computation of satellite's acceleration based on Newton's law of gravity
!  considering Earth as a point mass
! ----------------------------------------------------------------------
! Input arguments:
! - r:				position vector (m)
!
! Output arguments:
! - fx,fy,fz:		Acceleration's cartesian components (m)
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	July 2015
! ----------------------------------------------------------------------

      USE mdl_precision
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(3) :: r
      REAL (KIND = prec_q), INTENT(IN) :: GM
! OUT
      REAL (KIND = prec_q), INTENT(OUT) :: fx,fy,fz
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q) :: phi, lamda, radius
      REAL (KIND = prec_q) :: fr
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Numerical Constants
!      GM = GM_global
! ----------------------------------------------------------------------

! computation of spherical coordinates
      CALL coord_r2sph (r , phi,lamda,radius)

! Gradient of geopotential V
      fr = - GM / (radius ** 2)

! Cartesian counterparts (fx,fy,fz) of acceleration fr
      fx = fr * cos(phi) * cos(lamda)
      fy = fr * cos(phi) * sin(lamda)
      fz = fr * sin(phi)

END


SUBROUTINE pearsn(x,y,n,r,prob,z)
INTEGER n
REAL*8 prob,r,z,x(n),y(n),TINY
PARAMETER (TINY=1.e-20)
!CU    USES betai
INTEGER j
REAL*8 ax,ay,df,sxx,sxy,syy,t,xt,yt,betai
ax=0.
ay=0.
do j=1,n
  ax=ax+x(j)
  ay=ay+y(j)
enddo
ax=ax/n
ay=ay/n
sxx=0.
syy=0.
sxy=0.
do j=1,n
  xt=x(j)-ax
  yt=y(j)-ay
  sxx=sxx+xt**2
  syy=syy+yt**2
  sxy=sxy+xt*yt
enddo
r=sxy/(sqrt(sxx*syy)+TINY)
z=0.5*log(((1.+r)+TINY)/((1.-r)+TINY))
df=n-2
t=r*sqrt(df/(((1.-r)+TINY)*((1.+r)+TINY)))
prob=betai(0.5*df,0.5,df/(df+t**2))
!C     prob=erfcc(abs(z*sqrt(n-1.))/1.4142136)
return
END


function funcre(param,npara,ifuge,timev)
!------------------------------------------------------------------------
!
! This function yields a parabolic or periodic evolution
!
!------------------------------------------------------------------------
  use      typre
  use      def_parame
  implicit none
  real(rp)                 :: funcre
  integer(ip), intent(in)  :: npara,ifuge
  real(rp),    intent(in)  :: param(npara),timev
  integer(ip)              :: ipara
  real(rp)                 :: timea,timeb,funca,funcb,zerom,timec
  real(rp)                 :: timei,timef,Tgp,T0,Tp,Tn

  funcre=0.0_rp
  zerom=epsilon(1.0_rp)

  if(ifuge==0) then
!
! No time dependence
!
     funcre=1.0_rp

  else if(ifuge==1) then
!
! Parabolic evolution
!
     if(param(1)-zerom<=timev.and.timev<=param(2)+zerom) then
        funcre=param(3)*timev*timev+param(4)*timev+param(5)
     else if (timev>param(2)+zerom) then
        timea=param(2)
        funcre=param(3)*timea*timea+param(4)*timea+param(5)
     else if (timev<param(1)-zerom) then
        timea=param(1)
        funcre=param(3)*timea*timea+param(4)*timea+param(5)
     end if
  else if(ifuge==2) then

     !Periodic evolution
     !param(1) : tini
     !param(2) : tfin
     !param(3) : amplitude
     !param(4) : frequency
     !param(5) : phase
     !param(6) : mean value

     if(param(1)-zerom<=timev.and.timev<=param(2)+zerom) then
        funcre=param(3)*sin(param(4)*timev+param(5))+param(6)
     else if (timev>param(2)+zerom) then
        timea=param(2)
        funcre=param(3)*sin(param(4)*timea+param(5))+param(6)
     else if (timev<param(1)-zerom) then
        timea=param(1)
        funcre=param(3)*sin(param(4)*timea+param(5))+param(6)
     end if
  else if(ifuge==3) then
!
! Discrete evolution
!
     timei=param(1)
     timef=param((npara/2-1)*2+1)

     if(timev<=timei) then
        funcre=param(2)
     else
        if(timev>=timef) then            ! Look for the time inside the period
           timec=timev
           do while(timec>timef)
              timec=timec-(timef-timei)
           end do
        else
           timec=timev
        end if
        ipara=0
        do while(ipara<npara/2)
           ipara=ipara+1
           if(timec<param((ipara-1)*2+1)) then
              timea=param((ipara-1)*2+1)
              funca=param((ipara-1)*2+2)
              timeb=param((ipara-2)*2+1)
              funcb=param((ipara-2)*2+2)
              funcre=(funcb-funca)/(timeb-timea)*(timec-timea)+funca
              ipara=npara/2
           end if
        end do
     end if

  else if(ifuge==4) then
!
! Special function to change boundary values
!
     funcre=param(2)

  else if(ifuge==5) then
!
! Parabolic discontinuous
!
     if(param(1)-zerom<=timev.and.timev<=param(2)+zerom) then
        funcre=param(5)*timev*timev+param(4)*timev+param(3)
     else if (timev>param(2)+zerom) then
        funcre=param(6)
     else if (timev<param(1)-zerom) then
        funcre=param(7)
     end if
  else if(ifuge==6) then
! Time-Stretched pulse, as appeared in takemoto et al Acoustic analysis of the vocal tract during vowel production by finite-difference time-domain method
    Tgp = 0.646/param(1)
    funcre = exp(-(((timev-Tgp)/(0.29*Tgp))**2))

  else if(ifuge==7) then
! Rosenberg glottal model
  ! param(1) t0 initial time
  ! param(2) tf final time
  ! param(3) A  amplitude factor
  ! param(4) F0 fundamental frequency
  !  fs sampling frequency computed from time step
    if(param(1)-zerom<=timev.and.timev<=param(2)+zerom) then
        timea = timev
    else if (timev>param(2)+zerom) then
        timea = param(2)
    else if (timev<param(1)-zerom) then
        timea = param(1)
    end if
    T0 = 1.0/param(4)
    Tp = 0.4*T0
    Tn = 0.16*T0
    timea = mod(timea,T0)
    if (timea<=Tp) then
        funcre = param(3)*0.5*(1.0-cos(pi*timea/Tp))
    else if(timea<=Tp+Tn) then
        funcre = param(3)*cos(pi*(timea-Tp)/(2.0*Tn))
    else
        funcre = 0.0
    end if

    else if(ifuge==8) then
    ! Constant velocity
      funcre = param(1)*timev + param(2)

    else if(ifuge==9) then
    ! Velocity ramp
      if(timev<=param(1)+zerom) then
         funcre = param(2)*(timev**2.0_rp) + param(3)*timev + param(4)
      else
         !funcre = (2*param(2)*param(1) + param(3))*(timev-param(1)) + (param(2)*(param(1)**2.0_rp) + param(3)*param(1) + param(4))
         funcre = param(2)*(param(1)**2.0_rp) + param(3)*param(1) + param(4)
      endif

    else if(ifuge==10) then
      !Hyperbolic
      funcre = 0.5_rp*(1.0_rp+tanh(8*(timev-param(1))))

    else if(ifuge==11) then
      !Sinusoidal function (Taylor 1998)
      funcre = 1.0_rp + sin(2.0_rp*4.0_rp*atan(1.0_rp)*timev/param(1))
    else if(ifuge==12) then
      !Sinusoidal function (Wall2003)
      funcre = 1.0_rp - cos(2.0_rp*4.0_rp*atan(1.0_rp)*timev/param(1))
      !funcre = cos(2.0_rp*4.0_rp*atan(1.0_rp)*timev/param(1))

  end if

end function funcre


program main
    call q1()
    call q2a()
    call q2b()
    call q2c()
end program main

subroutine q1()
    real matrix(10,10)
    real length(10)
    do j = 1, 10
        do i =1, 10
            matrix(i,j) = cos(i * 0.7 + j + 2)/(i+j-1)
        end do
    end do
    do j = 1, 10
        length(j) = 0
        do i = 1, 10
            length(j) = length(j) + matrix(i, j)
        end do
    end do
    result = Maxval(length)
    write(*,*) "result = ", result
end subroutine q1

subroutine q2a()
    integer prime(300)
    integer cnt
    integer index
    cnt = 0
    index = 1
    do i = 2, 300
        do j = 1 , i - 1
            if (j .GE. 2 .AND. mod(i,j) .EQ. 0) then
                cnt = cnt + 1
                exit
            end if
        end do
        if(cnt .EQ. 0) then
            prime(index) = i
            index = index + 1
        end if
        cnt = 0
    end do
    do i = 1 , index-1
        write(*,*) prime(i)
    end do
end subroutine q2a

subroutine q2b()
    integer prime(300)
    integer cnt
    integer index
    integer i
    cnt = 0
    index = 1
    i = 2
    do while (index < 301)
        do j = 1 , i - 1
            if (j .GE. 2 .AND. mod(i,j) .EQ. 0) then
                cnt = cnt + 1
                exit
            end if
        end do
        if(cnt .EQ. 0) then
            prime(index) = i
            index = index + 1
        end if
        cnt = 0
        i = i + 1
    end do
    write(*,*) "300-th prime number =" ,prime(300)
end subroutine q2b

subroutine q2c()
    integer total
    integer cnt
    cnt = 0
    total = 0
    do i = 2, 10000
        do j = 1, i - 1
            if (j .GE. 2 .AND. mod(i,j) .EQ. 0) then
                cnt = cnt + 1
                exit
            end if
        end do
        if(cnt .EQ. 0) then
            total = total + 1
        end if
        cnt = 0
    end do
    write(*,*) "numbers of primes = ", total
end subroutine q2c


module link1

    !! This module contains subroutines specific to the link1 element
    !!
    !! The link1 element has 2 nodes. Each node has 2 degrees-of-freedom,
    !! namely, displacement along the x- and y-coordinate directions.
    !!
    !!             o N2
    !!            /
    !!           / E1
    !!          /
    !!         o N1
    !!
    !! `N1` = element node 1
    !! `N2` = element node 2
    !! `E1` = element edge 1
    use types
    implicit none
    save

    private
    public :: link1_ke, link1_ss

contains

    subroutine link1_ke(xe, young, area, ke)

        !! This subroutine constructs the stiffness matrix for
        !! a truss element

        real(wp), intent(in) :: young
            !! Young's Modulus for this element
        real(wp), intent(in) :: area
            !! Cross-sectional area of this element
        real(wp), dimension(:), intent(in) :: xe
            !! Nodal coordinate of this element in undeformed configuration
            !!
            !! * `xe(1)` = \(x\)-coordinate of element node 1
            !! * `xe(2)` = \(y\)-coordinate of element node 1
            !! * `xe(3)` = \(x\)-coordinate of element node 2
            !! * `xe(4)` = \(y\)-coordinate of element node 2
            !!
            !! See also [[link1]]
        real(wp), dimension(:,:), intent(out) :: ke
            !! Element stiffness matrix

        real(wp) :: delx, dely, l0, delx2, dely2, delxy, coef

        delx = xe(3) - xe(1)
        dely = xe(4) - xe(2)
        delx2 = delx * delx
        dely2 = dely * dely
        delxy = delx * dely
        l0 = sqrt(delx2 + dely2)

        coef = young*area/l0**3

        ke(1,1) = coef * delx2
        ke(1,2) = coef * delxy
        ke(1,3) = -coef * delx2
        ke(1,4) = -coef * delxy
        ke(2,1) = coef * delxy
        ke(2,2) = coef * dely2
        ke(2,3) = -coef * delxy
        ke(2,4) = -coef * dely2
        ke(3,1) = -coef * delx2
        ke(3,2) = -coef * delxy
        ke(3,3) = coef * delx2
        ke(3,4) = coef * delxy
        ke(4,1) = -coef * delxy
        ke(4,2) = -coef * dely2
        ke(4,3) = coef * delxy
        ke(4,4) = coef * dely2
    end subroutine link1_ke
!
!--------------------------------------------------------------------------------------------------
!
    subroutine link1_ss(xe, de, young, estress, estrain)

        !! This subrotuine constructs the element stress and strain

        real(wp), intent(in) :: young
            !! Young's Modulus of this element
        real(wp), dimension(:), intent(in) :: xe
            !! Nodal coordinate of this element in undeformed configuration (see alse [[link1_ke]])
        real(wp), dimension(:), intent(in) :: de
            !! Displacement field
            !!
            !! * de(1) = displacement along x-axis of element node 1
            !! * de(2) = displacement along y-axis of element node 1
            !! * de(3) = displacement along x-axis of element node 2
            !! * de(4) = displacement along y-axis of element node 2
        real(wp), dimension(:), intent(out) :: estress
            !! Element stress
            !!
            !! * estress(1) = stress on section perpendicular to element axis
            !! * estress(2:) = unused
        real(wp), dimension(:), intent(out) :: estrain
            !! Element strain
            !!
            !! * estrain(1) = strain measured along element axis
            !! * estrain(2:) = unused
        real(wp) :: delx, dely, l0, delx2, dely2, delu, delv

        delx = xe(3) - xe(1)
        dely = xe(4) - xe(2)
        delx2 = delx * delx
        dely2 = dely * dely
        l0 = sqrt(delx2 + dely2)

        delu = de(3) - de(1)
        delv = de(4) - de(2)

        estrain(1) = (delu*delx + delv*dely)/l0**2
        estrain(2:3) = 0
        estress(1) = young * estrain(1)
        estress(2:3) = 0
    end subroutine link1_ss

end module link1


! Interface routine for uni-dimensional optimization through
! the golden section method.
! Igor Lopes, February 2015
SUBROUTINE GOLDENINT
    IMPLICIT NONE
    ! Parameters
    REAL(8) R0 /0.0D0/
    REAL(8) R1 /1.0D0/
    REAL(8) R2 /2.0D0/
    REAL(8) R5 /5.0D0/
    !Locals
    REAL(8),DIMENSION(2) ::  XO
    REAL(8),DIMENSION(4) ::  XF, F
    REAL(8) ::  TOL, GOLD, XI, XMIN, XMAX, FMIN, EVALFUNC1,FI
    INTEGER ::  I , NITER
    CHARACTER STRING*256,ANS*1

    ! Innititalization
    XO=R0; XF=R0

    GOLD=(R1+DSQRT(R5))/R2
    STRING='goldensection.res'
    !
    CALL RESULTFILE(STRING)
    ! Begin algorithm
    WRITE(*,*)'Automatic bounds search?(Y/N)'
    READ(*,*)ANS
    IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')THEN
        WRITE(*,*)'Give a lower limit for X...'
        READ(*,*)XMIN
        WRITE(*,*)'and an upper limit...'
        READ(*,*)XMAX
        WRITE(*,*)'and an initial point for the search.'
        READ(*,*)XI
        FI=EVALFUNC1(XI)
        CALL FINDBOUNDS1D(XI,FI,XO(1),XO(2),XMAX,XMIN)
        WRITE(*,*)'Automatic bounds'
        WRITE(11,*)'Automatic bounds'
        WRITE(*,*)'X_l=',XO(1),'X_u=',XO(2)
        WRITE(11,*)'X_l=',XO(1),'X_u=',XO(2)
        GOTO 10
    ENDIF

    WRITE(*,*)'Insert lower and upper bounds:'
    WRITE(*,*)'X_lower='
    READ(*,*)XO(1)
    WRITE(*,*)'X_upper='
    READ(*,*)XO(2)
10  WRITE(*,*)'Define relative tolerance:'
    READ(*,*)TOL
    WRITE(11,*)'Tolerance:',TOL
    ! Number of iterations
    NITER=INT(LOG(TOL)/LOG(GOLD-R1))+1
    ! Determine minimum
    CALL GOLDENSECTION(XO,XF,F,NITER)
    XMIN=XF(1)
    FMIN=F(1)
    DO I=2,4
        IF(F(I).LT.FMIN)THEN
            FMIN=F(I)
            XMIN=XF(I)
        ENDIF
    ENDDO
    WRITE(*,*) 'Minimum: X_min=',XMIN,' with F_min=',FMIN
    WRITE(11,*) 'Minimum: X_min=',XMIN,' with F_min=',FMIN
    CLOSE(UNIT=11)
END SUBROUTINE


! Compile and run:  make run_gauss_jordan_test

program gauss_jordan_test
  use gauss_jordan
  implicit none

  real, dimension(3, 3) :: A
  real, dimension(3) :: y, x, x_exp
  real, dimension(size(A, 1) + 1, size(A, 2)) :: Ay

  A(1, :) = (/  0,  2,  1 /)
  A(2, :) = (/  1, -2, -3 /)
  A(3, :) = (/ -1,  1,  2 /)
  y       = (/ -8,  0,  3 /)
  x_exp   = (/ -4, -5,  2 /)

  print *
  print "(a)", "Solving matrix equation Ax = y using Gauss-Jordan..."
  print *

  print "(a)", "A:"
  print "(3f6.1)", transpose(A)
  print *

  print "(a)", "y:"
  print "(3f6.1)", y
  print *

  Ay(1:size(A, 1), :) = transpose(A)
  Ay(size(Ay, 1), :) = y
  print "(a)", "Augmented [A | y]:"
  print "(4f6.1)", Ay
  print *

  Ay = upper_triangular(Ay)
  print "(a)", "Upper triangular form:"
  print "(4f6.1)", Ay
  print *

  Ay = substitution(Ay)
  print "(a)", "Substitution:"
  print "(4f6.1)", Ay
  print *

  x = solve(A, y)
  print "(a)", "Answer:"
  print "(3f6.1)", x
  print *

  print "(a)", "Expected answer:"
  print "(3f6.1)", x_exp
  print *
end program gauss_jordan_test


pure subroutine btdbma(aglob,aloca,bmatr,n1,n2)
!**********************************************************************
!
!**** This routine computes Ag = Bt Al B  when Ag and Al are stored
!**** as full matrices (Ag := aglob, Al := aloca, B := bmatr). The di-
!**** mensions are Al -> Mat(n1,n1), Ag -> Mat(n2,n2), B -> Mat(n2,n1)
!
!**********************************************************************
  use      typre
  implicit none
  integer(ip),intent(in)   ::n1,n2
  real(rp),intent(in)      ::aloca(n1,n1), bmatr(n1,n2)
  real(rp),intent(out)     ::aglob(n2,n2)

!  integer(ip)              ::i,j,k,l

! commented by hespinoza on 2013/05/22
!  do i=1,n2
!     do j=1,n2
!        aglob(i,j)=0.0
!        do k=1,n1
!           do l=1,n1
!              aglob(i,j)=aglob(i,j)+bmatr(k,i)*aloca(k,l)*bmatr(l,j)
!           end do
!        end do
!     end do
!  end do

! added by hespinoza on 2013/05/22 to use MATMUL, two variants, profile to see which one is better
!  aglob =  matmul(matmul(transpose(bmatr),aloca),bmatr) ! (B^t A) B
  aglob =  matmul(transpose(bmatr),matmul(aloca,bmatr)) ! B^t (A B)

end subroutine btdbma


! mathematical and physical constants module
module aloha2d_constants

  implicit none

  !--! specific precisions, usually same as real and double precision
  integer, parameter :: r6 = selected_real_kind(6)
  integer, parameter :: r15 = selected_real_kind(15)
  ! Code working precision
  integer, parameter :: wp = 8!kind(1.0D0)
  ! 10 decimals numbers and a dynamic of 10^60
  !     integer, parameter :: wp = selected_real_kind(10,60)

  ! mathematical constants
  real, parameter :: pi = 3.14159265358979323846264338327950288419716939937510
  complex, parameter :: j = (0.0,1.0)   ! Imaginary Unit shortcut
  complex, parameter       :: one = (1.0, 0.0)! Real Unit shortcut
  real, parameter          :: SQRT2 = sqrt(2.0)

  ! physics constants
  real, parameter :: c0 = 299792458.0     ! Vacuum light velocity
  real, parameter :: mu0= 4.0*pi*1.E-7    ! Vacuum permeability
  real, parameter :: Eps0=8.854187E-12    ! Vacuum permittivity
  real, parameter :: Z0 = mu0*c0          ! Vacuum impedance
  real, parameter :: Y0 = 1.0/Z0          ! Vacuum inductance

  ! Electron properties
  real, parameter :: me = 9.10938215E-31  ! Electron mass
  real, parameter :: qe = 1.602176487E-19 ! Electron Electric charge (modulus)
  ! misc.
  real, parameter          :: pc = 1.*1.E-3

  ! Ion species masses
  real, parameter :: mD=3.345E-27     ! Deuton mass
  real, parameter :: mT=5.018E-2     ! Tritium mass
  real, parameter ::  mH=1.673E-27  ! Hydrogen mass
  real, parameter :: mHe=5.018E-27        ! Helium mass

  ! Had-Hoc losses
  real, parameter :: pertes = -10.E-2 ! converge from values > 5E-2
  ! Integration error
  ! relative accuracy requested
  real, parameter :: epsrel = 0.001
  ! absolute accuracy requested
  real, parameter :: epsabs = 0.01
  integer, parameter :: quad_key = 6

end module aloha2d_constants


! compute integral of sin(x) from 0 to pi using the trapezoidal rule
program integral
    implicit none

    real :: sum,x,pi,h
    integer :: i,N

    N = 32
    pi = 4. * atan(1.)
    h = (pi - 0.) / N
    sum = 0.

    do i = 1,N
        x = i * h
        sum = sum + h * (sin(x - h) + sin(x)) / 2
    end do

    write (*,*) sum

end program


!  solve.f90
!
!  FUNCTIONS/SUBROUTINES exported from solve.dll:
!  solve      - AX = B
!
subroutine solve ( A, X, B, N, M, INFO )
    implicit none
  ! Variables
    integer, intent (in) :: N, M !Rank and Solutions

    real*8, dimension(N,N), intent (inout) :: A
    real*8, dimension(N,M), intent (inout) :: X
    real*8, dimension(N,M), intent (in   ) :: B
    integer, dimension(N) :: IPIV
    integer, intent (out) :: INFO !return state of the program

    integer :: LDA, LDB !Leading dimension of A and B
    integer :: NRHS !number of righthandsides

    ! Body of solve
    LDA = N
    LDB = N
    NRHS = M
    X = B
    CALL DGESV( N, NRHS, A, LDA, IPIV, X, LDB, INFO )
end subroutine solve

subroutine invert ( A, N )
    implicit none
  ! Variables
    integer, intent (in) :: N !Rank and Solutions

    real*8, dimension(N,N), intent (inout) :: A
    integer, dimension(N) :: IPIV

    integer :: LDA !Leading dimension of A and B
    integer :: INFO  !return state of the program
    integer :: LWORK !length of array work

    real*8, allocatable, dimension(:) :: WORK

    ! Body of solve
    LDA = N
    LWORK = 3*N-1     !Set size of WORK array
    allocate(WORK(LWORK))
    WORK = 0.0        !Zero the work array
    INFO = 0
    CALL DGETRF( N, N, A, LDA, IPIV, INFO )
    CALL DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
    return
end subroutine invert


!Factorial of number

program Factorial
    implicit none

    INTEGER :: number, i
    INTEGER :: fact = 1

    print *, "Enter the number whose factorial is to be calculted"
    read *, number

    do i = number, 1, -1

        fact = fact*i

    end do

    print '(A13,I4)', "Factorial is ", fact

end program Factorial


module activations
implicit none

contains

pure function sigmoid(z)
	double precision, intent(in) :: z(:)
	double precision, dimension(size(z)) :: sigmoid

	sigmoid = 1.0 / (1.0 + exp(-z))
end function sigmoid

pure function sigmoid_prime(z)
	double precision, intent(in) :: z(:)
	double precision, dimension(size(z)) :: sigmoid_prime

	sigmoid_prime = sigmoid(z) * (1 - sigmoid(z))
end function sigmoid_prime

! maybe we will move this to another module later
function cost(output, target)
	double precision, intent(in) :: output(:)
	double precision, intent(in) :: target(:)
	double precision :: cost

	cost = 0.5 * sum((target - output)**2)
end function cost

end module activations


      FUNCTION DQS_OHD (T)

      IMPLICIT NONE

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CC  PURPOSE:  TO CALCULATE VALUES OF VAPOR PRESSURE (E)
CC            AND P * DQS/DT (P TIMES CHG IN SAT MXG RATIO WITH RESPECT
CC            TO THE CHG IN TEMP) IN SUBSTITUTION TO THE LOOK-UP TABLES.
CC
CC            SUBSTITUTES LOOK-UP TABLES ASSOCIATED WITH THE DATA
CC            BLOCK  /CHMXR/ .
CC
CC            FORMULAS AND CONSTANTS FROM ROGERS AND YAU, 1989.
CC
CC                         ADDED BY PABLO J. GRUNMANN, 6/30/97.
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      REAL DESDT
      REAL DQS_OHD
      REAL LW
      REAL T
      REAL ES
      REAL CPV
      REAL RV
      REAL CW
      REAL EPS
      REAL ESO
      REAL TO
      REAL LVH2O

      PARAMETER (LVH2O = 2.501000E+6)
      PARAMETER (CPV = 1870.)
      PARAMETER  (RV = 461.5)
      PARAMETER ( CW = 4187.)
      PARAMETER (EPS =  0.622)
      PARAMETER (ESO =  611.2)
      PARAMETER ( TO =  273.16)
C
C     ABOUT THE PARAMETERS:
C
C     EPS ---------- WATER - DRY AIR MOLECULAR MASS RATIO, EPSILON
C
C   VALUES FOR SPECIFIC HEAT CAPACITY AND INDIVIDUAL GAS CONSTANTS
C   IN [JOULES/(KG*KELVIN)] UNITS.

C     DRY AIR:
C             CP, CV
C     WATER VAPOR:
C                 CVV = 1410.
C                 CPV = 1870.
C                 RV  =  461.5
C     LIQUID WATER:
C                  CW = 4187.

C     ESO = ES(T=273.16 K) = SAT. VAPOR PRESSURE (IN PASCAL) AT T=TO
C      TO = 273.16

C     SAT. MIXING  RATIO: QS ~= EPS*ES/P
C     CLAUSIUS-CLAPEYRON: DES/DT = L*ES/(RV*T^2)
C     @QS/@T =  (EPS/P)*DES/DT
C
          LW = LVH2O - ( CW - CPV ) * ( T - TO )
          ES = ESO*EXP (LW*(1/TO - 1/T)/RV)
          DESDT = LW*ES/(RV*T*T)

C      FOR INSERTION IN DQSDT FUNCTION:
C      DQSDT = DQS/P , WHERE DQS = EPS*DESDT

          DQS_OHD = EPS*DESDT

          RETURN
          END


MODULE CONVERT_MOD

! The Conversion Module contains all the procedures necessary to convert
!  locations between latitude and longitude coordinates and metric (x and y)
!  coordinates.  The default setting assumes a spherical earth
!  (SphericalProjection = .TRUE. in LTRANS.data). This code is based on the
!  equations in earthdist.m from Seagrid which was written by Rich Signel.
!  These equations and the inverse of earthdist.m were coded in Fortran by
!  Elizabeth North.
!
!  If the user specifies (SphericalProjection = .FALSE. in LTRANS.data), then
!  a Mercator projection is used. The equations are from the sg_mercator.m and
!  seagrid2roms.m matlab scripts that are found in Seagrid.
!
!  This Conversion Module module contains four interface blocks to cover the
!  four necessary conversions:
!
!  lon2x = convert longitude to x-coordinate
!  lat2y = convert latitude  to y-coordinate
!  x2lon = convert x-coordinate to longitude
!  y2lat = convert y-coordinate to latitude.
!
!  NOTE: The Interface blocks were created so that the functions can handle
!        both REAL and DOUBLE PRECISION variables as input
!  NOTE: Output is DOUBLE PRECISION regardless of input
!  NOTE: RCF = radian conversion factor (RCF = 180/pi)
!  NOTE: The values of lonmin and latmin which are specified in LTRANS.data by
!        the user are altered in the PARAMETER MODULE. 1 is subtracted from
!        each. This is done to ensure that there are no problems that could
!        result from rounding by the user.
!
!  The functions used to make these conversions are as follows:

!  Spherical Projection:
!   x&y = acos(ax*bx + ay*by + az*bz) * Earth_Radius
!   Note: both x & y are calculated as the arclength of the central angle
!     between the two vectors [ax,ay,az] and [bx,by,bz] multiplied by the
!     Earth's radius
!   lon = lonmin + RCF*acos( (cos(x/Earth_Radius) - sin(lat)*sin(lat)) /
!                                                  (cos(lat)*cos(lat)) )
!   lat = y * RCF / Earth_Radius + latmin

!  Mercator Projection:
!   x   = lon / RCF * Earth_Radius
!   y   = log( tan( pi/4.0 + lat/(RCF*2.0) ))*Earth_Radius
!   lon = x / Earth_Radius * RCF
!   lat = 2.0*RCF * ( atan(exp(y/Earth_Radius)) - pi/4.0 )
!
! Created by:           Zachary Schlag
! Created on:           23 Jul 2008

! Last modified on:     08 Jul 2015
! Last modified by:     K.A.S. Mislan
! Last modification:    Added code to correctly convert grids that span >180 deg

USE PARAM_MOD, ONLY: PI,Earth_Radius,SphericalProjection,lonmin,latmin
IMPLICIT NONE
PRIVATE
SAVE

  !Return x location given longitude
  INTERFACE lon2x
    MODULE PROCEDURE rlon2x  !real input
    MODULE PROCEDURE dlon2x  !double precision input
  END INTERFACE lon2x

  !Return y location given latitude
  INTERFACE lat2y
    MODULE PROCEDURE rlat2y  !real input
    MODULE PROCEDURE dlat2y  !double precision input
  END INTERFACE lat2y

  !Return longitude given x location
  INTERFACE x2lon
    MODULE PROCEDURE rx2lon  !real input
    MODULE PROCEDURE dx2lon  !double precision input
  END INTERFACE x2lon

  !Return latitude given y location
  INTERFACE y2lat
    MODULE PROCEDURE ry2lat  !real input
    MODULE PROCEDURE dy2lat  !double precision input
  END INTERFACE y2lat

  !The following procedures have been made public for the use of other modules:
  PUBLIC :: lon2x,lat2y,x2lon,y2lat

CONTAINS

  DOUBLE PRECISION FUNCTION rlon2x(lon,lat)
    IMPLICIT NONE
    REAL, INTENT(IN) :: lon
    REAL, INTENT(IN), OPTIONAL :: lat
    DOUBLE PRECISION :: RCF  ! Radian conversion factor
    DOUBLE PRECISION :: c,ax,ay,az,bx,by,bz,alon,alat,blon,blat,x180,xtralon

    RCF = DBLE(180.0) / PI

    if(SphericalProjection)then
      if( present(lat) )then

        if((lon-lonmin) .gt. 180.0)then
          alon = 180.0
          alat = lat
          blon = 0
          blat = lat

          alon = alon / RCF
          alat = alat / RCF
          blon = blon / RCF
          blat = blat / RCF

          c  = cos(alat)
          ax = c * cos(alon)
          ay = c * sin(alon)
          az = sin(alat)

          c  = cos(blat)
          bx = c * cos(blon)
          by = c * sin(blon)
          bz = sin(blat)

          x180 = acos(ax*bx + ay*by + az*bz) * Earth_Radius

          alon = lon
          blon = lonmin+180.0

          alon = alon / RCF
          blon = blon / RCF

          ax = c * cos(alon)
          ay = c * sin(alon)
          bx = c * cos(blon)
          by = c * sin(blon)

          xtralon = acos(ax*bx + ay*by + az*bz) * Earth_Radius
          rlon2x = x180 + xtralon
        else
          alon = lon
          alat = lat
          blon = lonmin
          blat = lat

          alon = alon / RCF
          alat = alat / RCF
          blon = blon / RCF
          blat = blat / RCF

          c  = cos(alat)
          ax = c * cos(alon)
          ay = c * sin(alon)
          az = sin(alat)

          c  = cos(blat)
          bx = c * cos(blon)
          by = c * sin(blon)
          bz = sin(blat)

          rlon2x = acos(ax*bx + ay*by + az*bz) * Earth_Radius
        endif
      else
        write(*,*) "Problem lon2x: spherical projection without lat value"
      endif
    else
      rlon2x = lon / RCF * Earth_Radius
    endif

  END FUNCTION rlon2x

  DOUBLE PRECISION FUNCTION dlon2x(lon,lat)
    IMPLICIT NONE
    DOUBLE PRECISION, INTENT(IN) :: lon
    DOUBLE PRECISION, INTENT(IN), OPTIONAL :: lat
    DOUBLE PRECISION :: RCF  ! Radian conversion factor
    DOUBLE PRECISION :: c,ax,ay,az,bx,by,bz,alon,alat,blon,blat,x180,xtralon

    RCF = DBLE(180.0) / PI

    if(SphericalProjection)then
      if( present(lat) )then

	dlon2x = (lon-lonmin)/180.0 * Earth_Radius * pi * cos(lat/RCF)

      else
        write(*,*) "Problem lon2x: spherical projection without lat value"
      endif
    else
      dlon2x = lon / RCF * Earth_Radius
    endif

  END FUNCTION dlon2x

  DOUBLE PRECISION FUNCTION rlat2y(lat,lon)
    IMPLICIT NONE
    REAL, INTENT(IN) :: lat
    DOUBLE PRECISION, INTENT(IN), OPTIONAL :: lon
    DOUBLE PRECISION :: RCF  ! Radian conversion factor
    DOUBLE PRECISION :: c,ax,ay,az,bx,by,bz,alon,alat,blon,blat

    RCF = DBLE(180.0) / PI

    if(SphericalProjection) then
      if( present(lon) )then
        alon = lon
        alat = lat
        blon = lon
        blat = latmin
      else
	alon = lonmin
	alat = lat
        blon = lonmin
        blat = latmin
      endif

      alon = alon / RCF
      alat = alat / RCF
      blon = blon / RCF
      blat = blat / RCF

      c = cos(alat)
      ax = c * cos(alon)
      ay = c * sin(alon)
      az = sin(alat)

      c = cos(blat)
      bx = c * cos(blon)
      by = c * sin(blon)
      bz = sin(blat)

      rlat2y = acos(ax*bx + ay*by + az*bz) * Earth_Radius

    else

      rlat2y = log( tan( pi/4.0 + lat/(RCF*2.0) ))*Earth_Radius

    endif

  END FUNCTION rlat2y

  DOUBLE PRECISION FUNCTION dlat2y(lat)
    IMPLICIT NONE
    DOUBLE PRECISION, INTENT(IN) :: lat
    DOUBLE PRECISION :: RCF  ! Radian conversion factor
    DOUBLE PRECISION :: c,ax,ay,az,bx,by,bz,alon,alat,blon,blat

    RCF = DBLE(180.0) / PI

    if(SphericalProjection) then

      dlat2y = (lat-latmin)*Earth_Radius*pi/180.0

    else

      dlat2y = log( tan( pi/4.0 + lat/(RCF*2.0) ))*Earth_Radius

    endif

  END FUNCTION dlat2y

  DOUBLE PRECISION FUNCTION rx2lon(x,y)
    IMPLICIT NONE
    REAL, INTENT(IN) :: x
    REAL, INTENT(IN), OPTIONAL :: y
    DOUBLE PRECISION :: RCF  ! Radian conversion factor
    DOUBLE PRECISION :: lat,c,ax,ay,az,bx,by,bz,alon,alat,blon,blat,x180

    RCF = DBLE(180.0) / PI

    if(SphericalProjection) then

      if( PRESENT(y) )then
        lat = (y * RCF / Earth_Radius + latmin) / RCF

        alon = 0
        alat = lat
        blon = 180.0
        blat = lat

        alon = alon / RCF
        blon = blon / RCF

        c  = cos(alat)
        ax = c * cos(alon)
        ay = c * sin(alon)
        az = sin(alat)

        c  = cos(blat)
        bx = c * cos(blon)
        by = c * sin(blon)
        bz = sin(blat)

        x180 = acos(ax*bx + ay*by + az*bz) * Earth_Radius

        if(x .gt. x180)then

          rx2lon = lonmin + 180.0 + RCF*acos( (cos((x180-x)/Earth_Radius) - sin(lat)*sin(lat)) &
                                                          / (cos(lat)*cos(lat)) )
        else
          rx2lon = lonmin + RCF*acos( (cos(x/Earth_Radius) - sin(lat)*sin(lat)) &
                                                        / (cos(lat)*cos(lat)) )
        endif
      else
        write(*,*) "Problem x2lon: Spherical projection without y value"
      endif

    else
      rx2lon = x / Earth_Radius * RCF
    endif

  END FUNCTION rx2lon

  DOUBLE PRECISION FUNCTION dx2lon(x,y)
    IMPLICIT NONE
    DOUBLE PRECISION, INTENT(IN) :: x
    DOUBLE PRECISION, INTENT(IN), OPTIONAL :: y
    DOUBLE PRECISION :: RCF  ! Radian conversion factor
    DOUBLE PRECISION :: lat,c,ax,ay,az,bx,by,bz,alon,alat,blon,blat,x180

    RCF = DBLE(180.0) / PI

    if(SphericalProjection) then

      if( PRESENT(y) )then
        lat = y*180.0/(Earth_Radius*pi) + latmin

	dx2lon = x*180.0 / (Earth_Radius * pi * cos(lat/RCF)) + lonmin

      else
        write(*,*) "Problem x2lon: Spherical projection without y value"
      endif

    else
      dx2lon = x / Earth_Radius * RCF
    endif

  END FUNCTION dx2lon

  DOUBLE PRECISION FUNCTION ry2lat(y)
    IMPLICIT NONE
    REAL, INTENT(IN) :: y
    DOUBLE PRECISION :: RCF  ! Radian conversion factor

    RCF = DBLE(180.0) / PI

    if(SphericalProjection) then
      ry2lat = y * RCF / Earth_Radius + latmin
    else
      ry2lat = 2.0*RCF * ( atan(exp(y/Earth_Radius)) - pi/4.0 )
    endif

  END FUNCTION ry2lat

  DOUBLE PRECISION FUNCTION dy2lat(y)
    IMPLICIT NONE
    DOUBLE PRECISION, INTENT(IN) :: y
    DOUBLE PRECISION :: RCF  ! Radian conversion factor

    RCF = DBLE(180.0) / PI

    if(SphericalProjection) then
	dy2lat = y * RCF / Earth_Radius + latmin
    else
      dy2lat = 2.0*RCF * ( atan(exp(y/Earth_Radius)) - pi/4.0 )
    endif

  END FUNCTION dy2lat

END MODULE CONVERT_MOD


module fft_mod
    implicit none
    integer,       parameter :: dp=selected_real_kind(15,300)
    real(kind=dp), parameter :: pi=3.141592653589793238460_dp

contains

  ! In place Cooley-Tukey FFT
recursive subroutine fft(x)
    complex(kind=dp), dimension(:), intent(inout)   :: x
    complex(kind=dp)                                :: t
    integer                                         :: N
    integer                                         :: i
    complex(kind=dp), dimension(:), allocatable     :: even, odd

    N=size(x)

    if(N .le. 1) return

    allocate(odd((N+1)/2))
    allocate(even(N/2))

    ! divide
    odd =x(1:N:2)
    even=x(2:N:2)

    ! conquer
    call fft(odd)
    call fft(even)

    ! combine
    do i=1,N/2

       t=exp(cmplx(0.0_dp,-2.0_dp*pi*real(i-1,dp)/real(N,dp),KIND=DP))*even(i)

       x(i)     = odd(i) + t
       x(i+N/2) = odd(i) - t

    end do

    deallocate(odd)
    deallocate(even)

  end subroutine fft

end module fft_mod

program test
    use fft_mod
    implicit none
    complex(kind=dp), dimension(8)                    :: data = (/1.0, 1.0, 1.0, 1.0, 0.0, 0.0, 0.0, 0.0/)
    real(kind=dp)                                     :: mag, phase
    integer                                           :: i

    call fft(data)

    do i=1,8
        write(*,'("(", F20.15, ",", F20.15, "i )")') data(i)
        mag = sqrt(real(data(i))**2 + aimag(data(i))**2)

        if (real(data(i)) .ne. 0.0) then
            phase = (atan(aimag(data(i))/real(data(i))))*(180.0_dp/pi)
        else
            phase = 0
        end if

        write (*,*) 'The magnitude is ->', mag, 'amps.'
        write (*,*) 'The phase is ->', phase, 'degrees.'
        print *
    end do

end program test


! Fortran 2008 Print Fibonacci
! This program prints a user specified number of numbers from the
!     fibonacci sequence, starting at 0. Uses iteration to determine
!     the fibonacci numbers

program print_fibos
	implicit none
	! Use 128-bit integers
	integer(16) :: x, k, n
	integer(16) :: fibo0 = 0
	integer(16) :: fibo1 = 1

	! Get input from user
	write (*, '(A$)') "How many fibonacci numbers should be printed? "
	read *, k

	if (k == 1) then
		print *, fibo0
	else if (k == 2) then
		print *, fibo0
		print *, fibo1
 	else
		print *, fibo0
		print *, fibo1
		do n=3, k, 1
			x = fibo1 + fibo0
			fibo0 = fibo1
			fibo1 = x
			print *, fibo1
		enddo
	end if
end


Program q1106   !Trapezoidal method for definite integral
implicit none
    integer n, i
    real S, dx, a, b
    real ubound, lbound
    real, external ::trapezoid, f

    read(*,*)a, b, n
        dx = (b-a)/n
        S = 0
    do i = 1, n
       ubound = f((a+(i-1))*dx)
	   lbound = f(b-(n-i)*dx)
	   S = S + trapezoid(ubound,lbound,dx)
    end do
    write(*,"(F0.2)")S
end program q1106

real function trapezoid(ubound,lbound,dx)
implicit none
    real,intent(in)::ubound,lbound,dx
        trapezoid = (ubound+lbound)*dx/2.
    return
end function trapezoid

real function f(x)
implicit none
    real,intent(in) :: x
	    f=x**2
    return
end function f


! =================================================
!   Jocobi iteration (point) method to solve linear
!       equation system 'Ax = b'.
! =================================================

subroutine iter_ja_p(A, b, x, iter_cr, iter_max)

    use coordinates, only: Nx, Ny
    use log_config,  only: log_conv_show
    implicit none

    integer*4, parameter     :: n = Nx*Ny
    real*8,    intent(in)    :: A(n,n)
    real*8,    intent(in)    :: b(n)
    real*8,    intent(inout) :: x(n)
    real*8,    intent(in)    :: iter_cr
    integer*4, intent(in)    :: iter_max

    real*8    :: x0(n)
    real*8    :: iter_err, tmp
    integer*4 :: iter_cnt
    integer*4 :: I, J

    x0 = 0
    iter_cnt = 1
    do while (iter_cnt < iter_max)

        do I = 1, n
            tmp = 0.
            do J = 1, I - 1
                tmp = tmp + A(I,J)*x(J)
            end do
            do J = I + 1, n
                tmp = tmp + A(I,J)*x(J)
            end do
            x(I) = (b(I) - tmp)/A(I,I)
        end do

        iter_err = maxval(abs(x - x0)/x0)
        if (log_conv_show) print *, "", iter_cnt,  iter_err
        if (iter_err < iter_cr) exit

        x0 = x
        iter_cnt = iter_cnt + 1

    end do

end subroutine


! jacobi2d_main_omp.f90

program jacobi2d_main
    implicit none
    real(kind=8) :: tol, dumax
    integer :: n,iter,maxiter,nthreads

    n = 120
    tol = 0.1 / (n+1)**2
    tol = 1.d-6
    maxiter = 100000

	print "('Solving Laplace equation on',i4,' by',i4,' grid by Jacobi iteration')", n,n
	print "('Note: This is a lousy numerical method but illustrates OpenMP speedup')"
	print *,' '

    ! Specify number of threads to use:
    nthreads = 1
    call jacobi2d_sub(n, tol, maxiter, iter, dumax, nthreads)

    nthreads = 3
    call jacobi2d_sub(n, tol, maxiter, iter, dumax, nthreads)

end program jacobi2d_main


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

REAL,ALLOCATABLE :: nums(:)
INTEGER :: length
INTEGER :: i
REAL, EXTERNAL :: RMS

WRITE (*,*) 'Please input the data'' length:'
READ  (*,*) length
ALLOCATE(nums(length))
WRITE (*,*) 'Please input numbers:'
DO i = 1, length
    READ  (*,*) nums(i)
END DO

WRITE (*,*) 'The RMS of those number is ', RMS(nums, length)
DEALLOCATE(nums)
END PROGRAM main

! 求均方根平均值的函数
REAL FUNCTION RMS(nums,length)
IMPLICIT NONE

INTEGER :: length
REAL :: nums(length)
INTEGER :: i

RMS = SQRT(SUM(nums*nums)/length)
RETURN
END FUNCTION RMS


      PROGRAM MAIN
C     GAUSSIAN ELIMINATION
C     From: http://users.metu.edu.tr/azulfu/courses/es361/programs/fortran/GAUEL.FOR

      IMPLICIT NONE
      REAL, DIMENSION (20,21) :: A
      INTEGER :: I, J, N

 10   FORMAT(/,' GAUSS ELIMINATION')
      WRITE (*,10)

C INITIALIZATION
C      DATA  N/4/
C      DATA  (A(1,J), J=1,5) /-40.0,28.5,0.,0.,1.81859/
C      DATA  (A(2,J), J=1,5) /21.5,-40.0,28.5,0.,-1.5136/
C      DATA  (A(3,J), J=1,5) /0.,21.5,-40.0,28.5,-0.55883/
C      DATA (A(4,J), J=1,5) /0.,0.,21.5,-40.0,1.69372/

      N = 4

 11   FORMAT(5(X,F8.2))
      OPEN(10, FILE="INFILE-GAUSSIAN")

      DO I = 1, N
         READ (10,11) A(I,1), A(I,2), A(I,3), A(I,4), A(I,5)
      END DO
      CLOSE(10)
C END INITIALIZATION

 12   FORMAT(/,' AUGMENTED MATRIX',/)
      WRITE(*,12)

61    FORMAT(5(1X,f8.4))
      DO I=1,N
      WRITE(*, 61) A(I,1), A(I,2), A(I,3), A(I,4), A(I,5)
      END DO

 13   FORMAT('')
 14   FORMAT(' SOLUTION')
 15   FORMAT(' ...........................................')
 16   FORMAT('         I       X(I)')

      WRITE(*,13)

      CALL GAUSS(N,A)

      WRITE(*,13)
      WRITE(*,14)
      WRITE(*,15)
      WRITE(*,16)
      WRITE(*,15)

72    FORMAT(5X,I5, F12.6)

      DO I=1,N
          WRITE (*,72) I, A(I,N+1)
      END DO

      WRITE(*,15)
      WRITE(*,13)

      STOP
      END PROGRAM MAIN
C*************************************
      SUBROUTINE GAUSS(N,A)

      REAL, DIMENSION(20,21) :: A
      INTEGER PV, I, J, K, N, R, JC, JR, KC, NV
      REAL :: EPS, EPS2, DET, TM, TEMP, VA

      EPS=1.0
      DO WHILE (1.0+EPS.GT.1.0)
          EPS=EPS/2.0
      END DO
      EPS=EPS*2

 11   FORMAT ('      MACHINE EPSILON=',E16.8)
      WRITE(*,11) EPS

      EPS2=EPS*2

1005  DET=1.0
      DO 1010 I=1,N-1
         PV=I
         DO J=I+1,N
            IF (ABS(A(PV,I)) .LT. ABS(A(J,I))) PV=J
         END DO
         IF (PV.NE.I) THEN
             DO JC=1,N+1
              TM=A(I,JC)
              A(I,JC)=A(PV,JC)
              A(PV,JC)=TM
            END DO
1045        DET=-1*DET
        END IF

1050    IF (A(I,I).EQ.0.0) THEN
            STOP 'MATRIX IS SINGULAR'
        END IF

        DO JR=I+1,N
           IF (A(JR,I).NE.0.0) THEN
              R=A(JR,I)/A(I,I)
              DO KC=I+1,N+1
              TEMP=A(JR,KC)
              A(JR,KC)=A(JR,KC)-R*A(I,KC)
              IF (ABS(A(JR,KC)).LT.EPS2*TEMP) A(JR,KC)=0.0
            END DO
          END IF
1060     END DO
1010  CONTINUE
      DO I=1,N
         DET=DET*A(I,I)
      END DO

 12   FORMAT(/,'  DETERMINANT= ',F16.5,/)
      WRITE(*,12) DET

      IF (A(N,N).EQ.0.0) THEN
          STOP 'MATRIX IS SINGULAR'
      END IF

      A(N,N+1)=A(N,N+1)/A(N,N)
      DO NV=N-1,1,-1
         VA=A(NV,N+1)
         DO K=NV+1,N
            VA=VA-A(NV,K)*A(K,N+1)
         END DO
         A(NV,N+1)=VA/A(NV,NV)
      END DO
      RETURN
1100  CONTINUE
      RETURN

      END


      double precision function deter3(r)
      implicit none
      double precision r(3,3)
c
c     return the determinant of a 3x3 matrix
c
      deter3 =
     $     r(1,1)*(r(2,2)*r(3,3)-r(2,3)*r(3,2)) -
     $     r(1,2)*(r(2,1)*r(3,3)-r(2,3)*r(3,1)) +
     $     r(1,3)*(r(2,1)*r(3,2)-r(2,2)*r(3,1))
c
      end


subroutine inverse(a,c,n)
!============================================================
! Inverse matrix
! Method: Based on Doolittle LU factorization for Ax=b
! Alex G. December 2009
!-----------------------------------------------------------
! input ...
! a(n,n) - array of coefficients for matrix A
! n      - dimension
! output ...
! c(n,n) - inverse matrix of A
! comments ...
! the original matrix a(n,n) will be destroyed
! during the calculation
!===========================================================
implicit none
integer n
double precision a(n,n), c(n,n)
double precision L(n,n), U(n,n), b(n), d(n), x(n)
double precision coeff
integer i, j, k

! step 0: initialization for matrices L and U and b
! Fortran 90/95 aloows such operations on matrices
L=0.0
U=0.0
b=0.0

! step 1: forward elimination
do k=1, n-1
   do i=k+1,n
      coeff=a(i,k)/a(k,k)
      L(i,k) = coeff
      do j=k+1,n
         a(i,j) = a(i,j)-coeff*a(k,j)
      end do
   end do
end do

! Step 2: prepare L and U matrices
! L matrix is a matrix of the elimination coefficient
! + the diagonal elements are 1.0
do i=1,n
  L(i,i) = 1.0
end do
! U matrix is the upper triangular part of A
do j=1,n
  do i=1,j
    U(i,j) = a(i,j)
  end do
end do

! Step 3: compute columns of the inverse matrix C
do k=1,n
  b(k)=1.0
  d(1) = b(1)
! Step 3a: Solve Ld=b using the forward substitution
  do i=2,n
    d(i)=b(i)
    do j=1,i-1
      d(i) = d(i) - L(i,j)*d(j)
    end do
  end do
! Step 3b: Solve Ux=d using the back substitution
  x(n)=d(n)/U(n,n)
  do i = n-1,1,-1
    x(i) = d(i)
    do j=n,i+1,-1
      x(i)=x(i)-U(i,j)*x(j)
    end do
    x(i) = x(i)/u(i,i)
  end do
! Step 3c: fill the solutions x(n) into column k of C
  do i=1,n
    c(i,k) = x(i)
  end do
  b(k)=0.0
end do
end subroutine inverse


SUBROUTINE stencilf90(A, B, n, iters)
    IMPLICIT NONE
    INTEGER, INTENT( IN ) :: n, iters
    DOUBLE PRECISION, DIMENSION (n,n,n) :: A, B
    DOUBLE PRECISION :: c
    INTEGER :: count

    c = 1 / 7.

    DO count=1,iters
        A(2:N-1,2:N-1,2:N-1) = c * (B(2:N-1,2:N-1,2:N-1) + B(3:N,2:N-1,2:N-1) &
           + B(1:N-2,2:N-1,2:N-1) + B(2:N-1,3:N,2:N-1) + B(2:N-1,1:N-2,2:N-1) &
           + B(2:N-1,2:N-1,3:N) + B(2:N-1,2:N-1,1:N-2))

        B(2:N-1,2:N-1,2:N-1) = c * (A(2:N-1,2:N-1,2:N-1) + A(3:N,2:N-1,2:N-1) &
           + A(1:N-2,2:N-1,2:N-1) + A(2:N-1,3:N,2:N-1) + A(2:N-1,1:N-2,2:N-1) &
           + A(2:N-1,2:N-1,3:N) + A(2:N-1,2:N-1,1:N-2))
    END DO
END SUBROUTINE