File: AXIS.FS of Tape: Various/Decus/decus-4
(Source file text)
C AXIS SUBROUTINE FOR OS/8 FORTRAN 4
C BASED ON DEC'S ROUTINE AXIS.FS
C WRITTEN ON 27-SEP-78 BY J. MAURISSEN &
C A. VAN DER HEIDE
C UNIVERSITY OF ROCHESTER
C DEPARTMENT OF RADIATION BIOLOGY AND
C BIOPHYSICS
C BEHAVIOR LABORATORY
C ROCHESTER N.Y. 14642
C
SUBROUTINE AXIS(XAX,YAX,TITLE,NCHR,AXLEN,ANG,
1 FV,DV,LOGCYC)
DATA PFCT/'*10'/
C-WHEN LOG AXES ARE USED THE FOLLOWING CODE
C-PREVENTS ILLEGAL STARTING POINTS, I.E. NEGATIVE
C-OR NOT EQUAL TO 10**I, I BEING A POSITIVE OR
C-NEGATIVE INTEGER.
LLFT=0
IF(FV.LE.0.AND.LOGCYC.NE.0)GO TO 140
IF(LOGCYC.EQ.0.OR.FV.EQ.0)GO TO 3
AFV=ABS(FV)
105 IF(AFV.GT.0.5)GO TO 100
AFV=AFV*10
GO TO 105
100 IF(AFV.LT.5)GO TO 110
AFV=AFV/10.
GO TO 100
110 IFV=IFIX(AFV+.01)
IF(IFV.NE.1)GO TO 140
3 ICW=-1
IF(NCHR.GE.0) ICW=1
ZANG=ANG
4 IF(ZANG.LT.0)ZANG=ZANG+360
IF(ZANG.GT.360)ZANG=ZANG-360
IF(ZANG.GT.360.OR.ZANG.LT.0)GO TO 4
CALL XYPLOT(XAX,YAX,-3)
C-MOVE TO START OF AXIS
XPT=ZANG*.017453294
CANGL=COS(XPT)
SANGL=SIN(XPT)
AD=ICW*SANGL
AFV=.1*SANGL*ICW
ADV=.1*CANGL*ICW
XPT=0
YPT=0
IXLEN=ABS(AXLEN)
IF(LOGCYC.EQ.0) GO TO 2
IXLEN=ABS(LOGCYC)
CYCINC=ABS(AXLEN)/ABS(LOGCYC)
2 DO 10 ICHAR=0,IXLEN
CALL XYPLOT(XPT,YPT,2)
IF(LOGCYC.NE.0) GO TO 5
XTIC=XPT-AFV
YTIC=YPT+ADV
C-DRAW THE TIC MARKS ON LINEAR AXES
CALL XYPLOT(XTIC,YTIC,2)
CALL XYPLOT(XPT,YPT,3)
XPT=CANGL*(ICHAR+1)
YPT=SANGL*(ICHAR+1)
GO TO 10
C-DRAW TIC MARKS ON LOGARITHMIC SCALE
5 AFV2=AFV*2
ADV2=ADV*2
XTIC=XPT-AFV2
YTIC=YPT+ADV2
CALL XYPLOT(XTIC,YTIC,2)
CALL XYPLOT(XPT,YPT,3)
IF(ICHAR.EQ.IXLEN) GO TO 10
DO 6 ILOG=1,9
ANT=ILOG+1
C-TEST FOR REVERSE LOGARITHMIC SCALING
IF (LOGCYC.LT.0) ANT=10./(10-ILOG)
XPT=CANGL*ALOG10(ANT*10**ICHAR)*CYCINC
YPT=SANGL*ALOG10(ANT*10**ICHAR)*CYCINC
CALL XYPLOT(XPT,YPT,2)
XTIC=XPT-AFV
YTIC=YPT+ADV
CALL XYPLOT(XTIC,YTIC,2)
CALL XYPLOT(XPT,YPT,3)
6 CONTINUE
10 CONTINUE
IEXP=1
PWR=1
AFV=ABS(FV)
IF(LOGCYC.LT.0)AFV=1.0001*(FV/10.**ABS
1 (LOGCYC))
IF(AFV.EQ.0)AFV=ABS(DV)
IF(AFV.GE.100) GO TO 30
IF(AFV.LT.0.01) GO TO 40
C-IEXP=EXPONENT,PWR=POWER IN 10S
20 IF(LOGCYC.EQ.0)YTIC=(FV+(DV*IXLEN))/PWR
IF(LOGCYC.GT.0)YTIC=FV*10.**ABS(LOGCYC)/PWR
IF(LOGCYC.LT.0)YTIC=AFV/PWR
XPT=CANGL*ABS(AXLEN)-(.3*ICW-.05)*SANGL-
1 .05*CANGL
YPT=SANGL*ABS(AXLEN)+(.4*ICW-.05)*CANGL-
1 .05*ABS(SANGL)
DO 50 ICHAR=0,IXLEN
NLFT=3
IF(LOGCYC.EQ.0) GO TO 31
C-THIS CODE COMPUTES HOW MANY PLACES TO THE
C-RIGHT OF THE DECIMAL POINT THE LOGARITHMIC
C-LABEL WILL NEED.
II=-1
SUBFV=ABS(YTIC)
34 IF(SUBFV.GE.1) GO TO 31
SUBFV=SUBFV*10.
II=II+1
IF(II.EQ.0) II=1
GO TO 34
C-NEXT THE LOCATION OF THE FIRST NUMBER IN THE LABEL
C-IS CALCULATED.
31 TST=ABS(YTIC)
120 IF(TST.LT.10)GO TO 32
TST=TST/10
NLFT=NLFT+1
GO TO 120
32 IF(LOGCYC.NE.0)NLFT=NLFT-2+II
IF(YTIC.LT.0)NLFT=NLFT+1
IF(NLFT.GT.LLFT)LLFT=NLFT
IF(LOGCYC.EQ.0)II=2
OXPT=XPT
IF(AD.GT.0)XPT=XPT-(.2+NLFT*.14)
C-NEXT PRINT THE NUMBER.
CALL NUMBER(XPT,YPT,.14,YTIC,0,II)
XPT=OXPT
CALL XYPLOT(XPT,YPT,3)
IF(LOGCYC.NE.0)GO TO 130
XPT=XPT-CANGL
YPT=YPT-SANGL
YTIC=YTIC-DV/PWR
GO TO 50
130 XPT=XPT-CANGL*CYCINC
YPT=YPT-SANGL*CYCINC
YTIC=FV*10.**(LOGCYC-ICHAR-1)/PWR
IF(LOGCYC.LT.0)YTIC=AFV*10.**(ICHAR+1)/PWR
50 CONTINUE
PWR=0
55 IF(IEXP/10**PWR.LT.10)GO TO 60
PWR=PWR+1
GO TO 55
60 ICHAR=ABS(NCHR)
IF(IEXP.GT.1)PWR=PWR+4
C-FOR THE 10* CHARACTERS. PWR = # DIGITS
ADV=(ABS(AXLEN)-(ICHAR+PWR)*.21)/2
XTIC=ADV*CANGL-SANGL*ICW*(.65+LLFT*.14)
IF(ZANG.GT.180.AND.ICW.LT.0)XTIC=XTIC-.21
YPT=ADV*SANGL+ICW*.9*CANGL
CALL SYMBOL(XTIC,YPT,.21,TITLE,ZANG,ICHAR)
C-PRINT THE TITLE
IF(IEXP.LE.1) GO TO 70
CALL WHERE(XTIC,YTIC,XPT)
CALL SYMBOL(XTIC,YTIC,.21,PFCT,ZANG,3)
IF(AFV.LT..01)IEXP=-IEXP+2
CALL WHERE(XTIC,YTIC,XPT)
CALL NUMBER(XTIC-.09*SANGL,YTIC+.09*CANGL,
1 .21,IEXP-1,ZANG,-1)
C-PRINT THE EXPONENT
70 RETURN
30 XTIC=AFV/PWR
IF(XTIC.LT.100) GO TO 20
PWR=AINT(PWR*10)
IEXP=IEXP+1
GO TO 30
40 XTIC=AFV*PWR
IF(XTIC.GE.0.01)GO TO 45
PWR=PWR*10
IEXP=IEXP+1
GO TO 40
45 PWR=1/PWR
C-FOR THE DIVISION ABOVE
GO TO 20
140 WRITE(4,150)
150 FORMAT(' WARNING! STARTING VALUE ',
1 'ILLEGAL FOR LOG AXES')
GO TO 70
END