{prints flt on display to a given length and format} {could be converted to any text file varible like} {lst:,myfile etc. with an additional pram} PROCEDURE ftostr (u:flt; fieldsize:byte; mode:char); var num$:string 30; {string to written out} sign_u :integer; exp_u :integer; counter :integer; fieldleft :integer; chtoleft :integer; numzeros :integer; uu :array [1..digmax] of byte; {builds pusedo string too copy from} procedure fillarray; var n,m:byte; begin m:=1; for n:=1 to dpmax do begin uu[m]:=(u.dp[n] div 10)+ord('0'); uu[m+1]:=(u.dp[n] mod 10)+ord('0'); m:=m+2 end; end; {fillarray} {completes string after decimal point} procedure fillfield; begin while (fieldleft>0) and (counter<=digmax) do begin append(num$,chr(uu[counter])); fieldleft:=fieldleft-1; counter:=counter+1 end; while fieldleft>0 do begin append(num$,'0'); fieldleft:=fieldleft-1 end; end; {fillfield} {for engineering type buy it from eric brom} procedure scitype; var exp$ :string 10; radix,x :integer; anyway :boolean; begin fillarray; setlength(num$,0); sign_u:=signdig(u); exp_u:=expvalue(u); if sign_u=1 then append(num$,'-'); append (num$,chr(uu[1])); append (num$,'.'); setlength(exp$,0); append(exp$,'E'); if exp_u <0 then begin append(exp$,'-'); exp_u:=abs(exp_u); end; radix:=10000; anyway:=false; for counter:=1 to 5 do begin if (exp_u>=radix) or anyway then begin x:=exp_u div radix +ord('0'); exp_u:=exp_u mod radix; radix:=radix div 10; append(exp$,chr(x)); anyway:=true end else radix:=radix div 10 end; x:=fieldsize+1-length(num$)-length(exp$); for counter :=2 to x do append(num$,chr(uu[counter])); append (num$,exp$); write(num$) end; {scitype} {this mode tells you as much as possible in the space allotted} {it drops thru to scitype automatic} procedure infotype; begin fillarray; setlength(num$,0); sign_u:=signdig(u); exp_u:=expvalue(u); fieldleft:=fieldsize; if sign_u=1 then begin append(num$,'-'); fieldleft:=fieldleft-1; end; chtoleft:=exp_u+1; if chtoleft>fieldleft then scitype else begin if chtoleft<1 then begin append(num$,'0.'); fieldleft:=fieldleft-2; numzeros:=0-chtoleft; if numzeros>(fieldleft-2) then scitype else begin fieldleft:=fieldleft-numzeros; while numzeros>0 do begin append(num$,'0'); numzeros:=numzeros-1 end; counter:=1; fillfield; write(num$) end end else begin for counter:=1 to chtoleft do append(num$,chr(uu[counter])); counter:=chtoleft+1; fieldleft:=fieldleft-chtoleft; if fieldleft>0 then begin append(num$,'.'); fieldleft:=fieldleft-1; end; fillfield; write(num$) end end end; {infotype} {tries to hold decimal point in a given position but} {will drop thru to infotype to avoid displaying 0.0000} procedure fixtype; var fixval :integer; numblank :integer; holestoleft:integer; begin fillarray; setlength(num$,0); exp_u:=expvalue(u); sign_u:=signdig(u); fixval:=ord(mode)-ord('0'); chtoleft:=exp_u+1; holestoleft:=fieldsize-fixval-sign_u-1; fieldleft:=fieldsize; if chtoleft>holestoleft then infotype else begin if chtoleft<1 then begin numblank:=holestoleft-sign_u-1; while numblank>0 do begin append(num$,' '); numblank:=numblank-1 end; if sign_u=1 then append(num$,'-'); append(num$,'0.'); fieldleft:=fixval; if (fieldleft+chtoleft)<1 then infotype else begin while (chtoleft<0) and (fieldleft>0) do begin append(num$,'0'); chtoleft:=chtoleft+1; fieldleft:=fieldleft-1 end; counter:=1; fillfield; write(num$) end end else begin numblank:=holestoleft-sign_u-chtoleft; while numblank>0 do begin append(num$,' '); numblank:=numblank-1; end; if sign_u=1 then append(num$,'-'); counter:=1; while chtoleft>0 do begin append(num$,chr(uu[counter])); counter:=counter+1; chtoleft:=chtoleft-1 end; append(num$,'.'); fieldleft:=fixval; fillfield; write(num$) end end end; {fixtype} begin case mode of '0','1','2','3','4','5','6','7','8','9' :fixtype; {allows console entry of mode} 'i','I':infotype; else:scitype end; {case} end; {ftostr}