! ffptos1a ! 15/01/87 - insert alias for INTO RANGE ! make sure host & taget set to IBM ! ffptos1 ! 10/10/86 - insert include files ! ftnfptos5 !Modified 25/June/86 to use own rather than local arrays !Modified 28/May/86 to allow for GOULD !Modified 5/May/86 to reference TRUNC for PERQ3 rather than INT PT !Modified 2/March/86 to reference F77REAL instead using local ! power of ten routine/table AGRK !* modified 25/ 2/85 !* !* !*********************************************************************** !* exports * !*********************************************************************** %string(36)%fnspec FPTOS (%integer REAL ADDR{ess}, REAL MODE {3 for REAL* 4}) {4 for REAL* 8} %include "ftn_ht" {%include "ftn_copy1"} !* modified 23/09/86 !* %routine Copy(%integer Length,Fbase,Fdisp,Tbase,Tdisp) !*********************************************************************** !* copy Length bytes from fbase(fdisp) to tbase(tdisp) * !*********************************************************************** %integer I,From,To %if Length<=0 %then %return From=Fbase+Fdisp To=Tbase+Tdisp %cycle I=0,1,Length-1 byteinteger(To+I)=byteinteger(From+I) %repeat %end;! Copy !* %CONSTINTEGER I2= 2 %CONSTINTEGER I4= 4 %CONSTINTEGER R4= 4 %CONSTINTEGER R8= 8 %externallonglongrealfnspec INTO RANGE %alias "s#intorange" %c (%longlongreal x, %integername exp) {found in F77REAL} %%EXTERNALstring(36) %fn FPTOS (%integer REAL ADDR{ess}, %integer REAL MODE {3 for REAL*4}) ! {4 for REAL*8} ! ! ! A Procedure to print the value of either a single ! ! or double or extended precision Real ! ! for the FORTRAN77 Optimising Compiler. ! ! !Note: This version does not handle extended precision (REAL*16) reals ! ! ! ! ! Floating-Point Constants ! ! %constlongrealarray rounding factor(0:1)= 5.0@-7 , 5.0@-7 %if HOST= PERQPNX %OR HOST= WCW %OR HOST= M68000 %thenstart ! ! Define Real Constants in IEEE Standard ! %constlongreal point one = r'3fb999999999999a' {1.0@-1 } %constlongreal ten to the max= r'7fe1ccf385ebc8a0' {1.0@+308} %constlongreal ten to the min= r'0066789e3750f791' {1.0@-306} %constinteger maximum power= 308 %constinteger minimum power= -306 %finishelsestart ! HOST=IBM or HOST=EMAS or HOST=GOULD %if TARGET=IBM %or TARGET=GOULD %thenstart ! ! Define Real Constants in IBM Standard ! %constlongreal ten to the max= r'7f235fadd81c2823' %constlongreal ten to the min= r'0273cac65c39c961' %constinteger maximum power= 75 %constinteger minimum power= -75 %finishelsestart ! ! Define Real Constants in IEEE Standard on EMAS ! %constintegerarray pnx ten to the max (0:1)= x'7fe1ccf3' , x'85ebc8a0' %constintegerarray pnx ten to the min (0:1)= x'0066789e' , x'3750f791' %longrealname ten to the max {mapped onto PNX TEN TO THE MAX} %longrealname ten to the min {mapped onto PNX TEN TO THE MIN} %constinteger maximum power= 308 %constinteger minimum power= -306 %finish %constlongreal point one = r'401999999999999a' %finish ! ! Work-Areas ! %ownbyteintegerarray work area (0:30) {---used while formatting} %ownbyteintegerarray text (0:37) {---used to construct the formatted value} %integer workarea addr {address of work-area(0)} %integer text addr {address of text (0)} ! ! Locals ! %integer decs ; !set to number of significant digits required %integer exp ; !set to number of digits to the left of the '.' %integer sign ; !set to either '+' or '-' or nothing %integer exponent ; !set to the value of a floating-point exponent %integer format ; !set to 'F' if using fixed-point format, else set to 'E' %integer chars reqd; !set to the number of digits to produce %integer area ptr ; !ptr into WORK AREA %integer ptr ; !ptr into TEXT %integer i ; !work variable %integer n ; !work variable %longreal a; !the real value to be formatted %longreal x; !the real value in the range 10.0> a>= 1.0 %if HOST=IBM %and TARGET=PERQPNX %thenstart ! ! Initialise Real Constants ! ten to the max==longreal(addr(pnx ten to the max(0))) ten to the min==longreal(addr(pnx ten to the min(0))) %finish ! ! Initialise Variables ! workarea addr= addr(work area(0)) text addr= addr( text(0)) real mode= real mode-3 %if real mode= 0 %then a= real(real addr{ess}) %and decs=7 %c %else a= longreal(real addr{ess}) %and decs=7 exp= 1 ! ! Pick Up the REAL ! %if a<0.0 %then a=-a %and sign='-' %c %else sign= 0 !Scale the REAL into the range: 10.0> a >=1.0 ! %if a = 0.0 %then x= 0.0 %and exp= 0 %c %elsestart x =into range(a, exp) + rounding factor(real mode) %if x>=10.0 %thenstart x= x/10.0; !apply correction if rounding exp=exp+1 ; ! put the value back out of range %finish %finish %if 0<= exp< decs %thenstart ! ! ! Output the REAL in Fixed-Point Format ! ! decs= decs-exp; !reduce DECS by digits reqd to the left of the '.' format='F' %finishelsestart ! ! ! Output the REAL in Floating-Point Format ! ! exponent= exp-1 %and exp= 1; !one digit reqd to the left of '.' decs= decs-1 ; ! and reduce digits right of '.' accordingly format='E' %finish !Analyse Form of the Number Required: ! ! chars reqd= decs + exp %if exp= 0 %then workarea(0)= '0' %and area ptr= 1 %and exp= 1 %c %else area ptr= 0 !Acquire the Digits in Character Form: ! ! %while chars reqd\= 0 %cycle chars reqd = chars reqd - 1 n = int pt (x) %if host\= M68000 n = trunc (x) %if host = M68000 x = 10.0*(x - n) workarea(area ptr)= '0' + n area ptr = area ptr + 1 ! %repeat !Produce the Formatted Number: ! ! ptr = 1 %unless sign = 0 %then text(ptr)= sign %c %and ptr = ptr+1 ! ! Write out Digits to the LEFT of the Decimal Point ! copy (exp, workarea addr, 0, text addr, ptr) ! area ptr= exp ptr= ptr + exp text(ptr)= '.' {write out } ptr = ptr + 1 { the decimal point} ! ! Write Out the Digits to the RIGHT of the Decimal Point ! copy (decs,workarea addr,area ptr,text addr,ptr) ptr= decs+ptr %if format='E' %thenstart ! ! ! Now Format the Exponent ! ! %if exponent< 0 %then exponent=-exponent %and sign='-' %c %else sign='+' text(ptr )= 'E' text(ptr+1)= sign ptr = ptr+2 i = exponent//10 text(ptr )= i + '0' text(ptr+1)= exponent- (i*10) + '0' ptr = ptr+2 %finish !Return the Formatted Value: ! ! text(0)= ptr-1 %andresult= string(addr(text(0))) %end; !of FPTOS %ENDOFFILE