gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sr_kind.f90

   1 ! Program to test SELECTED_REAL_KIND intrinsic function.
   2 Program test_sr_kind
   3   integer res, i4, i8, t
   4   real*4 r4
   5   real*8 r8
   6
   7   i4 = int (log10 (huge (r4)))
   8   t = - int (log10 (tiny (r4)))
   9   if (i4 .gt. t) i4 = t
  10
  11   i8 = int (log10 (huge (r8)))
  12   t = - int (log10 (tiny (r8)))
  13   if (i8 .gt. t) i8 = t
  14
  15   res = selected_real_kind (r = i4)
  16   if (res .ne. 4) call abort
  17
  18   res = selected_real_kind (r = i8)
  19   if (res .ne. 8) call abort
  20
  21   res = selected_real_kind (r = (i8 + 1))
  22   if (res .ne. -2) call abort
  23
  24   res = selected_real_kind (p = precision (r4))
  25   if (res .ne. 4) call abort
  26
  27   res = selected_real_kind (p = precision (r4), r = i4)
  28   if (res .ne. 4) call abort
  29
  30   res = selected_real_kind (p = precision (r4), r = i8)
  31   if (res .ne. 8) call abort
  32
  33   res = selected_real_kind (p = precision (r4), r = i8 + 1)
  34   if (res .ne. -2) call abort
  35
  36   res = selected_real_kind (p = precision (r8))
  37   if (res .ne. 8) call abort
  38
  39   res = selected_real_kind (p = precision (r8), r = i4)
  40   if (res .ne. 8) call abort
  41
  42   res = selected_real_kind (p = precision (r8), r = i8)
  43   if (res .ne. 8) call abort
  44
  45   res = selected_real_kind (p = precision (r8), r = i8 + 1)
  46   if (res .ne. -2) call abort
  47
  48   res = selected_real_kind (p = (precision (r8) + 1))
  49   if (res .ne. -1) call abort
  50
  51   res = selected_real_kind (p = (precision (r8) + 1), r = i4)
  52   if (res .ne. -1) call abort
  53
  54   res = selected_real_kind (p = (precision (r8) + 1), r = i8)
  55   if (res .ne. -1) call abort
  56
  57   res = selected_real_kind (p = (precision (r8) + 1), r = i8 + 1)
  58   if (res .ne. -3) call abort
  59
  60 end
  61