*DECK SLADOC PROGRAM SLADOC C***BEGIN PROLOGUE SLADOC C***PURPOSE Retrieve documentation for the SLATEC library. C***LIBRARY (NONE) C***CATEGORY R4 C***KEYWORDS DOCUMENTATION, SLATEC C***AUTHOR Boland, W. Robert, C-8, Los Alamos National Laboratory C Bacon, Barbara A., C-10, Los Alamos National Laboratory C***DESCRIPTION C C This program retrieves SLATEC type documentation by routine name. C The search for name can be narrowed by using keyword(s) or C classification category. The database for this program consists of C four files, generated by another program. These are C C 1) a direct access documentation text file, C 2) a sequential table of routine names, categories, etc., C 3) a sequential file of keywords and pointers to the routines. C 4) a sequential file of expanded categories and messages. C C There are a number of system dependent parameters which the C installer of this program may have to change before compiling, C linking and installing the program. All parameters are defined in C the records which immediately follow the prologue. In the C discussion here we refer to the default values which are distributed C with this code; we give values for several different C machine/operating system configurations. C C MXLFN - the maximum length of a file name to be used. The value C used is highly system dependent. Set the value to the C length of longest file name allowed on the system. C FIN - the name of the input file. Some typical names are C tty (CTSS), INPUT (NOS), /dev/tty (UNIX) and C SYS$INPUT (VMS). C FTBL - the name of the input sequential file which contains C the table of routine names, categories, etc. C FCAT - the name of the input file which contains the category C information. C FKWD - the name of the input sequential file which contains C the table of keywords and routine names. C FDAF - the name of the input direct access file which contains C the documentation modules. C FOUT - the name of the output file. Some typical names are C tty (CTSS), OUTPUT (NOS), /dev/tty (UNIX) and C SYS$OUTPUT (VMS). C FERR - the name of the file which is to contain error C information. All errors are processed by the XERMSG C package. Some typical names are tty (CTSS), C OUTPUT (NOS), /dev/tty (UNIX) and SYS$OUTPUT (VMS). C C MXLRN - the maximum length of a routine name. For most Fortran C based libraries, including SLATEC, the value must be at C least 6. If your library uses names longer than 6, you C should set the value of this parameter to the maximum C length. C MXNRN - the maximum number of routine names which are in the C library. C MXLCAT - the maximum length of a category number. For the GAMS C classification scheme which is used by the SLATEC C Collection, the value is 10. C MXNCAT - the maximum number of categories in the entire library. C MXNKWD - the maximum number of keyword phrases in the entire C library. C MXNCL - the maximum number of lines in the GAMS classification C file. C KMAXI - the maximum number of characters in a keyword phrase. C KMAXJ - the maximum number of keywords in a subroutine. C LLN - the number of characters in an input line. C C On some systems, it may be necessary to remove or comment out the C REWIND (UNIT=LU5, ERR=...) statements to avoid program abort. It C has been found that on most systems these REWIND statements have no C effect and can be either "active" or commented out; they have been C incorporated into the code for those few systems which interpret a C null line as an end-of-file signal. C C***REFERENCES Guide to the SLATEC Common Mathematical Library. C***ROUTINES CALLED I1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 870819 DATE WRITTEN C 880325 REVISION DATE from Version 3.2 C 891215 Prologue converted to Version 4.0 format. (BAB) C 901024 Added code to check array bounds when reading files. (BAB) C 910325 Changed A6 format used when printing routine name list to an C A format. (WRB) C 920825 Added view option. (BKS, WRB) C 920911 Declarations section restructured. (WRB) C***END PROLOGUE SLADOC C C System dependent parameter definitions. C INTEGER MXLFN PARAMETER (MXLFN = 32) CHARACTER * (MXLFN) FIN, FCAT, FDAF, FKWD, FTBL, FLIS, FOUT, FERR CHARACTER * (MXLFN) TEMP PARAMETER (FIN = '/dev/tty', + FCAT = 'slacat', + FDAF = 'sladaf', + FKWD = 'slakwd', + FTBL = 'slatbl', + FLIS = 'slalis', + FOUT = '/dev/tty', + FERR = '/dev/tty') C C Library dependent parameter definitions. C INTEGER MXLCAT, MXNCAT, MXLRN, MXNCL, MXNRN, MXLKAT PARAMETER (MXLKAT = 7) PARAMETER (MXLCAT = 10, MXLRN = 6, MXNRN = 1900) PARAMETER (MXNCAT = 750, MXNCL = 750) CHARACTER * (MXLCAT) TCLASS(MXNCAT), TCL INTEGER IPTR(MXNCAT), JPTR(MXNCAT), KPTR(MXNCAT) CHARACTER * 80 STMTS(MXNCL) INTEGER LUTIL, LLIB PARAMETER (LUTIL = 6, LLIB = 6) CHARACTER * (LUTIL) UTIL CHARACTER * (LLIB) LIB PARAMETER (UTIL = 'SLADOC', LIB = 'SLATEC') INTEGER LLN PARAMETER (LLN = 72) C C Other declarations. C INTEGER IERROR, IFIND, II, IJ, IL, ILEN, IN, INEXT, IR, IREC, + ISTART, ISTMT, ITEMP, JCL, JJ, LB2, LENG, LFTBL, LKATS, + LL, LS, LT2, LTCL, NCC, NERR, NLINES, NPD, NTKWD, + NTRY, NUM CHARACTER * (LLN) LINE, LINESV C CHARACTER * (MXLRN) RTNAME(MXNRN), RTNIN CHARACTER * (MXLRN) CNAME(MXNRN/2) C INTEGER LCAT, LCATLS, MLCAT, SEVEN PARAMETER (LCAT = 6, LCATLS = 72, MLCAT = MXLCAT-LCAT, SEVEN = 7) CHARACTER * (MXLCAT) CAT(MXNRN), KAT CHARACTER * (MXLKAT) KATS C C KMAXI - maximum length of a keyword phrase. C MXKWDS - maximum number of keyword phrases C INTEGER KMAXI, MXKWDS PARAMETER (KMAXI = 60, MXKWDS = 500) CHARACTER * (KMAXI) KWRD CHARACTER * (KMAXI) TKWD(MXKWDS) C C IPTRL - table of pointers associated with the keyword phrases. C IPTRR - table of pointers to the routines containing the C keyword phrases. C INTEGER IPTRL(10*MXKWDS), IPTRR(10*MXKWDS) C INTEGER LU13, LU14, LU5, LU6, LU17, LU18, LU19 PARAMETER (LU13 = 13, LU14 = 14, LU5 = 5, LU6 = 6, LU17 = 17, + LU18 = 18, LU19 = 19) CHARACTER * (MXLFN) FNAME, FNAMSV, FN LOGICAL LLU13, LLU18, LLU19, LLU14 LOGICAL FOUND, LEXIST C C IS - table of pointers to the record in file FDAF containing C the subprogram statement. C IE - table of pointers to the record in file FDAF containing C the "END PROLOGUE" statement. C IPS - table of pointers to the record in file FDAF containing C starting line of the "PURPOSE" section. C IPE - table of pointers to the record in file FDAF containing C ending line of the "PURPOSE" section. C INTEGER IS(MXNRN), IE(MXNRN), IPS(MXNRN), IPE(MXNRN) INTEGER I, INFO, J, LB, LT C CHARACTER * 1 INPUT1 CHARACTER * 24 FMT1 CHARACTER * (LUTIL+LLIB+54) FMT2 CHARACTER * 80 MSG CHARACTER FORM * 25 CHARACTER FORMA * 60 INTEGER IALPHA PARAMETER (IALPHA = 26) INTEGER I1(IALPHA), I2(IALPHA), I3(IALPHA), LMSG(IALPHA) CHARACTER * 7 CLASS(IALPHA) C C Variables used in the browsing mode. C INTEGER PGSZ, LOW, HIGH COMMON /CATGRY/ I1, I2, I3, LMSG COMMON /KLASS/ CLASS C C External functions. C INTEGER FIND, LENSTR, MINOR CHARACTER*10 CVTCAT EXTERNAL CVTCAT, FIND, LENSTR, MINOR C C Intrinsic functions. C INTRINSIC ABS, INDEX, MAX, MIN C C DATA statement definitions. C DATA LLU13 /.FALSE./, FNAMSV /' '/ C C These three variables indicate whether the information from C the files FCAT, FTBL and FKWD have been read in. The files C are read only once and then only if the information is needed. C DATA LLU18, LLU19, LLU14 /.FALSE.,.FALSE.,.FALSE./ C DATA FORMA(1:29), FORMA(30:60) /'(/, 1X, A , '' category does ', + 'not exist in this library.'', /)'/ C***FIRST EXECUTABLE STATEMENT SLADOC WRITE (UNIT=MSG, FMT=9720) LCAT, MLCAT FMT1 = '(1X, A' // MSG(1:2) // ', ' // MSG(3:4) // 'X, A, 3I8)' FNAME = FLIS C C OPEN (UNIT=LU5, FILE=FIN, STATUS='UNKNOWN', IOSTAT=INFO, C + FORM='FORMATTED') C IF (INFO .NE. 0) THEN C MSG = 'Failure in attempting to open ' // FIN // ' for input' C NERR = 1 C GO TO 520 C ENDIF C C OPEN (UNIT=LU6, FILE=FOUT, STATUS='UNKNOWN', IOSTAT=INFO, C + FORM='FORMATTED') C IF (INFO .NE. 0) THEN C MSG = ' Failure in attempting to open ' // FOUT // ' for output' C NERR = 1 C GO TO 520 C ENDIF C C Check to see if the input files to be used are in the user's C local space. If so, use them instead of the ones on the C system. C TEMP = FDAF ILEN = LENSTR(TEMP) DO 10 I = ILEN,1,-1 IF (TEMP(I:I) .EQ. '/') THEN INQUIRE (FILE=TEMP(I+1:ILEN), EXIST=LEXIST) IF (LEXIST) THEN TEMP = TEMP(I+1:ILEN) ENDIF GO TO 20 ENDIF 10 CONTINUE 20 OPEN (UNIT=LU17, FILE=TEMP, STATUS='OLD', ACCESS='DIRECT', + FORM='FORMATTED', RECL = LLN, IOSTAT = INFO) IF (INFO .NE. 0) THEN MSG = ' Failure in attempting to open ' // TEMP NERR = 1 GO TO 940 ENDIF TEMP = FCAT ILEN = LENSTR(TEMP) DO 30 I = ILEN,1,-1 IF (TEMP(I:I) .EQ. '/') THEN INQUIRE (FILE=TEMP(I+1:ILEN), EXIST=LEXIST) IF (LEXIST) THEN TEMP = TEMP(I+1:ILEN) ENDIF GO TO 40 ENDIF 30 CONTINUE 40 OPEN (UNIT=LU14, FILE=TEMP, STATUS='OLD', FORM='FORMATTED', + IOSTAT=INFO) IF (INFO .NE. 0) THEN MSG = ' Failure in attempting to open ' // TEMP NERR = 1 GO TO 940 ENDIF TEMP = FKWD ILEN = LENSTR(TEMP) DO 50 I = ILEN,1,-1 IF (TEMP(I:I) .EQ. '/') THEN INQUIRE (FILE=TEMP(I+1:ILEN), EXIST=LEXIST) IF (LEXIST) THEN TEMP = TEMP(I+1:ILEN) ENDIF GO TO 60 ENDIF 50 CONTINUE 60 OPEN (UNIT=LU19, FILE=TEMP, STATUS='OLD', FORM='FORMATTED', + IOSTAT=INFO) IF (INFO .NE. 0) THEN MSG = ' Failure in attempting to open ' // TEMP NERR = 1 GO TO 940 ENDIF TEMP = FTBL ILEN = LENSTR(TEMP) DO 70 I = ILEN,1,-1 IF (TEMP(I:I) .EQ. '/') THEN INQUIRE (FILE=TEMP(I+1:ILEN), EXIST=LEXIST) IF (LEXIST) THEN TEMP = TEMP(I+1:ILEN) ENDIF GO TO 80 ENDIF 70 CONTINUE 80 OPEN (UNIT=LU18, FILE=TEMP, STATUS='OLD', FORM='FORMATTED', + IOSTAT=INFO) IF (INFO .NE. 0) THEN MSG = ' Failure in attempting to open ' // TEMP NERR = 1 GO TO 940 ENDIF C C Write welcome message. C FMT2 = '('' Welcome to ' // UTIL // ', the ' // LIB // + ' on-line documentation program'' /)' WRITE (UNIT=LU6, FMT=FMT2) C C Write the complete message showing the commands. C 90 WRITE (UNIT=LU6, FMT=9020) C C Write "Ready for your command". C 100 WRITE (UNIT=LU6, FMT=9030) REWIND (UNIT=LU5, ERR=110) 110 READ (UNIT=LU5, FMT=9000, END=120) LINE CALL UPCASE (LINE, LINE) GO TO 130 120 LINE = ' ' 130 LENG = LENSTR(LINE) CALL CHARIN (LINE, LENG, 2, LB, LT) 140 LB = MAX(LB,1) IF (LINE(LB:LB).EQ.'L' .OR. LINE(LB:LB).EQ.'C' .OR. + LINE(LB:LB).EQ.'K' .OR. LINE(LB:LB).EQ.'X' .OR. + LINE(LB:LB).EQ.'V') THEN INPUT1 = LINE(LB:LB) C C IF (INPUT1 .EQ. 'L') THEN C C User has requested information on the GAMS classification C scheme. C IF (.NOT.LLU14) THEN C C Read in the information from file FCAT. C READ (UNIT=LU14, FMT=9700) NCC IF (NCC .GT. MXNCAT) THEN MSG = 'MXNCAT internal error. Please contact the ' + // 'consulting office.' NERR = 3 GO TO 940 ENDIF NCC = NCC-1 DO 150 J = 1,NCC READ (UNIT=LU14, FMT=9730) IPTR(J), JPTR(J), + KPTR(J), TCLASS(J) 150 CONTINUE READ (UNIT=LU14, FMT=9710) KPTR(NCC+1) ISTMT = KPTR(NCC+1) IF (ISTMT .GT. MXNCL) THEN MSG = 'MXNCL internal error. Please contact the ' + // 'consulting office.' NERR = 4 GO TO 940 ENDIF READ (UNIT=LU14, FMT=9000) (STMTS(I), I=1, ISTMT) LLU14 = .TRUE. CLOSE (LU14) ENDIF LS = LT+LB CALL CHARIN (LINE(LS:LS), LENG, 2, LB, LT) IF (LT .EQ. 0) THEN C C CASE I. l or l C C Print out the major categories. C WRITE (UNIT=LU6, FMT=9100) KAT = TCLASS(1) IFIND = FIND(TCLASS,NCC,KAT) 160 IF (IFIND .GT. 0) THEN C I1(1) = IPTR(IFIND) I3(1) = KPTR(IFIND) TCL = ' ' CALL UNDOCL (TCLASS(IFIND), TCL) LMSG(1) = KPTR(IFIND+1)-KPTR(IFIND) IFIND = I1(1) LTCL = LENSTR(TCL) WRITE (UNIT=FORM, FMT=9740) LTCL ISTART = I3(1) DO 170 JCL = 1,LMSG(1) WRITE (UNIT=LU6, FMT=FORM) TCL(1:LTCL), + STMTS(ISTART)(1:LENSTR(STMTS(ISTART))) ISTART = ISTART+1 TCL = ' ' 170 CONTINUE GOTO 160 ENDIF C C Ask the user to input a MAJOR category he/she wishes to C explore. C WRITE (UNIT=LU6, FMT=9110) REWIND (UNIT=LU5, ERR=180) 180 READ (UNIT=LU5, FMT=9000, END=90) LINE CALL UPCASE (LINE, LINE) C C Remove leading blanks from the input line. C CALL RBLNKS (LINE, LINESV) KAT = LINESV(1:1) KATS = KAT C C KATS is the unexpanded version of the category name. C KAT is the expanded version of the category name. C E.G., If (KAT) = H02A01A01, then (KATS) = H2A1A1. C 190 IERROR = MINOR(KAT, KATS, NCC, TCLASS, IPTR, JPTR, KPTR, + NTRY) IF (IERROR .NE. 0) THEN WRITE (UNIT=LU6, FMT=9230) KATS GO TO 100 ELSE C C The first entry is a repeat of the category information C he/she now wishes to explore. C LKATS = LENSTR(KATS) WRITE (UNIT=FORM, FMT=9740) LKATS ISTART = I3(1) TCL = KATS DO 200 JCL = 1,LMSG(1) WRITE (UNIT=LU6, FMT=FORM) TCL(1:LKATS), + STMTS(ISTART)(1:LENSTR(STMTS(ISTART))) ISTART = ISTART+1 TCL = ' ' 200 CONTINUE ENDIF IF (NTRY .GT. 1) THEN DO 220 IN = 2,NTRY TCL = CLASS(IN) LTCL = LENSTR(TCL) WRITE (UNIT=FORM, FMT=9740) LTCL ISTART = I3(IN) DO 210 JCL = 1,LMSG(IN) WRITE (UNIT=LU6, FMT=FORM) TCL(1:LTCL), + STMTS(ISTART)(1:LENSTR(STMTS(ISTART))) ISTART = ISTART+1 TCL = ' ' 210 CONTINUE 220 CONTINUE WRITE (UNIT=LU6, FMT=9120) LINE = ' ' REWIND (UNIT=LU5, ERR=230) 230 READ (UNIT=LU5, FMT=9000, END=100) LINE IF (LENSTR(LINE) .EQ. 0) GO TO 100 CALL RBLNKS (LINE, LINESV) LENG = LENSTR(LINESV) CALL UPCASE (LINESV(1:LENG), KATS) KAT = CVTCAT(KATS(1:LENG)) GO TO 190 ELSE WRITE (UNIT=LU6, FMT=9130) KATS KATS = ' ' WRITE (UNIT=LU6, FMT=9140) GO TO 100 ENDIF ELSE C C CASE II. l,cat C LL = LS-1+LB IF ((LENG-LL+1) .GT. MXLKAT) THEN C C A longer category has been requested than permitted. C WRITE (UNIT=FORM, FMT=9720) LENG-LL+1 FORMA(10:11) = FORM(1:2) WRITE (UNIT=LU6, FMT=FORMA) LINE(LL:LENG) GO TO 100 ENDIF KATS = LINE(LL:LENG) LENG = LENSTR(KATS) KAT = CVTCAT(KATS(1:LENG)) C C KATS is the unexpanded version of the category name. C KAT is the expanded version of the category name. C E.G., If (KAT) = H02A01A01, then (KATS) = H2A1A1. C 240 IERROR = MINOR(KAT, KATS, NCC, TCLASS, IPTR, JPTR, KPTR, + NTRY) IF (IERROR .NE. 0) THEN C C Category not found in this library. C WRITE (UNIT=LU6, FMT=9230) KATS GO TO 100 ELSE C C The first entry is a repeat of the category information C he/she now wishes to explore. C LKATS = LENSTR(KATS) WRITE (UNIT=FORM, FMT=9740) LKATS ISTART = I3(1) TCL = KATS DO 250 JCL = 1,LMSG(1) WRITE (UNIT=LU6, FMT=FORM) TCL(1:LKATS), + STMTS(ISTART)(1:LENSTR(STMTS(ISTART))) ISTART = ISTART+1 TCL = ' ' 250 CONTINUE ENDIF IF (NTRY .GT. 1) THEN DO 270 IN = 2,NTRY TCL = CLASS(IN) LTCL = LENSTR(TCL) WRITE (UNIT=FORM, FMT=9740) LTCL ISTART = I3(IN) DO 260 JCL = 1,LMSG(IN) WRITE (UNIT=LU6, FMT=FORM) TCL(1:LTCL), + STMTS(ISTART)(1:LENSTR(STMTS(ISTART))) ISTART = ISTART+1 TCL = ' ' 260 CONTINUE 270 CONTINUE WRITE (UNIT=LU6, FMT=9120) LINE = ' ' REWIND (UNIT=LU5, ERR=280) 280 READ (UNIT=LU5, FMT=9000, END=100) LINE IF (LENSTR(LINE) .EQ. 0) GO TO 100 CALL RBLNKS (LINE, LINESV) LENG = LENSTR(LINESV) CALL UPCASE (LINESV(1:LENG), KATS) KAT = CVTCAT(KATS(1:LENG)) GO TO 240 ELSE WRITE (UNIT=LU6, FMT=9130) KATS KATS = ' ' WRITE (UNIT=LU6, FMT=9140) GO TO 100 ENDIF ENDIF C ELSEIF (INPUT1 .EQ. 'K') THEN C C User is looking for routine names by keyword phrase. C IF (.NOT.LLU19) THEN C C Read in the information from file FKWD. C READ (UNIT=LU19, FMT=9700) NTKWD WRITE (UNIT=FORM, FMT=9750) KMAXI IF (NTKWD .GT. MXKWDS) THEN MSG = 'MXKWDS internal error. Please contact the ' + // 'consulting office.' NERR = 5 GO TO 940 ENDIF READ (UNIT=LU19, FMT=FORM) (TKWD(J), J=1, NTKWD) C INEXT = 0 290 CONTINUE READ (UNIT=LU19, FMT=9000, END=300) LINESV IF (INEXT .GE. 10*MXKWDS) THEN MSG = 'MXKWDS internal error. Please contact the ' + // 'consulting office.' NERR = 6 GO TO 940 ENDIF READ (UNIT=LINESV, FMT=9700) IPTRL(INEXT+1), IPTRR(INEXT+1) INEXT = INEXT+1 GO TO 290 300 CONTINUE LLU19 = .TRUE. CLOSE (LU19) ENDIF IF (.NOT.LLU18) THEN C C Read in the information from file FTBL. C LFTBL = 0 310 CONTINUE LFTBL = LFTBL+1 READ (UNIT=LU18, FMT=9000, END=320) LINESV IF (LFTBL .GT. MXNRN) THEN MSG = 'MXNRN internal error. Please contact the ' + // 'consulting office.' NERR = 2 GO TO 940 ENDIF READ (UNIT=LINESV, FMT=9310) CAT(LFTBL), RTNAME(LFTBL), + IS(LFTBL), IE(LFTBL), IPS(LFTBL), IPE(LFTBL) GO TO 310 320 CONTINUE LFTBL = LFTBL - 1 LLU18 = .TRUE. CLOSE (LU18) ENDIF LS = LT+LB CALL CHARIN (LINE(LS:LS), LENG, 2, LB, LT) IF (LT .EQ. 0) THEN C C Ask the user to input the keyword phrase he/she wishes C to find. C WRITE (UNIT=LU6, FMT=9300) REWIND (UNIT=LU5, ERR=330) 330 READ (UNIT=LU5, FMT=9000, END=340) LINE CALL UPCASE (LINE, LINE) GO TO 350 340 LINE = ' ' 350 LB = 1 LT = LENSTR(LINE) IF (LT .EQ. 0) THEN WRITE (UNIT=LU6, FMT=9340) GO TO 90 ENDIF KWRD = LINE(LB:LT) ELSE KWRD = LINE(LS-1+LB:LENG) ENDIF C C The keyword phrase was found on the original command line. C ILEN = LENSTR(KWRD) FOUND = .FALSE. DO 380 I = 1,NTKWD IJ = INDEX(TKWD(I),KWRD(1:ILEN)) IF (IJ .NE. 0) THEN FOUND = .TRUE. C C We have found this keyword in one of the phrases. C IJ = I IN = 1 360 IL = IPTRL(IJ) IR = IPTRR(IJ) C C Collect together in CNAME all the routines which C contain the keyword phrase, so that they can be printed C six on a line. C CNAME(IN) = RTNAME(IR) IF (IL .EQ. 0) GO TO 370 IJ = IL IN = IN+1 GO TO 360 370 WRITE (UNIT=LU6, FMT=9320) TKWD(I) WRITE (UNIT=LU6, FMT=9330) WRITE (UNIT=LU6, FMT=9760) (CNAME(IJ), IJ=1, IN) ENDIF 380 CONTINUE IF (.NOT.FOUND) THEN WRITE (UNIT=LU6, FMT=9340) ENDIF C C ELSEIF (INPUT1 .EQ. 'C') THEN C C User is looking for routine names by category. C IF (.NOT.LLU18) THEN C C Read in the information from file FTBL. C LFTBL = 0 390 CONTINUE LFTBL = LFTBL+1 READ (UNIT=LU18, FMT=9000, END=400) LINESV IF (LFTBL .GT. MXNRN) THEN MSG = 'MXNRN internal error. Please contact the ' + // 'consulting office.' NERR = 2 GO TO 940 ENDIF READ (UNIT=LINESV, FMT=9310) CAT(LFTBL), RTNAME(LFTBL), + IS(LFTBL), IE(LFTBL), IPS(LFTBL), IPE(LFTBL) GO TO 390 400 CONTINUE LFTBL = LFTBL - 1 LLU18 = .TRUE. CLOSE (LU18) ENDIF LS = LT+LB CALL CHARIN (LINE(LS:LS), LENG, 2, LB, LT) IF (LT .EQ. 0) THEN C C Ask the user to input the classification category he/she C wishes to find. C WRITE (UNIT=LU6, FMT=9200) REWIND (UNIT=LU5, ERR=410) 410 READ (UNIT=LU5, FMT=9000, END=420) LINE CALL UPCASE (LINE, LINE) GO TO 430 420 LINE = ' ' 430 LB = 1 LT = LENSTR(LINE) IF (LT .EQ. 0) THEN WRITE (UNIT=LU6, FMT=9220) GO TO 90 ENDIF KAT = LINE(LB:LT) ELSE C C The category appeared on the original input line. C KAT = LINE(LS-1+LB:LS-1+LB+LT-1) ENDIF IJ = 0 ILEN = LENSTR(KAT) DO 440 I = 1,LFTBL IF (KAT .EQ. CAT(I)(1:ILEN)) THEN IJ = IJ+1 C C Collect together in CNAME all the routines having C this category. C CNAME(IJ) = RTNAME(I) ENDIF 440 CONTINUE IF (IJ .EQ. 0) THEN WRITE (UNIT=LU6, FMT=9220) ELSE WRITE (UNIT=LU6, FMT=9210) C C Write out the routine names, six per line. C WRITE (UNIT=LU6, FMT=9760) (CNAME(I), I=1, IJ) ENDIF ELSEIF (INPUT1 .EQ. 'V') THEN LS = LT+LB CALL CHARIN (LINE(LS:LS), LENG, 2, LB, LT) IF (LT .EQ. 0) THEN C C Ask the user to input if he wants classification categories C or the keywords. C WRITE (UNIT=LU6, FMT=9600) REWIND (UNIT=LU5, ERR=450) 450 READ (UNIT=LU5, FMT=9000, END=460) LINE CALL UPCASE (LINE, LINE) GO TO 470 460 LINE = ' ' 470 LB = 1 LT = LENSTR(LINE) IF (LT .EQ. 0) THEN WRITE (UNIT=LU6, FMT=9220) GO TO 90 ENDIF KAT = LINE(LB:LT) ELSE C C The category appeared on the original input line. C KAT = LINE(LS-1+LB:LS-1+LB+LT-1) ENDIF IF (KAT(1:1) .EQ. 'C') THEN IF (.NOT.LLU14) THEN C C Read in the information from file FCAT. C READ (UNIT=LU14, FMT=9700) NCC IF (NCC .GT. MXNCAT) THEN MSG = 'MXNCAT internal error. Please contact the ' + // 'consulting office.' NERR = 3 GO TO 940 ENDIF NCC = NCC-1 DO 480 J = 1,NCC READ (UNIT=LU14, FMT=9730) IPTR(J), JPTR(J), + KPTR(J), TCLASS(J) 480 CONTINUE READ (UNIT=LU14, FMT=9710) KPTR(NCC+1) ISTMT = KPTR(NCC+1) IF (ISTMT .GT. MXNCL) THEN MSG = 'MXNCL internal error. Please contact the ' + // 'consulting office.' NERR = 4 GO TO 940 ENDIF READ (UNIT=LU14, FMT=9000) (STMTS(I), I=1, ISTMT) LLU14 = .TRUE. CLOSE(LU14) ENDIF ELSEIF (KAT(1:1) .EQ. 'K') THEN C C The keywords are being requested. C IF (.NOT.LLU19) THEN C C Read in the information from file FKWD. C READ (UNIT=LU19, FMT=9700) NTKWD WRITE (UNIT=FORM, FMT=9750) KMAXI IF (NTKWD .GT. MXKWDS) THEN MSG = 'MXKWDS internal error. Please contact the ' + // 'consulting office.' NERR = 5 GO TO 940 ENDIF READ (UNIT=LU19, FMT=FORM) (TKWD(J), J=1, NTKWD) C INEXT = 0 490 CONTINUE READ (UNIT=LU19, FMT=9000, END=500) LINESV IF (INEXT .GE. 10*MXKWDS) THEN MSG = 'MXKWDS internal error. Please contact the ' + // 'consulting office.' NERR = 6 GO TO 940 ENDIF READ (UNIT=LINESV, FMT=9700) IPTRL(INEXT+1), + IPTRR(INEXT+1) INEXT = INEXT+1 GO TO 490 500 CONTINUE LLU19 = .TRUE. CLOSE (LU19) ENDIF ELSE WRITE (UNIT=LU6, FMT=9050) GOTO 100 ENDIF IF (KAT(1:1) .EQ. 'C') THEN FNAME = 'classlis' WRITE (UNIT=LU6, FMT=9610) 'Classification', NCC ELSE FNAME = 'keylis' WRITE (UNIT=LU6, FMT=9610) 'Keyword', NTKWD ENDIF ILEN = LENSTR(FNAME) WRITE (UNIT=LU6, FMT=9620) FNAME(1:ILEN) C C Ask where he/she wants the list information written. C WRITE (UNIT=LU6, FMT=9630) READ (UNIT=LU5, FMT=9000) LINE LENG = LENSTR(LINE) CALL CHARIN (LINE, LENG, 2, LB, LT) C C The user wants to browse through the list on her/his terminal. C IF (LINE(LB:LB).EQ.'b' .OR. LINE(LB:LB).EQ.'B') THEN PGSZ = 21 LOW = 1 HIGH = PGSZ 520 WRITE (UNIT=LU6, FMT=9450) 530 READ (UNIT=LU5, FMT=9000, END=520) LINE LENG = LENSTR(LINE) CALL UPCASE (LINE, LINE) CALL CHARIN (LINE, LENG, 2, LB, LT) IF (KAT(1:1) .EQ. 'C') THEN NLINES = NCC ELSE NLINES = NTKWD ENDIF C C 'SPGSZ' Set page size C IF (LINE(LB:LB+4) .EQ. 'SPGSZ') THEN IF ((LT .EQ. 5) .AND. (LB+4 .EQ. LENG)) THEN C C Print out the current value of PGSZ C WRITE (UNIT=LU6, FMT=9490) PGSZ ELSE C C Get a new pgsz C IF (LT+LB-1 .GT. LB+4) THEN C C There are no spaces between 'spgsz' and a value C WRITE (FORM, 9460) LT-5 READ (LINE(LB+5:LB+LT-1), FORM, ERR=640) PGSZ PGSZ = ABS(PGSZ) ELSE C C There are spaces; call CHARIN again to get the next C field C LS = LB+LT CALL CHARIN (LINE(LS:LS), LENG, 2, LB2, LT2) WRITE (FORM, 9460) LENG-LS-LB2+2 READ (LINE(LS+LB2-1:LENG), FORM, + ERR=640) PGSZ PGSZ = ABS(PGSZ) ENDIF WRITE (UNIT=LU6, FMT=9500) PGSZ ENDIF WRITE (UNIT=LU6, FMT=9470) GO TO 530 C C 'PD' Page forwards (downward) C ELSEIF (LINE(LB:LB+1) .EQ. 'PD') THEN IF ((LT .EQ. 2) .AND. (LB+1 .EQ. LENG)) THEN C C There is no value given; assume one (1). C NPD = 1 ELSE IF (LT+LB-1 .GT. LB+1) THEN C C There are no spaces between 'pd' and a value C WRITE (FORM, 9460) LT-2 READ (LINE(LB+2:LB+LT-1), FORM, ERR=640) NPD ELSE C C There are spaces; call CHARIN again to get the next C field C LS = LB+LT CALL CHARIN (LINE(LS:LS), LENG, 2, LB2, LT2) WRITE (FORM, 9460) LENG-LS-LB2+2 READ (LINE(LS+LB2-1:LENG), FORM, + ERR=640) NPD ENDIF ENDIF LOW = MAX(HIGH+(NPD-1)*PGSZ+1, 1) HIGH = MIN(LOW + PGSZ-1, NLINES) IF (LOW .GT. HIGH .OR. HIGH-LOW+1 .LT. PGSZ) THEN LOW = MAX(HIGH-PGSZ,1) ENDIF DO 550 IREC = LOW, MIN(HIGH,NLINES) IF (KAT(1:1) .EQ. 'C') THEN II = KPTR(IREC) TCL = ' ' CALL UNDOCL (TCLASS(IREC), TCL) WRITE (UNIT=LU6, FMT=9780) II, + TCL(1:LENSTR(TCL)), + STMTS(II)(1:LENSTR(STMTS(II))) ITEMP = KPTR(IREC+1)-KPTR(IREC)-1 LTCL = LENSTR(TCL)+3 WRITE (UNIT=FORM, FMT=9790) LTCL DO 540 JJ = 1, ITEMP II = II + 1 WRITE (UNIT=LU6, FMT=FORM) II, + STMTS(II)(1:LENSTR(STMTS(II))) 540 CONTINUE ELSE WRITE (UNIT=LU6, FMT=9640) IREC, TKWD(IREC) ENDIF 550 CONTINUE WRITE (UNIT=LU6, FMT=9470) GO TO 530 C C 'PU' Page backwards (upward) C ELSEIF (LINE(LB:LB+1) .EQ. 'PU') THEN IF ((LT .EQ. 2) .AND. (LB+1 .EQ. LENG)) THEN C C There is no value given; assume one (1). C NPD = 1 ELSE IF (LT+LB-1 .GT. LB+1) THEN C C There are no spaces between 'pu' and a value C WRITE (FORM, 9460) LT-2 READ (LINE(LB+2:LB+LT-1), FORM, ERR=640) NPD ELSE C C There are spaces; call CHARIN again to get the next C field C LS = LB+LT CALL CHARIN (LINE(LS:LS), LENG, 2, LB2, LT2) WRITE (FORM, 9460) LENG-LS-LB2+2 READ (LINE(LS+LB2-1:LENG), FORM, + ERR=640) NPD ENDIF ENDIF NPD = -NPD LOW = MAX(LOW + NPD*PGSZ, 1) HIGH = MIN(LOW + PGSZ-1, NLINES) IF (LOW .GT. HIGH .OR. HIGH-LOW+1 .LT. PGSZ) THEN LOW = MAX(HIGH-PGSZ,1) ENDIF DO 570 IREC = LOW, MIN(HIGH,NLINES) IF (KAT(1:1) .EQ. 'C') THEN II = KPTR(IREC) TCL = ' ' CALL UNDOCL (TCLASS(IREC), TCL) WRITE (UNIT=LU6, FMT=9780) II, + TCL(1:LENSTR(TCL)), + STMTS(II)(1:LENSTR(STMTS(II))) ITEMP = KPTR(IREC+1)-KPTR(IREC)-1 LTCL = LENSTR(TCL)+3 WRITE (UNIT=FORM, FMT=9790) LTCL DO 560 JJ = 1, ITEMP II = II + 1 WRITE (UNIT=LU6, FMT=FORM) II, + STMTS(II)(1:LENSTR(STMTS(II))) 560 CONTINUE ELSE WRITE (UNIT=LU6, FMT=9640) IREC, TKWD(IREC) ENDIF 570 CONTINUE WRITE (UNIT=LU6, FMT=9470) GO TO 530 C C 'HD' Page half a page forward C ELSEIF (LINE(LB:LB+1) .EQ. 'HD') THEN LOW = MAX(LOW + PGSZ/2, 1) HIGH = MIN(LOW + PGSZ-1,NLINES) IF (LOW .GT. HIGH .OR. HIGH-LOW+1 .LT. PGSZ) THEN LOW = MAX(HIGH-PGSZ,1) ENDIF DO 590 IREC = LOW, MIN(HIGH,NLINES) IF (KAT(1:1) .EQ. 'C') THEN II = KPTR(IREC) TCL = ' ' CALL UNDOCL (TCLASS(IREC), TCL) WRITE (UNIT=LU6, FMT=9780) II, + TCL(1:LENSTR(TCL)), + STMTS(II)(1:LENSTR(STMTS(II))) ITEMP = KPTR(IREC+1)-KPTR(IREC)-1 LTCL = LENSTR(TCL)+3 WRITE (UNIT=FORM, FMT=9790) LTCL DO 580 JJ = 1, ITEMP II = II + 1 WRITE (UNIT=LU6, FMT=FORM) II, + STMTS(II)(1:LENSTR(STMTS(II))) 580 CONTINUE ELSE WRITE (UNIT=LU6, FMT=9640) IREC, TKWD(IREC) ENDIF 590 CONTINUE WRITE (UNIT=LU6, FMT=9470) GO TO 530 C C 'HU' Page half a page backward C ELSEIF (LINE(LB:LB+1) .EQ. 'HU') THEN LOW = MAX (LOW - PGSZ/2, 1) HIGH = MIN(LOW + PGSZ-1,NLINES) IF (LOW .GT. HIGH .OR. HIGH-LOW+1 .LT. PGSZ) THEN LOW = MAX(HIGH-PGSZ,1) ENDIF DO 610 IREC = LOW, MIN(HIGH,NLINES) IF (KAT(1:1) .EQ. 'C') THEN II = KPTR(IREC) TCL = ' ' CALL UNDOCL (TCLASS(IREC), TCL) WRITE (UNIT=LU6, FMT=9780) II, + TCL(1:LENSTR(TCL)), + STMTS(II)(1:LENSTR(STMTS(II))) ITEMP = KPTR(IREC+1)-KPTR(IREC)-1 LTCL = LENSTR(TCL)+3 WRITE (UNIT=FORM, FMT=9790) LTCL DO 600 JJ = 1, ITEMP II = II + 1 WRITE (UNIT=LU6, FMT=FORM) II, + STMTS(II)(1:LENSTR(STMTS(II))) 600 CONTINUE ELSE WRITE (UNIT=LU6, FMT=9640) IREC, TKWD(IREC) ENDIF 610 CONTINUE WRITE (UNIT=LU6, FMT=9470) GO TO 530 C C 'P' Print the current page C ELSEIF (LINE(LB:LB) .EQ. 'P' .AND. LT .EQ. 1) THEN HIGH = MIN(LOW+PGSZ-1,NLINES) IF (LOW .GT. HIGH .OR. HIGH-LOW+1 .LT. PGSZ) THEN LOW = MAX(HIGH-PGSZ,1) ENDIF DO 630 IREC = LOW, MIN(HIGH,NLINES) IF (KAT(1:1) .EQ. 'C') THEN II = KPTR(IREC) TCL = ' ' CALL UNDOCL (TCLASS(IREC), TCL) WRITE (UNIT=LU6, FMT=9780) II, + TCL(1:LENSTR(TCL)), + STMTS(II)(1:LENSTR(STMTS(II))) ITEMP = KPTR(IREC+1)-KPTR(IREC)-1 LTCL = LENSTR(TCL)+3 WRITE (UNIT=FORM, FMT=9790) LTCL DO 620 JJ = 1, ITEMP II = II + 1 WRITE (UNIT=LU6, FMT=FORM) II, + STMTS(II)(1:LENSTR(STMTS(II))) 620 CONTINUE ELSE WRITE (UNIT=LU6, FMT=9640) IREC, TKWD(IREC) ENDIF 630 CONTINUE WRITE (UNIT=LU6, FMT=9470) GO TO 530 C C 'E' End the browsing mode C ELSEIF (LINE(LB:LB) .EQ. 'E' ) THEN WRITE (UNIT=LU6, FMT=9040) REWIND (UNIT=LU5, ERR=110) GO TO 110 C C 'Q' Quit the browsing mode C ELSEIF (LINE(LB:LB) .EQ. 'Q' ) THEN WRITE (UNIT=LU6, FMT=9040) REWIND (UNIT=LU5, ERR=110) GO TO 110 ELSEIF (LINE(LB:LB) .EQ. '?' ) THEN GO TO 520 ELSE WRITE (UNIT=LU6, FMT=9050) GO TO 520 ENDIF 640 WRITE (UNIT=LU6, FMT=9050) GO TO 520 ELSEIF (LINE(LB:LB).EQ.'t' .OR. LINE(LB:LB).EQ.'T') THEN C C Write it to the standard output file. C IF (KAT(1:1) .EQ. 'C') THEN DO 660 J = 1,NCC I = KPTR(J) TCL = ' ' CALL UNDOCL (TCLASS(J), TCL) WRITE (UNIT=LU6, FMT=9810) + TCL(1:LENSTR(TCL)), + STMTS(I)(1:LENSTR(STMTS(I))) ITEMP = KPTR(J+1)-KPTR(J)-1 LTCL = LENSTR(TCL)+1 WRITE (UNIT=FORM, FMT=9820) LTCL DO 650 JJ = 1, ITEMP I = I + 1 WRITE (UNIT=LU6, FMT=FORM) + STMTS(I)(1:LENSTR(STMTS(I))) 650 CONTINUE 660 CONTINUE ELSE DO 670 I = 1,NTKWD WRITE (UNIT=LU6, FMT=9010) TKWD(I) 670 CONTINUE ENDIF ELSEIF (LINE(LB:LB).EQ.'f' .OR. LINE(LB:LB).EQ.'F') THEN LS = LB+LT CALL CHARIN (LINE(LS:LS), LENG, 2, LB, LT) IF (LT .EQ. 0) THEN C C Write it to file FNAME. C FN = FNAME ELSE FN = LINE(LS-1+LB:LS-1+LB+LT-1) C C Write it to the file he/she specified. C ENDIF C IF (FN .NE. FNAMSV) THEN C C If this filename is not the one previously used for some C list, then close the file (if it is still open) and open C UNIT 13 for the new file. C IF (LLU13) CLOSE (LU13) OPEN (UNIT=LU13, FILE=FN, STATUS='UNKNOWN', + FORM='FORMATTED') FNAMSV = FN LLU13 = .TRUE. C ENDIF C C Write the list to the file specified by the user. C IF (KAT(1:1) .EQ. 'C') THEN DO 690 J = 1,NCC I = KPTR(J) TCL = ' ' CALL UNDOCL (TCLASS(J), TCL) WRITE (UNIT=LU13, FMT=9810) + TCL(1:LENSTR(TCL)), + STMTS(I)(1:LENSTR(STMTS(I))) ITEMP = KPTR(J+1)-KPTR(J)-1 LTCL = LENSTR(TCL)+1 WRITE (UNIT=FORM, FMT=9820) LTCL DO 680 JJ = 1, ITEMP I = I + 1 WRITE (UNIT=LU13, FMT=FORM) + STMTS(I)(1:LENSTR(STMTS(I))) 680 CONTINUE 690 CONTINUE ELSE DO 700 I = 1,NTKWD WRITE (UNIT=LU13, FMT=9010) TKWD(I) 700 CONTINUE ENDIF CLOSE(LU13) ELSE WRITE (UNIT=LU6, FMT=9040) REWIND (UNIT=LU5, ERR=110) GO TO 110 ENDIF IF (LB.GT.0 .AND. (LINE(LB:LB).EQ.'Q'.OR.LINE(LB:LB).EQ.'E')) + THEN C C The command typed in is assumed to be "quit" or "end". C INPUT1 = 'Q' ELSEIF (LB.GT.0 .AND. + (LINE(LB:LB).EQ.'H'.OR.LINE(LB:LB).EQ.'?')) THEN C C The command typed in is assumed to be "help" or "?". C Go back and print the original input instructions. C INPUT1 = 'H' ELSE C C Print "invalid command" and assume the command was "help". C INPUT1 = 'H' ENDIF ELSE C C The input command was X. C C User wants documentation for a specific routine. C IF (.NOT.LLU18) THEN C C Read in the information from file FTBL. C LFTBL = 0 710 CONTINUE LFTBL = LFTBL+1 READ (UNIT=LU18, FMT=9000, END=720) LINESV IF (LFTBL .GT. MXNRN) THEN MSG = 'MXNRN internal error. Please contact the ' + // 'consulting office.' NERR = 2 GO TO 940 ENDIF READ (UNIT=LINESV, FMT=9310) CAT(LFTBL), RTNAME(LFTBL), + IS(LFTBL), IE(LFTBL), IPS(LFTBL), IPE(LFTBL) GO TO 710 720 CONTINUE LFTBL = LFTBL - 1 LLU18 = .TRUE. CLOSE (LU18) ENDIF LS = LT+LB CALL CHARIN (LINE(LS:LS), LENG, 2, LB, LT) TEMP = ' ' IF (LT .EQ. 0) THEN C C Ask the user for the routine name. C WRITE (UNIT=LU6, FMT=9400) REWIND (UNIT=LU5, ERR=730) 730 READ (UNIT=LU5, FMT=9000, END=740) LINE CALL UPCASE (LINE, LINE) GO TO 750 740 LINE = ' ' 750 LENG = LENSTR(LINE) IF (LENG .EQ. 0) GO TO 770 TEMP = LINE(1:LENG) ELSE C C The routine name was given on the input command line. C TEMP = LINE(LS-1+LB:LS-1+LB+LT-1) ENDIF RTNIN = TEMP DO 760 I = 1,LFTBL IF (RTNIN .EQ. RTNAME(I)) GO TO 780 760 CONTINUE 770 WRITE (UNIT=LU6, FMT=9440) C C This routine does not exist in the library. C GO TO 100 780 CONTINUE C C IS(I) contains the location of the subprogram statement. C IE(I) contains the location of the END PROLOGUE statement. C IPS(I) contains the starting location of the PURPOSE section. C IPE(I) contains the ending location of the PURPOSE section. C NUM = IE(I)-IS(I)+1 C C Write the name of the routine and the number of lines of C documentation. C WRITE (UNIT=LU6, FMT=9410) RTNIN, NUM C C Write the purpose of the subprogram. C DO 790 IREC = IPS(I), IPE(I) READ (UNIT=LU17, FMT=9000, REC=IREC) LINE WRITE (UNIT=LU6, FMT=9010) LINE 790 CONTINUE FNAME = FLIS ILEN = LENSTR(FNAME) WRITE (UNIT=LU6, FMT=9420) FNAME(1:ILEN) C C Ask where he/she wants the documentation information written. C WRITE (UNIT=LU6, FMT=9430) READ (UNIT=LU5, FMT=9000) LINE LENG = LENSTR(LINE) CALL CHARIN (LINE, LENG, 2, LB, LT) C C The user wants to browse through the documentation on her/his C terminal. C IF (LINE(LB:LB).EQ.'b' .OR. LINE(LB:LB).EQ.'B') THEN PGSZ = 21 LOW = 1 HIGH = PGSZ 800 WRITE (UNIT=LU6, FMT=9450) 810 READ (UNIT=LU5, FMT=9000, END=800) LINE LENG = LENSTR(LINE) CALL UPCASE (LINE, LINE) CALL CHARIN (LINE, LENG, 2, LB, LT) C C 'SPGSZ' Set page size C IF (LINE(LB:LB+4) .EQ. 'SPGSZ') THEN IF ((LT .EQ. 5) .AND. (LB+4 .EQ. LENG)) THEN C C Print out the current value of PGSZ C WRITE (UNIT=LU6, FMT=9490) PGSZ ELSE C C Get a new pgsz C IF (LT+LB-1 .GT. LB+4) THEN C C There are no spaces between 'spgsz' and a value C WRITE (FORM, 9460) LT-5 READ (LINE(LB+5:LB+LT-1), FORM, ERR=870) PGSZ PGSZ = ABS(PGSZ) ELSE C C There are spaces; call CHARIN again to get the next C field C LS = LB+LT CALL CHARIN (LINE(LS:LS), LENG, 2, LB2, LT2) WRITE (FORM, 9460) LENG-LS-LB2+2 READ (LINE(LS+LB2-1:LENG), FORM, + ERR=870) PGSZ PGSZ = ABS(PGSZ) ENDIF WRITE (UNIT=LU6, FMT=9500) PGSZ ENDIF WRITE (UNIT=LU6, FMT=9470) GO TO 810 C C 'PD' Page forwards (downward) C ELSEIF (LINE(LB:LB+1) .EQ. 'PD') THEN IF ((LT .EQ. 2) .AND. (LB+1 .EQ. LENG)) THEN C C There is no value given; assume one (1). C NPD = 1 ELSE IF (LT+LB-1 .GT. LB+1) THEN C C There are no spaces between 'pd' and a value C WRITE (FORM, 9460) LT-2 READ (LINE(LB+2:LB+LT-1), FORM, ERR=870) NPD ELSE C C There are spaces; call CHARIN again to get the next C field C LS = LB+LT CALL CHARIN (LINE(LS:LS), LENG, 2, LB2, LT2) WRITE (FORM, 9460) LENG-LS-LB2+2 READ (LINE(LS+LB2-1:LENG), FORM, + ERR=870) NPD ENDIF ENDIF LOW = MAX(HIGH+(NPD-1)*PGSZ+1, 1) NLINES = IE(I) - IS(I) + 1 HIGH = MIN(LOW + PGSZ-1, NLINES) IF (LOW .GT. HIGH .OR. HIGH-LOW+1 .LT. PGSZ) THEN LOW = MAX(HIGH-PGSZ+1,1) ENDIF DO 820 IREC = IS(I)+LOW-1, + MIN(IS(I)+HIGH-1,IE(I)) READ (UNIT=LU17, FMT=9000, REC=IREC) LINE WRITE (UNIT=LU6, FMT=9480) IREC-IS(I)+1, LINE 820 CONTINUE WRITE (UNIT=LU6, FMT=9470) GO TO 810 C C 'PU' Page backwards (upward) C ELSEIF (LINE(LB:LB+1) .EQ. 'PU') THEN IF ((LT .EQ. 2) .AND. (LB+1 .EQ. LENG)) THEN C C There is no value given; assume one (1). C NPD = 1 ELSE IF (LT+LB-1 .GT. LB+1) THEN C C There are no spaces between 'pu' and a value C WRITE (FORM, 9460) LT-2 READ (LINE(LB+2:LB+LT-1), FORM, ERR=870) NPD ELSE C C There are spaces; call CHARIN again to get the next C field C LS = LB+LT CALL CHARIN (LINE(LS:LS), LENG, 2, LB2, LT2) WRITE (FORM, 9460) LENG-LS-LB2+2 READ (LINE(LS+LB2-1:LENG), FORM, + ERR=870) NPD ENDIF ENDIF NPD = -NPD LOW = MAX(LOW + NPD*PGSZ, 1) NLINES = IE(I) - IS(I) + 1 HIGH = MIN(LOW + PGSZ-1, NLINES) IF (LOW .GT. HIGH .OR. HIGH-LOW+1 .LT. PGSZ) THEN LOW = MAX(HIGH-PGSZ+1,1) ENDIF DO 830 IREC = IS(I)+LOW-1, + MIN(IS(I)+HIGH-1,IE(I)) READ (UNIT=LU17, FMT=9000, REC=IREC) LINE WRITE (UNIT=LU6, FMT=9480) IREC-IS(I)+1, LINE 830 CONTINUE WRITE (UNIT=LU6, FMT=9470) GO TO 810 C C 'HD' Page half a page forward C ELSEIF (LINE(LB:LB+1) .EQ. 'HD') THEN LOW = MAX(LOW + PGSZ/2, 1) NLINES = IE(I) - IS(I) + 1 HIGH = MIN(LOW + PGSZ-1,NLINES) IF (LOW .GT. HIGH .OR. HIGH-LOW+1 .LT. PGSZ) THEN LOW = MAX(HIGH-PGSZ+1,1) ENDIF DO 840 IREC = IS(I)+LOW-1, + MIN(IS(I)+HIGH-1,IE(I)) READ (UNIT=LU17, FMT=9000, REC=IREC) LINE WRITE (UNIT=LU6, FMT=9480) IREC-IS(I)+1, LINE 840 CONTINUE WRITE (UNIT=LU6, FMT=9470) GO TO 810 C C 'HU' Page half a page backward C ELSEIF (LINE(LB:LB+1) .EQ. 'HU') THEN LOW = MAX (LOW - PGSZ/2, 1) NLINES = IE(I) - IS(I) + 1 HIGH = MIN(LOW + PGSZ-1,NLINES) IF (LOW .GT. HIGH .OR. HIGH-LOW+1 .LT. PGSZ) THEN LOW = MAX(HIGH-PGSZ+1,1) ENDIF DO 850 IREC = IS(I)+LOW-1, + MIN(IS(I)+HIGH-1,IE(I)) READ (UNIT=LU17, FMT=9000, REC=IREC) LINE WRITE (UNIT=LU6, FMT=9480) IREC-IS(I)+1, LINE 850 CONTINUE WRITE (UNIT=LU6, FMT=9470) GO TO 810 C C 'P' Print the current page C ELSEIF (LINE(LB:LB) .EQ. 'P' .AND. LT .EQ. 1) THEN NLINES = IE(I) - IS(I) + 1 HIGH = MIN(LOW+PGSZ-1,NLINES) IF (LOW .GT. HIGH .OR. HIGH-LOW+1 .LT. PGSZ) THEN LOW = MAX(HIGH-PGSZ+1,1) ENDIF DO 860 IREC = IS(I)+LOW-1, + MIN(IS(I)+HIGH-1,IE(I)) READ (UNIT=LU17, FMT=9000, REC=IREC) LINE WRITE (UNIT=LU6, FMT=9480) IREC-IS(I)+1, LINE 860 CONTINUE WRITE (UNIT=LU6, FMT=9470) GO TO 810 C C 'E' End the browsing mode C ELSEIF (LINE(LB:LB) .EQ. 'E' ) THEN WRITE (UNIT=LU6, FMT=9040) REWIND (UNIT=LU5, ERR=110) GO TO 110 C C 'Q' Quit the browsing mode C ELSEIF (LINE(LB:LB) .EQ. 'Q' ) THEN WRITE (UNIT=LU6, FMT=9040) REWIND (UNIT=LU5, ERR=110) GO TO 110 ELSEIF (LINE(LB:LB) .EQ. '?' ) THEN GO TO 800 ELSE WRITE (UNIT=LU6, FMT=9050) GO TO 800 ENDIF 870 WRITE (UNIT=LU6, FMT=9050) GO TO 800 ELSEIF (LINE(LB:LB).EQ.'t' .OR. LINE(LB:LB).EQ.'T') THEN C C Write it to the standard output file. C DO 880 IREC = IS(I), IE(I) READ (UNIT=LU17, FMT=9000, REC=IREC) LINE WRITE (UNIT=LU6, FMT=9010) LINE 880 CONTINUE ELSEIF (LINE(LB:LB).EQ.'f' .OR. LINE(LB:LB).EQ.'F') THEN LS = LB+LT CALL CHARIN (LINE(LS:LS), LENG, 2, LB, LT) IF (LT .EQ. 0) THEN FN = FLIS C C Write it to file FLIS. C ELSE FN = LINE(LS-1+LB:LS-1+LB+LT-1) C C Write it to the file he/she specified. C ENDIF IF (FN .NE. FNAMSV) THEN C C If this filename is not the one previously used for some C documentation, then close the file (if it is still open) C and open UNIT 3 for the new file. C IF (LLU13) CLOSE (LU13) OPEN (UNIT=LU13, FILE=FN, STATUS='UNKNOWN', + FORM='FORMATTED') FNAMSV = FN LLU13 = .TRUE. ENDIF C C Write the documentation to the file specified by the user. C DO 890 IREC = IS(I), IE(I) READ (UNIT=LU17, FMT=9000, REC=IREC) LINE WRITE (UNIT=LU13, FMT=9010) LINE 890 CONTINUE ELSE WRITE (UNIT=LU6, FMT=9040) REWIND (UNIT=LU5, ERR=110) GO TO 110 ENDIF ENDIF ELSE IF (LB.GT.0 .AND. (LINE(LB:LB).EQ.'Q'.OR.LINE(LB:LB).EQ.'E')) + THEN C C The command typed in is assumed to be "quit" or "end". C INPUT1 = 'Q' ELSEIF (LB.GT.0 .AND. + (LINE(LB:LB).EQ.'H'.OR.LINE(LB:LB).EQ.'?')) THEN C C The command typed in is assumed to be "help" or "?". C Go back and print the original input instructions. C INPUT1 = 'H' ELSE C C Print "invalid command" and assume the command was "help". C WRITE (UNIT=LU6, FMT=9050) INPUT1 = 'H' ENDIF ENDIF IF (INPUT1 .EQ. 'H') THEN C C Go back to the beginning and print the original instructions. C GO TO 90 ELSE IF (INPUT1 .NE. 'Q') THEN C C Print "Ready for your command" and then go process the new C request. C WRITE (UNIT=LU6, FMT=9040) REWIND (UNIT=LU5, ERR=900) 900 READ (UNIT=LU5, FMT=9000, END=910) LINE CALL UPCASE (LINE, LINE) GO TO 920 910 LINE = ' ' 920 LENG = LENSTR(LINE) CALL CHARIN (LINE, LENG, 2, LB, LT) GO TO 140 ELSE C C Close any files still open and terminate. C IF (LLU13) CLOSE (UNIT=LU13) C CLOSE (UNIT=LU5) C CLOSE (UNIT=LU6) CLOSE (UNIT=LU17) GO TO 930 ENDIF ENDIF 930 STOP 940 CONTINUE C OPEN (UNIT=I1MACH(4), FILE=FERR, FORM='FORMATTED', C + STATUS='UNKNOWN') CALL XERMSG (' ', 'SLADOC', MSG, NERR, 1) STOP C 9000 FORMAT (A) 9010 FORMAT (' ', A) 9020 FORMAT (' The first field of a command line is required, but' / + ' the second field is optional. For example, to view' / + ' the main classification categories, just type ''l''.' / + ' Other commands are:' // + ' x,abc to extract the documentation by name, where' / + ' ''abc'' is a routine name' / + ' k,... to find routine names by keyword(s), where' / + ' ''...'' is a keyword or keyphrase' / + ' c,xyz to find routine names by classification ', + 'category,' / + ' where ''xyz'' is a classification category' / + ' l,c to list subcategories of a main category, where' + / + ' ''c'' is a main classification category' / + ' v,xyz to view the list of keywords or the ', + 'classification'/ + ' scheme, where ''abc'' is K for the keywords' + ' or C'/ + ' for the classification scheme'/ + ' q to quit') 9030 FORMAT (/ ' Ready for your command') 9040 FORMAT (/ ' Ready for your command {x, k, c, l, v, or q}') 9050 FORMAT (' Invalid command') 9100 FORMAT (/ ' The major categories are:') 9110 FORMAT (/ ' Input a MAJOR category you wish to explore') 9120 FORMAT (/ ' Type in the SUBCATEGORY you wish to explore, or ') 9130 FORMAT (/ ' There are no subcategories of: ',A) 9140 FORMAT (1X) 9200 FORMAT (/ ' Input classification category for routine names') 9210 FORMAT (/ ' The routine names classified under the category are') 9220 FORMAT (' category not found') 9230 FORMAT (/ 1X, A8, ' category does not exist in this library.' /) 9300 FORMAT (/ ' Input keyword(s) for routine names') 9310 FORMAT (1X, 2A, 4I8) 9320 FORMAT (/ ' This keyword was found in the keyword phrase:' / + 5X, A) 9330 FORMAT (/ ' The routine names associated with the keyword(s) are') 9340 FORMAT (/ ' Keyword not found') 9400 FORMAT (' Input a routine name for its purpose') 9410 FORMAT (' ', A, ' ... ', I6, ' lines of documentation') 9420 FORMAT (/ ' If you wish to see the full documentation,' / + ' type ''b'' to browse through the ', + 'documentation' / + ' type ''t'' to have it written on your ', + 'terminal' / + ' type ''f,filename'' to have it written on file ', + '''filename''' / + ' type ''f '' to have it written on file ', + '''', A, '''') 9430 FORMAT (' If you do not wish to see the full documentation,' / + ' type anything else') 9440 FORMAT (' Routine name not found') 9450 FORMAT (' The browsing commands are:' / + ' type ''p'' to display the current ', + 'page', / + ' type ''pd'' to display the next page', / + ' type ''pd {+-}[n]'' to display the {+-}[n]-th ', + 'page down', / + ' type ''pu'' to display the preceeding ', + 'page', / + ' type ''pu {+-}[n]'' to display the {+-}[n]-th ', + 'page up', / + ' type ''spgsz'' to show the current page ', + 'size', / + ' type ''spgsz [n]'' to set page size to [n] ', + 'lines', / + ' type ''hd'' to display one-half page ', + 'down (forward)', / + ' type ''hu'' to display one-half page ', + 'up (backward)', / + ' type ''e'' to exit browsing mode', / + ' type ''q'' to quit browsing mode') 9460 FORMAT ('(I',I2,')') 9470 FORMAT (/ ' Enter your next browsing command', + ' {spgsz p pd pu hd hu e q}') 9480 FORMAT (' ', I4, 2X, 72A) 9490 FORMAT (/, ' The current value of PGSZ is: ', I5) 9500 FORMAT (/, ' The new value of PGSZ is: ', I5) 9600 FORMAT (/ ' Input C for classification scheme or K for keywords') 9610 FORMAT (' ', A, ' list ', I6, ' lines ') 9620 FORMAT (/ ' If you wish to view these,' / + ' type ''b'' to browse through the ', + 'list' / + ' type ''t'' to have it written on your ', + 'terminal' / + ' type ''f,filename'' to have it written on file ', + '''filename''' / + ' type ''f '' to have it written on file ', + '''', A, '''') 9630 FORMAT (' If you do not wish to view these,' / + ' type anything else') 9640 FORMAT (' ', I4, 2X, A) 9700 FORMAT (I5, 2X, I5) 9710 FORMAT (I15) 9720 FORMAT (2I2) 9730 FORMAT (3I5, 3X, A) 9740 FORMAT ('(1X, A', I2, ', A)') 9750 FORMAT ('(A', I2, ')') 9760 FORMAT ((1X, 6(A, 2X))) 9780 FORMAT (1X, I4, 2X, A, 1X, A) 9790 FORMAT ('(1X, I4, ', I2, 'X, A)') 9810 FORMAT (1X, A, 1X, A) 9820 FORMAT ('(1X, ', I2, 'X, A)') END *DECK CHARIN SUBROUTINE CHARIN (CARDIN, LCARD, IOPT, LB, LT) C***BEGIN PROLOGUE CHARIN C***SUBSIDIARY C***PURPOSE Subsidiary to SLADOC C***LIBRARY (NONE) C***AUTHOR Chow, Jeff, C-10, Los Alamos National Laboratory C***DESCRIPTION C C Locate a phrase terminated by a comma or a blank. C C***SEE ALSO SLADOC C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 870827 DATE WRITTEN C 891208 Changed to check only for a blank or comma. C 891208 Prologue converted to Version 4.0 format. (BAB) C 920911 Declarations section restructured. (WRB) C***END PROLOGUE CHARIN C .. Parameters .. INTEGER LAST PARAMETER (LAST = 2) C .. Scalar Arguments .. INTEGER IOPT, LB, LCARD, LT CHARACTER*(*) CARDIN C .. Local Scalars .. INTEGER I, L, L1, L2, L3, L9, LBP1, LE, MATCH CHARACTER*2 SPECIA C .. Data statements .. DATA SPECIA /' ,'/ C***FIRST EXECUTABLE STATEMENT CHARIN IF (IOPT .NE. 2) THEN L1 = LCARD L2 = 1 L3 = -1 L9 = 1 ELSE L1 = 1 L2 = LCARD L3 = 1 L9 = LAST ENDIF LB = 0 DO 30 I = L1,L2,L3 MATCH = 0 DO 10 L = 1,L9 IF (CARDIN(I:I) .EQ. SPECIA(L:L)) THEN MATCH = L GO TO 20 ENDIF 10 CONTINUE 20 IF (MATCH .EQ. 0) THEN LB = I GO TO 40 ENDIF 30 CONTINUE 40 IF (IOPT .EQ. 2) THEN IF (LB .GT. 0) THEN IF (LB .EQ. LCARD) THEN LT = 1 RETURN ELSE LE = LCARD LBP1 = LB+1 DO 70 I = LBP1,LCARD MATCH = 0 DO 50 L = 1,L9 IF (CARDIN(I:I) .EQ. SPECIA(L:L)) THEN MATCH = L GO TO 60 ENDIF 50 CONTINUE 60 IF (MATCH .NE. 0) THEN LE = I-1 GO TO 80 ENDIF 70 CONTINUE 80 LT = LE-LB+1 ENDIF ELSE LT = 0 ENDIF ELSE IF (LB .GT. 0) THEN LT = LB ELSE LT = 1 ENDIF LB = 1 ENDIF RETURN END *DECK MINOR INTEGER FUNCTION MINOR (KAT, KATS, NCC, TCLASS, IPTR, JPTR, KPTR, + NTRY) C***BEGIN PROLOGUE MINOR C***SUBSIDIARY C***PURPOSE Subsidiary to SLADOC C***LIBRARY (NONE) C***AUTHOR Bacon, Barbara A., C-10, Los Alamos National Laboratory C***DESCRIPTION C C Function to locate all the subcategories of a given category in the C SLATEC library. C C***SEE ALSO SLADOC C***ROUTINES CALLED FIND, UNDOCL C***REVISION HISTORY (YYMMDD) C 871201 DATE WRITTEN C 891208 Prologue converted to Version 4.0 format. (BAB) C 920911 Declarations section restructured. (WRB) C***END PROLOGUE MINOR C .. Parameters .. INTEGER IALPHA PARAMETER (IALPHA = 26) C .. Scalar Arguments .. INTEGER NCC,NTRY CHARACTER*(*) KAT, KATS C .. Array Arguments .. INTEGER IPTR(NCC), JPTR(NCC), KPTR(NCC) CHARACTER*(*) TCLASS(NCC) C .. Arrays in Common .. INTEGER I1(IALPHA), I2(IALPHA), I3(IALPHA), LMSG(IALPHA) CHARACTER*7 CLASS(IALPHA) C .. Local Scalars .. INTEGER IFIND C .. External Functions .. INTEGER FIND EXTERNAL FIND C .. External Subroutines .. EXTERNAL UNDOCL C .. Common blocks .. COMMON /CATGRY/ I1, I2, I3, LMSG COMMON /KLASS/ CLASS C***FIRST EXECUTABLE STATEMENT MINOR MINOR = 0 IFIND = FIND(TCLASS,NCC,KAT) IF (IFIND .LE. 0) THEN MINOR = 1 NTRY = 0 RETURN ENDIF C NTRY = 1 CLASS(NTRY) = KATS LMSG(NTRY) = KPTR(IFIND+1)-KPTR(IFIND) I3(NTRY) = KPTR(IFIND) IFIND = JPTR(IFIND) 10 IF (IFIND .GT. 0) THEN NTRY = NTRY+1 I1(NTRY) = IPTR(IFIND) I2(NTRY) = JPTR(IFIND) I3(NTRY) = KPTR(IFIND) CLASS(NTRY) = ' ' CALL UNDOCL (TCLASS(IFIND), CLASS(NTRY)) LMSG(NTRY) = KPTR(IFIND+1)-KPTR(IFIND) IFIND = IPTR(IFIND) GO TO 10 ELSE RETURN ENDIF END *DECK RBLNKS SUBROUTINE RBLNKS (L1, L2) C***BEGIN PROLOGUE RBLNKS C***SUBSIDIARY C***PURPOSE Remove leading blanks from a character string. C***LIBRARY (NONE) C***AUTHOR Bacon, Barbara A., C-10, Los Alamos National Laboratory C***DESCRIPTION C C Subroutine to remove leading blanks from a character string C C***SEE ALSO SLADOC C***ROUTINES CALLED LENSTR C***REVISION HISTORY (YYMMDD) C 871201 DATE WRITTEN C 891208 Prologue converted to Version 4.0 format. (BAB) C 920911 Declarations section restructured. (WRB) C***END PROLOGUE RBLNKS C .. Scalar Arguments .. CHARACTER*80 L1, L2 C .. Local Scalars .. INTEGER I, J, K, LENG C .. External Functions .. INTEGER LENSTR EXTERNAL LENSTR C***FIRST EXECUTABLE STATEMENT RBLNKS LENG = LENSTR(L1) DO 10 I = 1,LENG IF (L1(I:I) .NE. ' ') GO TO 20 10 CONTINUE C C We found a completely blank line. C L2 = ' ' RETURN 20 CONTINUE L2 = ' ' K = 1 C C Remove leading blanks in the line. C DO 30 J = I,LENG L2(K:K) = L1(J:J) K = K+1 30 CONTINUE RETURN END *DECK UNDOCL SUBROUTINE UNDOCL (KAT, CAT) C***BEGIN PROLOGUE UNDOCL C***SUBSIDIARY C***PURPOSE Subsidiary to SLADOC C***LIBRARY (NONE) C***AUTHOR Bacon, Barbara A., C-10, Los Alamos National Laboratory C***DESCRIPTION C C Subroutine to collapse a GAMS category name by removing the C zero before a numerical part. C E.G., D02D01A becomes D2D1A C C***SEE ALSO SLADOC C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 871201 DATE WRITTEN C 891208 Prologue converted to Version 4.0 format. (BAB) C 920911 Declarations section restructured. (WRB) C***END PROLOGUE UNDOCL C .. Scalar Arguments .. CHARACTER*(*) CAT, KAT C .. Local Scalars .. INTEGER IC, IK, LENG, WENY C .. External Functions .. INTEGER LENSTR EXTERNAL LENSTR C***FIRST EXECUTABLE STATEMENT UNDOCL LENG = LENSTR(KAT) WENY = 1 IK = 1 IC = 1 10 IF (WENY .EQ. 1) THEN CAT(IC:IC) = KAT(IK:IK) IC = IC+1 IK = IK+WENY ELSE IF (KAT(IK:IK) .EQ. '0') THEN CAT(IC:IC) = KAT(IK+1:IK+1) IC = IC+1 IK = IK+WENY ELSE CAT(IC:IC+1) = KAT(IK:IK+1) IC = IC+2 IK = IK+WENY ENDIF ENDIF WENY = 3-WENY IF (IK .LE. LENG) GO TO 10 RETURN END