module integration

! Routines for calculating numerical integrals

use types, only: dp
use constants, only: pi
implicit none
private
public integrate_trapz_1, integrate_trapz_3, integrate_trapz_5, &
    integrate_trapz_7, integrate_simpson

contains

real(dp) pure function integrate_trapz_1(Rp, f) result(s)
real(dp), intent(in) :: Rp(:), f(:)
real(dp) :: g(size(Rp))
integer :: N
N = size(Rp)
g = f * Rp
s = (g(1) + g(N)) / 2
s = s + sum(g(2:N-1))
end function

real(dp) pure function integrate_trapz_3(Rp, f) result(s)
real(dp), intent(in) :: Rp(:), f(:)
real(dp) :: g(size(Rp))
integer :: N
N = size(Rp)
g = f * Rp
s = (9 * (g(1) + g(N)) + 28 * (g(2) + g(N-1)) + 23 * (g(3) + g(N-2))) / 24
s = s + sum(g(4:N-3))
end function

real(dp) pure function integrate_trapz_5(Rp, f) result(s)
real(dp), intent(in) :: Rp(:), f(:)
real(dp) :: g(size(Rp))
integer :: N
N = size(Rp)
g = f * Rp
s = (  475 * (g(1) + g(N  )) &
    + 1902 * (g(2) + g(N-1)) &
    + 1104 * (g(3) + g(N-2)) &
    + 1586 * (g(4) + g(N-3)) &
    + 1413 * (g(5) + g(N-4)) &
    ) / 1440
s = s + sum(g(6:N-5))
end function

real(dp) pure function integrate_trapz_7(Rp, f) result(s)
real(dp), intent(in) :: Rp(:), f(:)
real(dp) :: g(size(Rp))
integer :: N
N = size(Rp)
g = f * Rp
s = (  36799 * (g(1) + g(N  )) &
    + 176648 * (g(2) + g(N-1)) &
    +  54851 * (g(3) + g(N-2)) &
    + 177984 * (g(4) + g(N-3)) &
    +  89437 * (g(5) + g(N-4)) &
    + 130936 * (g(6) + g(N-5)) &
    + 119585 * (g(7) + g(N-6)) &
    ) / 120960
s = s + sum(g(8:N-7))
end function

real(dp) pure function integrate_simpson(Rp, f) result(s)
real(dp), intent(in) :: Rp(:), f(:)
real(dp) :: g(size(Rp))
integer :: i, N
N = size(Rp)
g = f * Rp
s = 0
do i = 2, N-1, 2
    s = s + g(i-1) + 4*g(i) + g(i+1)
end do
s = s / 3
if (modulo(N, 2) == 0) then
    ! If N is even, add the last slice separately
    s = s + (5*g(N) + 8*g(N-1) - g(N-2)) / 12
end if
end function

end module


program select_precision_test
    implicit none
    integer, parameter :: sp = selected_real_kind(p=6, r=30), &
                          dp = selected_real_kind(p=12, r=100), &
                          int = selected_int_kind(r=8), &
                          long = selected_int_kind(r=12)
    real(kind=sp) :: x
    real(kind=dp) :: y
    integer(Kind=int) :: m
    integer(Kind=long) :: n

    x = 1.0_sp/3.0_sp
    y = 1.0_dp/3.0_dp
    print *, x, y
    print *, sp, dp

    m = 2_int**30_int
    n = 2_long**40_long
    print *, m, n
    print *, int, long

end program select_precision_test


        function clebsch_gordan(j1,m1,j2,m2,j,m)
          implicit none
!     calculate a clebsch-gordan coefficient < j1/2 m1/2 j2/2 m2/2 | j/2 m/2 >
!     arguments are integer and twice the true value.

        real*8    :: cleb,factor,sum,binom
        real*8    :: clebsch_gordan
        integer :: j1,m1,j2,m2,j,m,par,z,zmin,zmax

