Home | History | Annotate | Line # | Download | only in intrinsics 
      1 !   Copyright (C) 2003-2022 Free Software Foundation, Inc.
      2 !   Contributed by Kejia Zhao <kejia_zh@yahoo.com.cn>
      3 !
      4 !This file is part of the GNU Fortran runtime library (libgfortran).
      5 !
      6 !Libgfortran is free software; you can redistribute it and/or
      7 !modify it under the terms of the GNU General Public
      8 !License as published by the Free Software Foundation; either
      9 !version 3 of the License, or (at your option) any later version.
     10 !
     11 !Libgfortran is distributed in the hope that it will be useful,
     12 !but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 !MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 !GNU General Public License for more details.
     15 !
     16 !Under Section 7 of GPL version 3, you are granted additional
     17 !permissions described in the GCC Runtime Library Exception, version
     18 !3.1, as published by the Free Software Foundation.
     19 !
     20 !You should have received a copy of the GNU General Public License and
     21 !a copy of the GCC Runtime Library Exception along with this program;
     22 !see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
     23 !.
     24 
     25 function _gfortran_selected_real_kind2008 (p, r, rdx)
     26   implicit none
     27   integer, optional, intent (in) :: p, r, rdx
     28   integer :: _gfortran_selected_real_kind2008
     29   integer :: i, p2, r2, radix2
     30   logical :: found_p, found_r, found_radix
     31   ! Real kind_precision_range table
     32   type :: real_info
     33     integer :: kind
     34     integer :: precision
     35     integer :: range
     36     integer :: radix
     37   end type real_info
     38 
     39   include "selected_real_kind.inc"
     40 
     41   _gfortran_selected_real_kind2008 = 0
     42   p2 = 0
     43   r2 = 0
     44   radix2 = 0
     45   found_p = .false.
     46   found_r = .false.
     47   found_radix = .false.
     48 
     49   if (present (p)) p2 = p
     50   if (present (r)) r2 = r
     51   if (present (rdx)) radix2 = rdx
     52 
     53   ! Assumes each type has a greater precision and range than previous one.
     54 
     55   do i = 1, c
     56     if (p2 <= real_infos (i) % precision) found_p = .true.
     57     if (r2 <= real_infos (i) % range) found_r = .true.
     58     if (radix2 <= real_infos (i) % radix) found_radix = .true.
     59 
     60     if (p2 <= real_infos (i) % precision   &
     61         .and. r2 <= real_infos (i) % range &
     62         .and. radix2 <= real_infos (i) % radix) then
     63       _gfortran_selected_real_kind2008 = real_infos (i) % kind
     64       return
     65     end if
     66   end do
     67 
     68   if (found_radix .and. found_r .and. .not. found_p) then
     69     _gfortran_selected_real_kind2008 = -1
     70   elseif (found_radix .and. found_p .and. .not. found_r) then
     71     _gfortran_selected_real_kind2008 = -2
     72   elseif (found_radix .and. .not. found_p .and. .not. found_r) then
     73     _gfortran_selected_real_kind2008 = -3
     74   elseif (found_radix) then
     75     _gfortran_selected_real_kind2008 = -4
     76   else
     77     _gfortran_selected_real_kind2008 = -5
     78   end if
     79 end function _gfortran_selected_real_kind2008
     80 
     81 function _gfortran_selected_real_kind (p, r)
     82   implicit none
     83   integer, optional, intent (in) :: p, r
     84   integer :: _gfortran_selected_real_kind
     85 
     86   interface
     87     function _gfortran_selected_real_kind2008 (p, r, rdx)
     88       implicit none
     89       integer, optional, intent (in) :: p, r, rdx
     90       integer :: _gfortran_selected_real_kind2008
     91     end function _gfortran_selected_real_kind2008
     92   end interface
     93 
     94   _gfortran_selected_real_kind = _gfortran_selected_real_kind2008 (p, r)
     95 end function
     96