C%%A-RCB-0047-SL-18-5 THE RATFOR LIBRARY C C MODIFIED FOR USE WITH THE SYKES RATFOR PREPROCESSOR C C C CDEFN RATLIB STANDARD DEFINITIONS C C THESE DEFINITIONS ARE CONSISTANT WITH THOSE OF THE RATFOR LIBRARY C (RATLIB) AND THE SYKES RATFOR PREPROCESSOR C C C RETURN YES IF S1==S2, NO OTHERWISE INTEGER FUNCTION EQUAL ( S1, S2 ) LOGICAL * 1 S1 ( 10000 ), S2 ( 10000 ) INTEGER I I = 1 20000 IF (.NOT.( S1 ( I ) .EQ. S2 ( I ))) GOTO 20002 IF (.NOT.( S1 ( I ) .EQ. 0 )) GOTO 20003 EQUAL = ( 1 ) RETURN 20003 CONTINUE 20001 I = I + 1 GOTO 20000 20002 CONTINUE EQUAL = ( 0 ) RETURN END C RETURN NUMBER OF CHARACTERS IN STR INTEGER FUNCTION LENGTH ( STR ) LOGICAL * 1 STR ( 10000 ) I = 0 20005 IF (.NOT.( STR ( I + 1 ) .NE. 0)) GOTO 20007 20006 I = I + 1 GOTO 20005 20007 CONTINUE LENGTH = ( I ) RETURN END C COPY UP TO MAX CHARACTERS FROM "FROM" TO "TO" SUBROUTINE SCOPY ( FROM, START1, TO, START2, MAX ) LOGICAL * 1 FROM ( 10000 ), TO ( 10000 ) INTEGER START1, START2, K1, K2, MAX, COUNT K1 = START1 K2 = START2 COUNT = 1 20008 IF (.NOT.( FROM ( K1 ) .NE. 0 .AND. COUNT .LT. MAX)) GOTO 20010 TO ( K2 ) = FROM ( K1 ) K2 = K2 + 1 K1 = K1 + 1 20009 COUNT = COUNT + 1 GOTO 20008 20010 CONTINUE TO ( K2 ) = 0 RETURN END C RETURN NUMERIC IF C IS DIGIT, ALPHABETIC IF C IS A LETTER, C ELSE RETURN CHARACTER C ITSELF. LOGICAL * 1 FUNCTION TYPE ( C ) LOGICAL * 1 C IF (.NOT.( C .GE. 48 .AND. C .LE. 57 )) GOTO 20011 TYPE = ( - 5 ) RETURN 20011 CONTINUE IF (.NOT.( ( C .GE. 65 .AND. C .LE. 90 ) .OR. ( C .GE. 97 .AND. $C .LE. 122 ) )) GOTO 20013 TYPE = ( - 4 ) RETURN 20013 CONTINUE TYPE = ( C ) RETURN 20014 CONTINUE 20012 CONTINUE END C MAKE IN(I) A BASE BASE INTEGER AND BUMP I TO NEXT DELIMITER INTEGER FUNCTION CTOI ( IN, I, BASE ) LOGICAL * 1 IN ( 10000 ), DIGITS ( 11 ) INTEGER BASE, I, D DATA DIGITS / 1H0, 1H1, 1H2, 1H3, 1H4, 1H5, 1H6, 1H7, 1H8, 1H9, 0 $ / 20015 IF (.NOT.( IN ( I ) .EQ. 32 .OR. IN ( I ) .EQ. 9 )) GOTO 20016 I = I + 1 GOTO 20015 20016 CONTINUE CTOI = 0 20017 IF (.NOT.( IN ( I ) .NE. 0)) GOTO 20019 D = INDEX ( DIGITS, IN ( I ) ) IF (.NOT.( D .EQ. 0 )) GOTO 20020 GOTO 20019 20020 CONTINUE CTOI = BASE * CTOI + D - 1 20018 I = I + 1 GOTO 20017 20019 CONTINUE RETURN END C FIND CHAR C IN STRING STR; RETURN 0 IF IT IS NO THERE INTEGER FUNCTION INDEX ( STR, C ) LOGICAL * 1 C, STR ( 10000 ) INDEX = 1 20022 IF (.NOT.( STR ( INDEX ) .NE. 0)) GOTO 20024 IF (.NOT.( STR ( INDEX ) .EQ. C )) GOTO 20025 RETURN 20025 CONTINUE 20023 INDEX = INDEX + 1 GOTO 20022 20024 CONTINUE INDEX = ( 0 ) RETURN END C PUT OUT ERROR MESSAGE MESS ON LUN LUN IDENTIFIED BY PRGNAM SUBROUTINE MCRERR ( LUN, PRGNAM, MESS ) LOGICAL * 1 PRGNAM ( 3 ), MESS ( 10000 ) INTEGER LENGTH, LUN, I WRITE ( LUN, 10 ) PRGNAM, ( MESS ( I ), I = 1, LENGTH ( MESS ) ) 10 FORMAT ( 1H0, 3A1, 4H -- , 255A1 ) RETURN END C UNOPENABLE FILE MESSAGE SUBROUTINE CANT ( LUN, PRGNAM, FNAME ) LOGICAL * 1 PRGNAM ( 3 ), FNAME ( 10000 ) INTEGER LENGTH, L, I L = LENGTH ( FNAME ) IF (.NOT.( L .LE. 0 )) GOTO 20027 WRITE ( LUN, 10 ) PRGNAM GOTO 20028 20027 CONTINUE WRITE ( LUN, 20 ) PRGNAM, ( FNAME ( I ), I = 1, L ) 20028 CONTINUE RETURN 10 FORMAT ( 1H0, 3A1, 18H -- NULL FILE NAME ) 20 FORMAT ( 1H0, 3A1, 27H -- CAN'T OPEN THIS FILE: , 255A1 ) END C STOP F4P OTS FROM PRINTING MESSAGES FOR SOME FILE OPEN ERRORS SUBROUTINE KILFER CALL ERRSET ( 29,, . FALSE .,, . FALSE . ) CALL ERRSET ( 43,, . FALSE .,, . FALSE . ) RETURN END C GETC RETURN THE NEXT INPUT CHAR FROM LUN STDLUNIN IN C AND IN GETC LOGICAL * 1 FUNCTION GETC ( C ) LOGICAL * 1 C, BUF ( 132 ) INTEGER N, GETL, POS DATA POS / 1 /, N / 0 / IF (.NOT.( POS .LE. N )) GOTO 20029 C = BUF ( POS ) POS = POS + 1 GOTO 20030 20029 CONTINUE N = GETL ( BUF, 132, 3 ) IF (.NOT.( N .EQ. - 3 )) GOTO 20031 C = - 3 GOTO 20032 20031 CONTINUE N = N + 1 BUF ( N ) = 10 POS = 2 C = BUF ( 1 ) 20032 CONTINUE 20030 CONTINUE GETC = ( C ) RETURN END C GETL RETURNS THE NEXT MAXLIN CHARS OF THE NEXT LINE FROM LUN LUNIN. INTEGER FUNCTION GETL ( LINE, MAXLIN, LUNIN ) INTEGER N, MAXLIN, LUNIN LOGICAL * 1 LINE ( MAXLIN ) READ ( LUNIN, 10, END = 100 ) N, LINE 10 FORMAT ( Q, 255A1 ) IF (.NOT.( N .GE. MAXLIN )) GOTO 20033 N = MAXLIN - 1 20033 CONTINUE LINE ( N + 1 ) = 0 GETL = ( N ) RETURN 100 GETL = ( - 3 ) RETURN END C PUTC PUTS NEXT CHAR IN OUTPUT BUFFER, FLUSHING BUFFER IF CHAR == NEWLINE SUBROUTINE PUTC ( C ) LOGICAL * 1 C, BUF ( 132 ) INTEGER POS DATA POS / 1 / IF (.NOT.( C .EQ. - 3 )) GOTO 20035 RETURN 20035 CONTINUE IF (.NOT.( C .EQ. 10 .OR. POS .GE. 132 )) GOTO 20037 BUF ( POS ) = 0 CALL PUTL ( BUF, 4 ) POS = 1 20037 CONTINUE IF (.NOT.( C .NE. 10 )) GOTO 20039 BUF ( POS ) = C POS = POS + 1 20039 CONTINUE RETURN END C PUTL WRITES STRING LINE TO LUN LUNOUT SUBROUTINE PUTL ( LINE, LUNOUT ) LOGICAL * 1 LINE ( 10000 ) INTEGER L, LENGTH, I, LUNOUT L = LENGTH ( LINE ) IF (.NOT.( L .GT. 0 )) GOTO 20041 WRITE ( LUNOUT, 10 ) ( LINE ( I ), I = 1, L ) GOTO 20042 20041 CONTINUE WRITE ( LUNOUT, 10 ) 20042 CONTINUE 10 FORMAT ( 255A1 ) RETURN END C GET NEXT MCR LINE: FROM GETMCR, INDIRECT FILE (1 LEVEL), OR PROMPTING. C PROMPT ON LUNPMT. LUN LUNIND ~=0 IF INDIRECT FILE LUN AVAILABLE. C PRE-SCAN MCR LINE, AND SET NUMOUT=NUMBER OF (POSSIBLY NULL) OUTPUT FILES. INTEGER FUNCTION NXTMCR ( LUNPMT, PROMPT, LUNIND, NUMOUT ) LOGICAL * 1 PROMPT ( 3 ), MCR ( 82 ), CJUNK, FN ( 41 ), TYPE INTEGER NUMOUT, DONE, I, N, POS, LUNIND, FIRST, NBRCK, ININD, $GETL COMMON / MCRNFO / MCR, POS DATA DONE / 0 /, FIRST / 1 /, ININD / 0 / IF (.NOT.( LUNPMT .LT. 0 )) GOTO 20043 CLOSE ( UNIT = LUNIND ) ININD = 0 NXTMCR = ( 1 ) RETURN C%^ 20043 CONTINUE 20045 CONTINUE IF (.NOT.( DONE .EQ. 1 .AND. ININD .EQ. 0 )) GOTO 20048 NXTMCR = ( 0 ) RETURN 20048 CONTINUE IF (.NOT.( FIRST .EQ. 1 )) GOTO 20050 CALL GETMCR ( MCR, N ) CONTINUE POS = 1 20052 IF (.NOT.( POS .LE. N .AND. MCR ( POS ) .NE. 32 .AND. MCR ( POS ) $ .NE. 9)) GOTO 20054 20053 POS = POS + 1 GOTO 20052 20054 CONTINUE CONTINUE 20055 IF (.NOT.( POS .LE. N .AND. MCR ( POS ) .EQ. 32 .OR. MCR ( POS ) $.EQ. 9 )) GOTO 20056 POS = POS + 1 GOTO 20055 20056 CONTINUE IF (.NOT.( POS .LE. N )) GOTO 20057 DONE = 1 20057 CONTINUE FIRST = 0 GOTO 20051 20050 CONTINUE IF (.NOT.( ININD .EQ. 1 .AND. LUNIND .GT. 0 )) GOTO 20059 N = GETL ( MCR, 80, LUNIND ) IF (.NOT.( N .EQ. - 3 )) GOTO 20061 ININD = 0 CLOSE ( UNIT = LUNIND ) 20061 CONTINUE GOTO 20060 20059 CONTINUE WRITE ( LUNPMT, 10 ) PROMPT 10 FORMAT ( 1H$, 3A1, 1H> ) READ ( LUNPMT, 20, END = 1000 ) N, MCR 20 FORMAT ( Q, 82A1 ) 20060 CONTINUE CONTINUE POS = 1 20063 IF (.NOT.( POS .LE. N .AND. MCR ( POS ) .EQ. 32 .OR. MCR ( POS ) $.EQ. 9)) GOTO 20065 20064 POS = POS + 1 GOTO 20063 20065 CONTINUE 20051 CONTINUE IF (.NOT.( POS .LT. N .AND. MCR ( POS ) .EQ. 1H@ )) GOTO 20066 MCR ( N + 1 ) = 0 N = - 1 IF (.NOT.( ININD .EQ. 1 .OR. LUNIND .LE. 0 )) GOTO 20068 CALL MCRERR ( LUNPMT, PROMPT, 25HCOMMAND FILE INVALID HERE ) GOTO 20069 20068 CONTINUE POS = POS + 1 JUNK = NXTFIL ( 4H.CMD, FN, 41, CJUNK, 1 ) OPEN ( UNIT = LUNIND, NAME = FN, TYPE = 'OLD', ERR = 30, READONLY $ ) ININD = 1 GO TO 31 30 CALL MCRERR ( LUNPMT, PROMPT, 32HCAN'T OPEN INDIRECT COMMAND FILE $ ) 31 CONTINUE 20069 CONTINUE 20066 CONTINUE 20046 IF (.NOT.( POS .LE. N )) GOTO 20045 20047 CONTINUE C%^ NUMOUT = 1 NBRCK = 0 MCR ( N + 1 ) = 0 I = 1 20070 IF (.NOT.( MCR ( I ) .NE. 0)) GOTO 20072 IF (.NOT.( MCR ( I ) .EQ. 1H[ )) GOTO 20073 NBRCK = NBRCK + 1 GOTO 20074 20073 CONTINUE IF (.NOT.( MCR ( I ) .EQ. 1H] )) GOTO 20075 NBRCK = NBRCK - 1 GOTO 20076 20075 CONTINUE IF (.NOT.( MCR ( I ) .EQ. 1H, .AND. NBRCK .EQ. 0 )) GOTO 20077 NUMOUT = NUMOUT + 1 GOTO 20078 20077 CONTINUE IF (.NOT.( MCR ( I ) .EQ. 1H= )) GOTO 20079 GOTO 20072 20079 CONTINUE 20078 CONTINUE 20076 CONTINUE 20074 CONTINUE 20071 I = I + 1 GOTO 20070 20072 CONTINUE IF (.NOT.( MCR ( I ) .NE. 1H= )) GOTO 20081 NUMOUT = 0 20081 CONTINUE NXTMCR = ( 1 ) RETURN 1000 DONE = 1 NXTMCR = ( 0 ) RETURN END C PICK UP NEXT FILE NAME FROM MCR AND PUT IN FNAME WITH EXTENSION EXT C IF NONE THERE. SWITCHES GO INTO SWITCH. ONLY FIRST MAXFNM CHARS OF C FILE NAME KEPT; ONLY FIRST MAXSW CHARS OF SWITCHES KEPT. INTEGER FUNCTION NXTFIL ( EXT, FNAME, MAXFNM, SWITCH, MAXSW ) LOGICAL * 1 EXT ( 4 ), FNAME ( MAXFNM ), SWITCH ( MAXSW ), MCR ( $82 ) INTEGER MAXFNM, MAXSW, POS, GOTDOT, I, J, NBRK COMMON / MCRNFO / MCR, POS 20083 IF (.NOT.( MCR ( POS ) .EQ. 32 .OR. MCR ( POS ) .EQ. 9 )) GOTO $20084 POS = POS + 1 GOTO 20083 20084 CONTINUE IF (.NOT.( MCR ( POS ) .EQ. 0 )) GOTO 20085 NXTFIL = ( 0 ) RETURN 20085 CONTINUE FNAME ( 1 ) = 0 SWITCH ( 1 ) = 0 I = 1 GOTDOT = 0 NBRAK = 0 20087 IF (.NOT.( MCR ( POS ) .NE. 0 .AND. MCR ( POS ) .NE. 1H/ .AND. $MCR ( POS ) .NE. 1H= .AND. ( MCR ( POS ) .NE. 1H, .OR. NBRK .GT. $0 ))) GOTO 20089 IF (.NOT.( MCR ( POS ) .GE. 97 .AND. MCR ( POS ) .LE. 122 )) GOTO $ 20090 MCR ( POS ) = MCR ( POS ) - 32 GOTO 20091 20090 CONTINUE IF (.NOT.( MCR ( POS ) .EQ. 1H. )) GOTO 20092 GOTDOT = 1 GOTO 20093 20092 CONTINUE IF (.NOT.( MCR ( POS ) .EQ. 1H[ )) GOTO 20094 NBRK = NBRK + 1 GOTO 20095 20094 CONTINUE IF (.NOT.( MCR ( POS ) .EQ. 1H] )) GOTO 20096 NBRK = NBRK - 1 GOTO 20097 20096 CONTINUE IF (.NOT.( MCR ( POS ) .EQ. 1H; .AND. GOTDOT .EQ. 0 )) GOTO 20098 CONTINUE J = 1 20100 IF (.NOT.( I .LT. MAXFNM .AND. J .LE. 4)) GOTO 20102 FNAME ( I ) = EXT ( J ) I = I + 1 20101 J = J + 1 GOTO 20100 20102 CONTINUE GOTDOT = 1 20098 CONTINUE 20097 CONTINUE 20095 CONTINUE 20093 CONTINUE 20091 CONTINUE IF (.NOT.( I .LT. MAXFNM .AND. MCR ( POS ) .NE. 32 .AND. MCR ( $POS ) .NE. 9 )) GOTO 20103 FNAME ( I ) = MCR ( POS ) I = I + 1 20103 CONTINUE C%^ 20088 POS = POS + 1 GOTO 20087 20089 CONTINUE IF (.NOT.( GOTDOT .EQ. 0 .AND. I .GT. 1 )) GOTO 20105 CONTINUE J = 1 20107 IF (.NOT.( I .LT. MAXFNM .AND. J .LE. 4)) GOTO 20109 FNAME ( I ) = EXT ( J ) I = I + 1 20108 J = J + 1 GOTO 20107 20109 CONTINUE 20105 CONTINUE FNAME ( I ) = 0 J = 1 IF (.NOT.( MCR ( POS ) .EQ. 1H/ )) GOTO 20110 CONTINUE POS = POS + 1 20112 IF (.NOT.( MCR ( POS ) .NE. 1H= .AND. MCR ( POS ) .NE. 0 .AND. $MCR ( POS ) .NE. 1H,)) GOTO 20114 IF (.NOT.( J .LT. MAXSW )) GOTO 20115 SWITCH ( J ) = MCR ( POS ) J = J + 1 20115 CONTINUE 20113 POS = POS + 1 GOTO 20112 20114 CONTINUE 20110 CONTINUE SWITCH ( J ) = 0 IF (.NOT.( MCR ( POS ) .NE. 0 )) GOTO 20117 POS = POS + 1 20117 CONTINUE NXTFIL = ( 1 ) RETURN END C SET UP LISTING PROGRAM - MCR LINE CONTAINS ONLY INPUT FILE & SWITCHES. C IF NO INPUT, DEFAULT TO PIPE.LYN & OPEN FILE AS DELETE DISPOSITION. INTEGER FUNCTION SETOTL ( LUNPMT, PROMPT, EXTIN, LUNIND ) LOGICAL * 1 EXTIN ( 4 ), SWITCH ( 80 ), FIN ( 41 ), DEFILE ( 9 ), $ PROMPT ( 3 ) INTEGER NXTFIL, I, DELETE, EQUAL, LUNPMT, LUNIND, NXTMCR COMMON / SWITCH / SWITCH DATA DEFILE / 1HP, 1HI, 1HP, 1HE, 1H., 1HL, 1HY, 1HN, 0 / CALL KILFER CLOSE ( UNIT = 3 ) 20119 CONTINUE IF (.NOT.( NXTMCR ( LUNPMT, PROMPT, LUNIND, NUMOUT ) .EQ. 0 )) $GOTO 20122 SETOTL = ( 0 ) RETURN 20122 CONTINUE IF (.NOT.( NUMOUT .GT. 0 )) GOTO 20124 CALL MCRERR ( LUNPMT, PROMPT, 29HEXACTLY ONE INPUT FILE NEEDED ) GOTO 20120 20124 CONTINUE JUNK = NXTFIL ( EXTIN, FIN, 41, SWITCH, 80 ) IF (.NOT.( FIN ( 1 ) .EQ. 0 )) GOTO 20126 CALL SCOPY ( DEFILE, 1, FIN, 1, 41 ) 20126 CONTINUE IF (.NOT.( EQUAL ( DEFILE, FIN ) .EQ. 1 )) GOTO 20128 OPEN ( UNIT = 3, NAME = FIN, TYPE = 'OLD', ERR = 1000, DISP = $'DELETE' ) GOTO 20129 20128 CONTINUE OPEN ( UNIT = 3, NAME = FIN, TYPE = 'OLD', ERR = 1000, READONLY ) 20129 CONTINUE SETOTL = ( 1 ) RETURN 1000 CALL MCRERR ( LUNPMT, PROMPT, 21HCAN'T OPEN INPUT FILE ) 20120 GOTO 20119 20121 CONTINUE END INTEGER FUNCTION SETFLT ( LUNPMT, PROMPT, EXTIN, EXTOUT, LUNIND ) INTEGER MAXSW, FIRST, NXTMCR, NXTFIL, JUNK, LUNIND, EQUAL, I LOGICAL * 1 SWITCH ( 80 ), PROMPT ( 3 ), EXTIN ( 4 ), EXTOUT ( 4 $), FIN ( 41 ), FOUT ( 41 ), DEFILE ( 9 ) COMMON / SWITCH / SWITCH DATA DEFILE / 1HP, 1HI, 1HP, 1HE, 1H., 1HL, 1HY, 1HN, 0 / CALL KILFER CLOSE ( UNIT = 3 ) CLOSE ( UNIT = 4 ) 20130 CONTINUE IF (.NOT.( NXTMCR ( LUNPMT, PROMPT, LUNIND, NUMOUT ) .EQ. 0 )) $GOTO 20133 SETFLT = ( 0 ) RETURN 20133 CONTINUE IF (.NOT.( NUMOUT .GT. 1 )) GOTO 20135 CALL MCRERR ( LUNPMT, PROMPT, 12HBAD MCR LINE ) GOTO 20131 20135 CONTINUE IF (.NOT.( NUMOUT .EQ. 1 )) GOTO 20137 JUNK = NXTFIL ( EXTOUT, FOUT, 41, SWITCH, 80 ) GOTO 20138 20137 CONTINUE FOUT ( 1 ) = 0 20138 CONTINUE 20136 CONTINUE IF (.NOT.( NXTFIL ( EXTIN, FIN, 41, SWITCH, 80 ) .EQ. 0 )) GOTO $20139 FIN ( 1 ) = 0 GOTO 20140 20139 CONTINUE IF (.NOT.( NXTFIL ( EXTIN, FIN, 41, SWITCH, 80 ) .EQ. 1 )) GOTO $20141 CALL MCRERR ( LUNPMT, PROMPT, 12HBAD MCR LINE ) GOTO 20131 20141 CONTINUE 20140 CONTINUE IF (.NOT.( FIN ( 1 ) .EQ. 0 )) GOTO 20143 CALL SCOPY ( DEFILE, 1, FIN, 1, 41 ) 20143 CONTINUE IF (.NOT.( FOUT ( 1 ) .EQ. 0 )) GOTO 20145 CALL SCOPY ( DEFILE, 1, FOUT, 1, 41 ) 20145 CONTINUE IF (.NOT.( EQUAL ( DEFILE, FIN ) .EQ. 1 )) GOTO 20147 OPEN ( UNIT = 3, NAME = FIN, TYPE = 'OLD', DISPOSE = 'DELETE', $ERR = 1000 ) GOTO 20148 20147 CONTINUE OPEN ( UNIT = 3, NAME = FIN, TYPE = 'OLD', ERR = 1000, READONLY ) 20148 CONTINUE OPEN ( UNIT = 4, NAME = FOUT, CARRIAGECONTROL = 'LIST', ERR = $1001, TYPE = 'NEW' ) SETFLT = ( 1 ) RETURN 1000 CALL CANT ( LUNPMT, PROMPT, FIN ) GOTO 20131 1001 CALL CANT ( LUNPMT, PROMPT, FOUT ) CLOSE ( UNIT = 3, DISPOSE = 'SAVE' ) 20131 GOTO 20130 20132 CONTINUE END C GET SLASH DELIMITED ARGUMENT NUMBER ARGNUM PLACING FIRST MAXARG CHARS C IN ARG. SLASHES LOSE DELIMITER FUNCTION IF PRECEDED BY ESCAPECHAR. C ARGS NOW STORED IN ARRAY SWITCH SET BY SETFLT OR SETOTL. INTEGER FUNCTION GETARG ( ARGNUM, ARG, MAXARG ) LOGICAL * 1 SWITCH ( 80 ), ARG ( MAXARG ) INTEGER ARGNUM, MAXARG, I, CNTARG, J COMMON / SWITCH / SWITCH ARG ( 1 ) = 0 IF (.NOT.( ARGNUM .LE. 0 .OR. MAXARG .LE. 1 .OR. SWITCH ( 1 ) $.EQ. 0 )) GOTO 20149 GETARG = ( - 3 ) RETURN 20149 CONTINUE I = 1 CNTARG = 1 20151 IF (.NOT.( CNTARG .LT. ARGNUM )) GOTO 20152 IF (.NOT.( SWITCH ( I ) .EQ. 0 )) GOTO 20153 GETARG = ( - 3 ) RETURN 20153 CONTINUE IF (.NOT.( SWITCH ( I ) .EQ. 1H/ )) GOTO 20155 CNTARG = CNTARG + 1 20155 CONTINUE IF (.NOT.( SWITCH ( I ) .EQ. 64 .AND. SWITCH ( I + 1 ) .NE. 0 )) $GOTO 20157 I = I + 2 GOTO 20158 20157 CONTINUE I = I + 1 20158 CONTINUE GOTO 20151 20152 CONTINUE J = 1 20159 IF (.NOT.( J .LT. MAXARG .AND. SWITCH ( I ) .NE. 1H/ .AND. SWITCH $ ( I ) .NE. 0)) GOTO 20161 IF (.NOT.( SWITCH ( I ) .EQ. 64 .AND. SWITCH ( I + 1 ) .NE. 0 )) $GOTO 20162 I = I + 1 20162 CONTINUE ARG ( J ) = SWITCH ( I ) J = J + 1 20160 I = I + 1 GOTO 20159 20161 CONTINUE ARG ( J ) = 0 GETARG = ( J - 1 ) RETURN END C R A T L B 2 C C RATFOR LIBRARY 2 C MORE STRING PROCESSING ROUTINES C C RICHARD L. MICHAUD C BRIDGEPORT CONTROLS C 200 PRECISION ROAD C HORSHAM,PA. C 18-JUL-78 C C RATLB2 CONTAINS SEVERAL STRING PROCESSING FUNCTIONS WRITTEN C IN RATFOR. EACH FUNCTION MUST BE DECLARED AS INTEGER BY THE C CALLING PROGRAM. STRINGS ARE THE STANDARD RATFOR STRING - BYTE C ARRAYS WITH AN OCTAL ZERO AS THE LAST CHARACTER IN THE STRING. C C# MODIFICATIONS MADE TO MAKE COMPATABLE WITH SYKES" INCLUDE: C# >> --> > C# << --> < C# C# THERE WERE NO "&&", "!!", OR OCTAL REPRESENTATIONS. C# AL 1/16/80 C * - SPAN - SPAN ACROSS (REMOVE) LONGEST STRING IN S1 CONTAINED IN S2. C ON SUCCESS, SPAN WILL STORE SPANNED SUBSTRING IN S3 AND C THE FUNCTION WILL RETURN THE NEW SIZE OF S1. C C SPAN WILL FAIL IF ALL CHARACTERS IN S1 ARE CONTAINED IN S2. C THE FUNCTION WILL RETURN -1 AND S3 WILL BECOME A NULL STRING. C C SPAN WILL ALSO FAIL IF THE FIRST CHARACTER IN S1 IS NOT CONTAINED C IN S2. THE FUNCTION WILL RETURN 0 AND S3 WILL BECOME A NULL STRING. C SPAN MUST BE DECLARED INTEGER BY THE CALLING PROGRAM AND S1,S2 AND C S3 MUST BE RATFOR STRINGS. S1 AND S2 MAY BE LITERAL, BUT S3 MUST C BE A STRING VARIABLE. INTEGER FUNCTION SPAN ( S1, S2, S3 ) LOGICAL * 1 S1 ( 10000 ), S2 ( 10000 ), S3 ( 10000 ) INTEGER D, INDEX, LENGTH I = 0 20164 IF (.NOT.( S1 ( I + 1 ) .NE. 0)) GOTO 20166 IF (.NOT.( INDEX ( S2, S1 ( I + 1 ) ) .EQ. 0 )) GOTO 20167 IF (.NOT.( I .EQ. 0 )) GOTO 20169 S3 ( 1 ) = 0 SPAN = ( 0 ) RETURN 20169 CONTINUE K = I + 1 CALL SCOPY ( S1, 1, S3, 1, K ) CALL SCOPY ( S1, K, S1, 1, 10000 ) K = LENGTH ( S1 ) SPAN = ( K ) RETURN 20170 CONTINUE 20167 CONTINUE 20165 I = I + 1 GOTO 20164 20166 CONTINUE S3 ( 1 ) = 0 SPAN = ( - 1 ) RETURN END C * - BRAKE - SKIP ACROSS LONGEST SUBSTRING IN S1 NOT CONTAINED IN S2. C C ON SUCCESS, BRAKE WILL TRANSFER TO S3 ALL CHARS UP TO THE FIRST BREAK C CHARACTER AND RETURN THE NEW SIZE OF S1. C C BRAKE WILL FAIL IF THE FIRST CHAR IN S1 IS A BREAK CHARACTER, S3 C WILL BE MADE A NULL STRING, AND THE FUNCTION WILL RETURN 0. C C BRAKE WILL FAIL IF S1 CONTAINS NO CHARACTERS IN S2, S3 WILL BE C MADE A NULL STRING AND THE FUNCTION WILL RETURN -1. C C BRAKE MUST BE DECLARED AS INTEGER, S1,S2, AND S3 AS CHAR. C S2 MAY BE LITERAL. INTEGER FUNCTION BRAKE ( S1, S2, S3 ) INTEGER INDEX, I, K LOGICAL * 1 S1 ( 10000 ), S2 ( 10000 ), S3 ( 10000 ) I = 0 20171 IF (.NOT.( S1 ( I + 1 ) .NE. 0)) GOTO 20173 IF (.NOT.( INDEX ( S2, S1 ( I + 1 ) ) .NE. 0 )) GOTO 20174 IF (.NOT.( I .EQ. 0 )) GOTO 20176 S3 ( 1 ) = 0 BRAKE = ( 0 ) RETURN 20176 CONTINUE K = I + 1 CALL SCOPY ( S1, 1, S3, 1, K ) CALL SCOPY ( S1, K, S1, 1, 10000 ) K = LENGTH ( S1 ) BRAKE = ( K ) RETURN 20177 CONTINUE 20174 CONTINUE 20172 I = I + 1 GOTO 20171 20173 CONTINUE S3 ( 1 ) = 0 BRAKE = ( - 1 ) RETURN END C * - ANY - RETURN FIRST POSITION IN S1 MATCHED BY ANY CHAR IN S2 C C ON SUCCESS, FUNCTION RETURNS FIRST MATCH POSITION C ON FAILURE RETURN EOS. C C ANY MUST BE DECLARED INTEGER, S1 AND S2 DECLARED CHAR. S1 AND S2 C MAY BE LITERAL. INTEGER FUNCTION ANY ( S1, S2 ) LOGICAL * 1 S1 ( 10000 ), S2 ( 10000 ) INTEGER INDEX, I I = 1 20178 IF (.NOT.( S1 ( I ) .NE. 0)) GOTO 20180 IF (.NOT.( INDEX ( S2, S1 ( I ) ) .NE. 0 )) GOTO 20181 ANY = ( I ) RETURN 20181 CONTINUE 20179 I = I + 1 GOTO 20178 20180 CONTINUE ANY = ( 0 ) RETURN END C * - NOTANY - RETURN FIRST POSITION IN S1 NOT MATCHED BY ANY CHAR IN S2. C FUNCTION RETURNS EOS IF ALL CHARS IN S1 MATCH WITH ANY CHAR IN S2. C NOTANY MUST BE DECLARED INTEGER. C S1 AND S2 MUST BE STRING OF CHAR, AND MAY BE LITERAL. INTEGER FUNCTION NOTANY ( S1, S2 ) LOGICAL * 1 S1 ( 10000 ), S2 ( 10000 ) INTEGER INDEX, I I = 1 20183 IF (.NOT.( S1 ( I ) .NE. 0)) GOTO 20185 IF (.NOT.( INDEX ( S2, S1 ( I ) ) .EQ. 0 )) GOTO 20186 NOTANY = ( I ) RETURN 20186 CONTINUE 20184 I = I + 1 GOTO 20183 20185 CONTINUE NOTANY = ( 0 ) RETURN END C * - SHIFT - SHIFT FIRST N CHARACTERS FROM STRING S1 C C FUNCTION RETURNS NUMBER OF CHARACTERS IN S1 AFTER SHIFT. C C SHIFT MUST BE DECLARED INTEGER. C N MUST BE INTEGER OR INTEGER VARIABLE C S1 MUST BE STRING OF CHAR - LITERAL NOT ALLOWED. INTEGER FUNCTION SHIFT ( S1, N ) C CORRECTED 9/10/79 SML INTEGER LENGTH, I, J, N LOGICAL * 1 S1 ( 10000 ) I = LENGTH ( S1 ) J = N + 1 I = ( I - N ) + 1 CALL SCOPY ( S1, J, S1, 1, I ) SHIFT = ( I - 1 ) RETURN END C * - RPLACE - REPLACE ALL OCCURRENCES OF CHARACTER BY CHARACTER C FUNCTION WILL REPLACE ALL WITH IN S1 AND RETURN NUMBER C OF REPLACEMENTS. C C FUNCTION WILL FAIL IF S1 DOES NOT COINTAIN OR IF = - C RETURN 0. C C RPLACE MUST BE DECLARED INTEGER C A AND B MUST BE SINGLE CHARACTER STRING OF CHAR OR LITERAL INTEGER FUNCTION RPLACE ( S1, A, B ) LOGICAL * 1 S1 ( 10000 ), A, B INTEGER INDEX, I IF (.NOT.( A .EQ. B )) GOTO 20188 RPLACE = ( 0 ) RETURN 20188 CONTINUE I = 0 20190 CONTINUE I = INDEX ( S1, A ) IF (.NOT.( I .EQ. 0 )) GOTO 20193 GOTO 20192 20193 CONTINUE S1 ( I ) = B I = I + 1 20191 GOTO 20190 20192 CONTINUE RPLACE = ( I ) RETURN END C * - TRIM - REMOVE TRAILING BLANKS OR TABS C FUNCTION REMOVES TRAILING BLANKS OR TABS AND RETURNS NEW LENGTH OF S1. C C TRIM MUST BE DECLARED INTEGER C S1 MUST BE STRING OF CHAR, NO LITERAL ALLOWED. INTEGER FUNCTION TRIM ( S1 ) LOGICAL * 1 S1 ( 10000 ) INTEGER LENGTH, I I = LENGTH ( S1 ) 20195 IF (.NOT.( I .GT. 0)) GOTO 20197 IF (.NOT.( S1 ( I ) .EQ. 32 .OR. S1 ( I ) .EQ. 9 )) GOTO 20198 S1 ( I ) = 0 GOTO 20199 20198 CONTINUE GOTO 20197 20199 CONTINUE 20196 I = I - 1 GOTO 20195 20197 CONTINUE I = LENGTH ( S1 ) TRIM = ( I ) RETURN END C * - ITOC - CONVERT INTEGER TO CHAR STRING OF RADIX . C C FUNCTION TO CONVERT INTEGER TO STRING OF RADIX C ON SUCCESS, FUNCTION RETURNS SIZE OF CONVERTED STRING . C FUNCTION WILL FAIL IF BASE IS LT 2. OR GT 16. AND WILL MAKE C S1 A NULL STRING AND RETURN 0. C C ITOC MUST BE DECLARED INTEGER C NUMBR MUST BE INTEGER OR INTEGER VARIABLE C S1 MUST BE STRING OF CHAR. C BASE MUST BE INTEGER OR INTEGER VARIABLE GE 2 AND LE 16. C C EXAMPLE: C C ITOC(10,S1,16) WILL PRODUCE "A" IN S1 WITH EOS IN S1(2) AND C RETURN 1 INTEGER FUNCTION ITOC ( NUMBR, S1, BASE ) INTEGER BASE, NUMBR, I, J, K, WRKNUM LOGICAL * 1 S1 ( 10000 ), JUNK ( 18 ), TABLE ( 16 ) DATA TABLE / 1H0, 1H1, 1H2, 1H3, 1H4, 1H5, 1H6, 1H7, 1H8, 1H9, $1HA, 1HB, 1HC, 1HD, 1HE, 1HF / IF (.NOT.( BASE . LT . 2 . OR . BASE . GT . 16 )) GOTO 20200 S1 ( 1 ) = 0 ITOC = ( 0 ) RETURN 20200 CONTINUE WRKNUM = NUMBR I = 1 20202 CONTINUE J = MOD ( WRKNUM, BASE ) + 1 JUNK ( I ) = TABLE ( J ) I = I + 1 WRKNUM = WRKNUM / BASE 20203 IF (.NOT.( WRKNUM .LE. 0 )) GOTO 20202 20204 CONTINUE I = I - 1 K = 1 J = I 20205 IF (.NOT.( J .GT. 0)) GOTO 20207 S1 ( K ) = JUNK ( J ) K = K + 1 20206 J = J - 1 GOTO 20205 20207 CONTINUE S1 ( K ) = 0 ITOC = ( I ) RETURN END C * - CHEXTI - CONVERT ASCII NUMERIC SUBSTRING TO INTEGER OF RADIX . C C NOTE: CHEXTI IS A SUPERSET OF CTOI THAT INCLUDES HEXADECIMAL AS A LEGAL C BASE. THEREFORE A-F ARE LEGAL NUMERIC CHARACTERS IF IS GT 10. C C CHEXTI WILL CONVERT NUMERIC CHARACTERS IN S1 STARTING AT POSITION I UNTIL C FIRST NON-NUMERIC CHARACTER OF RADIX TO INTEGER. C C CHEXTI MUST BE DECLARED INTEGER C S1 STRING OF CHAR OR LITERAL STRING C I INTEGER VARIABLE. MUST NOT BE A CONSTANT (SEE CTOI). C BASE INTEGER CONSTANT OR INTEGER VARIABLE. C C EXAMPLE: C C I=1 C CHEXTI("A",I,16) WILL RETURN THE INTEGER 10. INTEGER FUNCTION CHEXTI ( S1, I, BASE ) LOGICAL * 1 S1 ( 10000 ), DIGITS ( 17 ) INTEGER BASE, I, J, INDEX DATA DIGITS / 1H0, 1H1, 1H2, 1H3, 1H4, 1H5, 1H6, 1H7, 1H8, 1H9, $1HA, 1HB, 1HC, 1HD, 1HE, 1HF, 0 / 20208 IF (.NOT.( S1 ( I ) .EQ. 32 .OR. S1 ( I ) .EQ. 9 )) GOTO 20209 I = I + 1 GOTO 20208 20209 CONTINUE CHEXTI = 0 20210 IF (.NOT.( S1 ( I ) .NE. 0)) GOTO 20212 J = INDEX ( DIGITS, S1 ( I ) ) IF (.NOT.( J .EQ. 0 )) GOTO 20213 GOTO 20212 20213 CONTINUE CHEXTI = BASE * CHEXTI + J - 1 20211 I = I + 1 GOTO 20210 20212 CONTINUE RETURN END C * - MATCH - FIND MATCH ANYWHERE ON LINE C C FUNCTION WILL RETURN POSITION IN OF THE FIRST IDENTICAL OCCURRENCE C OF THE STRING IN WITHIN . IF MATCH FAILS, FUNCTION WILL C RETURN . C C FROM KERNIGHAN AND PLAUGER "SOFTWARE TOOLS" PAGE 140. C C MATCH MUST BE DECLARED INTEGER BY CALLING PROGRAM C LIN MUST BE STRING OF CHAR OR LITERAL C PAT MUST BE STRING OF CHAR OR LITERAL INTEGER FUNCTION MATCH ( LIN, PAT ) LOGICAL * 1 LIN ( 10000 ), PAT ( 10000 ) INTEGER AMATCH, I I = 1 20215 IF (.NOT.( LIN ( I ) .NE. 0)) GOTO 20217 IF (.NOT.( AMATCH ( LIN, I, PAT ) .GT. 0 )) GOTO 20218 MATCH = ( I ) RETURN 20218 CONTINUE 20216 I = I + 1 GOTO 20215 20217 CONTINUE MATCH = ( 0 ) RETURN END C * - AMATCH - WORK ROUTINE FOR MATCH WITH NO METACHARACTERS C C FROM KERNIGHAN AND PLAUGER "SOFTWARE TOOLS" PAGE 140. INTEGER FUNCTION AMATCH ( LIN, FROM, PAT ) LOGICAL * 1 LIN ( 10000 ), PAT ( 10000 ) INTEGER FROM, I, J I = FROM J = 1 20220 IF (.NOT.( PAT ( J ) .NE. 0)) GOTO 20222 IF (.NOT.( LIN ( I ) .NE. PAT ( J ) )) GOTO 20223 AMATCH = ( 0 ) RETURN 20223 CONTINUE I = I + 1 20221 J = J + 1 GOTO 20220 20222 CONTINUE AMATCH = ( I ) RETURN END C * - APPEND - APPEND S2 ONTO END OF S1 C C FUNCTION WILL CONCATENATE S2 ON THE END OF S1 TIMES AND C RETURN THE NEW LENGTH OF S1. C C APPEND MUST BE DECLARED INTEGER C S1 MUST BE STRING OF CHAR. LITERAL NOT ALLOWED C NOTE THAT S1 MUST BE LARGE ENOUGH TO CONTAIN THE RESULT. C S2 MUST BE STRING OF CHAR OR LITERAL. C COUNT MUST BE INTEGER OR INTEGER VARIABLE. INTEGER FUNCTION APPEND ( S1, S2, COUNT ) LOGICAL * 1 S1 ( 10000 ), S2 ( 10000 ) INTEGER LENGTH, I, J, K, COUNT J = LENGTH ( S2 ) + 1 IF (.NOT.( COUNT .LE. 0 )) GOTO 20225 APPEND = ( 0 ) RETURN 20225 CONTINUE K = 1 20227 IF (.NOT.( K .LE. COUNT)) GOTO 20229 I = LENGTH ( S1 ) + 1 CALL SCOPY ( S2, 1, S1, I, J ) 20228 K = K + 1 GOTO 20227 20229 CONTINUE APPEND = ( LENGTH ( S1 ) ) RETURN END C * - REMOVE - REMOVE SUBSTRING FROM STRING C C FUNCTION WILL REMOVE A SUBSTRING FROM BEGINNING AT POSITION C THROUGH POSITION , AND RETURN THE NEW SIZE OF C C FUNCTION WILL FAIL IF IS LE AND RETURN C FUNCTION WILL FAIL IF IS GE LENGTH(S1) AND RETURN C IF IS LE 1, CHARS WILL BE REMOVED FROM STARTING C AT S1(1). C IF GE LENGTH(S1), WILL BE TRUNCATED AT C C REMOVE MUST BE DECLARED INTEGER C S1 MUST BE STRING OF CHAR - LITERAL NOT ALLOWED. C FROM MUST BE INTEGER OR INTEGER VARIABLE C TO MUST BE INTEGER OR INTEGER VARIABLE INTEGER FUNCTION REMOVE ( S1, FROM, TO ) LOGICAL * 1 S1 ( 10000 ) INTEGER LENGTH, I, FROM, TO, SHIFT I = LENGTH ( S1 ) IF (.NOT.( TO .LE. FROM )) GOTO 20230 REMOVE = ( 0 ) RETURN 20230 CONTINUE IF (.NOT.( FROM .GE. I )) GOTO 20232 REMOVE = ( 0 ) RETURN 20232 CONTINUE 20231 CONTINUE IF (.NOT.( TO .GE. I )) GOTO 20234 S1 ( FROM ) = 0 GOTO 20235 20234 CONTINUE IF (.NOT.( FROM .LE. 1 )) GOTO 20236 I = SHIFT ( S1, TO ) GOTO 20237 20236 CONTINUE I = TO + 1 CALL SCOPY ( S1, I, S1, FROM, 10000 ) 20237 CONTINUE 20235 CONTINUE I = LENGTH ( S1 ) REMOVE = ( I ) RETURN END C * - INSERT - INSERT INTO AFTER . C C FUNCTION WILL INSERT STRING INTO AFTER S1(FROM) AND RETURN C NEW LENGTH OF . C C IF GE LENGTH(S1), WILL BE APPENDED TO C IF LT 1, WILL BE PREPENDED TO C C INSERT MUST BE DECLARED INTEGER C S1 MUST BE STRING OF CHAR - LITERAL NOT ALLOWED. C S2 MUST BE STRING OF CHAR OR LITERAL. C FROM MUST BE INTEGER OR INTEGER VARIABLE. INTEGER FUNCTION INSERT ( S1, FROM, S2 ) LOGICAL * 1 S1 ( 10000 ), S2 ( 10000 ) INTEGER FROM, I, K, APPEND, LENGTH, L2 IF (.NOT.( FROM .GE. LENGTH ( S1 ) )) GOTO 20238 I = APPEND ( S1, S2, 1 ) INSERT = ( I ) RETURN 20238 CONTINUE IF (.NOT.( FROM .LT. 1 )) GOTO 20240 I = 1 GOTO 20241 20240 CONTINUE I = FROM + 1 20241 CONTINUE L2 = LENGTH ( S2 ) K = LENGTH ( S1 ) + 1 20242 IF (.NOT.( K .GT. 0 .AND. K .GE. I)) GOTO 20244 S1 ( K + L2 ) = S1 ( K ) 20243 K = K - 1 GOTO 20242 20244 CONTINUE K = 1 20245 IF (.NOT.( K .LE. L2)) GOTO 20247 S1 ( I ) = S2 ( K ) I = I + 1 20246 K = K + 1 GOTO 20245 20247 CONTINUE I = LENGTH ( S1 ) INSERT = ( I ) RETURN END C C * - LPAD - LEFT PAD BLANKS IN STRING C C FUNCTION INSERTS BLANKS AT THE BEGINNING OF (PREPENDS), C AND RETURNS NEW LENGTH OF . IF LT 1, NO BLANKS ARE C PREPENDED AND LENGTH(S1) IS UNCHANGED. C C LPAD MUST BE DECLARED INTEGER C S1 MUST BE STRING OF CHAR - LITERAL NOT ALLOWED. C N MUST BE INTEGER OR INTEGER VARIABLE. INTEGER FUNCTION LPAD ( S1, N ) LOGICAL * 1 S1 ( 10000 ) INTEGER N, LENGTH, I IF (.NOT.( N .LT. 1 )) GOTO 20248 LPAD = LENGTH ( S1 ) GOTO 20249 20248 CONTINUE CONTINUE I = LENGTH ( S1 ) + 1 20250 IF (.NOT.( I .GE. 1)) GOTO 20252 S1 ( I + N ) = S1 ( I ) 20251 I = I - 1 GOTO 20250 20252 CONTINUE DO 20253 I = 1, N S1 ( I ) = 32 20253 CONTINUE 20254 CONTINUE LPAD = LENGTH ( S1 ) 20249 CONTINUE RETURN END C * - RPAD - PAD END OF WITH BLANKS C C FUNCTION APPENDS WITH SPACES AND RETURNS NEW SIZE OF S1. C IF LT 1, FUNCTION RETURNS ORIGINAL SIZE OF WITH NO PADDING DONE. C C RPAD MUST BE DECLARED INTEGER C S1 MUST BE STRING OF CHAR - LITERAL NOT ALLOWED C N MUST BE INTEGER OR INTEGER VARIABLE. INTEGER FUNCTION RPAD ( S1, N ) LOGICAL * 1 S1 ( 10000 ) INTEGER APPEND, LENGTH IF (.NOT.( N .LT. 1 )) GOTO 20255 RPAD = LENGTH ( S1 ) GOTO 20256 20255 CONTINUE RPAD = APPEND ( S1, 32, N ) 20256 CONTINUE RETURN END C * - ALIGN - ALIGN TO RIGHT, LEFT, OR CENTER OF C C FUNCTION LEFT JUSTIFIES, RIGHT JUSTIFIES OR CENTERS IN A FIELD C OF LENGTH DEPENDING ON VALUE OF AND RETURNS NEW LENGTH C OF . THIS IS ACCOMPLISHED BY PREPENDING THE CORRECT NUMBER OF C SPACES ONTO . C C IF IS LE LENGTH(S1) FUNCTION WILL FAIL AND RETURN EOS C IF IS LT 0 WILL BE LEFT JUSTIFIED (ANY LEADING BLANKS OR TABS C WILL BE REMOVED. C IF IS EQ 0 WILL BE CENTERED ON . C IF IS GT 0 WILL BE RIGHT JUSTIFIED. C C ALIGN MUST BE DECLARED INTEGER C S1 MUST BE STRING OF CHAR - LITERAL NOT ALLOWED C FIELD MUST BE INTEGER OR INTEGER VARIABLE C POS MUST BE INTEGER OR INTEGER VARIABLE INTEGER FUNCTION ALIGN ( S1, POS, FIELD ) LOGICAL * 1 S1 ( 10000 ) INTEGER LPAD, I, J, POS, FIELD, LENGTH, SHIFT IF (.NOT.( FIELD .LE. LENGTH ( S1 ) )) GOTO 20257 ALIGN = ( 0 ) RETURN 20257 CONTINUE IF (.NOT.( POS .LT. 0 )) GOTO 20259 CONTINUE 20261 CONTINUE IF (.NOT.( S1 ( 1 ) .NE. 32 . AND . S1 ( 1 ) .NE. 9 )) GOTO 20264 GOTO 20263 20264 CONTINUE I = SHIFT ( S1, 1 ) 20265 CONTINUE 20262 IF (.NOT.( S1 ( 1 ) .EQ. 0 )) GOTO 20261 20263 CONTINUE 20259 CONTINUE IF (.NOT.( POS .EQ. 0 )) GOTO 20266 I = LENGTH ( S1 ) / 2 I = ( FIELD / 2 ) - I J = LPAD ( S1, I ) 20266 CONTINUE IF (.NOT.( POS .GT. 0 )) GOTO 20268 I = FIELD - LENGTH ( S1 ) J = LPAD ( S1, I ) 20268 CONTINUE ALIGN = LENGTH ( S1 ) RETURN END INTEGER FUNCTION ALLDIG ( STR ) INTEGER TYPE, I LOGICAL * 1 STR ( 10000 ) ALLDIG = 0 IF (.NOT.( STR ( 1 ) .EQ. 0 )) GOTO 20270 RETURN 20270 CONTINUE I = 1 20272 IF (.NOT.( STR ( I ) .NE. 0)) GOTO 20274 IF (.NOT.( TYPE ( STR ( I ) ) .NE. - 5 )) GOTO 20275 RETURN 20275 CONTINUE 20273 I = I + 1 GOTO 20272 20274 CONTINUE ALLDIG = 1 RETURN END C ## clower - change letter to lower case LOGICAL * 1 FUNCTION CLOWER ( C ) LOGICAL * 1 C, K IF (.NOT.( C .GE. 1HA .AND. C .LE. 1HZ )) GOTO 20277 K = 1Ha - 1HA CLOWER = C + K GOTO 20278 20277 CONTINUE CLOWER = C 20278 CONTINUE RETURN END LOGICAL * 1 FUNCTION CUPPER ( C ) LOGICAL * 1 C, K IF (.NOT.( C .GE. 1Ha .AND. C .LE. 1Hz )) GOTO 20279 K = 1HA - 1Ha CUPPER = C + K GOTO 20280 20279 CONTINUE CUPPER = C 20280 CONTINUE RETURN END SUBROUTINE FOLD ( TOKEN ) LOGICAL * 1 TOKEN ( 10000 ), CLOWER INTEGER I I = 1 20281 IF (.NOT.( TOKEN ( I ) .NE. 0)) GOTO 20283 TOKEN ( I ) = CLOWER ( TOKEN ( I ) ) 20282 I = I + 1 GOTO 20281 20283 CONTINUE RETURN END INTEGER FUNCTION ADDSET ( C, STR, J, MAXSIZ ) INTEGER J, MAXSIZ LOGICAL * 1 C, STR ( MAXSIZ ) IF (.NOT.( J .GT. MAXSIZ )) GOTO 20284 ADDSET = 0 GOTO 20285 20284 CONTINUE STR ( J ) = C J = J + 1 ADDSET = 1 20285 CONTINUE RETURN END INTEGER FUNCTION GETWRD ( IN, I, OUT ) LOGICAL * 1 IN ( 10000 ), OUT ( 10000 ) INTEGER I, J 20286 IF (.NOT.( IN ( I ) .EQ. 32 .OR. IN ( I ) .EQ. 9 )) GOTO 20287 I = I + 1 GOTO 20286 20287 CONTINUE J = 1 20288 IF (.NOT.( IN ( I ) .NE. 0 .AND. IN ( I ) .NE. 32 .AND. IN ( I ) $ .NE. 9 .AND. IN ( I ) .NE. 10 )) GOTO 20289 OUT ( J ) = IN ( I ) I = I + 1 J = J + 1 GOTO 20288 20289 CONTINUE OUT ( J ) = 0 GETWRD = J - 1 RETURN END SUBROUTINE PUTDEC ( N, W ) LOGICAL * 1 CHARS ( 132 ) INTEGER ITOC INTEGER I, N, ND, W ND = ITOC ( N, CHARS, 10 ) I = ND + 1 20290 IF (.NOT.( I .LE. W)) GOTO 20292 CALL PUTC ( 32 ) 20291 I = I + 1 GOTO 20290 20292 CONTINUE I = 1 20293 IF (.NOT.( I .LE. ND)) GOTO 20295 CALL PUTC ( CHARS ( I ) ) 20294 I = I + 1 GOTO 20293 20295 CONTINUE RETURN END SUBROUTINE SKIPBL ( LIN, I ) LOGICAL * 1 LIN ( 10000 ) INTEGER I 20296 IF (.NOT.( LIN ( I ) .EQ. 32 .OR. LIN ( I ) .EQ. 9 )) GOTO 20297 I = I + 1 GOTO 20296 20297 CONTINUE RETURN END C ## upper - fold all alphas to upper case SUBROUTINE UPPER ( TOKEN ) LOGICAL * 1 TOKEN ( 10000 ), CUPPER INTEGER I I = 1 20298 IF (.NOT.( TOKEN ( I ) .NE. 0)) GOTO 20300 TOKEN ( I ) = CUPPER ( TOKEN ( I ) ) 20299 I = I + 1 GOTO 20298 20300 CONTINUE RETURN END C CSUBFOR Replaces OLD by NEW in STR C INTEGER FUNCTION SUBFOR ( STR, OLD, NEW ) C LOGICAL * 1 STR ( 10000 ), OLD ( 10000 ), NEW ( 10000 ) INTEGER MATCH, LENGTH, INSERT, REMOVE, SHIFT, JUNK, LOCAT, ENDM, $LENNEW, LENOLD, START C LENNEW = LENGTH ( NEW ) LENOLD = LENGTH ( OLD ) START = 1 SUBFOR = 0 LOCAT = MATCH ( STR ( START ), OLD ) 20301 IF (.NOT.( LOCAT .NE. 0)) GOTO 20303 IF (.NOT.( LENOLD .GT. 1 )) GOTO 20304 ENDM = LOCAT + LENOLD - 1 JUNK = REMOVE ( STR ( START ), LOCAT, ENDM ) GOTO 20305 20304 CONTINUE JUNK = SHIFT ( STR ( START + LOCAT - 1 ), 1 ) 20305 CONTINUE SUBFOR = START - 1 + INSERT ( STR ( START ), LOCAT - 1, NEW ) START = START + LOCAT + LENNEW - 1 20302 LOCAT = MATCH ( STR ( START ) , OLD ) GOTO 20301 20303 CONTINUE RETURN END