!     some checks for validity (let's just return zero for bogus arguments)

        if (2*(j1/2)-int(2*(j1/2.0)).ne.2*(abs(m1)/2)-
     &     int(2*(abs(m1)/2.0)) .or.
     &     2*(j2/2)-int(2*(j2/2.0)).ne.2*(abs(m2)/2)-
     &     int(2*(abs(m2)/2.0)) .or.
     &     2*(j/2)-int(2*(j/2.0)).ne.2*(abs(m)/2)-
     &     int(2*(abs(m)/2.0)) .or.
     &     j1.lt.0 .or. j2.lt.0 .or. j.lt.0 .or. abs(m1).gt.j1 .or.
     &     abs(m2).gt.j2 .or.
     &     abs(m).gt.j .or. j1+j2.lt.j .or. abs(j1-j2).gt.j .or.
     &     m1+m2.ne.m) then

           cleb= 0.0
        else

           factor = 0.0
           factor = binom(j1,(j1+j2-j)/2) /
     &                binom((j1+j2+j+2)/2,(j1+j2-j)/2)
           factor = factor * binom(j2,(j1+j2-j)/2) /
     &                binom(j1,(j1-m1)/2)
           factor = factor / binom(j2,(j2-m2)/2) / binom(j,(j-m)/2)
           factor = sqrt(factor)

           zmin = max(0,j2+(j1-m1)/2-(j1+j2+j)/2,
     &                j1+(j2+m2)/2-(j1+j2+j)/2)
           zmax = min((j1+j2-j)/2,(j1-m1)/2,(j2+m2)/2)

           sum=0.0
           do z = zmin,zmax
              par=1
              if(2*(z/2)-int(2*(z/2.0)) /= 0) par=-1
              sum=sum+par*binom((j1+j2-j)/2,z)*
     &          binom((j1-j2+j)/2,(j1-m1)/2-z)*
     &          binom((-j1+j2+j)/2,(j2+m2)/2-z)
           end do

           cleb = factor*sum
        end if
           clebsch_gordan=cleb
      end function clebsch_gordan

      recursive function binom(n,r) result(res)
        implicit none
        integer :: n,r
        real*8 :: res
        real*8 :: tmp

        if(n==r .or. r==0) then
           res = 1.0
        else if (r==1) then
           res = real(n)
        else
           res = real(n)/real(n-r)*binom(n-1,r)
        end if
      end function binom


!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief  This module contains functions for interpolation in 10 node
!!    tetrahedron element (Langrange  interpolation)
module shape_tet10n
  integer, parameter, private :: kreal = kind(0.0d0)

contains
  subroutine ShapeFunc_tet10n(volcoord,shp)
    real(kind=kreal), intent(in) :: volcoord(3)
    real(kind=kreal) :: shp(10)
    real(kind=kreal) :: xi, et, ze, a
    xi= volcoord(1);  et=volcoord(2);  ze=volcoord(3)
    a=1.d0-xi-et-ze
    shp(1)=(2.d0*a-1.d0)*a
    shp(2)=xi*(2.d0*xi-1.d0)
    shp(3)=et*(2.d0*et-1.d0)
    shp(4)=ze*(2.d0*ze-1.d0)
    shp(5)=4.d0*xi*a
    shp(6)=4.d0*xi*et
    shp(7)=4.d0*et*a
    shp(8)=4.d0*ze*a
    shp(9)=4.d0*xi*ze
    shp(10)=4.d0*et*ze
  end subroutine

  subroutine ShapeDeriv_tet10n(volcoord,shp)
    real(kind=kreal), intent(in) :: volcoord(3)
    real(kind=kreal) :: shp(10,3)
    real(kind=kreal) :: xi, et, ze, a
    !     real(kind=kreal) :: x1, x2, x3, x4
    xi= volcoord(1);  et=volcoord(2);  ze=volcoord(3)
    a=1.d0-xi-et-ze
    !
    !     local derivatives of the shape functions: xi-derivative
    !
    shp(1,1)=1.d0-4.d0*a
    shp(2,1)=4.d0*xi-1.d0
    shp(3,1)=0.d0
    shp(4,1)=0.d0
    shp(5,1)=4.d0*(1.d0-2.d0*xi-et-ze)
    shp(6,1)=4.d0*et
    shp(7,1)=-4.d0*et
    shp(8,1)=-4.d0*ze
    shp(9,1)=4.d0*ze
    shp(10,1)=0.d0
    !
    !     local derivatives of the shape functions: eta-derivative
    !
    shp(1,2)=1.d0-4.d0*a
    shp(2,2)=0.d0
    shp(3,2)=4.d0*et-1.d0
    shp(4,2)=0.d0
    shp(5,2)=-4.d0*xi
    shp(6,2)=4.d0*xi
    shp(7,2)=4.d0*(1.d0-xi-2.d0*et-ze)
    shp(8,2)=-4.d0*ze
    shp(9,2)=0.d0
    shp(10,2)=4.d0*ze
    !
    !     local derivatives of the shape functions: zeta-derivative
    !
    shp(1,3)=1.d0-4.d0*a
    shp(2,3)=0.d0
    shp(3,3)=0.d0
    shp(4,3)=4.d0*ze-1.d0
    shp(5,3)=-4.d0*xi
    shp(6,3)=0.d0
    shp(7,3)=-4.d0*et
    shp(8,3)=4.d0*(1.d0-xi-et-2.d0*ze)
    shp(9,3)=4.d0*xi
    shp(10,3)=4.d0*et
  end subroutine

end module


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief return normalisation-vector for initial normalisation of the linear-system
!>    @param[in] mw right side, solution, diagonal (system matrix)
!>    @param[in] mbc_mask boundary mask
!>    @param[in] N number of elements, vector length
!>    @param[in] md diagonal of the system matrx
!>    @param[in] mx currentr solution vector (used for step by step updates)
!>    @param[out] dnormalise updated (new) normalisation vector
!>    @param[in] soddmx second offset (dominant) diagonal*mx
      SUBROUTINE get_norm2(n,mw,mbc_mask,md,mx,dnormalise,soddmx)
        IMPLICIT NONE
        INTEGER n, i
        DOUBLE PRECISION dnormalise(n), dcrit_nrm
!     right side, solution, diagonal (system matrix)
        DOUBLE PRECISION mw(n), mx(n), md(n), soddmx(n)
!     boundary mask
        CHARACTER mbc_mask(n)
        INTRINSIC dsqrt, dabs, dble
        LOGICAL test_null
        EXTERNAL test_null

!     correction for 2-Norm
        dcrit_nrm = dsqrt(dble(n))

        DO i = 1, n
          dnormalise(i) = 1.D0
!        add, since it is no boundary condition element
          IF (mbc_mask(i)=='+') THEN
!           important: diagonal dominance
            IF ( .NOT. test_null(mx(i))) THEN
              dnormalise(i) = 1.D0 /(max(dabs(md(i)*mx(i)), soddmx(i))*dcrit_nrm)
            ELSE
              dnormalise(i) = 1.D0 /(max(dabs(md(i)), dabs(mw(i)), soddmx(i))*dcrit_nrm)
            END IF
          END IF
        END DO
!
        RETURN
      END


! ==================================================================================================================================
!
! # file created #
! 2020/09/20
!
! ==================================================================================================================================

module mod_coordinate_cartesian

    ! <module>s to import
    use,     intrinsic :: iso_fortran_env
    use, non_intrinsic :: mod_inv

    ! require all variables to be explicitly declared
    implicit none

    ! accessibility of the <subroutine>s and <function>s in this <module>

    ! kind: type
    public :: typ_coordinate_cartesian_2D_R32
    public :: typ_coordinate_cartesian_2D_R64
    public :: typ_coordinate_cartesian_3D_R32
    public :: typ_coordinate_cartesian_3D_R64

    ! kind: function
    private :: add_2D_R32
    private :: add_2D_R64
    private :: add_3D_R32
    private :: add_3D_R64

    private :: cos_with_hypot_2D_R32
    private :: cos_with_hypot_2D_R64

    private :: cos_without_hypot_2D_R32
    private :: cos_without_hypot_2D_R64

    private :: divide_2D_R32
    private :: divide_2D_R64
    private :: divide_3D_R32
    private :: divide_3D_R64

    private :: dot_product_2D_R32
    private :: dot_product_2D_R64
    private :: dot_product_3D_R32
    private :: dot_product_3D_R64

    private :: hypot_R32
    private :: hypot_R64

    private :: normalize_2D_R32
    private :: normalize_2D_R64
    private :: normalize_3D_R32
    private :: normalize_3D_R64

    private :: norm2_R32
    private :: norm2_R64

    private :: minus_2D_R32
    private :: minus_2D_R64
    private :: minus_3D_R32
    private :: minus_3D_R64

    private :: prod_2D_sclr_R32
    private :: prod_2D_sclr_R64
    private :: prod_3D_sclr_R32
    private :: prod_3D_sclr_R64
    private :: prod_sclr_2D_R32
    private :: prod_sclr_2D_R64
    private :: prod_sclr_3D_R32
    private :: prod_sclr_3D_R64

    private :: rank_R32
    private :: rank_R64

    private :: sin_with_hypot_2D_R32
    private :: sin_with_hypot_2D_R64

    private :: sin_without_hypot_2D_R32
    private :: sin_without_hypot_2D_R64

    private :: sub_2D_R32
    private :: sub_2D_R64
    private :: sub_3D_R32
    private :: sub_3D_R64

    private :: tan_2D_R32
    private :: tan_2D_R64

    ! kind: subroutine
    private :: assign_scalar_2D_R32
    private :: assign_scalar_2D_R64
    private :: assign_scalar_3D_R32
    private :: assign_scalar_3D_R64

    private :: random_number_2D_R32
    private :: random_number_2D_R64
    private :: random_number_3D_R32
    private :: random_number_3D_R64

    ! kind: interface: assignment
    public :: assignment(=)

    ! kind: interface: operator
    public :: operator(+)
    public :: operator(-)
    public :: operator(*)
    public :: operator(/)

    ! kind: interface: function
    public :: cos
    public :: cos_with_hypot
    public :: dot_product
    public :: normalize
    public :: hypot
    public :: norm2
    public :: rank
    public :: sin
    public :: sin_with_hypot
    public :: tan

    ! kind: interface: subroutine
    public :: random_number

    ! <type>s for this <module>

    type typ_coordinate_cartesian_2D_R32
        real(REAL32), public :: x
        real(REAL32), public :: y
    end type typ_coordinate_cartesian_2D_R32

    type typ_coordinate_cartesian_2D_R64
        real(REAL64), public :: x
        real(REAL64), public :: y
    end type typ_coordinate_cartesian_2D_R64

    type, extends(typ_coordinate_cartesian_2D_R32) :: typ_coordinate_cartesian_3D_R32
        real(REAL32), public :: z
    end type typ_coordinate_cartesian_3D_R32

    type, extends(typ_coordinate_cartesian_2D_R64) :: typ_coordinate_cartesian_3D_R64
        real(REAL64), public :: z
    end type typ_coordinate_cartesian_3D_R64

    ! <interface>s for this <module>
    interface assignment(=)
        module procedure :: assign_scalar_2D_R32
        module procedure :: assign_scalar_2D_R64
        module procedure :: assign_scalar_3D_R32
        module procedure :: assign_scalar_3D_R64
    end interface assignment(=)

    interface operator(+)

        ! binary operator
        module procedure :: add_2D_R32
        module procedure :: add_2D_R64
        module procedure :: add_3D_R32
        module procedure :: add_3D_R64

    end interface operator(+)

    interface operator(-)

        ! Unary operator
        module procedure :: minus_2D_R32
        module procedure :: minus_2D_R64
        module procedure :: minus_3D_R32
        module procedure :: minus_3D_R64

        ! Binary operator
        module procedure :: sub_2D_R32
        module procedure :: sub_2D_R64
        module procedure :: sub_3D_R32
        module procedure :: sub_3D_R64

    end interface operator(-)

    interface operator(*)
        module procedure :: prod_2D_sclr_R32
        module procedure :: prod_2D_sclr_R64
        module procedure :: prod_3D_sclr_R32
        module procedure :: prod_3D_sclr_R64
        module procedure :: prod_sclr_2D_R32
        module procedure :: prod_sclr_2D_R64
        module procedure :: prod_sclr_3D_R32
        module procedure :: prod_sclr_3D_R64
    end interface operator(*)

    interface operator(/)
        module procedure :: divide_2D_R32
        module procedure :: divide_2D_R64
        module procedure :: divide_3D_R32
        module procedure :: divide_3D_R64
    end interface operator(/)

    interface cos
        module procedure :: cos_without_hypot_2D_R32
        module procedure :: cos_without_hypot_2D_R64
    end interface cos

    interface cos_with_hypot
        module procedure :: cos_with_hypot_2D_R32
        module procedure :: cos_with_hypot_2D_R64
    end interface cos_with_hypot

    interface dot_product
        module procedure :: dot_product_2D_R32
        module procedure :: dot_product_2D_R64
        module procedure :: dot_product_3D_R32
        module procedure :: dot_product_3D_R64
    end interface dot_product

    interface hypot
        module procedure :: hypot_R32
        module procedure :: hypot_R64
    end interface hypot

    interface norm2
        module procedure :: norm2_R32
        module procedure :: norm2_R64
    end interface norm2

    interface normalize
        module procedure :: normalize_2D_R32
        module procedure :: normalize_2D_R64
        module procedure :: normalize_3D_R32
        module procedure :: normalize_3D_R64
    end interface normalize

    interface rank
        module procedure :: rank_R32
        module procedure :: rank_R64
    end interface rank

    interface sin
        module procedure :: sin_without_hypot_2D_R32
        module procedure :: sin_without_hypot_2D_R64
    end interface sin

    interface sin_with_hypot
        module procedure :: sin_with_hypot_2D_R32
        module procedure :: sin_with_hypot_2D_R64
    end interface sin_with_hypot

    interface tan
        module procedure :: tan_2D_R32
        module procedure :: tan_2D_R64
    end interface tan

    interface random_number
        module procedure :: random_number_2D_R32
        module procedure :: random_number_2D_R64
        module procedure :: random_number_3D_R32
        module procedure :: random_number_3D_R64
    end interface random_number

    ! contained <subroutine>s and <function>s are below
    contains

    pure function add_2D_R32 (coordinate_a, coordinate_b) result(coordinate_add)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R32), intent(in) :: coordinate_a, coordinate_b

        ! return value of this <function>
        type(typ_coordinate_cartesian_2D_R32) :: coordinate_add

        coordinate_add%x = coordinate_a%x + coordinate_b%x
        coordinate_add%y = coordinate_a%y + coordinate_b%y

    end function add_2D_R32

    pure function add_2D_R64 (coordinate_a, coordinate_b) result(coordinate_add)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R64), intent(in) :: coordinate_a, coordinate_b

        ! return value of this <function>
        type(typ_coordinate_cartesian_2D_R64) :: coordinate_add

        coordinate_add%x = coordinate_a%x + coordinate_b%x
        coordinate_add%y = coordinate_a%y + coordinate_b%y

    end function add_2D_R64

    pure function add_3D_R32 (coordinate_a, coordinate_b) result(coordinate_add)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_3D_R32), intent(in) :: coordinate_a, coordinate_b

        ! return value of this <function>
        type(typ_coordinate_cartesian_3D_R32) :: coordinate_add

        coordinate_add%x = coordinate_a%x + coordinate_b%x
        coordinate_add%y = coordinate_a%y + coordinate_b%y
        coordinate_add%z = coordinate_a%z + coordinate_b%z

    end function add_3D_R32

    pure function add_3D_R64 (coordinate_a, coordinate_b) result(coordinate_add)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_3D_R64), intent(in) :: coordinate_a, coordinate_b

        ! return value of this <function>
        type(typ_coordinate_cartesian_3D_R64) :: coordinate_add

        coordinate_add%x = coordinate_a%x + coordinate_b%x
        coordinate_add%y = coordinate_a%y + coordinate_b%y
        coordinate_add%z = coordinate_a%z + coordinate_b%z

    end function add_3D_R64

    pure function cos_with_hypot_2D_R32 (coordinate, hypot) result(cos)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R32), intent(in) :: coordinate
        real(REAL32),                          intent(in) :: hypot

        ! return value of this <function>
        real(REAL32) :: cos

        cos = coordinate%x / hypot

    end function cos_with_hypot_2D_R32

    pure function cos_with_hypot_2D_R64 (coordinate, hypot) result(cos)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R64), intent(in) :: coordinate
        real(REAL64),                          intent(in) :: hypot

        ! return value of this <function>
        real(REAL64) :: cos

        cos = coordinate%x / hypot

    end function cos_with_hypot_2D_R64

    pure function cos_without_hypot_2D_R32 (coordinate) result(cos)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R32), intent(in) :: coordinate

        ! return value of this <function>
        real(REAL32) :: cos

        cos = cos_with_hypot( coordinate= coordinate, hypot= hypot(coordinate) )

    end function cos_without_hypot_2D_R32

    pure function cos_without_hypot_2D_R64 (coordinate) result(cos)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R64), intent(in) :: coordinate

        ! return value of this <function>
        real(REAL64) :: cos

        cos = cos_with_hypot( coordinate= coordinate, hypot= hypot(coordinate) )

    end function cos_without_hypot_2D_R64

    pure function divide_2D_R32 (coordinate_left, scalar_right) result(coordinate_divided)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R32), intent(in) :: coordinate_left
        real(REAL32),                          intent(in) :: scalar_right

        ! return value of this <function>
        type(typ_coordinate_cartesian_2D_R32) :: coordinate_divided

        coordinate_divided = coordinate_left * inv( scalar_right )

    end function divide_2D_R32

    pure function divide_2D_R64 (coordinate_left, scalar_right) result(coordinate_divided)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R64), intent(in) :: coordinate_left
        real(REAL64),                          intent(in) :: scalar_right

        ! return value of this <function>
        type(typ_coordinate_cartesian_2D_R64) :: coordinate_divided

        coordinate_divided = coordinate_left * inv( scalar_right )

    end function divide_2D_R64

    pure function divide_3D_R32 (coordinate_left, scalar_right) result(coordinate_divided)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_3D_R32), intent(in) :: coordinate_left
        real(REAL32),                          intent(in) :: scalar_right

        ! return value of this <function>
        type(typ_coordinate_cartesian_3D_R32) :: coordinate_divided

        coordinate_divided = coordinate_left * inv( scalar_right )

    end function divide_3D_R32

    pure function divide_3D_R64 (coordinate_left, scalar_right) result(coordinate_divided)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_3D_R64), intent(in) :: coordinate_left
        real(REAL64),                          intent(in) :: scalar_right

        ! return value of this <function>
        type(typ_coordinate_cartesian_3D_R64) :: coordinate_divided

        coordinate_divided = coordinate_left * inv( scalar_right )

    end function divide_3D_R64

    pure function dot_product_2D_R32 (coordinate_a, coordinate_b) result(product)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R32), intent(in) :: coordinate_a, coordinate_b

        ! return value of this <function>
        real(REAL32) :: product

        product = coordinate_a%x * coordinate_b%x + coordinate_a%y * coordinate_b%y

    end function dot_product_2D_R32

    pure function dot_product_2D_R64 (coordinate_a, coordinate_b) result(product)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R64), intent(in) :: coordinate_a, coordinate_b

        ! return value of this <function>
        real(REAL64) :: product

        product = coordinate_a%x * coordinate_b%x + coordinate_a%y * coordinate_b%y

    end function dot_product_2D_R64

    pure function dot_product_3D_R32 (coordinate_a, coordinate_b) result(product)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_3D_R32), intent(in) :: coordinate_a, coordinate_b

        ! return value of this <function>
        real(REAL32) :: product

        product = coordinate_a%x * coordinate_b%x + coordinate_a%y * coordinate_b%y + coordinate_a%z * coordinate_b%z

    end function dot_product_3D_R32

    pure function dot_product_3D_R64 (coordinate_a, coordinate_b) result(product)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_3D_R64), intent(in) :: coordinate_a, coordinate_b

        ! return value of this <function>
        real(REAL64) :: product

        product = coordinate_a%x * coordinate_b%x + coordinate_a%y * coordinate_b%y + coordinate_a%z * coordinate_b%z

    end function dot_product_3D_R64

    pure function hypot_R32 (coordinate) result(norm)

        ! arguments for this <function>
        class(typ_coordinate_cartesian_2D_R32), intent(in) :: coordinate

        ! return value of this <function>
        real(REAL32) :: norm

        norm = sqrt( norm2(coordinate) )

    end function hypot_R32

    pure function hypot_R64 (coordinate) result(norm)

        ! arguments for this <function>
        class(typ_coordinate_cartesian_2D_R64), intent(in) :: coordinate

        ! return value of this <function>
        real(REAL64) :: norm

        norm = sqrt( norm2(coordinate) )

    end function hypot_R64

    pure function minus_2D_R32 (coordinate) result(coordinate_minus)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R32), intent(in) :: coordinate

        ! return value of this <function>
        type(typ_coordinate_cartesian_2D_R32) :: coordinate_minus

        coordinate_minus%x = - coordinate%x
        coordinate_minus%y = - coordinate%y

    end function minus_2D_R32

    pure function minus_2D_R64 (coordinate) result(coordinate_minus)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R64), intent(in) :: coordinate

        ! return value of this <function>
        type(typ_coordinate_cartesian_2D_R64) :: coordinate_minus

        coordinate_minus%x = - coordinate%x
        coordinate_minus%y = - coordinate%y

    end function minus_2D_R64

    pure function minus_3D_R32 (coordinate) result(coordinate_minus)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_3D_R32), intent(in) :: coordinate

        ! return value of this <function>
        type(typ_coordinate_cartesian_3D_R32) :: coordinate_minus

        coordinate_minus%x = - coordinate%x
        coordinate_minus%y = - coordinate%y
        coordinate_minus%z = - coordinate%z

    end function minus_3D_R32

    pure function minus_3D_R64 (coordinate) result(coordinate_minus)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_3D_R64), intent(in) :: coordinate

        ! return value of this <function>
        type(typ_coordinate_cartesian_3D_R64) :: coordinate_minus

        coordinate_minus%x = - coordinate%x
        coordinate_minus%y = - coordinate%y
        coordinate_minus%z = - coordinate%z

    end function minus_3D_R64

    pure function norm2_R32 (coordinate) result(norm2)

        ! arguments for this <function>
        class(typ_coordinate_cartesian_2D_R32), intent(in) :: coordinate

        ! return value of this <function>
        real(REAL32) :: norm2

        norm2 = dot_product(coordinate, coordinate)

    end function norm2_R32

    pure function norm2_R64 (coordinate) result(norm2)

        ! arguments for this <function>
        class(typ_coordinate_cartesian_2D_R64), intent(in) :: coordinate

        ! return value of this <function>
        real(REAL64) :: norm2

        norm2 = dot_product(coordinate, coordinate)

    end function norm2_R64

    pure function normalize_2D_R32 (coordinate) result(coordinate_normalized)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R32), intent(in) :: coordinate

        ! return value of this <function>
        type(typ_coordinate_cartesian_2D_R32) :: coordinate_normalized

        coordinate_normalized = coordinate / hypot(coordinate)

    end function normalize_2D_R32

    pure function normalize_2D_R64 (coordinate) result(coordinate_normalized)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R64), intent(in) :: coordinate

        ! return value of this <function>
        type(typ_coordinate_cartesian_2D_R64) :: coordinate_normalized

        coordinate_normalized = coordinate / hypot(coordinate)

    end function normalize_2D_R64

    pure function normalize_3D_R32 (coordinate) result(coordinate_normalized)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_3D_R32), intent(in) :: coordinate

        ! return value of this <function>
        type(typ_coordinate_cartesian_3D_R32) :: coordinate_normalized

        coordinate_normalized = coordinate / hypot(coordinate)

    end function normalize_3D_R32

    pure function normalize_3D_R64 (coordinate) result(coordinate_normalized)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_3D_R64), intent(in) :: coordinate

        ! return value of this <function>
        type(typ_coordinate_cartesian_3D_R64) :: coordinate_normalized

        coordinate_normalized = coordinate / hypot(coordinate)

    end function normalize_3D_R64

    pure function prod_2D_sclr_R32 (coordinate_left, scalar_right) result(coordinate_prod)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R32), intent(in) :: coordinate_left
        real(REAL32),                          intent(in) :: scalar_right

        ! return value of this <function>
        type(typ_coordinate_cartesian_2D_R32) :: coordinate_prod

        coordinate_prod%x = coordinate_left%x * scalar_right
        coordinate_prod%y = coordinate_left%y * scalar_right

    end function prod_2D_sclr_R32

    pure function prod_2D_sclr_R64 (coordinate_left, scalar_right) result(coordinate_prod)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R64), intent(in) :: coordinate_left
        real(REAL64),                          intent(in) :: scalar_right

        ! return value of this <function>
        type(typ_coordinate_cartesian_2D_R64) :: coordinate_prod

        coordinate_prod%x = coordinate_left%x * scalar_right
        coordinate_prod%y = coordinate_left%y * scalar_right

    end function prod_2D_sclr_R64

    pure function prod_3D_sclr_R32 (coordinate_left, scalar_right) result(coordinate_prod)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_3D_R32), intent(in) :: coordinate_left
        real(REAL32),                          intent(in) :: scalar_right

        ! return value of this <function>
        type(typ_coordinate_cartesian_3D_R32) :: coordinate_prod

        coordinate_prod%x = coordinate_left%x * scalar_right
        coordinate_prod%y = coordinate_left%y * scalar_right
        coordinate_prod%z = coordinate_left%z * scalar_right

    end function prod_3D_sclr_R32

    pure function prod_3D_sclr_R64 (coordinate_left, scalar_right) result(coordinate_prod)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_3D_R64), intent(in) :: coordinate_left
        real(REAL64),                          intent(in) :: scalar_right

        ! return value of this <function>
        type(typ_coordinate_cartesian_3D_R64) :: coordinate_prod

        coordinate_prod%x = coordinate_left%x * scalar_right
        coordinate_prod%y = coordinate_left%y * scalar_right
        coordinate_prod%z = coordinate_left%z * scalar_right

    end function prod_3D_sclr_R64

    pure function prod_sclr_2D_R32 (scalar_left, coordinate_right) result(coordinate_prod)

        ! arguments for this <function>
        real(REAL32),                          intent(in) :: scalar_left
        type(typ_coordinate_cartesian_2D_R32), intent(in) :: coordinate_right

        ! return value of this <function>
        type(typ_coordinate_cartesian_2D_R32) :: coordinate_prod

        coordinate_prod%x = scalar_left * coordinate_right%x
        coordinate_prod%y = scalar_left * coordinate_right%y

    end function prod_sclr_2D_R32

    pure function prod_sclr_2D_R64 (scalar_left, coordinate_right) result(coordinate_prod)

        ! arguments for this <function>
        real(REAL64),                          intent(in) :: scalar_left
        type(typ_coordinate_cartesian_2D_R64), intent(in) :: coordinate_right

        ! return value of this <function>
        type(typ_coordinate_cartesian_2D_R64) :: coordinate_prod

        coordinate_prod%x = scalar_left * coordinate_right%x
        coordinate_prod%y = scalar_left * coordinate_right%y

    end function prod_sclr_2D_R64

    pure function prod_sclr_3D_R32 (scalar_left, coordinate_right) result(coordinate_prod)

        ! arguments for this <function>
        real(REAL32),                          intent(in) :: scalar_left
        type(typ_coordinate_cartesian_3D_R32), intent(in) :: coordinate_right

        ! return value of this <function>
        type(typ_coordinate_cartesian_3D_R32) :: coordinate_prod

        coordinate_prod%x = scalar_left * coordinate_right%x
        coordinate_prod%y = scalar_left * coordinate_right%y
        coordinate_prod%z = scalar_left * coordinate_right%z

    end function prod_sclr_3D_R32

    pure function prod_sclr_3D_R64 (scalar_left, coordinate_right) result(coordinate_prod)

        ! arguments for this <function>
        real(REAL64),                          intent(in) :: scalar_left
        type(typ_coordinate_cartesian_3D_R64), intent(in) :: coordinate_right

        ! return value of this <function>
        type(typ_coordinate_cartesian_3D_R64) :: coordinate_prod

        coordinate_prod%x = scalar_left * coordinate_right%x
        coordinate_prod%y = scalar_left * coordinate_right%y
        coordinate_prod%z = scalar_left * coordinate_right%z

    end function prod_sclr_3D_R64

    pure function rank_R32 (coordinate) result(rank)

        ! arguments for this <function>
        class(typ_coordinate_cartesian_2D_R32), intent(in) :: coordinate

        ! return value of this <function>
        integer(INT8) :: rank

        select type(coordinate)
            type is(typ_coordinate_cartesian_2D_R32); rank = 2_INT8; return
            type is(typ_coordinate_cartesian_3D_R32); rank = 3_INT8; return
        end select

        rank = 0_INT8

        return

    end function rank_R32

    pure function rank_R64 (coordinate) result(rank)

        ! arguments for this <function>
        class(typ_coordinate_cartesian_2D_R64), intent(in) :: coordinate

        ! return value of this <function>
        integer(INT8) :: rank

        select type(coordinate)
            type is(typ_coordinate_cartesian_2D_R64); rank = 2_INT8; return
            type is(typ_coordinate_cartesian_3D_R64); rank = 3_INT8; return
        end select

        rank = 0_INT8

        return

    end function rank_R64

    pure function sin_with_hypot_2D_R32 (coordinate, hypot) result(sin)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R32), intent(in) :: coordinate
        real(REAL32),                          intent(in) :: hypot

        ! return value of this <function>
        real(REAL32) :: sin

        sin = coordinate%y / hypot

    end function sin_with_hypot_2D_R32

    pure function sin_with_hypot_2D_R64 (coordinate, hypot) result(sin)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R64), intent(in) :: coordinate
        real(REAL64),                          intent(in) :: hypot

        ! return value of this <function>
        real(REAL64) :: sin

        sin = coordinate%y / hypot

    end function sin_with_hypot_2D_R64

    pure function sin_without_hypot_2D_R32 (coordinate) result(sin)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R32), intent(in) :: coordinate

        ! return value of this <function>
        real(REAL32) :: sin

        sin = sin_with_hypot( coordinate= coordinate, hypot= hypot(coordinate) )

    end function sin_without_hypot_2D_R32

    pure function sin_without_hypot_2D_R64 (coordinate) result(sin)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R64), intent(in) :: coordinate

        ! return value of this <function>
        real(REAL64) :: sin

        sin = sin_with_hypot( coordinate= coordinate, hypot= hypot(coordinate) )

    end function sin_without_hypot_2D_R64

    pure function sub_2D_R32 (coordinate_a, coordinate_b) result(coordinate_sub)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R32), intent(in) :: coordinate_a, coordinate_b

        ! return value of this <function>
        type(typ_coordinate_cartesian_2D_R32) :: coordinate_sub

        coordinate_sub = - coordinate_b + coordinate_a

    end function sub_2D_R32

    pure function sub_2D_R64 (coordinate_a, coordinate_b) result(coordinate_sub)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R64), intent(in) :: coordinate_a, coordinate_b

        ! return value of this <function>
        type(typ_coordinate_cartesian_2D_R64) :: coordinate_sub

        coordinate_sub = - coordinate_b + coordinate_a

    end function sub_2D_R64

    pure function sub_3D_R32 (coordinate_a, coordinate_b) result(coordinate_sub)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_3D_R32), intent(in) :: coordinate_a, coordinate_b

        ! return value of this <function>
        type(typ_coordinate_cartesian_3D_R32) :: coordinate_sub

        coordinate_sub = - coordinate_b + coordinate_a

    end function sub_3D_R32

    pure function sub_3D_R64 (coordinate_a, coordinate_b) result(coordinate_sub)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_3D_R64), intent(in) :: coordinate_a, coordinate_b

        ! return value of this <function>
        type(typ_coordinate_cartesian_3D_R64) :: coordinate_sub

        coordinate_sub = - coordinate_b + coordinate_a

    end function sub_3D_R64

    pure function tan_2D_R32 (coordinate) result(tan)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R32), intent(in) :: coordinate

        ! return value of this <function>
        real(REAL32) :: tan

        tan = coordinate%y / coordinate%x

    end function tan_2D_R32

    pure function tan_2D_R64 (coordinate) result(tan)

        ! arguments for this <function>
        type(typ_coordinate_cartesian_2D_R64), intent(in) :: coordinate

        ! return value of this <function>
        real(REAL64) :: tan

        tan = coordinate%y / coordinate%x

    end function tan_2D_R64

    subroutine assign_scalar_2D_R32 (coordinate, scalar)

        ! arguments for this <subroutine>
        type(typ_coordinate_cartesian_2D_R32), intent(out) :: coordinate
        real(REAL32),                          intent(in)  :: scalar

        coordinate%x = scalar
        coordinate%y = scalar

        return

    end subroutine assign_scalar_2D_R32

    subroutine assign_scalar_2D_R64 (coordinate, scalar)

        ! arguments for this <subroutine>
        type(typ_coordinate_cartesian_2D_R64), intent(out) :: coordinate
        real(REAL64),                          intent(in)  :: scalar

        coordinate%x = scalar
        coordinate%y = scalar

        return

    end subroutine assign_scalar_2D_R64

    subroutine assign_scalar_3D_R32 (coordinate, scalar)

        ! arguments for this <subroutine>
        type(typ_coordinate_cartesian_3D_R32), intent(out) :: coordinate
        real(REAL32),                          intent(in)  :: scalar

        coordinate%x = scalar
        coordinate%y = scalar
        coordinate%z = scalar

        return

    end subroutine assign_scalar_3D_R32

    subroutine assign_scalar_3D_R64 (coordinate, scalar)

        ! arguments for this <subroutine>
        type(typ_coordinate_cartesian_3D_R64), intent(out) :: coordinate
        real(REAL64),                          intent(in)  :: scalar

        coordinate%x = scalar
        coordinate%y = scalar
        coordinate%z = scalar

        return

    end subroutine assign_scalar_3D_R64

    subroutine random_number_2D_R32 (coordinate)

        ! arguments for this <subroutine>
        type(typ_coordinate_cartesian_2D_R32), intent(out) :: coordinate

        call random_number( coordinate%x )
        call random_number( coordinate%y )

    end subroutine random_number_2D_R32

    subroutine random_number_2D_R64 (coordinate)

        ! arguments for this <subroutine>
        type(typ_coordinate_cartesian_2D_R64), intent(out) :: coordinate

        call random_number( coordinate%x )
        call random_number( coordinate%y )

    end subroutine random_number_2D_R64

    subroutine random_number_3D_R32 (coordinate)

        ! arguments for this <subroutine>
        type(typ_coordinate_cartesian_3D_R32), intent(out) :: coordinate

        call random_number( coordinate%x )
        call random_number( coordinate%y )
        call random_number( coordinate%z )

    end subroutine random_number_3D_R32

    subroutine random_number_3D_R64 (coordinate)

        ! arguments for this <subroutine>
        type(typ_coordinate_cartesian_3D_R64), intent(out) :: coordinate

        call random_number( coordinate%x )
        call random_number( coordinate%y )
        call random_number( coordinate%z )

    end subroutine random_number_3D_R64

