1!pr 12839- F2003 formatting of Inf /Nan 2! Modified for PR47434 3 implicit none 4 character*40 l 5 character*12 fmt 6 real zero, pos_inf, neg_inf, nan 7 zero = 0.0 8 9! need a better way of generating these floating point 10! exceptional constants. 11 12 pos_inf = 1.0/zero 13 neg_inf = -1.0/zero 14 nan = zero/zero 15 16! check a field width = 0 17 fmt = '(F0.0)' 18 write(l,fmt=fmt)pos_inf 19 if (l.ne.'Inf') STOP 1 20 write(l,fmt=fmt)neg_inf 21 if (l.ne.'-Inf') STOP 2 22 write(l,fmt=fmt)nan 23 if (l.ne.'NaN') STOP 3 24 25! check a field width < 3 26 fmt = '(F2.0)' 27 write(l,fmt=fmt)pos_inf 28 if (l.ne.'**') STOP 4 29 write(l,fmt=fmt)neg_inf 30 if (l.ne.'**') STOP 5 31 write(l,fmt=fmt)nan 32 if (l.ne.'**') STOP 6 33 34! check a field width = 3 35 fmt = '(F3.0)' 36 write(l,fmt=fmt)pos_inf 37 if (l.ne.'Inf') STOP 7 38 write(l,fmt=fmt)neg_inf 39 if (l.ne.'***') STOP 8 40 write(l,fmt=fmt)nan 41 if (l.ne.'NaN') STOP 9 42 43! check a field width > 3 44 fmt = '(F4.0)' 45 write(l,fmt=fmt)pos_inf 46 if (l.ne.' Inf') STOP 10 47 write(l,fmt=fmt)neg_inf 48 if (l.ne.'-Inf') STOP 11 49 write(l,fmt=fmt)nan 50 if (l.ne.' NaN') STOP 12 51 52! check a field width = 7 53 fmt = '(F7.0)' 54 write(l,fmt=fmt)pos_inf 55 if (l.ne.' Inf') STOP 13 56 write(l,fmt=fmt)neg_inf 57 if (l.ne.' -Inf') STOP 14 58 write(l,fmt=fmt)nan 59 if (l.ne.' NaN') STOP 15 60 61! check a field width = 8 62 fmt = '(F8.0)' 63 write(l,fmt=fmt)pos_inf 64 if (l.ne.'Infinity') STOP 16 65 write(l,fmt=fmt)neg_inf 66 if (l.ne.' -Inf') STOP 17 67 write(l,fmt=fmt)nan 68 if (l.ne.' NaN') STOP 18 69 70! check a field width = 9 71 fmt = '(F9.0)' 72 write(l,fmt=fmt)pos_inf 73 if (l.ne.' Infinity') STOP 19 74 write(l,fmt=fmt)neg_inf 75 if (l.ne.'-Infinity') STOP 20 76 write(l,fmt=fmt)nan 77 if (l.ne.' NaN') STOP 21 78 79! check a field width = 14 80 fmt = '(F14.0)' 81 write(l,fmt=fmt)pos_inf 82 if (l.ne.' Infinity') STOP 22 83 write(l,fmt=fmt)neg_inf 84 if (l.ne.' -Infinity') STOP 23 85 write(l,fmt=fmt)nan 86 if (l.ne.' NaN') STOP 24 87 end 88 89