!pr 12839- F2003 formatting of Inf /Nan
|
!pr 12839- F2003 formatting of Inf /Nan
|
implicit none
|
implicit none
|
character*40 l
|
character*40 l
|
character*12 fmt
|
character*12 fmt
|
real zero, pos_inf, neg_inf, nan
|
real zero, pos_inf, neg_inf, nan
|
zero = 0.0
|
zero = 0.0
|
|
|
! need a better way of generating these floating point
|
! need a better way of generating these floating point
|
! exceptional constants.
|
! exceptional constants.
|
|
|
pos_inf = 1.0/zero
|
pos_inf = 1.0/zero
|
neg_inf = -1.0/zero
|
neg_inf = -1.0/zero
|
nan = zero/zero
|
nan = zero/zero
|
|
|
! check a field width = 0
|
! check a field width = 0
|
fmt = '(F0.0)'
|
fmt = '(F0.0)'
|
write(l,fmt=fmt)pos_inf
|
write(l,fmt=fmt)pos_inf
|
if (l.ne.'+Inf') call abort
|
if (l.ne.'+Inf') call abort
|
write(l,fmt=fmt)neg_inf
|
write(l,fmt=fmt)neg_inf
|
if (l.ne.'-Inf') call abort
|
if (l.ne.'-Inf') call abort
|
write(l,fmt=fmt)nan
|
write(l,fmt=fmt)nan
|
if (l.ne.' NaN') call abort
|
if (l.ne.' NaN') call abort
|
|
|
! check a field width < 3
|
! check a field width < 3
|
fmt = '(F2.0)'
|
fmt = '(F2.0)'
|
write(l,fmt=fmt)pos_inf
|
write(l,fmt=fmt)pos_inf
|
if (l.ne.'**') call abort
|
if (l.ne.'**') call abort
|
write(l,fmt=fmt)neg_inf
|
write(l,fmt=fmt)neg_inf
|
if (l.ne.'**') call abort
|
if (l.ne.'**') call abort
|
write(l,fmt=fmt)nan
|
write(l,fmt=fmt)nan
|
if (l.ne.'**') call abort
|
if (l.ne.'**') call abort
|
|
|
! check a field width = 3
|
! check a field width = 3
|
fmt = '(F3.0)'
|
fmt = '(F3.0)'
|
write(l,fmt=fmt)pos_inf
|
write(l,fmt=fmt)pos_inf
|
if (l.ne.'Inf') call abort
|
if (l.ne.'Inf') call abort
|
write(l,fmt=fmt)neg_inf
|
write(l,fmt=fmt)neg_inf
|
if (l.ne.'***') call abort
|
if (l.ne.'***') call abort
|
write(l,fmt=fmt)nan
|
write(l,fmt=fmt)nan
|
if (l.ne.'NaN') call abort
|
if (l.ne.'NaN') call abort
|
|
|
! check a field width > 3
|
! check a field width > 3
|
fmt = '(F4.0)'
|
fmt = '(F4.0)'
|
write(l,fmt=fmt)pos_inf
|
write(l,fmt=fmt)pos_inf
|
if (l.ne.'+Inf') call abort
|
if (l.ne.'+Inf') call abort
|
write(l,fmt=fmt)neg_inf
|
write(l,fmt=fmt)neg_inf
|
if (l.ne.'-Inf') call abort
|
if (l.ne.'-Inf') call abort
|
write(l,fmt=fmt)nan
|
write(l,fmt=fmt)nan
|
if (l.ne.' NaN') call abort
|
if (l.ne.' NaN') call abort
|
|
|
! check a field width = 7
|
! check a field width = 7
|
fmt = '(F7.0)'
|
fmt = '(F7.0)'
|
write(l,fmt=fmt)pos_inf
|
write(l,fmt=fmt)pos_inf
|
if (l.ne.' +Inf') call abort
|
if (l.ne.' +Inf') call abort
|
write(l,fmt=fmt)neg_inf
|
write(l,fmt=fmt)neg_inf
|
if (l.ne.' -Inf') call abort
|
if (l.ne.' -Inf') call abort
|
write(l,fmt=fmt)nan
|
write(l,fmt=fmt)nan
|
if (l.ne.' NaN') call abort
|
if (l.ne.' NaN') call abort
|
|
|
! check a field width = 8
|
! check a field width = 8
|
fmt = '(F8.0)'
|
fmt = '(F8.0)'
|
write(l,fmt=fmt)pos_inf
|
write(l,fmt=fmt)pos_inf
|
if (l.ne.' +Inf') call abort
|
if (l.ne.' +Inf') call abort
|
write(l,fmt=fmt)neg_inf
|
write(l,fmt=fmt)neg_inf
|
if (l.ne.' -Inf') call abort
|
if (l.ne.' -Inf') call abort
|
write(l,fmt=fmt)nan
|
write(l,fmt=fmt)nan
|
if (l.ne.' NaN') call abort
|
if (l.ne.' NaN') call abort
|
|
|
! check a field width = 9
|
! check a field width = 9
|
fmt = '(F9.0)'
|
fmt = '(F9.0)'
|
write(l,fmt=fmt)pos_inf
|
write(l,fmt=fmt)pos_inf
|
if (l.ne.'+Infinity') call abort
|
if (l.ne.'+Infinity') call abort
|
write(l,fmt=fmt)neg_inf
|
write(l,fmt=fmt)neg_inf
|
if (l.ne.'-Infinity') call abort
|
if (l.ne.'-Infinity') call abort
|
write(l,fmt=fmt)nan
|
write(l,fmt=fmt)nan
|
if (l.ne.' NaN') call abort
|
if (l.ne.' NaN') call abort
|
|
|
! check a field width = 14
|
! check a field width = 14
|
fmt = '(F14.0)'
|
fmt = '(F14.0)'
|
write(l,fmt=fmt)pos_inf
|
write(l,fmt=fmt)pos_inf
|
if (l.ne.' +Infinity') call abort
|
if (l.ne.' +Infinity') call abort
|
write(l,fmt=fmt)neg_inf
|
write(l,fmt=fmt)neg_inf
|
if (l.ne.' -Infinity') call abort
|
if (l.ne.' -Infinity') call abort
|
write(l,fmt=fmt)nan
|
write(l,fmt=fmt)nan
|
if (l.ne.' NaN') call abort
|
if (l.ne.' NaN') call abort
|
end
|
end
|
|
|
|
|