end module mod_coordinate_cartesian

! ==================================================================================================================================
! EOF
! ==================================================================================================================================


program sum_matrices

implicit none

integer:: m, n, i, j
real, allocatable, dimension(:,:):: a, b, s

print*, 'Numero de filas da matriz'
read*, m
print*, 'Numero de columnas da matriz'
read*, n

allocate(a(m,n), b(m,n), s(m,n))

do i=1,m
  do j=1,n
    print*, 'A[ ', i, ' , ', j, ' ]: '
    read*, a(i,j)
  end do
end do

do i=1,m
  do j=1,n
    print*, 'B[ ', i, ' , ', j, ' ]: '
    read*, b(i,j)
  end do
end do

s = a + b

do i=1,m
  do j=1,n
    print*, 'S[ ', i, ' , ', j, ' ]: ', s(i,j)
  end do
end do

end program


! { dg-do run }
! { dg-require-effective-target fortran_large_real }
!
! Test the Fortran 2008 intrinsics gamma and log_gamma
!
! PR fortran/32980
!
program gamma_test
implicit none
intrinsic :: gamma, log_gamma
integer, parameter :: qp = selected_real_kind(precision (0.0_8) + 1)

real(qp) :: rqp

if (abs(gamma(1.0_qp)  - 1.0_qp) > tiny(1.0_qp)) call abort()
if (abs(log_gamma(1.0_qp)) > tiny(1.0_qp)) call abort()
end program gamma_test


