
subroutine setround(i)
integer i,j
CHARACTER *9 out
IF (i.eq. 1) THEN
j = ieee_flags('set','direction','nearest',out)
ELSE IF (i .EQ. 2) THEN
j = ieee_flags('set','direction','tozero',out)
ELSE IF (i .EQ. 3) THEN
j = ieee_flags('set','direction','positive',out)
ELSE IF (i .EQ. 4) THEN
j = ieee_flags('set','direction','negative',out)
end if
j = ieee_flags('clear','exception','all',out)
return
end

subroutine getexcept(flgs)
integer flgs,j
CHARACTER *16 out
flgs = ieee_flags('get','exception','',out)
j = ieee_flags('clear','exception','all',out)
return
end


subroutine addf(a,b,c)
real a
real b
real c
c = a + b
return
end

subroutine addd(a,b,c)
double precision a
double precision b
double precision c
c = a + b
return
end

subroutine addl(a,b,c)
real(KIND=16) a
real(KIND=16) b
real(KIND=16) c
c = a + b
return
end

subroutine mulf(a,b,c)
real a
real b
real c
c = a * b
return
end

subroutine muld(a,b,c)
double precision a
double precision b
double precision c
c = a * b
return
end

subroutine mull(a,b,c)
real(KIND=16) a
real(KIND=16) b
real(KIND=16) c
c = a * b
return
end

subroutine divf(a,b,c)
real a
real b
real c
c = a / b
return
end

subroutine divd(a,b,c)
double precision a
double precision b
double precision c
c = a / b
return
end

subroutine divl(a,b,c)
real(KIND=16) a
real(KIND=16) b
real(KIND=16) c
c = a / b
return
end

subroutine remf(a,b,c)
real a
real b
real c

return
end

subroutine remd(a,b,c)
double precision a
double precision b
double precision c

return
end

subroutine reml(a,b,c)
real(KIND=16) a
real(KIND=16) b
real(KIND=16) c

return
end

subroutine sqrtf(a,c)
real a
real c
c = SQRT(a) 
return
end

subroutine sqrtd(a,c)
double precision a
double precision c
c = DSQRT(a)
return
end

subroutine sqrtl(a,c)
real(16) a
real(16) c

return
end

subroutine rtds(d,s)
real(KIND=4) s
real(KIND=8) d
s = d
return
end

subroutine rtls(l,s)
real(KIND=4) s
real(KIND=16) l
s = l
return
end

subroutine rtld(l,d) 
double precision d
real(KIND=16) l
d = l 
return
end

subroutine cfs2d(s,d)
real(KIND=4) s
real(KIND=8) d
d=s
return
end;

subroutine cfs2q(s,q)
real(KIND=4) s
real(KIND=16) q
q=s
return
end;

subroutine cfd2q(d,q)
real(KIND=8) d
real(KIND=16) q
q=d
return
end;

subroutine rintegralf(a,c)
real a
real c
c = r_rint(a)
return
end

subroutine rintegrald(a,c)
double precision a,c, d_rint
c = d_rint(a)
return
end

subroutine rintegrall(a,c)
real(KIND=16) a
real(KIND=16) c,anint
CHARACTER *9 out
integer i
i = ieee_flags('get','direction','',out)
IF (out.eq. 'positive') THEN

ELSE IF (out.eq. 'negative') THEN

ELSE IF (out.eq. 'tozero') THEN
c = aint(a,16)
ELSE IF (out.eq. 'nearest') THEN
c = anint(a,16)
end if
return
end

subroutine rif(a,c)
real a
integer(KIND=4) c
CHARACTER *9 out
c = ieee_flags('get','direction','',out)
IF (out.eq. 'positive') THEN
c = CEILING(a)
ELSE IF (out.eq. 'negative') THEN
c = FLOOR(a)
ELSE IF (out.eq. 'tozero') THEN
c = INT(a)
ELSE IF (out.eq. 'nearest') THEN
c = NINT(a,4)
end if
return
end

subroutine rid(a,c)
real(8) a
integer(4) c
CHARACTER *9 out
c = ieee_flags('get','direction','',out)
IF (out.eq. 'positive') THEN
c = CEILING(a)
ELSE IF (out.eq. 'negative') THEN
c = FLOOR(a)
ELSE IF (out.eq. 'tozero') THEN
c = INT(a,4)
ELSE IF (out.eq. 'nearest') THEN
c = NINT(a,4)
end if
return
end

