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 ! We can in fact have kinds wider than r8.  How do we want to check?
  22 ! res = selected_real_kind (r = (i8 + 1))
  23 ! if (res .ne. -2) call abort
  24
  25   res = selected_real_kind (p = precision (r4))
  26   if (res .ne. 4) call abort
  27
  28   res = selected_real_kind (p = precision (r4), r = i4)
  29   if (res .ne. 4) call abort
  30
  31   res = selected_real_kind (p = precision (r4), r = i8)
  32   if (res .ne. 8) call abort
  33
  34 ! res = selected_real_kind (p = precision (r4), r = i8 + 1)
  35 ! if (res .ne. -2) call abort
  36
  37   res = selected_real_kind (p = precision (r8))
  38   if (res .ne. 8) call abort
  39
  40   res = selected_real_kind (p = precision (r8), r = i4)
  41   if (res .ne. 8) call abort
  42
  43   res = selected_real_kind (p = precision (r8), r = i8)
  44   if (res .ne. 8) call abort
  45
  46 ! res = selected_real_kind (p = precision (r8), r = i8 + 1)
  47 ! if (res .ne. -2) call abort
  48
  49 ! res = selected_real_kind (p = (precision (r8) + 1))
  50 ! if (res .ne. -1) call abort
  51
  52 ! res = selected_real_kind (p = (precision (r8) + 1), r = i4)
  53 ! if (res .ne. -1) call abort
  54
  55 ! res = selected_real_kind (p = (precision (r8) + 1), r = i8)
  56 ! if (res .ne. -1) call abort
  57
  58 ! res = selected_real_kind (p = (precision (r8) + 1), r = i8 + 1)
  59 ! if (res .ne. -3) call abort
  60
  61 end
  62