program divisionmatrix
    implicit none

    integer :: i,j,io,k
    integer :: m,n,mm,nn
    real, dimension(:,:), allocatable :: matrixA
    real, dimension(:,:), allocatable :: matrixB
    real, dimension(:,:), allocatable :: division
    real, dimension(:,:), allocatable :: invmat
    real, dimension(:,:), allocatable :: submatrix
    real, dimension(:,:), allocatable :: adjugate
    real :: determinant,caldet

    ! Read number of data for matrixA
    write(*,*) 'Status IOSTAT (Matrix A)'
    open(1, file='data_matrix_high_A.txt')
    m = 0
    do
        read(1,*,iostat=io)
        write(*,*)'Baris ke-',m+1, io
        if (io /= 0) exit
        m = m + 1
    end do
    close(1)

    ! Set number of rows and columns of square matrixA
    m = int(m**0.5)
    n = m

    write(*,*)

    ! Read number of data for matrixB
    write(*,*) 'Status IOSTAT (Matrix B)'
    open(3, file='data_matrix_high_B.txt')
    mm = 0
    do
        read(3,*,iostat=io)
        write(*,*)'Baris ke-',mm+1, io
        if (io /= 0) exit
        mm = mm + 1
    end do
    close(3)

    ! Set number of rows and columns of square matrixB
    mm = int(mm**0.5)
    nn = mm

    ! Allocate memory size for array variables
    allocate(matrixA(m,n), matrixB(m,n), division(m,n), invmat(m,n), adjugate(m,n), submatrix(m-1,n-1))

    ! Read matrixA file
    open(2,file='data_matrix_high_A.txt')
    do i = 1,m
        do j = 1,n
            read(2,*) matrixA(i,j)
        end do
    end do
    close(2)

    ! Read matrixB file
    open(4,file='data_matrix_high_B.txt')
    do i = 1,mm
        do j = 1,nn
            read(4,*) matrixB(i,j)
        end do
    end do
    close(4)

    ! Show matrixA
    write(*,*)
    write(*,*) 'matrixA'
    do i = 1,m
        write(*,*) (matrixA(i,j), j=1,n)
    end do

    write(*,*)

    ! Show matrixB
    write(*,*)
    write(*,*) 'matrixB'
    do i = 1,mm
        write(*,*) (matrixB(i,j), j=1,nn)
    end do

    write(*,*)

    ! Calculate determinant by calling its function
    determinant = caldet(matrixA,m,n)

    write(*,*) 'determinant:'
    write(*,*) determinant

    write(*,*)

    ! Get adjugate matrixA
    write(*,*) 'Adjugate'

    call getadjugate(matrixA,m,n,adjugate)

    ! Show adjugate matrixA
    do i = 1,m
        write(*,*) (adjugate(i,j), j=1,n)
    end do

    ! Calculate inverse matrixA
    do i = 1,m
        do j = 1,n
            invmat(i,j) = (1/determinant) * adjugate(i,j)
        end do
    end do

    write(*,*)

    write(*,*) 'Inverse matrixA'
    do i = 1,m
        write(*,*) (invmat(i,j), j= 1,m)
    end do

    ! Calculate division on matrix B/A = B*inv(A)
    do i = 1,m
        do j = 1,n
            division(i,j) = 0
            do k = 1,m
                division(i,j) = division(i,j) + (matrixB(i,k) * invmat(k,j))
            end do
        end do
    end do

    write(*,*)

    write(*,*) 'Division Matrix'
    do i = 1,m
        write(*,*) (division(i,j), j = 1,n)
    end do

    ! Deallocate memory size for array variables
    deallocate(matrixA, matrixB, division, invmat, adjugate, submatrix)

