*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 <cr> or l<cr>
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 <cr>
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 <cr>')
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