PROGRAM PARALLEL * * /PAGESYNC (default) * * /QUOTESYNC (on slave, string must be quoted; it is removed * from the slave) * * /SYNC="string" / MASTER * /SYNC=("string",REMOVE=option) option = < SLAVE * \ BOTH * * * 14 Nov 84 Add /OVERPRINT option. * * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) COMMON /SYNC_/ SYNCTYPE EXTERNAL SYNC1, SYNC2 EXTERNAL PAGESYNC1, PAGESYNC2 EXTERNAL QUOTESYNC1 CALL INITIALIZE CALL OPEN_FILES IF (SYNCTYPE) 10,20,30 10 CALL PRE_SCAN(PAGESYNC1) CALL PROCESS(PAGESYNC2) 20 CALL PRE_SCAN(QUOTESYNC1) CALL PROCESS(SYNC2) 30 CALL PRE_SCAN(SYNC1) CALL PROCESS(SYNC2) END SUBROUTINE INITIALIZE IMPLICIT INTEGER (A-Z) * * / -1 for /PAGESYNC * / 0 for /QUOTESYNC * SYNCTYPE = < 1 for /SYNC, remove neither * \ 3 for /SYNC, remove slave * \ 5 for /SYNC, remove master * \ 7 for /SYNC, remove both * CHARACTER*64 SYNCSTR CHARACTER*133 STRING CHARACTER*32 FORMAT / '(A,T002,A,T041,'' '',T043,A)' / CHARACTER*6 REMOVE,MASTER,SLAVE,BOTH INTEGER*2 NSYNC,SYNCOL LOGICAL CLI$PRESENT,CLI_INT,OVERPRINT COMMON /SYNC_/ SYNCTYPE,NSYNC,SYNCREC,SYNCOL(2),SYNCSTR,SSLEN, 1 SAVELEN COMMON /PAGE_/ MSIZE,SSIZE,FORMAT,OVERPRINT COMMON /WORK_/ STRING * Error codes from PARALLEL.MSG EXTERNAL PARALLEL_CONFQUAL,PARALLEL_SYNCQUAL,PARALLEL_COLQUAL, 1 PARALLEL_BARQUAL DATA SAVELEN / 4 / DATA MSIZE,SSIZE / 38,39 / DATA REMOVE,MASTER,SLAVE,BOTH 1 / 'REMOVE','MASTER','SLAVE','BOTH' / SYNCTYPE = WHICH_QUAL('PAGESYNC','QUOTESYNC','SYNC') - 2 IF (SYNCTYPE.LT.-1) CALL LIB$STOP(PARALLEL_CONFQUAL) IF (SYNCTYPE.EQ.1) THEN SAVELEN = 8 CALL CLI_GET('SYNC',SYNCSTR,SSLEN) CALL CLI_GET('SYNC',STRING,LEN) IF (LEN.GT.0) THEN COL = INDEX(STRING(1:LEN),'=') IF (COL.EQ.0 .OR. STRING(1:COL-1).NE.REMOVE(1:COL-1) 1 .OR. LEN.EQ.COL .OR. LEN.GT.COL+6) 2 CALL LIB$STOP(PARALLEL_SYNCQUAL) LEN = LEN - COL STRING(1:LEN) = STRING(COL+1:COL+LEN) IF (STRING(1:LEN).EQ.SLAVE(1:LEN)) THEN SYNCTYPE = 3 ELSE IF (STRING(1:LEN).EQ.MASTER(1:LEN)) THEN SYNCTYPE = 5 ELSE IF (STRING(1:LEN).EQ.BOTH(1:LEN)) THEN SYNCTYPE = 7 ELSE CALL LIB$STOP(PARALLEL_SYNCQUAL) ENDIF ENDIF ENDIF OVERPRINT = CLI$PRESENT('OVERPRINT') IF (OVERPRINT) THEN BARCOL = 133 IF (CLI$PRESENT('COLUMN')) THEN CALL CLI_INT('COLUMN',COL) IF (COL.LT.1.OR.COL.GT.120) 1 CALL LIB$STOP(PARALLEL_COLQUAL) ELSE COL = 1 ENDIF ELSE IF (.NOT.CLI_INT('COLUMN',COL)) 1 CALL LIB$STOP(PARALLEL_COLQUAL) IF (COL.LT.10.OR.COL.GT.120) CALL LIB$STOP(PARALLEL_COLQUAL) IF (CLI$PRESENT('BAR')) THEN FORMAT (17:17) = '|' IF (.NOT.CLI_INT('BAR',BARCOL,COL)) 1 CALL LIB$STOP(PARALLEL_BARQUAL) IF (BARCOL.GT.COL) CALL LIB$STOP(PARALLEL_BARQUAL) COL = MAX(COL,BARCOL+2) ELSE BARCOL = COL - 2 ENDIF ENDIF IF (CLI$PRESENT('RIGHT')) THEN MTAB = COL + 1 STAB = 2 MSIZE = 134 - COL SSIZE = BARCOL - 1 ELSE MTAB = 2 STAB = COL + 1 MSIZE = BARCOL - 1 SSIZE = 134 - COL ENDIF WRITE (FORMAT,1000) MTAB,BARCOL+1,FORMAT(17:17),STAB IF (OVERPRINT) FORMAT(11:20) = ' ' 1000 FORMAT ('(A,T',I3.3,',A,T',I3.3,',''',A,' '',T',I3.3,',A)') END SUBROUTINE OPEN_FILES IMPLICIT INTEGER (A-Z) CHARACTER*133 FILE COMMON /WORK_/ FILE LOGICAL CLI$PRESENT CALL CLI_GET('P1',FILE,LEN) OPEN (10,FILE=FILE(1:LEN),STATUS='OLD',READONLY) IF (CLI$PRESENT('OUTPUT')) THEN CALL CLI_GET('OUTPUT',FILE,LEN) ELSE INQUIRE (10,NAME=FILE) LEN = INDEX(FILE,']') LEN =SUBINDEX(FILE,LEN,'.') - 1 ENDIF OPEN (1,FILE=FILE(1:LEN),DEFAULTFILE='.LIS',STATUS='NEW') CALL CLI_GET('P2',FILE,LEN) OPEN (11,FILE=FILE(1:LEN),STATUS='OLD',READONLY) END SUBROUTINE PRE_SCAN(TEST_ROUTINE) IMPLICIT INTEGER (A-Z) CHARACTER*256 MLINE,SLINE CHARACTER*64 SYNCSTR INTEGER*2 NSYNC,SYNCOL COMMON /LINE_/ LASTSLAVE,SLAVEREC,MLEN,SLEN,MLINE,SLINE COMMON /SYNC_/ SYNCTYPE,NSYNC,SYNCREC,SYNCOL(2),SYNCSTR,SSLEN, 1 SAVELEN CHARACTER*72 SYNC_DATA EQUIVALENCE (SYNC_DATA,SYNCREC) BYTE BLOCK(1024) LOGICAL GET_LINE,TEST_ROUTINE EXTERNAL TEST_ROUTINE DATA SYNCREC,NSYNC / 0,1 / CALL DSA_INITIALIZE(BLOCK,1024) 10 SYNCREC = SYNCREC + 1 IF (.NOT.GET_LINE(11,SLINE,SLEN)) GO TO 20 IF (TEST_ROUTINE()) THEN CALL DSA_INSERT(SYNC_DATA(1:SAVELEN)) NSYNC = NSYNC + 1 ENDIF GO TO 10 20 CALL DSA_INSERT(SYNC_DATA(1:4)) REWIND 11 END LOGICAL FUNCTION PAGESYNC1 IMPLICIT INTEGER (A-Z) CHARACTER*256 MLINE,SLINE COMMON /LINE_/ LASTSLAVE,SLAVEREC,MLEN,SLEN,MLINE,SLINE DATA LINES / 0 / IF (SLEN.GE.1 .AND. SLINE(1:1).EQ.'1') THEN 10 PAGESYNC1 = .TRUE. LINES = 1 ELSE LINES = LINES + 1 IF (LINES.GT.61) GO TO 10 PAGESYNC1 = .FALSE. ENDIF END LOGICAL FUNCTION PAGESYNC2 IMPLICIT INTEGER (A-Z) CHARACTER*256 MLINE,SLINE CHARACTER*64 SYNCSTR INTEGER*2 NSYNC,SYNCOL COMMON /LINE_/ LASTSLAVE,SLAVEREC,MLEN,SLEN,MLINE,SLINE COMMON /SYNC_/ SYNCTYPE,NSYNC,SYNCREC,SYNCOL(2),SYNCSTR,SSLEN, 1 SAVELEN DATA LINES / 0 / IF (MLEN.GE.1 .AND. MLINE(1:1).EQ.'1' .AND. NSYNC.GT.0) THEN 10 PAGESYNC2 = .TRUE. LINES = 1 ELSE LINES = LINES + 1 IF (LINES.GT.61) GO TO 10 PAGESYNC2 = .FALSE. ENDIF END LOGICAL FUNCTION SYNC1 IMPLICIT INTEGER (A-Z) CHARACTER*256 MLINE,SLINE CHARACTER*64 SYNCSTR INTEGER*2 NSYNC,SYNCOL COMMON /LINE_/ LASTSLAVE,SLAVEREC,MLEN,SLEN,MLINE,SLINE COMMON /SYNC_/ SYNCTYPE,NSYNC,SYNCREC,SYNCOL(2),SYNCSTR,SSLEN, 1 SAVELEN SYNCOL(1) = INDEX(SLINE(1:SLEN),SYNCSTR(1:SSLEN)) SYNC1 = SYNCOL(1).GT.0 IF (SYNC1) THEN SYNCOL(2) = SYNCOL(1) + SSLEN SYNCOL(1) = SYNCOL(1) - 1 ENDIF END LOGICAL FUNCTION SYNC2 IMPLICIT INTEGER (A-Z) CHARACTER*256 MLINE,SLINE CHARACTER*64 SYNCSTR INTEGER*2 NSYNC,SYNCOL COMMON /LINE_/ LASTSLAVE,SLAVEREC,MLEN,SLEN,MLINE,SLINE COMMON /SYNC_/ SYNCTYPE,NSYNC,SYNCREC,SYNCOL(2),SYNCSTR,SSLEN, 1 SAVELEN MASTERCOL = INDEX(MLINE(1:MLEN),SYNCSTR(1:SSLEN)) IF (MASTERCOL.GT.0.AND.SYNCTYPE.GE.5) THEN MLINE(MASTERCOL:MLEN-SSLEN) = MLINE(MASTERCOL+SSLEN:MLEN) MLEN = MLEN - SSLEN ENDIF SYNC2 = MASTERCOL.GT.0 .AND. NSYNC.GT.0 END LOGICAL FUNCTION QUOTESYNC1 IMPLICIT INTEGER (A-Z) CHARACTER*256 MLINE,SLINE CHARACTER*64 SYNCSTR INTEGER*2 NSYNC,SYNCOL COMMON /LINE_/ LASTSLAVE,SLAVEREC,MLEN,SLEN,MLINE,SLINE COMMON /SYNC_/ SYNCTYPE,NSYNC,SYNCREC,SYNCOL(2),SYNCSTR,SSLEN, 1 SAVELEN SYNCOL(1) = INDEX(SLINE(1:SLEN),'"') IF (SYNCOL(1).GT.0) THEN SYNCOL(2) = SUBINDEX(SLINE(1:SLEN),SYNCOL(1)+1,'"') IF (SYNCOL(2).GT.0) THEN QUOTESYNC1 = .TRUE. SSLEN = SYNCOL(2) - SYNCOL(1) - 1 SAVELEN = SSLEN + 8 SYNCSTR(1:SSLEN) = SLINE(SYNCOL(1)+1:SYNCOL(2)-1) SYNCOL(1) = SYNCOL(1) - 1 SYNCOL(2) = SYNCOL(2) + 1 RETURN ENDIF ENDIF QUOTESYNC1 = .FALSE. END SUBROUTINE PROCESS(TEST_ROUTINE) IMPLICIT INTEGER (A-Z) CHARACTER*256 MLINE,SLINE CHARACTER*64 SYNCSTR INTEGER*2 NSYNC,SYNCOL LOGICAL GET_LINE,LASTSLAVE,TEST_ROUTINE COMMON /LINE_/ LASTSLAVE,SLAVEREC,MLEN,SLEN,MLINE,SLINE COMMON /SYNC_/ SYNCTYPE,NSYNC,SYNCREC,SYNCOL(2),SYNCSTR,SSLEN, 1 SAVELEN EXTERNAL TEST_ROUTINE IF (SYNCTYPE.EQ.0) SAVELEN = 72 10 CALL GET_SYNC_REC 20 CALL READ_MASTER IF (TEST_ROUTINE()) THEN DO WHILE (SLAVEREC.LT.SYNCREC) CALL READ_SLAVE(2) ENDDO CALL READ_SLAVE(3) GO TO 10 ELSE IF (SLAVEREC.LT.SYNCREC) THEN CALL READ_SLAVE(3) ELSE CALL PRINT(1) ENDIF GO TO 20 ENDIF END SUBROUTINE GET_SYNC_REC IMPLICIT INTEGER (A-Z) CHARACTER*64 SYNCSTR INTEGER*2 NSYNC,SYNCOL COMMON /SYNC_/ SYNCTYPE,NSYNC,SYNCREC,SYNCOL(2),SYNCSTR,SSLEN, 1 SAVELEN CHARACTER*72 SYNC_DATA EQUIVALENCE (SYNC_DATA,SYNCREC) CALL DSA_FETCH(SYNC_DATA(1:SAVELEN),LEN) IF (SYNCTYPE.EQ.0) SSLEN = LEN - 8 NSYNC = NSYNC - 1 END SUBROUTINE READ_MASTER IMPLICIT INTEGER (A-Z) CHARACTER*256 MLINE,SLINE COMMON /LINE_/ LASTSLAVE,SLAVEREC,MLEN,SLEN,MLINE,SLINE IF (.NOT.GET_LINE(10,MLINE,MLEN)) CALL FINISH CALL DETAB(MLINE(2:MLEN),MLINE(2:),MLEN) MLEN = MLEN + 1 ! Adjust for detabbing beyond column 1 END SUBROUTINE READ_SLAVE(CODE) * CODE = 1 -- Print master line only (use master's c.c.) * CODE = 2 -- Print slave line only (use blank c.c.) * CODE = 3 -- Print both master and slave lines (use master c.c.) * CODE = 4 -- Print slave line only (use slave's c.c.) * * c.c. = carriage control IMPLICIT INTEGER (A-Z) CHARACTER*256 MLINE,SLINE CHARACTER*64 SYNCSTR INTEGER*2 NSYNC,SYNCOL COMMON /LINE_/ LASTSLAVE,SLAVEREC,MLEN,SLEN,MLINE,SLINE COMMON /SYNC_/ SYNCTYPE,NSYNC,SYNCREC,SYNCOL(2),SYNCSTR,SSLEN, 1 SAVELEN LOGICAL GET_LINE,STATUS DATA SLAVEREC / 1 / STATUS = GET_LINE(11,SLINE,SLEN) IF (.NOT.STATUS) STOP 666 CALL DETAB(SLINE(2:SLEN),SLINE(2:),SLEN) SLEN = SLEN + 1 ! Adjust for detabbing beyond column 1 IF (SLAVEREC.EQ.SYNCREC) THEN IF (SYNCTYPE.EQ.3.OR.SYNCTYPE.EQ.7) THEN SLINE(1:SLEN-SSLEN) = SLINE(1:SYNCOL(1)) // 1 SLINE(SYNCOL(2):SLEN) SLEN = SLEN - SSLEN ELSE IF (SYNCTYPE.EQ.0) THEN SLINE(1:SLEN-SSLEN-2) = SLINE(1:SYNCOL(1)) // 1 SLINE(SYNCOL(2):SLEN) SLEN = SLEN - SSLEN - 2 ENDIF ENDIF SLAVEREC = SLAVEREC + 1 IF (CODE.EQ.4) THEN MLEN = 1 MLINE(1:1) = SLINE(1:1) CALL PRINT(3) ELSE CALL PRINT(CODE) ENDIF END SUBROUTINE PRINT(CODE) * CODE = 1 -- Print master line only (use master's c.c.) * CODE = 2 -- Print slave line only (use blank c.c.) * CODE = 3 -- Print both master and slave lines (use master c.c.) * * c.c. = carriage control IMPLICIT INTEGER (A-Z) CHARACTER*256 MLINE,SLINE CHARACTER*64 SYNCSTR CHARACTER*32 FORMAT CHARACTER*133 PRINTLINE,PRINTLINE2 INTEGER*2 NSYNC,SYNCOL LOGICAL LASTSLAVE,OVERPRINT COMMON /LINE_/ LASTSLAVE,SLAVEREC,MLEN,SLEN,MLINE,SLINE COMMON /SYNC_/ SYNCTYPE,NSYNC,SYNCREC,SYNCOL(2),SYNCSTR,SSLEN, 1 SAVELEN COMMON /PAGE_/ MSIZE,SSIZE,FORMAT,OVERPRINT COMMON /WORK_/ PRINTLINE * LASTSLAVE is .TRUE. if and only if the last line printed * contained a slave line. GO TO (10,20,30),CODE 10 MLEN = MIN(MLEN,MSIZE) WRITE (PRINTLINE,FORMAT) MLINE(1:1),MLINE(2:MLEN) LASTSLAVE = .FALSE. GO TO 40 20 SLEN = MIN(SLEN,SSIZE) WRITE (PRINTLINE,FORMAT) ' ',' ',SLINE(2:SLEN) LASTSLAVE = .TRUE. GO TO 40 30 MLEN = MIN(MLEN,MSIZE) SLEN = MIN(SLEN,SSIZE) LASTSLAVE = .TRUE. IF (OVERPRINT) THEN WRITE (PRINTLINE,FORMAT) MLINE(1:1),MLINE(2:MLEN) LEN = STR_LEN(PRINTLINE) WRITE (PRINTLINE2,FORMAT) '+',' ',SLINE(2:SLEN) LEN2 = STR_LEN(PRINTLINE2) DO I=2,MIN(LEN,LEN2) IF (PRINTLINE(I:I).NE.' ' .AND. PRINTLINE2(I:I).NE.' ') 1 THEN WRITE (1,1000) PRINTLINE(1:LEN) WRITE (1,1000) PRINTLINE2(1:LEN2) RETURN ENDIF ENDDO ENDIF WRITE (PRINTLINE,FORMAT) MLINE(1:1),MLINE(2:MLEN),SLINE(2:SLEN) 40 LEN = STR_LEN(PRINTLINE) WRITE (1,1000) PRINTLINE(1:LEN) 1000 FORMAT (A) END SUBROUTINE FINISH IMPLICIT INTEGER (A-Z) CHARACTER*256 MLINE,SLINE CHARACTER*64 SYNCSTR INTEGER*2 NSYNC,SYNCOL LOGICAL LASTSLAVE COMMON /LINE_/ LASTSLAVE,SLAVEREC,MLEN,SLEN,MLINE,SLINE COMMON /SYNC_/ SYNCTYPE,NSYNC,SYNCREC,SYNCOL(2),SYNCSTR,SSLEN, 1 SAVELEN DATA CODE / 2 / * If a slave group was currently being printed when the end of * the master file was reached, finish this slave group. IF (.NOT.LASTSLAVE) GO TO 20 10 IF (SLAVEREC.GE.SYNCREC) GO TO 20 CALL READ_SLAVE(CODE) GO TO 10 20 IF (NSYNC.EQ.0) CALL EXIT * If there are unprocessed slave groups left, then use the * slave's carraige control and print them (normally the slave's * carriage control is never used). CODE = 4 CALL READ_SLAVE(4) CALL GET_SYNC_REC GO TO 10 END INTEGER FUNCTION STR_LEN(STRING) ** * INTEGER FUNCTION STR_LEN( string ) * * * Returns, as the functional result, the length of the character * string argument STRING, minus any rightmost blanks and/or tabs. * * .INDEX STRING MANIPULATION>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 26 Feb 1984 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*(*) STRING STR_LEN = LEN(STRING) DO WHILE (STR_LEN.GT.0) IF ( STRING(STR_LEN:STR_LEN).NE.' ' .AND. 1 STRING(STR_LEN:STR_LEN).NE.CHAR(9) ) RETURN STR_LEN = STR_LEN - 1 ENDDO END INTEGER FUNCTION SUBINDEX(STRING,COLUMN,PATTERN) ** * INTEGER FUNCTION SUBINDEX ( string , column , pattern ) * * * This is very much like the Fortran INDEX built-in function, except * that SUBINDEX begins the search at an arbitrary column within the * string. * * STRING is the character string to be searched. COLUMN is the col- * umn number at which to begin the search. PATTERN is the substring * for which we are searching. * * The functional result is zero if the pattern is not found in the * string. If the pattern is found, the functional result is set to * the column where the first occurrence of the pattern begins * * .INDEX STRING MANIPULATION>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 16 Feb 1984 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*(*) STRING,PATTERN INTEGER*2 COLUMN SUBINDEX = INDEX(STRING(COLUMN:),PATTERN) IF (SUBINDEX.NE.0) SUBINDEX = SUBINDEX + COLUMN - 1 END INTEGER FUNCTION CLI_GET(TOKEN,VALUE,LENGTH) ** * INTEGER FUNCTION CLI_GET( token , value , length ) * * * Obtains the value of a command line parameter or qualifier. The * input character string argument TOKEN gives the name of the param- * eter or qualifier to be processed. The output longword integer * argument LENGTH is the length of the value associated with the * token; if zero, the token was not present on the command line, or * it had a null value. If LENGTH is non-zero, then the output char- * acter string VALUE contains the value associated with the token. * * The function result is the status return from the CLI$GET_VALUE * function. If the value of LENGTH is greater than the length of * the VALUE string, then the value was truncated. * * .INDEX ENVIRONMENT>> * .INDEX COMMAND LANGUAGE INTERFACE>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 9 Mar 1984 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*(*) TOKEN,VALUE INTEGER*4 LENGTH * The integer array STR is used as a descriptor for a 'Dynamic * String'. We use STR when we call CLI$GET_VALUE so we can de- * termine the valid length of the parameter or qualifier value. * If we used a normal string, we could not tell the difference * between, for instance, the cases: * * /QUAL = AAA /QUAL = "AAA " * * The Run-Time Library actually places the character string for * STR in memory which it allocates itself. We free this memory * after we are finished, by calling STR$FREE1. INTEGER*4 STR(2) STR(1) = '020F0000'X ! Dynamic character string, zero length STR(2) = '00000000'X ! VAX RTL will fill in an address here CLI_GET = CLI$GET_VALUE(TOKEN,STR) IF (CLI_GET) THEN LENGTH = IAND(STR(1),'FFFF'X) IF (LENGTH.GT.0) CALL STR$COPY_DX(VALUE,STR) ! Copy STR to VALUE ELSE LENGTH = 0 ENDIF CALL STR$FREE1_DX(STR) ! Free the space allocated for the string END INTEGER FUNCTION CLI_INT(QUALIFIER,VALUE,DEFAULT) ** * INTEGER FUNCTION CLI_INT( qualifier , value , [ default ] ) * * * Parses a command line parameter or qualifier which has an integer * value. The supplied value may be in either of the following for- * mats: * * i %i %Di %Oj %Xk * * where 'i' is one or more decimal digits, 'j' is one or more octal * digits, and 'k' is one or more hexadecimal digits. * * The calling routine specifies in character argument QUALIFIER the * name of the qualifier (or parameter) whose value is to be fetched. * The integer value is returned in the INTEGER*4 argument VALUE. The * functional result shows the status of the parse; it is SS$_NORMAL * (integer value 1) for success. * * If the qualifier (or parameter) is not present, or if it is a * qualifier specified with no value, then the action taken depends * on whether the optional INTEGER*4 argument DEFAULT is used: * * If DEFAULT is used, then its value is returned in VALUE, and * the functional result is set to 3. * * If DEFAULT is not used, then the functional result is set to * the failure status return from CLI$GET_VALUE, which should be * CLI$_ABSENT (integer value 0 currently). * * If the qualifier IS present, but its value is not in one of the * above formats, then the functional result will be a failure status * code: * * The value 2 will be returned if the value was null (""). * * The value OTS$_INPCONERR (hex value 0017802C) will be returned * if the value is not a legal decimal/octal/hex integer. * * .INDEX ENVIRONMENT>> * .INDEX COMMAND LANGUAGE INTERFACE>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 15 Apr 1984 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*(*) QUALIFIER CHARACTER*32 RAW_VALUE LOGICAL ARG_EXIST CLI_INT = 1 STATUS = CLI_GET(QUALIFIER,RAW_VALUE,VLEN) IF (.NOT.STATUS) THEN IF (ARG_EXIST(3)) THEN VALUE = DEFAULT CLI_INT = 3 ELSE CLI_INT = STATUS ENDIF ELSE IF (VLEN.EQ.0) THEN CLI_INT = 2 ELSE IF (RAW_VALUE(1:1).EQ.'%') THEN IF (RAW_VALUE(2:2).EQ.'D') THEN CLI_INT = OTS$CVT_TI_L(RAW_VALUE(3:VLEN),VALUE) ELSE IF (RAW_VALUE(2:2).EQ.'X') THEN CLI_INT = OTS$CVT_TZ_L(RAW_VALUE(3:VLEN),VALUE) ELSE IF (RAW_VALUE(2:2).EQ.'O') THEN CLI_INT = OTS$CVT_TO_L(RAW_VALUE(3:VLEN),VALUE) ELSE CLI_INT = OTS$CVT_TI_L(RAW_VALUE(2:VLEN),VALUE) ENDIF ELSE CLI_INT = OTS$CVT_TI_L(RAW_VALUE(1:VLEN),VALUE) ENDIF END INTEGER FUNCTION GET_LINE(UNIT,STRING,LENGTH,CCTYPE) ** * INTEGER FUNCTION GET_LINE( unit , string , length , [cctype] ) * * * Reads file whose Fortran unit number is the argument UNIT, and re- * turns one 'logical' line. The calling program must have previous- * ly opened the file. Only unit numbers 10 or 11 can be used. These * two units can be processed concurrently if desired. * * The line is returned in character string STRING; the length of the * line is returned in the longword integer LENGTH. * * If the file does not have Fortran Carriage Control, the actual * line read (the 'physical' line) is reformatted so that STRING con- * tains a Fortran-like line; i.e. column 1 contains the carriage * control for the line. In doing this reformatting, it may be ne- * cessary for GET_LINE to split the physical line into two or more * logical lines. Only one logical line is returned per call; the * remaining part(s) of the physical line are returned on subsequent * calls. * * The functional result is 1 (.TRUE.) unless end-of-file was reached * in which case it is 0 (.FALSE.). GET_LINE does NOT close the file * when it senses end-of-file. * * .INDEX DISK I/O>> * * This routine cannot handle every type of file. It is designed to * handle: * * * Any file with Fortran Carriage Control * * * Files output from the RUNOFF utility. * * * Files with 'List' Carriage Control (i.e. files created as * listing files by VMS components, or normal files created us- * ing EDT) which have no embedded ASCII control characters ex- * cept: * * a. A Form Feed (page eject) or Line Feed (double spacing) * may appear at the beginning of a line. * * b. A Carriage Return may appear anywhere in the line. * (This is used for underlining and overprinting.) * * c. A Carriage Return/Line Feed pair may appear anywhere * in the line. (This is used to pack multiple print * lines onto one record.) * * Files with records longer than 256 characters are not handled. A * file with 'Unknown' Carriage Control is assumed to be a VFC/Print * file format file (this is the format of a file created with the * VMS OPEN/WRITE command); this assumption is, of course, not very * good if the file is a .OBJ or .EXE file. *- * If the optional longword integer argument CCTYPE is present, * GET_LINE returns in it the type of Carriage Control the file has, * as follows: * * FORTRAN -- 0 * * LIST -- 1 * * NONE -- 2 (RUNOFF output files) * * * 23 Apr 1984 Treat UNKNOWN files same as LIST; the assumption * is that they are VFC/Print Format files created by * the VMS OPEN/WRITE command. * Handle double spacing (Line Feed in column 1). * * 3 May 1984 Handle CR/LF in col 1-2 of list files. * * 20 Jun 1984 Do not close file upon EOF; calling program may * need to do special processing. * * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 18 Mar 1984 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*(*) STRING CHARACTER CRLF*2,CR*1,LF*1,FF*1 PARAMETER ( CRLF = CHAR(13) // CHAR(10) ) PARAMETER ( CR = CHAR(13) ) PARAMETER ( LF = CHAR(10) ) PARAMETER ( FF = CHAR(12) ) CHARACTER*256 BUFFER(10:11) INTEGER*2 BLEN(10:11) / -1,-1 / ! Non-neg means buffer has data in it ! from last call BYTE CC_TYPE(10:11) / -1,-1 / ! Minus one means initialization needed LOGICAL ARG_EXIST IF (CC_TYPE(UNIT).LT.0) THEN INQUIRE ( UNIT , CARRIAGECONTROL=BUFFER(UNIT)(1:10) ) IF (BUFFER(UNIT)(1:10).EQ.'FORTRAN') THEN CC_TYPE(UNIT) = 0 ELSE IF (BUFFER(UNIT)(1:10).EQ.'LIST') THEN CC_TYPE(UNIT) = 1 ELSE IF (BUFFER(UNIT)(1:10).EQ.'NONE') THEN CC_TYPE(UNIT) = 2 ELSE CC_TYPE(UNIT) = 1 ! Treat VFC same as LIST ENDIF ENDIF IF (ARG_EXIST(4)) CCTYPE = CC_TYPE(UNIT) IF (BLEN(UNIT).LT.0) THEN READ (UNIT,1000,END=100) LEN,BUFFER(UNIT) ELSE LEN = BLEN(UNIT) BLEN(UNIT) = -1 ENDIF GET_LINE = 1 IF (CC_TYPE(UNIT).EQ.2.AND.LEN.GE.2) THEN ! Remove from ! RUNOFF lines IF (BUFFER(UNIT)(LEN-1:LEN).EQ.CRLF) LEN = LEN - 2 ENDIF IF (LEN.EQ.0) THEN STRING(1:1) = ' ' LENGTH = 1 RETURN ELSE IF (CC_TYPE(UNIT).EQ.0) THEN ! Copy Fortran files verbatim STRING(1:LEN) = BUFFER(UNIT)(1:LEN) LENGTH = LEN RETURN ELSE IF (BUFFER(UNIT)(1:1).EQ.FF) THEN STRING(1:1) = '1' COL = 2 ELSE IF (BUFFER(UNIT)(1:1).EQ.CR) THEN STRING(1:1) = '+' COL = 2 IF (LEN.GE.2.AND.BUFFER(UNIT)(2:2).EQ.LF) THEN STRING(1:1) = '0' COL = 3 ENDIF ELSE IF (BUFFER(UNIT)(1:1).EQ.LF) THEN STRING(1:1) = '0' COL = 2 ELSE STRING(1:1) = ' ' COL = 1 ENDIF IF (CC_TYPE(UNIT).EQ.1) THEN ! Check for embedded control characters ! in 'List' files COL2 = SUBINDEX( BUFFER(UNIT)(1:LEN) , COL , CR ) IF (COL2.NE.0) THEN LENGTH = COL2-1 - COL + 2 STRING(2:LENGTH) = BUFFER(UNIT)(COL:COL2-1) IF (BUFFER(UNIT)(COL2:COL2+1).EQ.CRLF) COL2 = COL2 + 2 BLEN(UNIT) = LEN - COL2 + 1 BUFFER(UNIT)(1:BLEN(UNIT)) = BUFFER(UNIT)(COL2:LEN) RETURN ENDIF ENDIF LENGTH = LEN - COL + 2 STRING(2:LENGTH) = BUFFER(UNIT)(COL:LEN) RETURN 100 CC_TYPE(UNIT) = -1 GET_LINE = 0 1000 FORMAT (Q,A) END INTEGER FUNCTION DETAB(IN_STRING,OUT_STRING,OUT_LEN) ** * LOGICAL FUNCTION DETAB ( in_string , out_string , out_len ) * * * Transforms the input character string IN_STRING to the output * string OUT_STRING by converting ASCII tab characters to blanks. * The output argument OUT_LEN is set to the last valid column of * OUT_STRING. * * If any tabs are present in IN_STRING, its length must be less than * the length of OUT_STRING, or else an overflow will occur. * * The functional result will be .TRUE. unless an overflow has occur- * red. A .FALSE. result means that one or more tabs did not get * converted to blanks; no characters will be missing from the end of * OUT_STRING. * * The standard VAX/VMS tab column spacing scheme is assumed, and the * IN_STRING's first column is assumed to be column 1 of this scheme. * * The input and output strings may overlap. * * .INDEX STRING MANIPULATION>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 31 Mar 1984 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*(*) IN_STRING, OUT_STRING CHARACTER*1 TAB PARAMETER ( TAB = CHAR(9) ) CHARACTER*8 BLANKS / ' ' / DETAB = .TRUE. START = 1 IN_LEN = LEN(IN_STRING) OUT_LEN = IN_LEN IF (%LOC(OUT_STRING).NE.%LOC(IN_STRING)) 1 OUT_STRING(1:OUT_LEN) = IN_STRING 10 COL = SUBINDEX(OUT_STRING(1:OUT_LEN),START,TAB) IF (COL.EQ.0) RETURN COUNT = 8 - MOD(COL-1,8) IF ( OUT_LEN+COUNT-1 .GT. LEN(OUT_STRING) ) THEN DETAB = .FALSE. ! Overflow RETURN ENDIF OUT_STRING(COL:OUT_LEN+COUNT-1) = BLANKS(1:COUNT) // 1 OUT_STRING(COL+1:OUT_LEN) OUT_LEN = OUT_LEN + COUNT - 1 START = START + COUNT GO TO 10 END