end program

subroutine getsubmatrix(matrixA,m,n,mainrow,maincolumn,submatrix)
    ! ------------------------------------------------------------------
    ! This is a subroutine to get a cofactor/submatrix from main matrixA
    ! This concept algorithm is obtained from
    ! https://www.geeksforgeeks.org/adjoint-inverse-matrixA/ in C++
    ! ------------------------------------------------------------------
    real, dimension(m,n) :: matrixA ! input matrixA
    real, dimension(m-1,n-1) :: submatrix ! output matrixA
    integer :: maincolumn, mainrow, row, col

    i = 1
    j = 1
    do row = 1,m
        do col = 1,n
            if ((row .ne. mainrow) .and. (col .ne. maincolumn)) then
                submatrix(i,j) = matrixA(row,col)
                if (j == n-1) then
                    j = 1
                    i = i + 1
                else
                    j = j + 1
                end if
            end if
        end do
    end do

end subroutine getsubmatrix

recursive function caldet(matrixA,m,n) result(sumdet)
    ! ------------------------------------------------------------------
    ! This is a recursive function to calculate determinant.
    ! ------------------------------------------------------------------
    real, dimension(m,n) :: matrixA
    real, dimension(m-1,n-1) :: submatrix
    integer :: j

    if (m == 2 .and. n == 2 ) then
        det = matrixA(1,1)*matrixA(2,2) - matrixA(1,2)*matrixA(2,1)
    else
        det = 0
        do j = 1,n
            sign = (-1)**(j-1)
            call getsubmatrix(matrixA,m,n,1,j,submatrix)
            det = det + (sign * matrixA(1,j) * caldet(submatrix,m-1,n-1))
        end do
    end if

    sumdet = det
    return
end function caldet

subroutine getadjugate(matrixA,m,n,adj)
    ! ------------------------------------------------------------------
    ! This is a subroutine to get a adjugate matrixA. Adjugate matrixA
    ! is a square matrixA that transposed of its cofactor matrixA
    !! ------------------------------------------------------------------
    real, dimension(m,n) :: matrixA, adj
    real, dimension(m-1,n-1) :: submatrix
    real :: caldet

    if (m == 2 .and. n == 2) then
        ! adjugate for 2x2 matrix
        adj(1,1) = 1 * matrixA(2,2)
        adj(1,2) = -1 * matrixA(1,2)
        adj(2,1) = -1 * matrixA(2,1)
        adj(2,2) = 1 * matrixA(1,1)
    else
        ! adjugate for 3x3 matrix and higher
        do i = 1,m
            do j = 1,n
                sign = (-1)**(i+j)
                call getsubmatrix(matrixA,m,n,i,j,submatrix)
                ! adj(i,j) is cofactor and adj(j,i) is adjugate (transposed)
                adj(j,i) = sign * caldet(submatrix,m-1,n-1)
            end do
        end do
    end if
end subroutine getadjugate


MODULE MODIFIED_SHEPARD
  USE ISO_FORTRAN_ENV, ONLY : REAL64
  IMPLICIT NONE

  PRIVATE
  PUBLIC SHEPMOD, SHEPMODVAL

