1! Copyright (C) 2003-2018 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!<http://www.gnu.org/licenses/>. 24 25function _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 79end function _gfortran_selected_real_kind2008 80 81function _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) 95end function 96