File: NUMBER.LS of Disk: V50/Source/Source-Listing-RALF-1
(Source file text)
FORTRAN IV 5AAAA (A6) 8-APR-92 PAGE ONE 0002 SUBROUTINE NUMBER(XS,YS,HGT,ANUM,ANG,IDIG) C VERSION 50A 30-MAY-80 WVDM C XS,YS=ORIGIN, HGT=HEIGHT, ANUM=NUMBER AS A VARIABLE, ANG=ANGLE C IDIG: GT 0 = NUM SIGNIFICANT PLACES+ROUND+DEC.PT; C 0 = NO ROUND,DEC PT,NO FRACT;-1 = NO ROUND, NO DEC.PT; C LT -1 = TRUNCATE IDIG-1 PLACES. 0003 DIMENSION ANMPAS(21) C ENOUGH FOR 19 DIGITS. 0004 DO 5 J=1,21 0005 ANMPAS(J)=0. 0006 5 CONTINUE 0007 IDGCNT=1 0010 J=1 0011 10 PABS=ABS(ANUM) 0012 IPART=PABS 0013 FPART=PABS-IPART C COUNT NUMBER OF DIGITS TO PRINT 0014 20 IF(IPART/(10.**IDGCNT).LT.1) GO TO 30 C DONE WITH WHOLE PART OF NUMBER WHEN JUMP 0015 IDGCNT=IDGCNT+1 0016 GO TO 20 0017 30 IF(IDGCNT.GT.21) GO TO 100 0020 PABS=(FLOAT(IPART)+.5)/(10.**(IDGCNT-1)) 0021 DO 40 J=1,IDGCNT 0022 ANMPAS(J)=AINT(PABS) 0023 PABS=(PABS-ANMPAS(J))*10. 0024 40 CONTINUE C FILL UP ARRAY WITH WHOLE ELEMENTS 0025 J=IDGCNT 0026 LDIG=IDGCNT+IDIG+1 0027 IF(LDIG.GT.20)GO TO 100 0030 IF(IDIG.LT.0)GO TO 51 0031 J=J+1 0032 ANMPAS(J)=-2. C FOR DECIMAL POINT 0033 IF(IDIG.LT.1)GO TO 51 C FOR THE IDIG=0 CASE 0034 DO 50 IPART=1,IDIG+1 C EXTRA PLACE TO CHECK FOR ROUNDING 0035 PABS=FPART*10. 0036 J=J+1 0037 ANMPAS(J)=AINT(PABS) 0040 FPART=PABS-ANMPAS(J) 0041 50 CONTINUE 0042 FPART=-3. 0043 IF(ANUM.LT.0)GO TO 52 C PREPARE FOR POSITIVE NUMBER ROUNDING 0044 IF(ANMPAS(J).LT.5)GO TO 55 0045 ANMPAS(J-1)=ANMPAS(J-1)+1. 0046 59 IF(ANMPAS(J-1).NE.10)GO TO 55 0047 IF(ANMPAS(J-2).NE.-2.)GO TO 53 0050 J=J-1 0051 IF(ANUM.GE.1)GO TO 53 0052 ANMPAS(J-2)=1. 0053 GO TO 55 FORTRAN IV 5AAAA (A6) 8-APR-92 PAGE TWO 0054 53 ANMPAS(J-2)=ANMPAS(J-2)+1. 0055 J=J-1 C CHECK NOT TO OVERFLOW ANMPAS 0056 IF(J.NE.2)GO TO 59 0057 FPART=1. C MOVE ARRAY DOWN BY 1 TO ADD- OR 1 FOR 9.99+ 0060 52 LDIG=LDIG+1 0061 J=1 0062 DO 60 J=1,LDIG-1 0063 ANMPAS(LDIG-J+1)=ANMPAS(LDIG-J) 0064 60 CONTINUE 0065 ANMPAS(1)=FPART 0066 GO TO 55 0067 51 FPART=-3. 0070 IF(LDIG.LE.0)GO TO 100 C FOR NEGATIVE NUMBERS WITH TOO FEW PLACES 0071 IF(ANUM.LT.0)GO TO 52 0072 55 IF(LDIG.GT.21).OR.(LDIG.LE.0)GO TO 100 0073 CALL SYMB(XS,YS,HGT,ANMPAS,ANG,LDIG) 0074 120 RETURN 0075 100 WRITE(0,200) 0076 200 FORMAT(' NUMBER OF DIGITS NOT 1-19'/) 0077 END