CONTAINS

  SUBROUTINE SHEPMOD ( M, N, X, RW, IER )
    ! This subroutine computes a set of parameters defining a function that
    ! interpolates N interpolation nodes at scattered X(i) in M dimensions. The
    ! interpolant may be evaluated at an arbitrary point by the function SHEPMODVAL.
    ! The interpolation scheme is a modified Shepard method, and can
    ! use either the Shepard weighted fit or standarad shepard method.
    !
    ! Input parameters:
    !   M is the dimension of the data.
    !   N is the number of nodes.
    !   X(M, N) contains the coordinates of the nodes.
    ! Output parameters:
    !   RW(N) is an array containing the radius of influence for each point.
    !   IER
    !   = 0, if no errors were encountered.
    !   = 1, if N is too small relative to M.
    INTEGER, INTENT(IN) :: M, N
    REAL(KIND=REAL64), DIMENSION(M,N), INTENT(IN) :: X
    REAL(KIND=REAL64), DIMENSION(N), INTENT(OUT) :: RW
    INTEGER, INTENT(OUT) :: IER

    ! Local variables.
    INTEGER :: I, J, K  ! loop control variables.
    INTEGER :: NP    ! number of nodes used for the local fit.
    REAL(KIND=REAL64), DIMENSION(N-1) :: DIST ! array that stores all the distances.

    IER = 0
    ! Check the validity of M and N.
    IF ( ( M < 1 ) .OR. ( N <= (M + 1) ) ) THEN
       IER = 1
       RETURN
    END IF
    ! Set the number of neighbors to define radius.
    NP = M + 1
    ! Calculate the radius of influence "RW" for all interpolation nodes.
    DO K = 1, N
       J = 0
       DO I = 1, N
          IF (I /= K) THEN
             ! Compute the squared distance to each *other* node.
             J = J + 1
             DIST(J) = DOT_PRODUCT( X(:, I) - X(:, K), X(:, I) - X(:, K) )
          END IF
       END DO
       ! Sort the squared distances to all other nodes.
       CALL SORT( DIST, NP, N - 1 )
       ! Only bother taking the square root of the choice distance.
       RW(K) = SQRT(DIST(NP))
    END DO
    RETURN
  END SUBROUTINE SHEPMOD

  SUBROUTINE SORT( DIST, NUM, LENGTH )
    ! The subroutine SORT sorts the real array DIST of length LENGTH in ascending
    ! order for the smallest NUM elements.
    ! Local variables.
    REAL(KIND=REAL64), INTENT(INOUT), DIMENSION(:)::DIST
    INTEGER :: I, ITEMP, J, LENGTH, NUM
    REAL(KIND=REAL64) :: TEMP

    DO I = 2, LENGTH
       DO J = 1, MIN( I-1, NUM )
          IF ( DIST(I) < DIST(J) ) THEN
             TEMP = DIST(I)
             DIST(J+1:I) = DIST(J:I-1)
             DIST(J) = TEMP
             EXIT
          END IF
       END DO
    END DO
  END SUBROUTINE SORT

  SUBROUTINE SHEPMODVAL( XP, M, N, X, RW, WTS, IER )
    ! SHEPMODVAL returns the modified Shepard approximation at the
    ! point XP, using the points computed by SHEPMOD.
    !
    ! Input parameters:
    !  XP is the point at which the modified Shepard interpolant
    !     function approximation function is to be evaluated.
    !  M is the dimension of the data.
    !  N is the number of interpolation points.
    !  X contains the interpolation nodes, by column.
    !  RW contains the radius of influence about each interpolation
    !    node returned by SHEPMOD.
    ! Output parameter:
    !  WTS contains the weight associated with each interpolation node.
    !  IER
    !   = 0, normal returns.
    !   = 1, if the point XP is outside the radius of influence RW(i) for all
    !        nodes, in which case SHEPMODVAL is computed using the original Shepard
    !        algorithm with the M+1 closest points.
    INTEGER, INTENT(IN)  :: M, N
    REAL(KIND=REAL64), DIMENSION(M), INTENT(IN) :: XP
    REAL(KIND=REAL64), DIMENSION(M, N), INTENT(IN) :: X
    REAL(KIND=REAL64), DIMENSION(N), INTENT(IN) :: RW
    REAL(KIND=REAL64), DIMENSION(N), INTENT(OUT) :: WTS ! weight values.
    INTEGER, INTENT(OUT):: IER

    ! Local variables.
    INTEGER :: I   ! number of nodal functions used in Shepard approximation.
    INTEGER :: J   ! temporary integer variable.
    INTEGER :: K   ! loop control variable.
    REAL(KIND=REAL64) :: DIST ! distance between XP and the interpolation nodes.
    REAL(KIND=REAL64) :: TEMP ! temporary real variable.
    REAL(KIND=REAL64) :: W    ! weight value, depends on D.
    REAL(KIND=REAL64), DIMENSION(M+1) :: D ! weights in the original Shepard scheme.
                                           ! local approximations with positive weights.
    INTEGER, DIMENSION(M+1) :: D_IDX ! Indices of points in D

    IER = 0
    I = 0
    J = 1
    ! Initialize all weights to be zero.
    WTS(:) = 0.0_REAL64
    ! Be prepared to interpolate using the nearest (M+1) points if
    ! there are no points whose radius of influence contain XP.
    D_IDX(:) = 0
    D(1:M+1) = 0.0_REAL64
    TEMP = 0.0_REAL64
    ! Cycle through interpolation nodes, checking distances to XP.
    DO K = 1, N
       DIST = SQRT( DOT_PRODUCT( XP(:) - X(:, K), XP(:) - X(:, K) ) )
       ! If XP is within the radius of influence of X(K)
       IF ( DIST < RW(K) ) THEN
          ! Set the weight for this point to 1 if it is exact.
          IF ( RW(K) - DIST == RW(K) ) THEN
             WTS(:) = 0
             WTS(K) = 1.0_REAL64
             RETURN
          END IF
          ! Otherwise store the weight based on standard scheme.
          ! WEIGHT = ((RADIUS - DIST_TO_DATA) / (RADIUS * DIST_TO_DATA))^2
          WTS(K) = ((RW(K) - DIST) / (RW(K) * DIST))**2
          ! Track the number of points inside the radius of influence.
          I = I + 1
       ! Otherwise, XP is *not* inside the radius of influence of X(K).
       ELSE
          ! Compute the weight as the inverse distance (will square later).
          W = 1.0_REAL64 / DIST
          ! If this point is closer than one of the elements of D, replace.
          IF ( W > TEMP ) THEN
             D(J) = W
             D_IDX(J) = K
             ! Get the next smallest influencer currently in D to be removed.
             J = MINLOC( D(1:M+1), DIM = 1 )
             TEMP = D(J)
          END IF
       END IF
    END DO
    ! I = 0 iff the point XP is not within the radius RW(K) of X(:,K) for all K;
    ! IER = 1. Revert to using the (M+1) points with inverse distance
    ! squared weighting (original shepard method).
    IF ( I == 0 ) THEN
       D = D**2
       ! If all (M+1) points have been used, increment J to include all.
       IF (D(MINLOC(D(1:M+1), DIM = 1 )) .GT. 0.0_REAL64) J = M+1
       ! Assume weights D(1:J) are all nonzero, use Shepard method.
       WTS(D_IDX(1:J)) = D(:) / SUM( D(:) )
       IER = 1
       RETURN
    ELSE
       WTS(1:N) = WTS(1:N) / SUM( WTS(1:N) )
    END IF

    RETURN
  END SUBROUTINE SHEPMODVAL

END MODULE MODIFIED_SHEPARD


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... file testrvsph.f
c
c     this file contains a test program for trvsph.f
c
c ... required files
c
c     trvsph.f, sphcom.f, hrfft.f, gaqd.f, vhaec.f, vhsec.f, vhagc.f, vhsgc.f
c
c ... description (see documentation in file trvsph.f)
c
c     Subroutine trvsph is used to demonstrate vector data transfer between a coarse
c     ten degree equally spaced grid and a higher resolution T42 Global Spectral
c     Gaussian grid.
c
c     Ten Degree Grid (Mathematical Spherical Coordinates)
c
c     The equally spaced vector data, given in mathematical spherical
c     coordinates,  is stored in 19 X 36 colatitude-longitude arrays (ue,ve).  The
c     colatitudinal values are stored north to south with increasing colatitude
c     subscript values.  ue is the east longitudinal component and ve is the
c     colatitudinal component of the vector.
c
c     Gaussian Grid (Geophysical Spherical Coordinates)
c
c     The T42 Gaussian grid vector data is in geophysical spherical coordinates.
c     It is stored in 128 X 64 longitude-latitude arrays (ug,vg).  Values are
c     stored south to north with increasing latitude subscript value.  ug
c     is the longitudinal component and vg is the latitudinal componenet of the
c     vector data.
c
c     For testing purposes we use an analytic vector field (u,v).  Let t and p
c     be colatitude and longitude and x=sin(t)cos(p), y=sint(t)*sin(p), z=cos(t)
c     be the cartesian coordinates restricted to the sphere in mathematical
c     coordinates. We derive the vector field (u,v) from the stream function
c     S and velocity function P given by
c
c               y    -z           x    z
c          S = e  + e  ,     P = e  + e
c
c     The corresponding vector field has the form
c
c                x          -z          y
c          u = -e sin(p) + e  sin(t) + e cos(t)sin(p)
c
c                y          z          x
c          v = -e cos(p) - e sin(t) + e cos(t)cos(p)
c
c
c     in mathematical spherical coordinates.  Values in geophysical
c     coordinates can be obtained by negating v.
c
c     In the code below, (ue,ve) is set equal to (u,v) and trvsph is used to
c     transfer (ue,ve) to (ug,vg).  (ug,vg) is then compared with (u,v) in
c     geophysical coordinates on the T42 Gaussian grid.  Finally, trvsph is
c     used to transfer (ug,vg) back to (ue,vg) and this is compared with (u,v).
c     Output from executing the test program on separate platforms with 32 bit
c     and 64 bit floating point arithmetic is listed below.  The minimum required
c     saved and unsaved work space lengths were predetermined by an earlier call
c     trvsph with nlone=36,nlate=19,nlong=128,nlatg=64,lsave=0,lwork=0 and printout
c     of lsvmin and lwkmin.
c
c
c **********************************************************************
c
c     OUTPUT FROM EXECUTING CODE IN THIS FILE
C
c **********************************************************************
c
c      EQUALLY SPACED TO GAUSSIAN GRID TRANSFER
c      trvsph input arguments:
c      intl =  0
c      igride(1) = -1   igride(2) =  1
c      nlone =  36   nlate =  19
c      ive =  1
c      igridg(1) =  2   igridg(2) =  0
c      nlong = 128   nlatg =  64
c      ivg =  0
c      lsave =   21814   lwork =   75173
c
c      trvsph output:
c      ier =        0  lsvmin =   21792  lwkmin =   75173
C ***  32 BIT FLOATING POINT ARITHMETIC
c      least squares error in u =  0.307E-06
c      least squares error in v =  0.272E-06
C ***  64 BIT FLOATING POINT ARITHMETIC
c      least squares error in u =  0.841E-12
c      least squares error in v =  0.603E-12
c
c      GAUSSIAN TO EQUALLY SPACED GRID TRANSFER
c      trvsph input arguments:
c      intl =  0
c      igridg(1) =  2   igridg(2) =  0
c      nlong = 128   nlatg =  64
c      ivg =  0
c      igride(1) = -1   igride(2) =  1
c      nlone =  36   nlate =  19
c      ive =  1
c      lsave =   21814   lwork =   75173
c
c      trvsph output:
c      ier =        0  lsvmin =   21814  lwkmin =   75173
C ***  32 BIT FLOATING POINT ARITHMETIC
c      least squares error in u =  0.374E-06
c      least squares error in v =  0.364E-06
C ***  64 BIT FLOATING POINT ARITHMETIC
c      least squares error in u =  0.170E-12
c      least squares error in v =  0.161E-12
c
C **********************************************************************
c
c     END OF OUTPUT ... CODE FOLLOWS
c
c **********************************************************************
      program testrvsph
      implicit none
c
c     set grid sizes with parameter statements
c
      integer nnlatg,nnlong,nnlate,nnlone,llwork,llsave,lldwork
      parameter (nnlatg=64, nnlong=128, nnlate=19,nnlone=36)
c
c     set predetermined minimum saved and unsaved work space lengths
c
      parameter (llwork =  76000)
      parameter (llsave = 21814)
c
c     set double precision work space length
c
      parameter (lldwork = 2*nnlatg*(nnlatg+1)+1)
c
c     dimension and type data arrays and grid vectors and internal variables
c
      real ue(nnlate,nnlone), ve(nnlate,nnlone)
      real ug(nnlong,nnlatg), vg(nnlong,nnlatg)
      real work(llwork),wsave(llsave),thetag(nnlatg)
      DOUBLE PRECISION DTHETA(NNLATG),DWTS(NNLATG),DWORK(LLDWORK)
      integer igride(2),igridg(2),ive,ivg
      integer nlatg,nlong,nlate,nlone,lwork,lsave,ldwork
      real pi,dlate,dlone,dlong,t,p,cosp,sinp,cost,sint,x,y,z
      real erru2,errv2,ex,ey,ez,emz,uee,vee
      integer i,j,ib,intl,ier,lsvmin,lwkmin
c
c     set grid sizes and dimensions from parameter statements
c
      nlatg = nnlatg
      nlong = nnlong
      nlate = nnlate
      nlone = nnlone
      lwork = llwork
      lsave = llsave
      ldwork = lldwork
c
c     set equally spaced grid increments
c
      pi = 4.0*atan(1.0)
      dlate = pi/(nlate-1)
      dlone = (pi+pi)/nlone
      dlong = (pi+pi)/nlong