subroutine ril(a,c)
real(16) a
integer(4) c
CHARACTER *9 out
c = ieee_flags('get','direction','',out)
IF (out.eq. 'positive') THEN
c = CEILING(a)
ELSE IF (out.eq. 'negative') THEN
c = FLOOR(a)
ELSE IF (out.eq. 'tozero') THEN
c = INT(a,4)
ELSE IF (out.eq. 'nearest') THEN
c = NINT(a,4)
end if
return
end

subroutine cif(a,c)
real a
integer(4) c
a = c
return
end

subroutine cid(a,c)
real(8) a
integer(4) c
a = c
return
end

subroutine cil(a,c)
real(16) a
integer(4) c
a = c
return
end

subroutine ri64f(a,c)
real(4) a
integer(8) c
CHARACTER *9 out
c = ieee_flags('get','direction','',out)
IF (out.eq. 'positive') THEN
c= CEILING(a,8)
ELSE IF (out.eq. 'negative') THEN
c= FLOOR(a,8)
ELSE IF (out.eq. 'tozero') THEN
c = INT(a,8)
ELSE IF (out.eq. 'nearest') THEN
c = NINT(a,8)
end if
return
end

subroutine ri64d(a,c)
real(8) a
integer(8) c
CHARACTER *9 out
c = ieee_flags('get','direction','',out)
IF (out.eq. 'positive') THEN
c= CEILING(a,8)
ELSE IF (out.eq. 'negative') THEN
c= FLOOR(a,8)
ELSE IF (out.eq. 'tozero') THEN
c = INT(a,8)
ELSE IF (out.eq. 'nearest') THEN
c = NINT(a,8)
end if
return
end

subroutine ri64l(a,c)
real(16) a
integer(8) c
CHARACTER *9 out
c = ieee_flags('get','direction','',out)
IF (out.eq. 'positive') THEN
c= CEILING(a,8)
ELSE IF (out.eq. 'negative') THEN
c= FLOOR(a,8)
ELSE IF (out.eq. 'tozero') THEN
c = INT(a,8)
ELSE IF (out.eq. 'nearest') THEN
c = NINT(a,8)
end if
return
end

subroutine ci64f(a,c)
real a
integer(8) c
a = c
return
end

subroutine ci64d(a,c)
real(8) a
integer(8) c
a = c
return
end

subroutine ci64l(a,c)
real(16) a
integer(8) c
a = c
return
end

subroutine b2df(i,r,str)
integer i
real(4) r
CHARACTER str*256
if (i .EQ. 1) THEN
   WRITE(str,'(E20.1E5 )') r
ELSE IF (i .EQ. 2) THEN
   WRITE(str,'(E20.2E5 )') r
ELSE IF (i .EQ. 3) THEN
   WRITE(str,'(E20.3E5 )') r
ELSE IF (i .EQ. 4) THEN
   WRITE(str,'( E20.4E5 )') r
ELSE IF (i .EQ. 5) THEN
   WRITE(str,'( E20.5E5 )') r
ELSE IF (i .EQ. 6) THEN
   WRITE(str,'( E20.6E5 )') r
ELSE IF (i .EQ. 7) THEN
   WRITE(str,'( E20.7E5 )') r
ELSE IF (i .EQ. 8) THEN
   WRITE(str,'( E20.8E5 )') r
ELSE IF (i .EQ. 9) THEN
   WRITE(str,'( E20.9E5 )') r
ELSE IF (i .EQ. 10) THEN
   WRITE(str,'( E50.10E5 )') r
ELSE IF (i .EQ. 11) THEN
   WRITE(str,'( E50.11E5 )') r
ELSE IF (i .EQ. 12) THEN
   WRITE(str,'( E50.12E5 )') r
ELSE IF (i .EQ. 13) THEN
   WRITE(str,'( E50.13E5 )') r
ELSE IF (i .EQ. 14) THEN
   WRITE(str,'( E50.14E5 )') r
ELSE IF (i .EQ. 15) THEN
   WRITE(str,'( E50.15E5 )') r
ELSE IF (i .EQ. 16) THEN
   WRITE(str,'( E50.16E5 )') r
ELSE IF (i .EQ. 17) THEN
   WRITE(str,'( E50.17E5 )') r
ELSE IF (i .EQ. 18) THEN
   WRITE(str,'( E50.18E5 )') r
ELSE IF (i .EQ. 19) THEN
   WRITE(str,'( E50.19E5 )') r
ELSE IF (i .EQ. 20) THEN
   WRITE(str,'( E50.20E5 )') r
END IF
return
end

subroutine b2dd(i,r,str)
integer i
double precision r
CHARACTER str*256
if (i .EQ. 1) THEN
   WRITE(str,'(E20.1E5 )') r
ELSE IF (i .EQ. 2) THEN
   WRITE(str,'(E20.2E5 )') r
