real_type.F90

Go to the documentation of this file.

module real_type
  
  implicit none

  private

  !! CONSTANTS
  public :: sp, dp, rp
  public :: real_tol                !! tested
  public :: pi                      !! tested

  !! DERIVED TYPES
  public :: r_1d, r_2d

  !! ROUTINES
  public :: equal                   !! tested
  public :: re                      !! tested
  public :: allocmem, freemem, print


  !       %----------------------------------------%
  !       |                                        |
  !       |          CONSTANTS                     |
  !       |                                        |
  !       %----------------------------------------%

  integer, parameter :: sp = selected_real_kind(6, 37)

  integer, parameter :: dp = selected_real_kind(12) 

  integer, parameter :: tp = selected_real_kind(17) 

  integer, parameter :: qp = selected_real_kind(32) 

#if RPC==4
  integer , parameter :: rp = sp 
  real(RP), parameter :: real_tol = 1e-6_rp

#elif RPC==8
  integer , parameter :: rp = dp
  real(RP), parameter :: real_tol = 1e-14_rp

#elif RPC==12
  integer , parameter :: rp = tp
  real(RP), parameter :: real_tol = 1e-18_rp

#elif RPC==16
  integer , parameter :: rp = qp
  real(RP), parameter :: real_tol = 1e-28_rp

# else
  integer, parameter :: rp = dp
  real(RP), parameter :: real_tol = 1e-14_rp

#endif
  
  real(RP), parameter :: pi=3.1415926535897932384626433832795028_rp

  !       %----------------------------------------%
  !       |                                        |
  !       |          DERIVED TYPE                  |
  !       |                                        |
  !       %----------------------------------------%

  type r_1d
     real(RP), dimension(:), allocatable :: y
   contains
     final :: r_1d_clear
  end type r_1d
  
  type r_2d
     real(RP), dimension(:,:), allocatable :: y
   contains
     final :: r_2d_clear
  end type r_2d

  !       %----------------------------------------%
  !       |                                        |
  !       |          INTERFACES                    |
  !       |                                        |
  !       %----------------------------------------%

  interface clear
     module procedure r_1d_clear
     module procedure r_2d_clear
  end interface clear

  !! constructor
  interface r_1d
     module procedure r_1d_create
  end interface r_1d
  interface r_2d
     module procedure r_2d_create
  end interface r_2d
  
  interface print
     module procedure r2d_print
  end interface print

  interface equal 
     module procedure  real_equal
  end interface equal

  interface re
     module procedure  rf, ri
  end interface re

  interface allocmem 
     module procedure alloc_ra1d, alloc_ra2d, alloc_ra3d
  end interface allocmem

  interface freemem 
     module procedure free_ra1d, free_ra2d, free_ra3d
  end interface freemem

contains

  subroutine r_1d_clear(r)
    type(r_1d), intent(inout) :: r

    call freemem(r%y)

  end subroutine r_1d_clear

  subroutine r_2d_clear(r)
    type(r_2d), intent(inout) :: r

    call freemem(r%y)

  end subroutine r_2d_clear

  function r_1d_create(n) result(r)
    type(r_1d) :: r
    integer, intent(in) :: n

    call allocmem(r%y, n)

  end function r_1d_create

  function r_2d_create(n1, n2) result(r)
    type(r_2d) :: r
    integer, intent(in) :: n1, n2

    call allocmem(r%y, n1, n2)

  end function r_2d_create


  subroutine r2d_print(x)
    real(RP), dimension(:,:), intent(in) :: x
    
    integer  :: ii
    real(SP) :: min, max

    write(*,*) "real_type       : R2D_print"
    write(*,*) "  shape                         = ",&
         & int(size(x,1),4), int(size(x,2),4)
    write(*,*) "  Component   Min              Max"
    do ii=1, size(x,1)
       min = real( minval(x(ii,:)), SP)
       max = real( maxval(x(ii,:)), SP)
       write(*,*) int(ii,4), min, max
    end do
    
  end subroutine r2d_print


  subroutine alloc_ra1d(p,n)
    real(RP), dimension(:), allocatable :: p
    integer, intent(in) :: n

    integer :: stat
    character(len=100) :: errmsg

    call freemem(p)
    allocate(p(n), stat=stat, errmsg=errmsg)
    if (stat > 0) write(*,*) &
         & "ERROR = real_type: alloc_RA1D: ", trim(errmsg) 

  end subroutine alloc_ra1d


  subroutine alloc_ra2d(p,n1,n2)
    real(RP), dimension(:,:), allocatable :: p
    integer, intent(in) :: n1,n2

    integer :: stat
    character(len=100) :: errmsg

    call freemem(p)
    allocate(p(n1,n2), stat=stat, errmsg=errmsg)
    if (stat > 0) write(*,*)  &
         & "ERROR = real_type: alloc_RA2D: ", trim(errmsg) 

  end subroutine alloc_ra2d


  subroutine alloc_ra3d(p,n1,n2,n3)
    real(RP), dimension(:,:,:), allocatable :: p
    integer, intent(in) :: n1,n2,n3

    integer :: stat
    character(len=100) :: errmsg

    call freemem(p)
    allocate(p(n1,n2,n3), stat=stat, errmsg=errmsg)
    if (stat > 0) write(*,*)  &
         & "ERROR = real_type:alloc_ RA3D: ", trim(errmsg) 

  end subroutine alloc_ra3d


  subroutine free_ra1d(p)
    real(RP), dimension(:), allocatable :: p

    integer :: stat
    character(len=100) :: errmsg

    if (allocated(p)) then
       deallocate(p, stat=stat, errmsg=errmsg)
       if (stat > 0) write(*,*)  &
         & "ERROR = real_type: free_RA1D: ", trim(errmsg) 
    end if

  end subroutine free_ra1d

  subroutine free_ra2d(p)
    real(RP), dimension(:,:), allocatable :: p

    integer :: stat
    character(len=100) :: errmsg

    if (allocated(p)) then
       deallocate(p, stat=stat, errmsg=errmsg)
       if (stat > 0) write(*,*)  &
         & "ERROR = real_type: free_RA2D: ", trim(errmsg) 
    end if

  end subroutine free_ra2d


  subroutine free_ra3d(p)
    real(RP), dimension(:,:,:), allocatable :: p

    integer :: stat
    character(len=100) :: errmsg

    if (allocated(p)) then
       deallocate(p, stat=stat, errmsg=errmsg)
       if (stat > 0) write(*,*)  &
         & "ERROR = real_type: free_RA3D: ", trim(errmsg) 
    end if

  end subroutine free_ra3d

  function real_equal(u, v) result(res)
    logical :: res
    real(RP), intent(in) :: u, v

    res = abs(u-v) < real_tol

  end function real_equal


  function rf(n, d) 
    integer, intent(in) :: n, d
    real(RP)          :: rf

    rf = real(n, rp)/real(d, rp)

  end function rf

  function ri(n) 
    integer, intent(in) :: n
    real(RP)          :: ri

    ri = real(n, rp)

  end function ri


end module real_type