c
c     set vector data in (ue,ve)
c
      do  j=1,nlone
	p = (j-1)*dlone
	cosp = cos(p)
	sinp = sin(p)
	do i=1,nlate
	  t = (i-1)*dlate
	  cost = cos(t)
	  sint = sin(t)
	  x = sint*cosp
	  y = sint*sinp
	  z = cost
	  ex = exp(x)
	  ey = exp(y)
	  ez = exp(z)
	  emz = exp(-z)
	  ve(i,j) = ex*cost*cosp-ey*cosp-ez*sint
	  ue(i,j) = -ex*sinp + emz*sint + ey*cost*sinp
	end do
      end do
c
c     set initial call flag
c
      intl = 0
c
c     flag (ue,ve) grid as north to south equally spaced
c
      igride(1) = -1
c
c     flag (ue,ve) as nlate by nlone arrays
c
      igride(2) = 1
c
c     flag ve as colatitude component of vector
      ive = 1
c
c     flag (ug,vg) as south to north gaussian
c
      igridg(1) = +2
c
c     flag (ug,vg) as nlong by nlatg arrays
c
      igridg(2) = 0
c
c     flag vg as latitude component of vector
      ivg = 0
c
c     print trvsph input arguments
c
      write(*,100) intl,igride(1),igride(2),nlone,nlate,ive,
     +igridg(1),igridg(2),nlong,nlatg,ivg,lsave,lwork
  100 format(//' EQUALLY SPACED TO GAUSSIAN GRID TRANSFER ' ,
     +/' trvsph input arguments: ' ,
     +/' intl = ',i2,
     +/' igride(1) = ',i2,2x,' igride(2) = ',i2,
     +/' nlone = ',i3,2x,' nlate = ',i3,
     +/' ive = ',i2,
     +/' igridg(1) = ',i2,2x,' igridg(2) = ',i2,
     +/' nlong = ',i3,2x,' nlatg = ',i3,
     +/' ivg = ',i2
     +/' lsave = ',i7,2x,' lwork = ',i7)
c
c     transfer  (ue,ve) to (ug,vg)
c
      call trvsph(intl,igride,nlone,nlate,ive,ue,ve,igridg,nlong,
     +nlatg,ivg,ug,vg,wsave,lsave,lsvmin,work,lwork,lwkmin,dwork,ier)
c
c     print output arguments
c
      write (*,200) ier, lsvmin, lwkmin
  200 format(//' trvsph output: '
     +/ ' ier = ', i8,2x, 'lsvmin = ',i7, 2x,'lwkmin = ',i7)

      if (ier .eq. 0) then
c
c     compute nlatg gaussian colatitude points and
c     set with south to north orientation in thetag
c
      call gaqd(nlatg,dtheta,dwts,dwork,ldwork,ier)
      do  i=1,nlatg
	ib = nlatg-i+1
	thetag(i) = dtheta(ib)
      end do
c
c     compute the least squares error in (ug,vg)
c     by comparing with exact geophysical vector
c
      errv2 = 0.0
      erru2 = 0.0
      do  j=1,nlong
	p = (j-1)*dlong
	cosp = cos(p)
	sinp = sin(p)
	do i=1,nlatg
	  t = thetag(i)
	  cost = cos(t)
	  sint = sin(t)
	  x = sint*cosp
	  y = sint*sinp
	  z = cost
	  ex = exp(x)
	  ey = exp(y)
	  ez = exp(z)
	  emz = exp(-z)
	  vee = -ex*cost*cosp+ey*cosp+ez*sint
	  uee = -ex*sinp + emz*sint + ey*cost*sinp
	  erru2 = erru2 + (ug(j,i)-uee)**2
	  errv2 = errv2 + (vg(j,i)-vee)**2
	end do
      end do
      erru2 = sqrt(erru2/(nlong*nlatg))
      errv2 = sqrt(errv2/(nlong*nlatg))
      write (6,300) erru2, errv2
  300 format(' least squares error in u = ', e10.3
     +      /' least squares error in v = ', e10.3)
      end if
c
c     now transfer (ug,vg) back to (ue,ve)
c
      do j=1,nlone
	do i=1,nlate
	  ue(i,j) = 0.0
	  ve(i,j) = 0.0
      end do
      end do
      write(*,101) intl,igridg(1),igridg(2),nlong,nlatg,ivg,
     +igride(1),igride(2),nlone,nlate,ive,lsave,lwork,ldwork
  101 format(//' GAUSSIAN TO EQUALLY SPACED GRID TRANSFER ' ,
     +/' trvsph input arguments: ' ,
     +/' intl = ',i2,
     +/' igridg(1) = ',i2,2x,' igridg(2) = ',i2,
     +/' nlong = ',i3,2x,' nlatg = ',i3,
     +/' ivg = ',i2,
     +/' igride(1) = ',i2,2x,' igride(2) = ',i2,
     +/' nlone = ',i3,2x,' nlate = ',i3,
     +/' ive = ',i2
     +/' lsave = ',i7,2x,' lwork = ',i7,2x,' ldwork = ',i5)
      call trvsph(intl,igridg,nlong,nlatg,ivg,ug,vg,igride,nlone,nlate,
     +ive,ue,ve,wsave,lsave,lsvmin,work,lwork,lwkmin,dwork,ldwork,ier)
c
c     print output arguments
c
      write (*,200) ier, lsvmin, lwkmin
      if (ier .eq. 0) then
c
c     compute the least squares error in (ue,ve)
c     by comparing with exact mathematical vector
c
      errv2 = 0.0
      erru2 = 0.0
      do  j=1,nlone
	p = (j-1)*dlone
	cosp = cos(p)
	sinp = sin(p)
	do i=1,nlate
	  t = (i-1)*dlate
	  cost = cos(t)
	  sint = sin(t)
	  x = sint*cosp
	  y = sint*sinp
	  z = cost
	  ex = exp(x)
	  ey = exp(y)
	  ez = exp(z)
	  emz = exp(-z)
	  vee =  ex*cost*cosp-ey*cosp-ez*sint
	  uee = -ex*sinp + emz*sint + ey*cost*sinp
	  erru2 = erru2 + (ue(i,j)-uee)**2
	  errv2 = errv2 + (ve(i,j)-vee)**2
	end do
      end do
      erru2 = sqrt(erru2/(nlone*nlate))
      errv2 = sqrt(errv2/(nlone*nlate))
      write (6,300) erru2, errv2
      end if
      end


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   dd2 :    Basic computations for discrete dynamical systems
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

       F(1)=PAR(1)*U(1)*(1-U(1)) - PAR(2)*U(1)*U(2)
       F(2)=(1-PAR(3))*U(2) + PAR(2)*U(1)*U(2)

      IF(IJAC.EQ.0)RETURN

       DFDU(1,1)=PAR(1)*(1-2*U(1))-PAR(2)*U(2)
       DFDU(1,2)=-PAR(2)*U(1)
       DFDU(2,1)=PAR(2)*U(2)
       DFDU(2,2)=1-PAR(3) + PAR(2)*U(1)

      IF(IJAC.EQ.1)RETURN

       DFDP(1,1)=U(1)*(1-U(1))
       DFDP(2,1)=0.0
       DFDP(1,2)=-U(1)*U(2)
       DFDP(2,2)= U(1)*U(2)

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

       PAR(1)=0.0
       PAR(2)=0.2
       PAR(3)=0.1

       U(1)=0.0
       U(2)=0.0

      END SUBROUTINE STPNT

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


subroutine linear(m,x,y,n,a,z)
      integer m,n
      real, intent(in) :: x(m)
      real, intent(in) :: y(m)
      real, intent(in) :: a(n)
      real, intent(out) :: z(n)

      do i=1, n

      if (a(i) .le. x(1) .or. a(i).ge.x(m)) then
          write ( *, '(a)'    ) ' '
          write ( *, '(a)'    ) '  You are trying to extrapolate'
          write ( *, '(a)'    ) ' '
          write ( *, '(a)'    ) '  Programming Stopping'
          write ( *, '(a)'    ) ' '
          stop
      endif
      enddo

      do i=1, n
      do j=1, m

      if ( (a(i) .ge. x(j) .and. a(i) .le. x(j+1)) .or. (a(i) .le. x(j) .and. a(i) .ge. x(j+1)) ) then

          z(i)=y(j) + (y(j+1) - y(j)) * (a(i) - x(j)) / (x(j+1) - x(j))

      endif
      enddo
      enddo

      return

end subroutine linear


	SUBROUTINE PR_RZLL ( stltdg, stlndg, range, azim, hght, xlat,
     +	                     xlon, iret )
C************************************************************************
C* PR_RZLL 								*
C*                                                                      *
C* This subroutine computes XLAT and XLON from STLTDG, STLNDG, RANGE,	*
c* AZIM, and HGHT.  Equations developed for use in the AOIPS radar	*
C* package are used.							*
C*									*
C* PR_RZLL  ( STLTDG, STLNDG, RANGE, AZIM, HGHT, XLAT, XLON, IRET )	*
C*									*
C* Input parameters:                                                    *
C*	STLTDG		REAL		Station latitude in degrees    	*
C*	STLNDG   	REAL   		Station longitude in degrees	*
C*	RANGE		REAL    	Range in kilometers		*
C*	AZIM		REAL   		Geographic azimuth in radians	*
C*	HGHT		REAL    	Height above ground in km 	*
C*									*
C* Output parameters:                                                   *
C*	XLAT		REAL    	Latitude in degrees		*
C*	XLON     	REAL    	Longitude in degrees		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**                                                                     *
C* Log:									*
C* A. Hhieh/GSC			CTRAN.FTN				*
C* J. Woytek/GSFC	10/81	Adapted for GEMPAK			*
C* G. Huffman/GSC	7/88	Documentation				*
C* J. Wu/GSC            07/00   Moved INCLUDE 'ERMISS.FNC' before the   *
C*                              DATA statement                          *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ERMISS.FNC'
C*
	DATA		fiftn  /.2618/
C*
C------------------------------------------------------------------------
	iret = 0
C
C*	Check for missing values.
C
	IF (( ERMISS (stltdg)) .or. ( ERMISS (stlndg)) .or.
     +	    ( ERMISS (range )) .or. ( ERMISS (azim))   .or.
     +	    ( ERMISS (hght  ))) THEN
	    xlat = RMISSD
	    xlon = RMISSD
	    RETURN
	END IF
