aboutsummaryrefslogtreecommitdiff
path: root/sys/gio/ncarutil/autograph/agexax.f
diff options
context:
space:
mode:
Diffstat (limited to 'sys/gio/ncarutil/autograph/agexax.f')
-rw-r--r--sys/gio/ncarutil/autograph/agexax.f415
1 files changed, 415 insertions, 0 deletions
diff --git a/sys/gio/ncarutil/autograph/agexax.f b/sys/gio/ncarutil/autograph/agexax.f
new file mode 100644
index 00000000..b16e2319
--- /dev/null
+++ b/sys/gio/ncarutil/autograph/agexax.f
@@ -0,0 +1,415 @@
+C
+C
+C +-----------------------------------------------------------------+
+C | |
+C | Copyright (C) 1986 by UCAR |
+C | University Corporation for Atmospheric Research |
+C | All Rights Reserved |
+C | |
+C | NCARGRAPHICS Version 1.00 |
+C | |
+C +-----------------------------------------------------------------+
+C
+C
+C ---------------------------------------------------------------------
+C
+ SUBROUTINE AGEXAX (IAXS,SVAL,UMIN,UMAX,NICE,QLUA,FUNS,QBTP,BASD,
+ + BASE,QMJD,QMND,QMNT,QLTD,QLTP,QLED,QLEX,QLFD,
+ + QLFL,QMIN,QMAX)
+C
+ DIMENSION SVAL(2)
+C
+C The routine AGEXAX is used by AGSTUP to examine the parameters which
+C determine how a given axis is tick-marked and labelled and to provide
+C default values for missing ones. Its arguments are as follows:
+C
+C -- IAXS is the number of the axis being drawn - 1, 2, 3, or 4.
+C
+C -- SVAL is the array of special values.
+C
+C -- UMIN and UMAX are the minimum and maximum values along the axis, in
+C the user coordinate system. Rounded values of UMIN and UMAX are
+C returned in QMIN and QMAX if the following argument (NICE) is zero.
+C
+C -- NICE is a flag indicating whether rounded values of UMIN and UMAX
+C are to be returned (NICE.EQ.0) or not (NICE.NE.0).
+C
+C -- LLUA and FUNS specify the user-system-to-label-system mapping along
+C the axis. See the routine AGAXIS for a discussion of them.
+C
+C -- NBTP, BASD, BASE, and NMJD are used to determine the positioning of
+C major tick marks in the label coordinate system. NBTP and BASE are
+C described in the routine AGNUMB. BASD is the desired value of BASE
+C supplied by the user. If BASD has a null value, BASE is computed
+C by AGEXAX. NMJD is a user-supplied-or-defaulted parameter giving
+C the approximate number of major ticks (and therefore the number of
+C numeric labels) to be placed on the axis.
+C
+C -- NMND and NMNT are the desired and actual (to be determined) number
+C of minor ticks per major division. See discussion in AGAXIS.
+C
+C -- NLTD, NLTP, NLED, NLEX, NLFD, and NLFL are desired and actual (to
+C be determined) values of the parameters describing the form to be
+C used for numeric labels. See discussion in AGNUMB.
+C
+C -- QMIN and QMAX are rounded values of UMIN and UMAX, returned only if
+C NICE.EQ.0.
+C
+C The following common block contains AUTOGRAPH variables which are
+C not control parameters. The only one used here is SMRL, which is a
+C (machine-dependent) small real which, when added to a number in the
+C range (1,10), will round it upward without seriously affecting the
+C leading significant digits. The object of this is to get rid of
+C strings of nines.
+C
+ COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ ,
+ + INIF
+C
+C The arrays BASP and NMNP specify possible default values for BASE and
+C NMNT when NBTP.EQ.1.
+C
+ DIMENSION BASP(5),NMNP(5)
+C
+ DATA BASP(1) / 10. / , NMNP(1) / 1 / ,
+ * BASP(2) / 5. / , NMNP(2) / 4 / ,
+ * BASP(3) / 2. / , NMNP(3) / 1 / ,
+ * BASP(4) / 1. / , NMNP(4) / 1 / ,
+ * BASP(5) / .5 / , NMNP(5) / 4 /
+C
+C If the parameter NBTP is zero, tick marks and labels are suppressed.
+C
+ NBTP=IFIX(QBTP)
+ IF (NBTP.EQ.0) RETURN
+C
+C Unpack integer values from floating-point arguments.
+C
+ LLUA=IFIX(QLUA)
+ NMJD=IFIX(QMJD)
+ IF (QMND.NE.SVAL(1).AND.QMND.NE.SVAL(2)) NMND=IFIX(QMND)
+ NMNT=0
+ IF (QLTD.NE.SVAL(1).AND.QLTD.NE.SVAL(2)) NLTD=IFIX(QLTD)
+ NLTP=0
+ IF (QLED.NE.SVAL(1).AND.QLED.NE.SVAL(2)) NLED=IFIX(QLED)
+ NLEX=0
+ IF (QLFD.NE.SVAL(1).AND.QLFD.NE.SVAL(2)) NLFD=IFIX(QLFD)
+ NLFL=0
+C
+C Compute label-coordinate-system values at the ends of the axis.
+C
+ CALL AGUTOL (IAXS,FUNS,1,UMIN,VMIN)
+ CALL AGUTOL (IAXS,FUNS,1,UMAX,VMAX)
+C
+C Error if the label-coordinate-system values are equal.
+C
+ IF (VMIN.EQ.VMAX) GO TO 901
+C
+C If a special value is specified for the parameter BASD, AGEXAX must
+C pick a value for the parameter BASE.
+C
+ IF (BASD.EQ.SVAL(1).OR.BASD.EQ.SVAL(2)) GO TO 101
+C
+C The user has specified a value for the parameter BASE. If that value
+C is less than or equal to zero, tick marks and labels are suppressed.
+C
+ BASE=AMAX1(0.,BASD)
+ IF (BASE.EQ.0.) RETURN
+ NMNT=0
+ GO TO 108
+C
+C Pick a value for the parameter BASE, depending on the number type.
+C
+ 101 GO TO (102,105,106) , NBTP
+C
+C Major ticks and labels are at numbers of the form (-) BASE * EXMU.
+C
+ 102 NMJD=MAX0(0,NMJD)
+C
+C Compute an approximate value for BASE.
+C
+ FTMP=ABS(VMAX-VMIN)/FLOAT(NMJD+1)
+C
+C Reduce the approximate value to the form FTMP * 10 ** ITMP.
+C
+ ASSIGN 103 TO JMP1
+ GO TO 200
+C
+C Pick a reasonable value for BASE (1., 2., OR 5. * 10**ITMP).
+C
+ 103 DO 104 I=1,5
+ IF (FTMP.LT.BASP(I)) GO TO 104
+ BASE=BASP(I)*SNGL(10.D0**ITMP)
+ NMNT=NMNP(I)
+ GO TO 107
+ 104 CONTINUE
+C
+C Major ticks and labels are at numbers of the form (-) BASE * 10**EXMU.
+C
+ 105 BASE=1.
+ NMNT=8
+ GO TO 107
+C
+C Major ticks and labels are at numbers of the form (-) BASE**EXMU.
+C
+ 106 BASE=10.
+ NMNT=8
+C
+ 107 IF (BASD.EQ.SVAL(2)) BASD=BASE
+C
+ 108 IF (QMND.NE.SVAL(1).AND.QMND.NE.SVAL(2)) NMNT=MAX0(0,NMND)
+ IF (QMND.EQ.SVAL(2)) QMND=FLOAT(NMNT)
+C
+C If the user wants nice values at the axis ends, reset UMIN and UMAX.
+C
+ IF (NICE.NE.0) GO TO 115
+C
+ LOOP=0
+C
+ WMIN=VMIN
+ WMAX=VMAX
+C
+ GO TO (109,110,112) , NBTP
+C
+ 109 EMIN=VMIN/BASE+.5+SIGN(.5,VMIN-VMAX)
+ EMIN=EMIN-.5+SIGN(.5,EMIN)-SIGN(SMRL*EMIN,VMIN-VMAX)
+ WMIN=BASE*(EMIN-AMOD(EMIN,1.))
+ EMAX=VMAX/BASE+.5+SIGN(.5,VMAX-VMIN)
+ EMAX=EMAX-.5+SIGN(.5,EMAX)-SIGN(SMRL*EMAX,VMAX-VMIN)
+ WMAX=BASE*(EMAX-AMOD(EMAX,1.))
+ GO TO 114
+C
+ 110 IF (VMIN.EQ.0.) GO TO 111
+ EMIN=ALOG10(ABS(VMIN)/BASE)+.5+SIGN(.5,VMIN*(VMIN-VMAX))
+ EMIN=EMIN-.5+SIGN(.5,EMIN)-SIGN(SMRL*EMIN,VMIN*(VMIN-VMAX))
+ WMIN=SIGN(BASE,VMIN)*10.**(EMIN-AMOD(EMIN,1.))
+ 111 IF (VMAX.EQ.0.) GO TO 114
+ EMAX=ALOG10(ABS(VMAX)/BASE)+.5+SIGN(.5,VMAX*(VMAX-VMIN))
+ EMAX=EMAX-.5+SIGN(.5,EMAX)-SIGN(SMRL*EMAX,VMAX*(VMAX-VMIN))
+ WMAX=SIGN(BASE,VMAX)*10.**(EMAX-AMOD(EMAX,1.))
+ GO TO 114
+C
+ 112 IF (BASE.EQ.1.) GO TO 115
+ IF (VMIN.EQ.0.) GO TO 113
+ EMIN=ALOG10(ABS(VMIN))/ALOG10(BASE)+.5+SIGN(.5,VMIN*(VMIN-VMAX))
+ EMIN=EMIN-.5+SIGN(.5,EMIN)-SIGN(SMRL*EMIN,VMIN*(VMIN-VMAX))
+ WMIN=SIGN(1.,VMIN)*BASE**(EMIN-AMOD(EMIN,1.))
+ 113 IF (VMAX.EQ.0.) GO TO 114
+ EMAX=ALOG10(ABS(VMAX))/ALOG10(BASE)+.5+SIGN(.5,VMAX*(VMAX-VMIN))
+ EMAX=EMAX-.5+SIGN(.5,EMAX)-SIGN(SMRL*EMAX,VMAX*(VMAX-VMIN))
+ WMAX=SIGN(1.,VMAX)*BASE**(EMAX-AMOD(EMAX,1.))
+C
+C Re-compute the user-coordinate-system minimum and maximum values.
+C
+ 114 CALL AGUTOL (IAXS,FUNS,-1,WMIN,QMIN)
+ CALL AGUTOL (IAXS,FUNS,-1,WMAX,QMAX)
+C
+C Test for problems with nice values chosen.
+C
+ IF (QMIN.LT.QMAX) GO TO 140
+ IF (QMIN.GT.QMAX) GO TO 901
+C
+C We have a pathological case - user values are clustered very close to
+C a label position. See what can be done about it.
+C
+ LOOP=LOOP+1
+ IF (LOOP.GT.1) GO TO 901
+C
+ GO TO (137,138,139) , NBTP
+C
+ 137 VMIN=VMIN+SIGN(BASE,VMIN-VMAX)
+ VMAX=VMAX+SIGN(BASE,VMAX-VMIN)
+ GO TO 109
+C
+ 138 VMIN=VMIN*10.**SIGN(1.,VMIN*(VMIN-VMAX))
+ VMAX=VMAX*10.**SIGN(1.,VMAX*(VMAX-VMIN))
+ GO TO 110
+C
+ 139 VMIN=VMIN*BASE**SIGN(1.,VMIN*(VMIN-VMAX))
+ VMAX=VMAX*BASE**SIGN(1.,VMAX*(VMAX-VMIN))
+ GO TO 112
+C
+ 140 VMIN=WMIN
+ VMAX=WMAX
+C
+C Now we examine the parameters defining the appearance of the numeric
+C labels. If the numeric-label type is zero, there is no more to do.
+C
+ 115 IF (QLTD.EQ.SVAL(1).OR.QLTD.EQ.SVAL(2)) GO TO 116
+ NLTP=MAX0(0,MIN0(3,NLTD))
+ IF (NLTP.EQ.0) GO TO 136
+C
+C The numeric-label type (NLTP) is specified. If both the numeric-label
+C exponent and numeric-label fraction-length are also specified, quit.
+C
+ NLEX=NLED
+ NLFL=NLFD
+ IF (QLED.NE.SVAL(1).AND.QLED.NE.SVAL(2).AND.
+ + QLFD.NE.SVAL(1).AND.QLFD.NE.SVAL(2) ) GO TO 136
+ GO TO 117
+C
+C We must pick a value for the numeric-label type. Start with the dummy
+C value 4 so as to jump to the proper piece of code.
+C
+ 116 NLTP=4
+C
+C Reduce the value of BASE to the form RBSE * 10**KBSE, where RBSE is
+C in the range (1,10) and KBSE is an integer.
+C
+ 117 FTMP=BASE
+ ASSIGN 118 TO JMP1
+ GO TO 200
+C
+ 118 RBSE=FTMP
+ KBSE=ITMP
+C
+C Compute LBSE = the number of significant digits in RBSE.
+C
+ ASSIGN 119 TO JMP2
+ GO TO 300
+C
+ 119 LBSE=1+ITMP
+C
+C Jump depending on the value of the numeric-label type.
+C
+ GO TO (120,128,131,132) , NLTP
+C
+C Scientific notation is to be used. Estimate the number of significant
+C digits that are likely to be required, depending on the number type.
+C
+ 120 GO TO (121,123,124) , NBTP
+C
+ 121 FTMP=AMAX1(ABS(VMIN),ABS(VMAX))/BASE
+ ASSIGN 122 TO JMP1
+ GO TO 200
+C
+ 122 NSIG=MAX0(1,ITMP+1+LBSE)
+ GO TO 125
+C
+ 123 NSIG=LBSE
+ GO TO 125
+C
+ 124 NSIG=10
+C
+C NLEX + NLFL should be equal to NSIG. Make that the case.
+C
+ 125 IF (QLED.NE.SVAL(1).AND.QLED.NE.SVAL(2)) GO TO 127
+ IF (QLFD.EQ.SVAL(1).OR. QLFD.EQ.SVAL(2)) GO TO 126
+ NLEX=NSIG-MAX0(0,NLFL)
+ GO TO 135
+ 126 NLEX=1
+ 127 NLFL=NSIG-NLEX
+ IF (NLFL.LE.0) NLFL=-1
+ GO TO 135
+C
+C Exponential notation is to be used. Compute the exponent NEXP such
+C that BASE / 10**NEXP is an integer.
+C
+ 128 NEXP=KBSE-LBSE+1
+C
+C NLEX - NLFL should be equal to NEXP. Make that the case. (Note that,
+C if NBTP is 3, NLEX is forced to zero.)
+C
+ IF (NBTP.EQ.3) NLEX=0
+C
+ IF (QLFD.NE.SVAL(1).AND.QLFD.NE.SVAL(2)) GO TO 129
+ IF (QLED.NE.SVAL(1).AND.QLED.NE.SVAL(2)) GO TO 130
+ NLFL=-1
+ 129 NLEX=MAX0(0,NLFL)+NEXP
+ GO TO 135
+ 130 NLFL=NLEX-NEXP
+ IF (NLFL.LE.0) NLFL=-1
+ GO TO 135
+C
+C No-exponent notation is to be used. NLFL is the only parameter we
+C need to worry about. If it is already set, quit.
+C
+ 131 IF (QLFD.NE.SVAL(1).AND.QLFD.NE.SVAL(2)) GO TO 136
+C
+C Set NLFL to the actual number of digits in the fractional portion of
+C BASE.
+C
+ NLFL=LBSE-KBSE-1
+ IF (NLFL.LE.0) NLFL=-1
+ GO TO 135
+C
+C We must pick a value for the numeric-label type, depending on the
+C number type.
+C
+ 132 GO TO (133,134,134) , NBTP
+C
+C Nunbers are of the form (-) BASE * EXMU. Use labels with no exponent
+C unless the use of an exponent would result in shorter labels.
+C
+ 133 IF (MAX0(KBSE+1-LBSE,-KBSE-1).GT.4) GO TO 134
+ NLTP=3
+ NLFL=LBSE-KBSE-1
+ IF (NLFL.LE.0) NLFL=-1
+ GO TO 135
+C
+C Exponential notation is used.
+C
+ 134 NLTP=2
+ NLEX=KBSE-LBSE+1
+ NLFL=-1
+C
+C Back-store the computed parameters, if requested, and return.
+C
+ 135 IF (QLTD.EQ.SVAL(2)) QLTD=FLOAT(NLTP)
+ IF (QLED.EQ.SVAL(2)) QLED=FLOAT(NLEX)
+ IF (QLFD.EQ.SVAL(2)) QLFD=FLOAT(NLFL)
+C
+C Pack up integer values to floating-point arguments and return.
+C
+ 136 QMNT=FLOAT(NMNT)
+ QLTP=FLOAT(NLTP)
+ QLEX=FLOAT(NLEX)
+ QLFL=FLOAT(NLFL)
+ RETURN
+C
+C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
+C
+C This internal procedure reduces the number (FTMP) to the range (1,10),
+C returning (FTMP) and (ITMP) such that (FTMP) * 10**(ITMP) is equal to
+C the original value of (FTMP). (FTMP) must be positive.
+C
+ 200 FTM1=ALOG10(FTMP+SMRL*FTMP)
+ IF (FTM1.LT.0.) FTM1=FTM1-1.
+ ITMP=IFIX(FTM1)
+ FTMP=AMAX1(1.,FTMP*SNGL(10.D0**(-ITMP)))
+ GO TO JMP1 , (103,118,122)
+C
+C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
+C
+C This internal procedure counts the number of digits in the fractional
+C portion of (FTMP), returning the count as the value of (ITMP).
+C
+ 300 FTM1=AMOD(FTMP+SMRL*FTMP,1.)
+ FTM2=10.*SMRL*FTMP
+ ITMP=0
+C
+ 301 IF (FTM1.LT.FTM2) GO TO 302
+ ITMP=ITMP+1
+ IF (ITMP.GE.10) GO TO 302
+ FTM1=AMOD(10.*FTM1,1.)
+ FTM2=10.*FTM2
+ GO TO 301
+C
+ 302 GO TO JMP2 , (119)
+C
+C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
+C
+C Error exit.
+C
+C +NOAO - Comment out FTN write and format statement, SETER is okay.
+C
+ 901 CONTINUE
+C 901 WRITE (I1MACH(4),9001) IAXS
+ CALL SETER ('AGEXAX (CALLED BY AGSTUP) - USER-SYSTEM-TO-LABEL-SYST
+ +EM MAPPING IS NOT MONOTONIC',1,2)
+C
+C Formats.
+C
+C9001 FORMAT ('0PROBLEM WITH AXIS NUMBER',I2,
+C + ' (1, 2, 3, AND 4 IMPLY LEFT, RIGHT, BOTTOM, AND TOP)')
+C
+C -NOAO
+ END
generated by cgit (git 2.34.1) at 2025-09-20 17:35:39 -0400