*DECK SLPREP PROGRAM SLPREP C***BEGIN PROLOGUE SLPREP C***PURPOSE Prepare one direct access file and three sequential files C for the SLATEC documentation program. C***LIBRARY (NONE) C***CATEGORY R4 C***KEYWORDS DOCUMENTATION, SLADOC, 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 reads a sequential documentation file where each module C in the file consists of the complete subprogram statement and a C SLATEC-style prologue. The program uses the information obtained to C generate four files. These are C C 1) a direct access file of the subprogram statement and prologue C for each routine in the library. C 2) a sequential file 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 These four files constitute the database for the SLADOC C documentation program. C C There are a number of system and library dependent parameters C which the user of this program may have to change before compiling C and running the code. All parameters are defined in the records C which immediately follow this prologue. In the discussion here, we C refer to the default values which are distributed with this code; C in order to assist others using this code, we give values for C several different machine/operating system configurations. C C MXLFN - the maximum length of a file name to be used. The value C used is highly user and system dependent. Set the value C to the length of longest of the 8 file names FOUT, FERR, C FINP, FDAF, FKWD, FTBL, FCLASS, and FCAT described C below. C FINP - the name of the input file which contains the prologues. C Each prologue must be preceeded by a *DECK name record, C where name is the name of the subprogram, and a C subprogram procedure declaration statement, i.e. the C SUBROUTINE or FUNCTION statement. C FCLASS - the name of the input file which contains the GAMS C (SLATEC) classification file. C FCAT - the name of the output sequential file which will C contain a linked list of all classifications used C by the SLATEC routines and their associated messages. C FDAF - the name of the output direct access file which will C contain the documentation. C FKWD - the name of the output sequential file which will C contain: C 1) the number of keyword phrases in section 2. C 2) the alphabetised KEYWORD phrases C 3) a table of two pointer arrays: C IL = {0 or next cell pointing to this keyword} C IR = {location of the routine containing this C keyword} C The first MXNKWD cells of this section correspond to C the entries in section 2 of this file. Cells after that C are "continuation" cells. C FTBL - the name of the output sequential file which will C contain: C 1) name (first) category number C 2) deck or routine name C 3) line number of the subprogram statement C 4) line number of the "END PROLOGUE" statement C 5) line number of the PURPOSE statement 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 FLOG - the name of the transaction log file. 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 in the library. C MXLCAT - the maximum length of a category number. For the GAMS C classification scheme which is used by the SLATEC C Common Mathematical Library, 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 keyword phrases in a subroutine. C LLN - the maximum number of characters in an input line. C C***REFERENCES Guide to the SLATEC Common Mathematical Library. C***ROUTINES CALLED CVTCAT, FIND, FTRUN, I1MACH, IFDECK, LENSTR, PSCAT, C SETSIZ, SORT, UPCASE, XERMSG C***REVISION HISTORY (YYMMDD) C 870818 DATE WRITTEN C 880324 REVISION DATE from Version 3.2 C 891215 Prologue converted to Version 4.0 format. (BAB) C 920911 Declarations section restructured. (WRB) C***END PROLOGUE SLPREP C C System dependent parameter definitions. C INTEGER MXLFN PARAMETER (MXLFN = 32) CHARACTER * (MXLFN) FINP, FCLASS, FCAT, FDAF, FKWD, FTBL, FOUT, + FLOG, FERR, FINPUT CHARACTER * (MXLFN) DFINP, DFCLAS, DFCAT, DFDAF, DFKWD, DFTBL, + DFLOG PARAMETER (DFINP = 'slainp', + DFCLAS = 'class', + DFCAT = 'slacat', + DFDAF = 'sladaf', + DFKWD = 'slakwd', + DFTBL = 'slatbl', + DFLOG = 'slalog', + FOUT = '/dev/tty', + FINPUT = '/dev/tty', + FERR = '/dev/tty') C C Library dependent parameter definitions. C INTEGER MXLRN, MXNRN, MXLCAT, MXNCAT, MXNKWD, MXNCL PARAMETER (MXLRN = 6, MXNRN = 1600, MXLCAT = 10, MXNCAT = 750, + MXNKWD = 500, MXNCL = 751) INTEGER KMAXI, KMAXJ, LLN PARAMETER (KMAXI = 60, KMAXJ = 40, LLN = 72) C C Other declarations. C INTEGER I, IB, IC, ICHNG, ICOM, ID, IENTRY, IFIND, ILEN, INEXT, + INFO, IPE, IPS, IRD, IWR, J, JJ, MNCL, MXLKW, MXLR, MXNCA, + MXNKW, NCAT, NCC, NCLASS, NERR, NEXTL, NKWD, NSTMTS, + NTCAT, NTKWD, NUMR, NUMRR C INTEGER LU5, LU6, LU12, LU13, LU14, LU15, LU17, LU18, LU19 PARAMETER (LU12 = 12, LU13 = 13, LU14 = 14, LU15 = 15, LU6 = 6, + LU17 = 17, LU18 = 18, LU19 = 19, LU5 = 5) CHARACTER * (LLN) LINE CHARACTER * 80 CLLINE CHARACTER * 80 MSG CHARACTER * (KMAXI) KWRDS(KMAXJ), TKWD(MXNKWD) CHARACTER * (MXLRN) RTNAME CHARACTER * (MXLCAT) TCAT(MXNCAT), ETCAT(MXNCAT), CATEG(15), + TCLASS(MXNCAT) INTEGER IPTR(MXNCAT), JPTR(MXNCAT), KPTR(MXNCAT) CHARACTER * 80 CLASS(MXNCL+1), STMTS(MXNCL) INTEGER IPTRL(7*MXNRN), IPTRR(7*MXNRN) C C External functions. C INTEGER FIND, LENSTR LOGICAL IFDECK, IFIF, IFSID CHARACTER*10 CVTCAT EXTERNAL CVTCAT, FIND, IFDECK, IFIF, IFSID, LENSTR C C Intrinsic functions. C INTRINSIC ABS, INDEX, MAX, MOD C***FIRST EXECUTABLE STATEMENT SLPREP C OPEN (UNIT=LU6, FILE=FOUT, STATUS='UNKNOWN', FORM='FORMATTED', C + IOSTAT = INFO) C IF (INFO .NE. 0) THEN C MSG = 'Failure in attempting to open ' // FOUT C NERR = 1 C GO TO 240 C ENDIF C C OPEN (UNIT=LU5, FILE=FINPUT, STATUS='UNKNOWN', FORM='FORMATTED', C + IOSTAT = INFO) C IF (INFO .NE. 0) THEN C MSG = 'Failure in attempting to open ' // FINPUT C NERR = 1 C GO TO 240 C ENDIF C FINP = ' ' WRITE (UNIT=LU6, FMT=9110) DFINP READ (UNIT=LU5, FMT=9000, END=12) FINP 12 IF (LENSTR(FINP) .EQ. 0) FINP = DFINP OPEN (UNIT=LU15, FILE=FINP, STATUS='OLD', FORM='FORMATTED', + IOSTAT=INFO) IF (INFO .NE. 0) THEN MSG = 'Failure in attempting to open ' // FINP NERR = 1 GO TO 240 ENDIF C FCLASS = ' ' WRITE (UNIT=LU6, FMT=9090) DFCLAS READ (UNIT=LU5, FMT=9000, END=8) FCLASS 8 IF (LENSTR(FCLASS) .EQ. 0) FCLASS = DFCLAS OPEN (UNIT=LU13, FILE=FCLASS, STATUS='OLD', FORM='FORMATTED', + IOSTAT=INFO) IF (INFO .NE. 0) THEN MSG = 'Failure in attempting to open ' // FCLASS NERR = 1 GO TO 240 ENDIF C FCAT = ' ' WRITE (UNIT=LU6, FMT=9100) DFCAT READ (UNIT=LU5, FMT=9000, END=10) FCAT 10 IF (LENSTR(FCAT) .EQ. 0) FCAT = DFCAT OPEN (UNIT=LU14, FILE=FCAT, STATUS='NEW', FORM='FORMATTED', + IOSTAT=INFO) IF (INFO .NE. 0) THEN MSG = 'Failure in attempting to open ' // FCAT NERR = 1 GO TO 240 ENDIF C FDAF = ' ' WRITE (UNIT=LU6, FMT=9120) DFDAF READ (UNIT=LU5, FMT=9000, END=14) FDAF 14 IF (LENSTR(FDAF) .EQ. 0) FDAF = DFDAF OPEN (UNIT=LU17, FILE=FDAF, STATUS='NEW', ACCESS='DIRECT', + FORM='FORMATTED', RECL=LLN, IOSTAT=INFO) IF (INFO .NE. 0) THEN MSG = 'Failure in attempting to open ' // FDAF NERR = 1 GO TO 240 ENDIF C FTBL = ' ' WRITE (UNIT=LU6,FMT=9130) DFTBL READ (UNIT=LU5,FMT=9000,END=16) FTBL 16 IF (LENSTR(FTBL) .EQ. 0) FTBL = DFTBL OPEN (UNIT=LU18, FILE=FTBL, STATUS='NEW', FORM='FORMATTED', + IOSTAT=INFO) IF (INFO .NE. 0) THEN MSG = 'Failure in attempting to open ' // FTBL NERR = 1 GO TO 240 ENDIF C FKWD = ' ' WRITE (UNIT=LU6,FMT=9140) DFKWD READ (UNIT=LU5,FMT=9000,END=18) FKWD 18 IF (LENSTR(FKWD) .EQ. 0) FKWD = DFKWD OPEN (UNIT=LU19, FILE=FKWD, STATUS='NEW', FORM='FORMATTED', + IOSTAT=INFO) IF (INFO .NE. 0) THEN MSG = 'Failure in attempting to open ' // FKWD NERR = 1 GO TO 240 ELSE NTKWD = 0 ENDIF C FLOG = ' ' WRITE (UNIT=LU6, FMT=9080) DFLOG READ (UNIT=LU5, FMT=9000, END=6) FLOG 6 IF (LENSTR(FLOG) .EQ. 0) FLOG = DFLOG OPEN (UNIT=LU12, FILE=FLOG, STATUS='NEW', FORM='FORMATTED', + IOSTAT=INFO) IF (INFO .NE. 0) THEN MSG = 'Failure in attempting to open ' // FLOG NERR = 1 GO TO 240 ENDIF C WRITE (UNIT=LU6, FMT=9070) FLOG C C Write the names of all files to the transaction log file. C WRITE (UNIT=LU12, FMT=9060) FINP, FOUT, FCLASS, FCAT, FDAF, FTBL, + FKWD C C IRD is the "READ" line number and IWR is the "WRITE" line number. C IRD = 0 IWR = 0 C C NUMR is the number of routines in the library and MXLR is the C maximum length of all these routines. C NUMR = 0 NUMRR = 0 MXLR = 0 MXNCA = 0 NTCAT = 0 INEXT = MXNKWD+1 MXNKW = 0 MXLKW = 0 C 20 READ (UNIT=LU15, FMT=9000, END=260) LINE IRD = IRD+1 IF (IFDECK(LINE) .OR. IFIF(LINE)) GO TO 20 IWR = IWR+1 WRITE (UNIT=LU17, FMT=9000, REC=IWR) LINE C IF (LINE(1:6) .EQ. ' ' .OR. IFSID(LINE)) THEN C C Subprogram statement. Save starting record number. C IB = IWR NCAT = 1 CATEG(1) = ' ' NKWD = 0 ENDIF C IF (LINE(2:6) .EQ. '***BE') THEN C C BEGIN PROLOGUE record. Extract routine name. C RTNAME = LINE(21:20+MXLRN) C C Check case of routine name; if not UPPER, terminate. C CALL UPCASE (RTNAME, RTNAME) IF (RTNAME .NE. LINE(21:20+MXLRN)) THEN MSG = 'Routine name not in UPPER case' NERR = 2 GO TO 240 ENDIF NUMR = NUMR+1 IF (NUMR .GT. MXNRN) THEN MSG = 'Too many routine names. Recompile code with ' // + 'larger MXNRN.' NERR = 2 GO TO 240 ENDIF C C Write every 10th routine name to standard output. C IF (MOD(NUMR,10) .EQ. 0) WRITE (UNIT=LU6, FMT=9020) RTNAME, NUMR ENDIF C C Effective with version 4.0, every routine MUST have a PURPOSE. C IF (LINE(2:6) .EQ. '***PU') THEN C C Record starting line number of Purpose section. C IPS = IWR 30 READ (UNIT=LU15, FMT=9000, END=260) LINE IRD = IRD + 1 IWR = IWR + 1 WRITE (UNIT=LU17, FMT=9000, REC=IWR) LINE IF (LINE(2:4) .NE. '***') GO TO 30 C C Record ending line number of Purpose section. C IPE = IWR - 1 ENDIF C IF (LINE(2:6) .EQ. '***CA') THEN C C "CATEGORY" record. C NCAT = 0 C C Initialize the pointer to point to the first category. C 40 IC = 15 ILEN = LENSTR(LINE) IF (IC .GT. ILEN) THEN MSG = 'No category on CATEGORY record' NERR = 3 GO TO 240 ENDIF C C Get the offset location of the next delimiter. C 60 ICOM = INDEX(LINE(IC:ILEN),',') IF (ICOM .EQ. 0) THEN ID = ILEN+1 ELSE ID = IC+ICOM-1 ENDIF NCAT = NCAT+1 IF (NCAT .GT. 15) THEN MSG = 'Too many categories in a routine. Recompile code ' // + 'with larger MXNCAT.' NERR = 3 GO TO 240 ENDIF C C Put category into table in UPPER case. C CATEG(NCAT) = ' ' CALL UPCASE (LINE(IC:ID-1), CATEG(NCAT)(1:ID-IC)) IF (LINE(IC:ID-1) .NE. CATEG(NCAT)(1:ID-IC)) THEN MSG = 'Category not in UPPER case' NERR = 3 GO TO 240 ENDIF C C Check to see if this category is already in the table of C categories. C IFIND = FIND (TCAT, NTCAT, CATEG(NCAT)) IF (IFIND .LE. 0) THEN C C Check to see if there is room in the table. C NTCAT = NTCAT+1 IF (NTCAT .GT. MXNCAT) THEN MSG = 'Too many categories in the library. Recompile ' // + 'code with larger MXNCAT.' NERR = 3 GO TO 240 ENDIF C C Put category in table and check case. If not UPPER case, C terminate. C DO 70 I = NTCAT-1,ABS(IFIND)+1,-1 TCAT(I+1) = TCAT(I) 70 CONTINUE TCAT(ABS(IFIND)+1) = CATEG(NCAT) ENDIF C C Is this the last category for this subprogram? C IF (ICOM .EQ. 0) GO TO 80 C C Is this the last category on the current line? C IF (ID .GE. ILEN) THEN C C We are at the end of the line and need to read again. C READ (UNIT=LU15, FMT=9000, END=260) LINE IRD = IRD+1 IF (LINE(1:5).NE.'C ' .AND. LINE(1:5).NE.'* ') THEN MSG = 'CATEGORY section not in correct form' NERR = 3 GO TO 240 ENDIF IWR = IWR+1 WRITE (UNIT=LU17, FMT=9000, REC=IWR) LINE GO TO 40 ENDIF C C Check to see that there is a blank character following the C delimiter after the category just processed. C IF (LINE(ID+1:ID+1) .NE. ' ') THEN MSG = 'CATEGORY section not in correct form' NERR = 3 GO TO 240 ENDIF C C Set the pointer IC to the next category. C IC = ID+2 GO TO 60 80 MXNCA = MAX(MXNCA,NCAT) ENDIF C IF (LINE(2:6) .EQ. '***KE') THEN C C "KEYWORD" section. C C C Initialize the pointer to point to the first keyword phrase. C 100 IC = 15 ILEN = LENSTR(LINE) IF (IC .GT. ILEN) THEN MSG = 'No keyword phrase on KEYWORD record' NERR = 4 GO TO 240 ENDIF C C Get the offset location of the next delimiter. C 120 ICOM = INDEX(LINE(IC:ILEN),',') IF (ICOM .EQ. 0) THEN ID = ILEN+1 ELSE ID = IC+ICOM-1 ENDIF NKWD = NKWD+1 IF (NKWD .GT. KMAXJ) THEN MSG = 'Too many keyword phrases in a routine. Recompile ' // + 'code with larger KMAXJ.' NERR = 4 GO TO 240 ENDIF KWRDS(NKWD) = ' ' IF (ID-IC .GT. KMAXI) THEN MSG = 'Keyword phrase is too long' NERR = 4 GO TO 240 ENDIF C C Put keyword phrase in table and check case. If not UPPER case, C terminate. C CALL UPCASE (LINE(IC:ID-1), KWRDS(NKWD)(1:ID-IC)) IF (LINE(IC:ID-1) .NE. KWRDS(NKWD)(1:ID-IC)) THEN MSG = 'Keyword phrase not in UPPER case' NERR = 4 GO TO 240 ENDIF MXLKW = MAX(MXLKW,ID-IC) C C Is this the last keyword for this subprogram? C IF (ICOM .EQ. 0) GO TO 140 IF (ID .GE. ILEN) THEN C C We are at the end of the line and need to read again. C READ (UNIT=LU15, FMT=9000, END=260) LINE IRD = IRD+1 IF (LINE(1:5).NE.'C ' .AND. LINE(1:5).NE.'* ') THEN MSG = 'KEYWORD section not in correct form' NERR = 4 GO TO 240 ENDIF IWR = IWR+1 WRITE (UNIT=LU17, FMT=9000, REC=IWR) LINE GO TO 100 ENDIF C C Check to see that there is a blank character following the C delimiter after the category just processed. C IF (LINE(ID+1:ID+1) .NE. ' ') THEN MSG = 'KEYWORD section not in correct form' NERR = 4 GO TO 240 ENDIF IC = ID+2 GO TO 120 140 MXNKW = MAX(MXNKW,NKWD) ENDIF C IF (LINE(2:6) .EQ. '***EN') THEN C C "END PROLOGUE" statement. C IF (LINE(19:18+MXLRN) .EQ. RTNAME(1:MXLRN)) THEN MXLR = MAX(MXLR,IWR-IB+1) C C Write the categories for this routine, the routine name, etc. C to the file FTBL. C WRITE (UNIT=LU18, FMT=9010) (CATEG(J), RTNAME, IB, IWR, IPS, + IPE, J=1,NCAT) NUMRR = NUMRR+NCAT C IF (NKWD .GT. 0) THEN MXNKW = MAX(MXNKW,NKWD) DO 200 J = NKWD,1,-1 IFIND = FIND(TKWD(1), NTKWD, KWRDS(J)) IF (IFIND .LE. 0) THEN NTKWD = NTKWD+1 IF (NTKWD .GT. MXNKWD) THEN MSG = 'Too many keyword phrases. Recompile code ' // + 'with larger MXNKWD.' NERR=2 GO TO 240 ENDIF DO 170 I = NTKWD-1,ABS(IFIND)+1,-1 TKWD(I+1) = TKWD(I) IPTRR(I+1) = IPTRR(I) IPTRL(I+1) = IPTRL(I) 170 CONTINUE TKWD(ABS(IFIND)+1) = KWRDS(J) IPTRR(ABS(IFIND)+1) = NUMRR IPTRL(ABS(IFIND)+1) = 0 ELSE IENTRY = IPTRL(IFIND) IF (IENTRY .EQ. 0) THEN C C No entries in the chain. C IPTRL(IFIND) = INEXT ELSE 180 NEXTL = IPTRL(IENTRY) IF (NEXTL .NE. 0) THEN C C Not at end of chain. C IENTRY = NEXTL GO TO 180 ENDIF IPTRL(IENTRY) = INEXT ENDIF IPTRL(INEXT) = 0 IPTRR(INEXT) = NUMRR INEXT = INEXT+1 ENDIF 200 CONTINUE ENDIF ELSE MSG = 'BEGIN name and END name differ' NERR = 5 GO TO 240 ENDIF C C Read to the next *DECK record. C 220 READ (UNIT=LU15, FMT=9000, END=260) LINE IRD = IRD+1 IF (.NOT.IFDECK(LINE)) GO TO 220 ENDIF C C GOTO read. C GO TO 20 C C Abnormal termination. C 240 CONTINUE CALL XERMSG (' ', 'SLPREP', MSG, NERR, 1) WRITE (UNIT=LU6, FMT=9050) RTNAME, IRD, LINE C C Write the job abort message to the transaction log file also. C WRITE (UNIT=LU12, FMT=9050) RTNAME, IRD, LINE CLOSE (UNIT=LU14, STATUS='DELETE') CLOSE (UNIT=LU17, STATUS='DELETE') CLOSE (UNIT=LU18, STATUS='DELETE') CLOSE (UNIT=LU19, STATUS='DELETE') GO TO 420 C 260 DO 280 J = 1,NTCAT ETCAT(J) = CVTCAT(TCAT(J)) 280 CONTINUE CALL SORT (ETCAT, NTCAT, 1, TCAT) C C Read in the GAMS classification file. C I = 0 300 READ (UNIT=LU13, FMT=9000, END = 320) CLLINE IF (I .GE. MXNCL) THEN MSG = 'Too many lines in file ' // FCLASS NERR = 6 GO TO 240 ENDIF I = I+1 CLASS(I) = CLLINE GO TO 300 320 NCLASS = I CLASS(I+1) = '@' MNCL = MXNCL CALL PSCAT (ETCAT, NTCAT, CLASS, MNCL, NCC, TCLASS, IPTR, JPTR, + KPTR, NSTMTS, STMTS, NERR) IF (NERR .NE. 0) THEN MSG = 'Could not locate ' // TCLASS(NERR) // ' in GAMS file.' LINE = 'Input file completely read.' NERR = 7 GO TO 240 ENDIF C C The reason NCC+1 is being written is to call attention to C the fact that an extra line is included in the KPTR array C which gives the line beyond the last line of the STMTS array. C WRITE (UNIT=LU14, FMT=9003) NCC+1 WRITE (UNIT=LU14, FMT=9005) (IPTR(I), JPTR(I), KPTR(I), + TCLASS(I)(1:LENSTR(TCLASS(I))),I=1,NCC) WRITE (UNIT=LU14, FMT=9007) KPTR(NCC+1) WRITE (UNIT=LU14, FMT=9000) + (STMTS(I)(1:LENSTR(STMTS(I))),I=1,NSTMTS) C WRITE (UNIT=LU19, FMT=9003) NTKWD DO 340 J = 1,NTKWD ILEN = LENSTR(TKWD(J)) WRITE (UNIT=LU19, FMT=9000) TKWD(J)(1:ILEN) 340 CONTINUE C C We now need to compress the IPTRL and IPTRR tables and remove C any unneeded cells between the original allocated cells (MXNKWD) C and the final number (NTKWD) of pointer cells. C ICHNG=MXNKWD-NTKWD IF (ICHNG .GT. 0) THEN DO 360 J = 1,NTKWD IF (IPTRL(J) .NE. 0) THEN IPTRL(J)=IPTRL(J)-ICHNG ENDIF 360 CONTINUE JJ=NTKWD+1 DO 380 J = MXNKWD+1,INEXT-1 IF (IPTRL(J) .NE. 0) THEN IPTRL(JJ)=IPTRL(J)-ICHNG ELSE C IPTRL(JJ)=IPTRL(J) IPTRL(JJ)=0 ENDIF IPTRR(JJ)=IPTRR(J) JJ=JJ+1 380 CONTINUE ENDIF C C Set last set of pointers to 0. C IPTRL(INEXT-ICHNG) = 0 IPTRR(INEXT-ICHNG) = 0 DO 400 J = 1,INEXT-ICHNG WRITE (UNIT=LU19, FMT=9003) IPTRL(J),IPTRR(J) 400 CONTINUE C C Normal termination. C WRITE (UNIT=LU6, FMT=9030) NUMR, IRD, IWR, NTCAT, NTKWD, MXLR, + MXNCA, MXNKW, MXLKW, NUMRR, NTKWD, + INEXT-ICHNG WRITE (UNIT=LU6, FMT=9040) NCLASS, NCC, NSTMTS C C Write summary information to the transaction log file also. C WRITE (UNIT=LU12, FMT=9030) NUMR, IRD, IWR, NTCAT, NTKWD, MXLR, + MXNCA, MXNKW, MXLKW, NUMRR, NTKWD, + INEXT-ICHNG WRITE (UNIT=LU12, FMT=9040) NCLASS, NCC, NSTMTS CLOSE (UNIT=LU14) C C Call to FTRUN for CTSS/CFTLIB systems only. C CLOSE (UNIT=LU17) CLOSE (UNIT=LU18) CLOSE (UNIT=LU19) C 420 CLOSE (UNIT=LU12) CLOSE (UNIT=LU13) CLOSE (UNIT=LU15) C CLOSE (UNIT=LU5) C CLOSE (UNIT=LU6) STOP C 9000 FORMAT (A) 9003 FORMAT (I5, 2X, I5) 9005 FORMAT (3I5, 3X, A) 9007 FORMAT (I15) 9010 FORMAT (1X, 2A, 4I8) 9020 FORMAT (' Processing routine ', A, ', number ', I4) 9030 FORMAT (// ' S U M M A R Y' // + ' There were ', I4, ' documentation modules and a total ', + 'of ', I6, ' lines read ' / + ' from the sequential input file and a total of ', + I6, ' lines written ' / + ' to the direct access documentation file.' / + ' The library has a total of ', I3, ' distinct ', + 'categories and ', I3, ' distinct keywords.' / + ' At least one module has ', I4, ' lines, one module ', + 'has ', I2, ' categories,' / + ' one module has ', I2, ' keyword phrases and ', + 'the longest keyword phrase is ' / + 1X, I2, ' characters.' / + ' There were ', I4, ' category/routine lines written to ', + 'the category file.' / + ' There were ', I3, ' distinct keyword phrases written ', + 'to the keyword file, and ' / + 1X, I4, ' keyword pointers written to the file.') 9040 FORMAT (' There were ', I3, ' lines read from the GAMS ', + 'classification scheme file.' / + ' There were ', I3, ' classification categories written ', + 'to the classification file' / + ' and a total of ', I3, ' classification descriptors ', + 'written to the file.' //) 9050 FORMAT (// ' J O B A B O R T' // + ' The job aborted in routine ', A, ' after processing ', + 'approximately ', I6, ' lines' / ' of the input file.' / + ' The last line read from the input file was ' / 1X, A //) 9060 FORMAT (// 5X, 'T R A N S A C T I O N L O G' // + 2X, 'Input source file: ', A / + 2X, 'Output source file: ', A / + 2X, 'GAMS classification file: ', A / + 2X, 'Sequential file containing linked list of all ', + 'classifications used: ', A / + 2X, 'Direct access file containing the documentation: ', + A / + 2X, 'Sequential file containing the deck names and ', + 'prologue line numbers: ', A / + 2X, 'Sequential file of keyword phrases and pointer ', + 'arrays: ', A/) 9070 FORMAT (2X, 'Transaction log file: ', A /) 9080 FORMAT (//, ' Enter the name of your transaction log file or', + ' ', /, + ' (The default is ''', A, ''')') 9090 FORMAT (//, ' Enter the name of the GAMS (SLATEC) classification', + ' file or ', /, = ' (The default is ''', A, ''')') 9100 FORMAT (//, ' Enter the name of the output file to contain the', + ' classifications used ', /, ' or ', /, + ' (The default is ''', A, ''')') 9110 FORMAT (//, ' Enter the name of your input source file or ',/, + ' (The default is ''', A, ''')') 9120 FORMAT (//, ' Enter the name of the output direct access file', + ' which will contain the ', /, ' documentation or', + ' ', /, + ' (The default is ''', A, ''')') 9130 FORMAT (//, ' Enter the name of the output file which will', + ' contain the line numbers', /, ' of data in the', + ' documentation file or ', /, + ' (The default is ''', A, ''')') 9140 FORMAT (//, ' Enter the name of the output file which will', + ' contain the keyword phrases ', /, ' and their', + ' pointers or ', /, + ' (The default is ''', A, ''')') END *DECK IFDECK LOGICAL FUNCTION IFDECK (LINE) C***BEGIN PROLOGUE IFDECK C***PURPOSE Determine if a line is an *DECK or *DK statement. C***LIBRARY SLATEC C***CATEGORY R3C C***TYPE LOGICAL (IFDECK-L) C***KEYWORDS DECK C***AUTHOR Boland, W. Robert, C-8, Los Alamos National Laboratory C***DESCRIPTION C C This FUNCTION determines if a record is an *DECK or *DK statement. C If it is, the value .TRUE. is returned; otherwise, the value C .FALSE. is returned. C C INPUT C C LINE - a character variable containing the string to be C examined. C C***REFERENCES (NONE) C***ROUTINES CALLED UPCASE C***REVISION HISTORY (YYMMDD) C 840427 DATE WRITTEN C 840430 REVISION DATE from the pre-1990 prologue. C 891215 Prologue converted to Version 4.0 format. (BAB) C 920911 Declarations section restructured. (WRB) C***END PROLOGUE IFDECK C .. Scalar Arguments .. CHARACTER*(*) LINE C .. Local Scalars .. CHARACTER*6 TEMP C .. External Subroutines .. EXTERNAL UPCASE C***FIRST EXECUTABLE STATEMENT IFDECK CALL UPCASE (LINE(1:6), TEMP(1:6)) IFDECK = .TRUE. IF (TEMP(1:6).NE.'*DECK ' .AND. TEMP(1:4).NE.'*DK ') + IFDECK = .FALSE. RETURN END *DECK IFIF LOGICAL FUNCTION IFIF (LINE) C***BEGIN PROLOGUE IFIF C***PURPOSE Determine if a line is an *IF statement. C***LIBRARY (NONE) C***CATEGORY (NONE) C***KEYWORDS (NONE) C***AUTHOR Boland, W. Robert, C-8, Los Alamos National Laboratory C***DESCRIPTION C C This FUNCTION determines if a record is an *IF statement. C If it is, the value .TRUE. is returned; otherwise, the value C .FALSE. is returned. C C INPUT C C LINE - a character variable containing the string to be C examined. C C***REFERENCES (NONE) C***ROUTINES CALLED UPCASE C***REVISION HISTORY (YYMMDD) C 910208 DATE WRITTEN C 920911 Declarations section restructured. (WRB) C***END PROLOGUE IFIF C .. Scalar Arguments .. CHARACTER*(*) LINE C .. Local Scalars .. CHARACTER*3 TEMP C .. External Subroutines .. EXTERNAL UPCASE C***FIRST EXECUTABLE STATEMENT IFIF CALL UPCASE (LINE(1:3), TEMP(1:3)) IFIF = .TRUE. IF (TEMP(1:3).NE.'*IF') IFIF = .FALSE. RETURN END *DECK IFSID LOGICAL FUNCTION IFSID (LINE) C***BEGIN PROLOGUE IFSID C***PURPOSE Determine if a line is a special *...IDENT statement. C***LIBRARY (NONE) C***CATEGORY (NONE) C***KEYWORDS (NONE) C***AUTHOR Bacon, Barbara, C-10, (LANL) C***DESCRIPTION C C This FUNCTION determines if a record is a *...IDENT statement. C If it is, the value .TRUE. is returned; otherwise, the value C .FALSE. is returned. C C INPUT C C LINE - a character variable containing the string to be C examined. C C***REFERENCES (NONE) C***ROUTINES CALLED UPCASE C***REVISION HISTORY (YYMMDD) C 910211 DATE WRITTEN C 920911 Declarations section restructured. (WRB) C***END PROLOGUE IFSID C .. Scalar Arguments .. CHARACTER*(*) LINE C .. Local Scalars .. INTEGER I, ID CHARACTER*20 TEMP C .. External Subroutines .. EXTERNAL UPCASE C .. Intrinsic Functions .. INTRINSIC INDEX C***FIRST EXECUTABLE STATEMENT IFSID CALL UPCASE (LINE(1:20), TEMP(1:20)) IFSID = .FALSE. IF (LINE(1:1) .EQ. '*') THEN ID = INDEX(LINE,'IDENT') IF (ID .NE. 0) THEN C IF (LINE(2:ID-1) .EQ. ' ') IFSID = .TRUE. DO 10 I=2,ID-1 IF (LINE(I:I) .NE. ' ') GO TO 20 10 CONTINUE C C We have a line with *^^...^^IDENT C IFSID = .TRUE. ENDIF ENDIF 20 RETURN END *DECK PSCAT SUBROUTINE PSCAT (ECAT, NCAT, CLASS, MNCL, NCC, TCLASS, IPTR, + JPTR, KPTR, ISTMT, STMTS, NERR) C***BEGIN PROLOGUE PSCAT C***SUBSIDIARY C***PURPOSE Subsidiary to SLPREP C***LIBRARY (NONE) C***AUTHOR Bacon, Barbara A., C-10, Los Alamos National Laboratory C***DESCRIPTION C C Creates the data for the FCAT file consisting of two parts: C 1) linked lists enabling one to obtain the various categories C and subcategories present in the library being examined C 2) statements from the classification file associated with C the categories. C C INPUT C C ECAT - an array of "extended" categories found in the library C C NCAT - the number of categories in the above arrays C C OUTPUT C C NCC - the number of elements in TCLASS, IPTR, etc. C C TCLASS - the expanded table of categories for this library; C e.g., if A1C were a category in the library, then C TCLASS would contain A, A1, and A1C. C C IPTR - the linked list allowing one to travel down categories C of the same length (i.e., A to C to ... to Z; C or A1 to A3 to ... to An). C C JPTR - the linked list allowing one to get the next larger C element in a category (i.e., A to A1) C C KPTR - the location in the STMTS array of the statement C associated with the element in TCLASS. C C ISTMT - the number of statements in STMTS C C STMTS - the statements from the classification file associated C with TCLASS. C C NERR - the number of the element in TCLASS which could not C be located in the GAMS file. This value is set to C zero upon entry to PSCAT and will indicate an error C to the calling routine if non-zero upon exit. C C The easiest way to describe how this program works is to C use examples. C 1) A02B05 C At the beginning of the DO loop, the following values C will be set: C OPART1=OPART2=OPART3=OPART4=OPART5=OPART6=OPART7=' ' C PART1='A' PART2='02' PART3='B' PART4='05' C PART5=' ' PART6=' ' PART7=' ' C C Since PART1 .NE. OPART1, we will go to 100, clear all C the OPART's. Then since OPART1 is not equal to PART1, C OPART1 will be set to PART1 and the first member of C TCLASS will be set to 'A'. Then we will loop back to C statement 160 to build the rest of A02B05. C Now OPART1 is equal to PART1, so go to the next IF block. C Since OPART2=' ' and PART2='02', we will set OPART2=PART2, C and build the next member of TCLASS to be "A02" by C concatenating OPART1 and OPART2. C Then loop back to statement 160. C This process continues down through PART4, so that we will C build A02B and A02B05 in TCLASS. So on the fifth time C down we will have OPART1='A', OPART2='02', OPART3='B', C OPART4='05', OPART5=OPART6=OPART7=' '. C Then since PART5=' ', we will transfer to the end of the C do 180 loop and return to the loop's beginning to pick up C a new member of ECAT. C 2) A02B05C C At this point, the following values will be set when C we reach the first IF statement: C OPART1='A' OPART2='02' OPART3='B' OPART4='05' C OPART5=' ' OPART6=' ' OPART7=' ' C PART1 ='A' PART2 ='02' PART3 ='B' PART4 ='05' C PART5 ='C' PART6 =' ' PART7 =' ' C So we will transfer to 100 and be sure that OPART5, OPART6, C and OPART7 are ' ' (it is possible for those to be non-blank C if the previous value of ECAT had been longer). C Then we will bypass the first four IF blocks and do number C five. Since PART5 is not blank and OPART5.NE.PART5, we C will set OPART5=PART5 which is 'C' and build the next C member of TCLASS as "A02B05C' by concatenating OPART1, C OPART2, OPART3, OPART4, and OPART5. C Loop back to 160 where we will completely fall through all C the IF blocks to the end of the loop. C 3) A03 C Now PART1='A' PART2='03' and PART3 through PART7 will be ' '. C But OPART1='A', OPART2='02', OPART3='B', OPART4='05', C OPART5='C' and OPART6=OPART7=' '. C This time we will branch to statement 40 since OPART1=PART1, C but OPART2 is not equal to PART2. C OPART2 through OPART7 will be set to ' '. C We will bypass the first IF block and do the second one, C since PART2 is not blank and OPART2.NE.PART2. C OPART2 will be set to PART2 (which is '03') and we will C build the next member of TCLASS by concatenating OPART1 and C OPART2 ('A03'). Then go back to statement 160. All the IF C blocks will fail and we will drop through to the end of the C loop and go back to the beginning of the loop to get a new C value of ECAT. C 4) This process continues until all the members of ECAT have been C processed. The complete table is built in TCLASS and the C number of elements in it is NCC. C C C The next two DO blocks (the DO 280 and the DO 320) build the C IPTR and JPTR arrays, such that the members of IPTR point to C the next member of TCLASS which has the same length of "CLASS" C and the (n-1)th part of the member is the same but the n-th part C is different. For example, the IPTR pointer associated with 'A' C would point to where 'C' is in TCLASS; then the IPTR pointer C associated with 'C' would point to where 'D' is, etc. The final C IPTR pointer associated with a single letter in TCLASS will be C zero. The IPTR pointer for A04 would point to where A06 is in C TCLASS and the IPTR pointer for A06 would be zero because there C are no more An. The IPTR pointer for C01 points to where C02 C is in TCLASS. The IPTR pointer for C02 points to where C03 is. C ... C14 is the last member of this type and its IPTR value is C zero. C C The JPTR pointers are similar to the IPTR pointers, but point to C where the next sized member of TCLASS will be located. For C example, the JPTR pointer for A points to where A04 is in TCLASS, C the JPTR pointer for A04 points to where A04A is in TCLASS, and C the JPTR pointer for A04A is zero since there is nothing more in C TCLASS which starts with A04A. C C The final section puts into the array STMTS the statements C associated with each member of TCLASS. Since a statement may take C up more than one line, we need another pointer table (KPTR) which C will point to the member of STMTS associated with each member of C TCLASS. E.g. The statement for A is in STMTS(1), ..., the C statement for C01 is in STMTS(7), but the statement for C02 is C STMTS(9) because the one for C01 is two lines long. C By setting up KPTR this way (and putting a dummy value in the C cell beyond the last entry corresponding to a member of TCLASS), C we can find out how long a statement is by taking the KPTR pointer C for the member of TCLASS in which we are interested and subtract C it from the next member of KPTR. C C The following is an excerpt from a file produced by this C code to show how it works. Column 1 are the IPTR pointers, C column 2 are the JPTR pointers, column 3 are the KPTR pointers, C and column 4 are the members of TCLASS. C C |<-------6 <----2 1 A C | |<-----4 |<-->3 2 A04 C | | 0 |--->0 3 A04A C | |----->0 <----5 4 A06 C | 0 |--->0 5 A06B C |<----->37 <----7 6 C C | |<-----8 |--->0 7 C01 C | |<---->9 0 9 C02 C | |<--->12 <---10 10 C03 C | | 0 |<->11 11 C03A C | | 0 |--->0 12 C03A02 C | |<--->16 <---13 13 C04 C | | |--<14 |--->0 14 C04A C | | |<->15 0 15 C04B C | | |--->0 0 16 C04C C | |<--->17 0 17 C05 C | |<--->23 <---18 18 C07 C | | |<--19 |--->0 19 C07A C | | |<->20 0 20 C07B C | | |<->21 0 21 C07C C | | |<->22 0 22 C07E C | | |--->0 0 23 C07F C | |<--->26 <---24 24 C08 C | | |--<25 |--->0 25 C08A C | | |--->0 0 27 C08C C | |<--->35 <---27 28 C10 C | | |--<30 |<->28 29 C10A C | | | |<29 |--->0 30 C10A01 C | | | |->0 0 31 C10A03 C | | |<->33 <---31 32 C10B C | | | |<32 |--->0 33 C10B01 C | | | |->0 0 34 C10B03 C | | |<->34 0 35 C10D C | | |--->0 0 36 C10F C | |<--->36 0 37 C11 C | |----->0 0 38 C14 C |<---->123 <---38 39 D C C***ROUTINES CALLED CVTCAT, LENSTR C***REVISION HISTORY (YYMMDD) C 891215 DATE WRITTEN C 891215 Prologue converted to Version 4.0 format. (BAB) C 920911 Declarations section restructured. (WRB) C***END PROLOGUE PSCAT C .. Scalar Arguments .. INTEGER ISTMT, MNCL, NCAT, NCC, NERR C .. Array Arguments .. INTEGER IPTR(*), JPTR(*), KPTR(*) CHARACTER*(*) CLASS(*), ECAT(*), STMTS(*), TCLASS(*) C .. Local Scalars .. INTEGER I, ICLASS, ILEN, IPER, ISTART, J, K, NLEN CHARACTER*1 OPART1, OPART3, OPART5, OPART7, PART1, PART3, + PART5, PART7 CHARACTER*2 OPART2, OPART4, OPART6, PART2, PART4, PART6 C .. Local Arrays .. INTEGER SIZE(7) C .. External Functions .. INTEGER LENSTR CHARACTER*10 CVTCAT EXTERNAL LENSTR,CVTCAT C .. Intrinsic Functions .. INTRINSIC INDEX C .. Data statements .. DATA SIZE /1, 3, 4, 6, 7, 9, 10/ C***FIRST EXECUTABLE STATEMENT PSCAT NERR = 0 NCC = 0 OPART1 = ' ' OPART2 = ' ' OPART3 = ' ' OPART4 = ' ' OPART5 = ' ' OPART6 = ' ' OPART7 = ' ' DO 180 I = 1,NCAT PART1 = ECAT(I)(1:1) PART2 = ECAT(I)(2:3) PART3 = ECAT(I)(4:4) PART4 = ECAT(I)(5:6) PART5 = ECAT(I)(7:7) PART6 = ECAT(I)(8:9) PART7 = ECAT(I)(10:10) IF (PART1 .NE. OPART1) GO TO 20 IF (PART2 .NE. OPART2) GO TO 40 IF (PART3 .NE. OPART3) GO TO 60 IF (PART4 .NE. OPART4) GO TO 80 IF (PART5 .NE. OPART5) GO TO 100 IF (PART6 .NE. OPART6) GO TO 120 IF (PART7 .NE. OPART7) GO TO 140 20 OPART1 = ' ' 40 OPART2 = ' ' 60 OPART3 = ' ' 80 OPART4 = ' ' 100 OPART5 = ' ' 120 OPART6 = ' ' 140 OPART7 = ' ' 160 IF (OPART1 .NE. PART1) THEN OPART1 = PART1 NCC = NCC+1 TCLASS(NCC) = OPART1 ENDIF IF (PART2 .EQ. ' ') GO TO 180 IF (OPART2 .NE. PART2) THEN OPART2 = PART2 NCC = NCC+1 TCLASS(NCC) = OPART1 // OPART2 GO TO 160 ENDIF IF (PART3 .EQ. ' ') GO TO 180 IF (OPART3 .NE. PART3) THEN OPART3 = PART3 NCC = NCC+1 TCLASS(NCC) = OPART1 // OPART2 // OPART3 GO TO 160 ENDIF IF (PART4 .EQ. ' ') GO TO 180 IF (OPART4 .NE. PART4) THEN OPART4 = PART4 NCC = NCC+1 TCLASS(NCC) = OPART1 // OPART2 // OPART3 // OPART4 GO TO 160 ENDIF IF (PART5 .EQ. ' ') GO TO 180 IF (OPART5 .NE. PART5) THEN OPART5 = PART5 NCC = NCC+1 TCLASS(NCC) = OPART1 // OPART2 // OPART3 // OPART4 // OPART5 GO TO 160 ENDIF IF (PART6 .EQ. ' ') GO TO 180 IF (OPART6 .NE. PART6) THEN OPART6 = PART6 NCC = NCC+1 TCLASS(NCC) = OPART1 // OPART2 // OPART3 // OPART4 // + OPART5 // OPART6 GO TO 160 ENDIF IF (PART7 .EQ. ' ') GO TO 180 IF (OPART7 .NE. PART7) THEN OPART7 = PART7 NCC = NCC+1 TCLASS(NCC) = OPART1 // OPART2 // OPART3 // OPART4 // + OPART5 // OPART6 // OPART7 ENDIF 180 CONTINUE DO 200 I = 1,NCC IPTR(I) = 0 JPTR(I) = 0 200 CONTINUE DO 280 J = 1,7 ISTART = 1 220 DO 260 I = ISTART,NCC ILEN = LENSTR(TCLASS(I)) IF (ILEN .EQ. SIZE(J)) THEN DO 240 K = I+1,NCC NLEN = LENSTR(TCLASS(K)) IF (ILEN .EQ. NLEN) THEN IF (J .EQ. 1) THEN IPTR(I) = K ELSEIF (TCLASS(I)(1:SIZE(J-1)) .EQ. + TCLASS(K)(1:SIZE(J-1))) + THEN IPTR(I) = K ELSE IPTR(I) = 0 ENDIF ISTART = K GO TO 220 ENDIF 240 CONTINUE ENDIF 260 CONTINUE 280 CONTINUE DO 320 J = 1,7 DO 300 I = 1,NCC ILEN = LENSTR(TCLASS(I)) IF (ILEN .EQ. SIZE(J)) THEN NLEN = LENSTR(TCLASS(I+1)) IF (ILEN .LT. NLEN) THEN IF (TCLASS(I)(1:SIZE(J)) .EQ. TCLASS(I+1)(1:SIZE(J))) THEN JPTR(I) = I+1 ENDIF ENDIF ENDIF 300 CONTINUE 320 CONTINUE DO 340 I = 1,NCC KPTR(I) = 0 340 CONTINUE C ICLASS = 1 ISTMT = 1 DO 400 I = 1,NCC C 360 IPER = INDEX(CLASS(ICLASS)(1:8),'.') IF (IPER .EQ. 0) THEN ICLASS = ICLASS+1 IF (ICLASS.GT.MNCL) THEN NERR = I RETURN ENDIF GO TO 360 ENDIF C IF (TCLASS(I) .EQ. CVTCAT(CLASS(ICLASS)(1:IPER-1))) THEN KPTR(I) = ISTMT 380 STMTS(ISTMT) = CLASS(ICLASS)(IPER+2:80) ISTMT = ISTMT+1 ICLASS = ICLASS+1 IF (CLASS(ICLASS)(1:1) .NE. ' ') GO TO 400 GO TO 380 ELSE ICLASS = ICLASS+1 IF (ICLASS.GT.MNCL) THEN NERR = I RETURN ENDIF GO TO 360 ENDIF 400 CONTINUE KPTR(NCC+1) = ISTMT RETURN END *DECK SORT SUBROUTINE SORT (R, N, NR, CR) C***BEGIN PROLOGUE SORT C***PURPOSE Alphabetise a character array and re-order one dependent C character array. C***LIBRARY (NONE) C***CATEGORY (NONE) C***KEYWORDS (NONE) C***AUTHOR Bacon, Barbara A., C-10, Los Alamos National Laboratory C***DESCRIPTION C C This subroutine alphabetises a character array. It then accordingly C reorders up to one dependent character array. C C INPUT C C R - the character array to be alphabetised. C N - the number of elements in the array R. C NR - the number (0 or 1) of dependent arrays. C CR - the dependent array of length at most 15 characters. C C***REFERENCES (NONE) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 891101 DATE WRITTEN C 891215 Prologue converted to Version 4.0 format. (BAB) C 920911 Declarations section restructured. (WRB) C***END PROLOGUE SORT C .. Scalar Arguments .. INTEGER N, NR C .. Array Arguments .. CHARACTER*(*) CR(*), R(*) C .. Local Scalars .. INTEGER I, J, K, M CHARACTER*15 IT C .. Intrinsic Functions .. INTRINSIC MOD C***FIRST EXECUTABLE STATEMENT SORT M = N C DO 5 I = 1,N C IR(I) = I C 5 CONTINUE 10 IF (M .GT. 15) GO TO 80 M = M/2 IF (M .EQ. 0) RETURN 20 IF (MOD(M,2) .EQ. 0) M = M+1 K = N-M J = 1 30 I = J 40 IF (R(I) .GT. R(I+M)) GO TO 60 50 J = J+1 IF (J .GT. K) GO TO 10 GO TO 30 60 IT = R(I) R(I) = R(I+M) R(I+M) = IT IF (NR .GT. 0) THEN IT = CR(I) CR(I) = CR(I+M) CR(I+M) = IT ENDIF I = I-M IF (I .LT. 1) GO TO 50 GO TO 40 80 M = M/4 GO TO 20 END