Google
 

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