ELSE IF (i .EQ. 3) THEN
   WRITE(str,'(E20.3E5 )') r
ELSE IF (i .EQ. 4) THEN
   WRITE(str,'( E20.4E5 )') r
ELSE IF (i .EQ. 5) THEN
   WRITE(str,'( E20.5E5 )') r
ELSE IF (i .EQ. 6) THEN
   WRITE(str,'( E20.6E5 )') r
ELSE IF (i .EQ. 7) THEN
   WRITE(str,'( E20.7E5 )') r
ELSE IF (i .EQ. 8) THEN
   WRITE(str,'( E20.8E5 )') r
ELSE IF (i .EQ. 9) THEN
   WRITE(str,'( E20.9E5 )') r
ELSE IF (i .EQ. 10) THEN
   WRITE(str,'( E50.10E5 )') r
ELSE IF (i .EQ. 11) THEN
   WRITE(str,'( E50.11E5 )') r
ELSE IF (i .EQ. 12) THEN
   WRITE(str,'( E50.12E5 )') r
ELSE IF (i .EQ. 13) THEN
   WRITE(str,'( E50.13E5 )') r
ELSE IF (i .EQ. 14) THEN
   WRITE(str,'( E50.14E5 )') r
ELSE IF (i .EQ. 15) THEN
   WRITE(str,'( E50.15E5 )') r
ELSE IF (i .EQ. 16) THEN
   WRITE(str,'( E50.16E5 )') r
ELSE IF (i .EQ. 17) THEN
   WRITE(str,'( E50.17E5 )') r
ELSE IF (i .EQ. 18) THEN
   WRITE(str,'( E50.18E5 )') r
ELSE IF (i .EQ. 19) THEN
   WRITE(str,'( E50.19E5 )') r
ELSE IF (i .EQ. 20) THEN
   WRITE(str,'( E50.20E5 )') r
END IF
return
end

subroutine b2dl(i,r,str)
integer i
real(16) r
CHARACTER str*256
if (i .EQ. 1) THEN
   WRITE(str,'(E20.1E5 )') r
ELSE IF (i .EQ. 2) THEN
   WRITE(str,'(E20.2E5 )') r
ELSE IF (i .EQ. 3) THEN
   WRITE(str,'(E20.3E5 )') r
ELSE IF (i .EQ. 4) THEN
   WRITE(str,'( E20.4E5 )') r
ELSE IF (i .EQ. 5) THEN
   WRITE(str,'( E20.5E5 )') r
ELSE IF (i .EQ. 6) THEN
   WRITE(str,'( E20.6E5 )') r
ELSE IF (i .EQ. 7) THEN
   WRITE(str,'( E20.7E5 )') r
ELSE IF (i .EQ. 8) THEN
   WRITE(str,'( E20.8E5 )') r
ELSE IF (i .EQ. 9) THEN
   WRITE(str,'( E20.9E5 )') r
ELSE IF (i .EQ. 10) THEN
   WRITE(str,'( E50.10E5 )') r
ELSE IF (i .EQ. 11) THEN
   WRITE(str,'( E50.11E5 )') r
ELSE IF (i .EQ. 12) THEN
   WRITE(str,'( E50.12E5 )') r
ELSE IF (i .EQ. 13) THEN
   WRITE(str,'( E50.13E5 )') r
ELSE IF (i .EQ. 14) THEN
   WRITE(str,'( E50.14E5 )') r
ELSE IF (i .EQ. 15) THEN
   WRITE(str,'( E50.15E5 )') r
ELSE IF (i .EQ. 16) THEN
   WRITE(str,'( E50.16E5 )') r
ELSE IF (i .EQ. 17) THEN
   WRITE(str,'( E50.17E5 )') r
ELSE IF (i .EQ. 18) THEN
   WRITE(str,'( E50.18E5 )') r
ELSE IF (i .EQ. 19) THEN
   WRITE(str,'( E50.19E5 )') r
ELSE IF (i .EQ. 20) THEN
   WRITE(str,'( E50.20E5 )') r
END IF
return
end

subroutine d2bf(r,str)
real(4) r
CHARACTER *256 str
!PRINT *,str 
READ(str,'( F64.0 )') r
!PRINT *,r
return
end

subroutine d2bd(r,str)
real(8) r
CHARACTER *256 str
!PRINT *,str 
READ(str,'( F64.0 )') r
!PRINT *,r
return
end

subroutine d2bl(r,str)
real(16) r
CHARACTER *256 str
!PRINT *,str 
READ(str,'( F64.0 )') r
!PRINT *,r
return
end

