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 33 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, p99
C
      p99 = zep999ep31
      x=y
      x= min(x,p99)
      x= max(x,-p99)
      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*10.**(-iexp)
      xman =xman*1000000000.
      IF(xman>=1000000000.)THEN
       xman=xman/10.
       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