strr.F File Reference

#include "implicit_f.inc"
#include "chrasc_c.inc"

Go to the source code of this file.

Functions/Subroutines
character *8 function	strr (y)

Function/Subroutine Documentation

strr()

character*8 function strr

(

y

)

Definition at line 23 of file strr.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      my_real
     .   y
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "chrasc_c.inc"
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER IEXP, ISE, ISM, MANT, MANT1, MANT2, MANT3, IS, MANT11,
     .   MANT12, MANT21, MANT22, MANT31, MANT32
C     REAL
      my_real
     .   x, a, xman, big
C-----------------------------------------------
      x=y
      big = zep999ep31
      x=min(x,big)
      x=max(x,-big)
      a=abs(x)
      IF(a<onep001em32)THEN
       strr='10000000'
       RETURN
      ENDIF
C
      iexp=log10(a)
      ise=max(0,-isign(1,iexp))
      ism=sign(one,x)
      ism=max(0,-ism)
      xman =a*ten**(-iexp)
      xman =xman*ep9
      IF(xman>=ep9)THEN
      xman=xman/ten
       iexp=iexp+1
      ENDIF
      mant =xman
      IF(mant>=1000000000)THEN
       mant=mant/10
       iexp=iexp+1
      ENDIF
      iexp=iabs(iexp)
C
      mant1=mant/1000000
      mant=mant-1000000*mant1
      mant2=mant/1000
      mant3=mant-1000*mant2
      is=2*ism+ise
C
      mant11=mant1/32
      mant12=mant1-32*mant11
      mant21=mant2/32
      mant22=mant2-32*mant21
      mant31=mant3/32
      mant32=mant3-32*mant31
C
      strr(1:1)=codas(is+1)
      strr(2:2)=codas(iexp)
      strr(3:3)=codas(mant11)
      strr(4:4)=codas(mant12)
      strr(5:5)=codas(mant21)
      strr(6:6)=codas(mant22)
      strr(7:7)=codas(mant31)
      strr(8:8)=codas(mant32)
C
      RETURN