C
C*	Put station lat/lon in radians
C
	stlat = stltdg * DTR
	stlon = stlndg * DTR
C
C*	Get elevation angle
C
	IF ( range .eq. 0.0 ) THEN
	    hdr = 0.0
	  ELSE
	    hdr = hght / range
	END IF
C
	IF ( ABS (hdr) .le. 1.0 ) THEN
	    elev = ASIN (hdr)
	  ELSE
	    elev = 0.0
	END IF
C
C*	Get corrected earth's radius
C
	rad = 6378.4 / SQRT (1. + (.00677 * (SIN (stlat) ** 2) ))
	radp = 4. * (rad / 3.)
C
C*	Calculate the distance
C
	IF (elev .gt. fiftn) THEN
	    dist = range * COS (elev)
	  ELSE
	    dist = range * ((1 - elev ** 2 / 2) - range * elev / radp)
	END IF
C*
C*	Calculate the latitude and longitude
C
	cx = dist * SIN (azim)
	cy = dist * COS (azim)
	xlat = stlat + (cy / rad) - (cx ** 2 / (2 * rad**2)*TAN (stlat))
	xlon = stlon + (cx / (rad * COS (xlat)))
C*
C*	Change lat/lon to degrees
C
	xlat = xlat * RTD
	xlon = xlon * RTD
C*
	RETURN
	END


use ArrayClass
use IOClass
use MathClass
implicit none

complex(complex64),allocatable :: Ft(:),Fw(:),Ft_(:)
complex(complex64),allocatable :: RW(:),FRW(:)
integer(int64) :: datasize
type(IO_) ::f

datasize = 2**10
call print("Data-Size is :: ")
call print(datasize)

Ft = zeros(datasize)
Ft(datasize/2-1:datasize/2+1) = 1.0d0

Fw = FFT(Ft)
Ft_ = IFFT(Fw)

call f%open("Ft.txt")
call f%write( abs(Ft) )
call f%close()
call f%plot(option="with lines")

call f%open("Fw.txt")
call f%write( abs(Fw(:datasize) ) )
call f%close()
call f%plot(option="with lines")

RW = HammingWindow(int(datasize)/2, int(datasize))
Fw = windowing(RW,Fw)
Ft_ = IFFT(Fw)
call f%open("RectangularWindow.txt")
call f%write( abs(Ft_(:datasize) ) )
call f%close()
call f%plot(option="with lines")

end


C
C $Id: moproj.f,v 1.4 2008-09-18 00:42:18 kennison Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE MOPROJ (DLAT,DLON,UVAL,VVAL)
C
        DOUBLE PRECISION DLAT,DLON,UVAL,VVAL
C
C The subroutine MOPROJ implements the true Mollweide projection,
C using formulas identical to those given on various Web sites (for
C example, Wikipedia).
C
C DLAT and DLON are input values of latitude and longitude, in radians.
C UVAL and VVAL are output values of U and V, in the projection plane.
C
C The common block MAPCM0 contains mathematical constants.
C
        COMMON /MAPCM0/  COS1,DTOR,DTRH,OOPI,PI,PIOF,PIOT,RTDD,RTOD,
     +                   SROT,SIN1,TOPI,TSRT
        DOUBLE PRECISION COS1,DTOR,DTRH,OOPI,PI,PIOF,PIOT,RTDD,RTOD,
     +                   SROT,SIN1,TOPI,TSRT
        SAVE   /MAPCM0/
C
C Local variables.
C
        DOUBLE PRECISION THTA,THTP
C
C Near the poles, the following code doesn't work properly, so we have
C to deal with that case separately:
C
        IF (ABS(DLAT)-PIOT.GT.-1.D-12) THEN
          UVAL=0.D0
          VVAL=SIGN(SROT,DLAT)
          RETURN
        END IF
C
C We have to do a Newton-Raphson iteration to get a value for "theta".
C Set up the iteration loop.  THTP is an initial guess (per MathWorld).
C
        THTP=2.D0*ASIN(MAX(-1.D0,MIN(+1.D0,DLAT/PIOT)))
C
C NITR keeps track of the number of iterations performed.
C
        NITR=1
C
C Iteration loop.  First, compute terms that occur frequently.
C
  101   THTA=THTP-(THTP+SIN(THTP)-PI*SIN(DLAT))/(1.D0+COS(THTP))
C
C If the improved value is not sufficiently different from the previous
C value and fewer than the maximum number of iterations have been done,
C go back for another one.  Otherwise, we have our value of THTA.
C
        IF (ABS(THTA-THTP).GT.1.D-12) THEN
          IF (NITR.LT.20) THEN
            THTP=THTA
            NITR=NITR+1
            GO TO 101
          END IF
        END IF
C
C Halve the value of "theta".
C
        THTA=.5D0*THTA
C
C Compute the values of UVAL and VVAL.
C
        UVAL=SROT*COS(THTA)*DLON/PIOT
        VVAL=SROT*SIN(THTA)
C
        RETURN
C
      END


module compute_rho_cic_m

use mesh_fields_m
use particles_m

implicit none

contains

subroutine compute_rho_cic( f, p)

type(particles_t), intent(in)    :: p
type(fields_3d_t), intent(inout) :: f

real(8)    :: a1, a2, a3, a4, a5, a6, a7, a8
real(8)    :: xp, yp, zp, vol
real(8)    :: dxp, dyp, dzp
integer    :: ip, jp, kp
real(8)    :: dx, dy, dz
integer    :: nx, ny, nz
integer(8) :: m

dx = f%mesh%dx
dy = f%mesh%dy
dz = f%mesh%dz

f%rho = 0.0d0

vol   = p%w / (dx*dy*dz)

do m = 1_8, p%nbpart

   xp = p%x(1, m)/dx
   yp = p%x(2, m)/dy
   zp = p%x(3, m)/dz

   ip = floor(xp)
   jp = floor(yp)
   kp = floor(zp)

   dxp = xp - real(ip, kind=8)
   dyp = yp - real(jp, kind=8)
   dzp = zp - real(kp, kind=8)

   a1 = (1d0 - dxp) * (1d0 - dyp) * (1d0 - dzp)
   a2 = dxp         * (1d0 - dyp) * (1d0 - dzp)
   a3 = (1d0 - dxp) * dyp         * (1d0 - dzp)
   a4 = dxp         * dyp         * (1d0 - dzp)
   a5 = (1d0 - dxp) * (1d0 - dyp) * dzp
   a6 = dxp         * (1d0 - dyp) * dzp
   a7 = (1d0 - dxp) * dyp         * dzp
   a8 = dxp         * dyp         * dzp

   ip = ip+1
   jp = jp+1
   kp = kp+1

   f%rho(ip  ,jp  ,kp  ) = f%rho(ip  ,jp  ,kp  ) + a1 * vol
   f%rho(ip+1,jp  ,kp  ) = f%rho(ip+1,jp  ,kp  ) + a2 * vol
   f%rho(ip  ,jp+1,kp  ) = f%rho(ip  ,jp+1,kp  ) + a3 * vol
   f%rho(ip+1,jp+1,kp  ) = f%rho(ip+1,jp+1,kp  ) + a4 * vol
   f%rho(ip  ,jp  ,kp+1) = f%rho(ip  ,jp  ,kp+1) + a5 * vol
   f%rho(ip+1,jp  ,kp+1) = f%rho(ip+1,jp  ,kp+1) + a6 * vol
   f%rho(ip  ,jp+1,kp+1) = f%rho(ip  ,jp+1,kp+1) + a7 * vol
   f%rho(ip+1,jp+1,kp+1) = f%rho(ip+1,jp+1,kp+1) + a8 * vol

end do

nx = f%mesh%nx
ny = f%mesh%ny
nz = f%mesh%nz

f%rho(nx+1,:,:) = f%rho(1,:,:)
f%rho(:,ny+1,:) = f%rho(:,1,:)
f%rho(:,:,nz+1) = f%rho(:,:,1)

end subroutine compute_rho_cic

end module compute_rho_cic_m


        SUBROUTINE INIT_FNBOD(N,Y)
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        intent(in) :: N
        double precision, intent(out) :: Y(N)
C --- INITIAL VALUES
        pi=3.141592653589d0
        mbdy = N/6
        rf1 = 4*pi/8
        rf2 = 2*pi/mbdy
        do i=1,mbdy
C          mass(i) = (0.3D0 +0.1D0*(cos(i*rf1)+1D0))/mbdy
          rad = 1.7D0+dcos(i*0.75D0)
          v = 0.22d0*dsqrt(rad)
          ci = dcos(i*rf2)
          si = dsin(i*rf2)
          ip = 6*(i-1)
          Y(ip+1) = rad*ci ! initial position
          Y(ip+2) = rad*si
          Y(ip+3) = 0.4D0*si
          Y(ip+4) = -v*si ! velocity is tangential
          Y(ip+5) = v*ci
          Y(ip+6) = 0.D0
        end do
        RETURN
        END

        SUBROUTINE FNBOD(Y,X,F,N)
C --- RIGHT-HAND SIDE OF N-body problem
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        double precision, intent(in) :: X, Y(N)
        double precision, intent(out) :: F(N)
        mbdy = N/6
        eps  = 1.D-4
        dmass =  1.D0
        do i=1,mbdy
           ip = 6*(i-1)
           F(ip+1) = Y(ip+4)
           F(ip+2) = Y(ip+5)
           F(ip+3) = Y(ip+6)
           f1 = 0D0; f2 = 0D0; f3 = 0D0
          do j=1,mbdy ! compute gravity force body j <- i
            if (j.ne.i) then
              jp = 6*(j-1)
              dist=eps+(Y(ip+1)-Y(jp+1))**2+(Y(ip+2)-Y(jp+2))**2+
     &              (Y(ip+3)-Y(jp+3))**2
              dist = dmass/(dist*sqrt(dist))
              f1 = f1+(Y(jp+1)-Y(ip+1))*dist
              f2 = f2+(Y(jp+2)-Y(ip+2))*dist
              f3 = f3+(Y(jp+3)-Y(ip+3))*dist
            end if
          end do
          F(ip+4) = f1
          F(ip+5) = f2
          F(ip+6) = f3
        end do
        RETURN
        END