Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0141/davary.for
There are 2 other files named davary.for in the archive. Click here to see a list.
SUBROUTINE DAVARY(KONTRL,ITTY ,JTTY ,LOCATN,NAMUSD,
1 NAMMAX,MAXBFR,NOTATN,MINDEC,MAXDEC,MINSIG,MAXSIG,
2 IDECML,AARRAY,IARRAY,NAME ,IBUFFR,LOWBFR,KIND ,
3 MODIFY)
C RENBR(/TYPE CURRENT VALUE AND ACCEPT NEW VALUE)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C THIS ROUTINE IS USED ALONG WITH SEVERAL OTHERS IN
C FASP, THE FORTRAN ALPHAMERIC SUBROUTINE PACKAGE, FOR
C THE PURPOSE OF SELECTING BY NAME AND SUBSCRIPTS,
C EXAMINING AND MODIFYING THE VALUES IN ARRAY LOCATIONS
C KNOWN TO THE CALLING PROGRAM. PLEASE CONSULT THE
C FASP DOCUMENTATION FOR DESCRIPTIONS OF THESE ROUTINES
C
C CONTENTS OF THE FASPH COMMON BLOCK MUST BE
C MAINTAINED FROM ONE CALL OF THIS ROUTINE TO NEXT
COMMON/FASPH/INIVAL,INCVAL,LMTVAL,
1VALINI,VALINC,VALLMT
C
DIMENSION NAME(NAMMAX),AARRAY(LOCATN),IARRAY(LOCATN),
1IBUFFR(MAXBFR)
DATA IEQUAL,ISPACE/1H=,1H /
C
C REPRESENT THE FORMER VALUE
MANY=KIND-2
LOCAL=0
KOUNT=NAMUSD
NAMINI=NAMUSD+1
1 IF((KOUNT+3).GT.NAMMAX)GO TO 3
NAME(KOUNT+1)=ISPACE
NAME(KOUNT+2)=IEQUAL
NAME(KOUNT+3)=ISPACE
KOUNT=KOUNT+3
LFTCOL=KOUNT
IF(KONTRL.GT.0)GO TO 2
IRADIX=10
IF(KONTRL.LT.0)IRADIX=8
CALL DANUMB(0,IARRAY(LOCATN),IRADIX,NAME,KOUNT,
1LFTCOL,NAMMAX)
GO TO 3
2 CALL DARITE(AARRAY(LOCATN),-1,NOTATN,0,0,
1-3,0,20,MINDEC,MAXDEC,MINSIG,MAXSIG,
2-1,0,IDECML,0,0,-1,LFTCOL,
3NAMMAX,NAME,KOUNT,IERR)
3 IF(MANY.LT.0)GO TO 19
IF(LOCAL.NE.0)GO TO 20
C
C GET NEXT VALUE SPECIFIED BY USER
4 CALL DANEXT(KONTRL,0.01,IBUFFR,MAXBFR,LOWBFR,
1MANY,KIND,INIVAL,INCVAL,LMTVAL,VALINI,VALINC,
2VALLMT)
GO TO(14,22,16,23,5,23,8,10,12),KIND
C
C STORE NEW VALUE AND REPORT IT IF FROM FORMER LINE
5 MODIFY=MODIFY+1
IF(KONTRL.GT.0)GO TO 6
IARRAY(LOCATN)=INIVAL
GO TO 7
6 AARRAY(LOCATN)=VALINI
7 IF(LOCAL.NE.0)GO TO 23
LOCAL=1
GO TO 1
C
C ILLEGAL ANSWER, CANCEL REST OF BUFFER
8 WRITE(JTTY,9)
9 FORMAT(' POSITIVE NUMBER REQUIRED LEFT OF ASTERISK')
GO TO 15
10 WRITE(JTTY,11)
11 FORMAT(' ILLEGAL RANGE SPECIFICATION')
GO TO 15
12 WRITE(JTTY,13)IBUFFR(LOWBFR-1)
13 FORMAT(' ILLEGAL CHARACTER ',1A1)
GO TO 15
C
C INPUT BUFFER IS EMPTY
14 KIND=3
IF(LOCAL.NE.0)GO TO 23
C
C ASK USER FOR VALUE IF NOTHING IN INPUT BUFFER
15 MANY=0
16 WRITE(JTTY,17)(NAME(I),I=1,KOUNT),ISPACE,IEQUAL,
1ISPACE
17 FORMAT(1X,$,100A1)
READ(ITTY,18)IBUFFR
18 FORMAT(100A1)
LOCAL=1
LOWBFR=1
GO TO 4
C
C TELL USER THE NEW VALUE IF BASED ON FORMER ANSWER
C OR IF THE VALUE IS NOT BEING CHANGED
19 KIND=1
20 WRITE(JTTY,21)(NAME(I),I=1,KOUNT)
21 FORMAT(1X,100A1)
GO TO 23
C
C TERMINATE LOOP IF SEMICOLON FOUND
22 KIND=0
C
C RETURN TO CALLING PROGRAM
23 RETURN
C594944882435'$
END