C STRING LIBRARY FILE=STRLIB.RAT C#PCN #47, 4 APR 79, ADD ALLDIG,FOLD,SHELL,INDEX,TYPE,UNFOLD C C#ALLDIG - I =ALLDIG(STR) C#FOLD - CALL FOLD (STR) C#INDEX - COL =INDEX (STR, CHAR) C#SCOMPR - I =SCOMPR(STR1, STR2) C#SCOMPX - I =SCOMPX(STR1, STR2, CHAR) C#SCOPY - LEN2=SCOPY (STR1, STR2, MAX, ERROR) C#SCTOI - NUM =SCTOI (STR, NCOL) C#SDECAT - CALL SDECAT(STR1, STR2, STR3, STR4) C#SEQL - I =SEQL (STR1, STR2) C#SFIND - COL =SFIND (STR, START, STOP, CHAR) C#SHELL - CALL SHELL (LASTP, NAMPTR, TABLE) C#SINDX - COL =SINDX (STR1, STR2) C#SINSRT - CALL SINSRT(STR1, STR2) C#SITOC - LEN =SITOC (NUM, STR, MAX) C#SJOIN - LEN2=SJOIN (STR1, STR2, MAX, ERROR) C#SLEN - LEN =SLEN (STR) C#SMIDV - LEN4=SMIDV (STR1, STR2, STR3, STR4, MAX, ERROR) C#SMOVE - I =SMOVE (STR1, FROM, TO, STR2, START) C#SNUMBR - NUM =SNUMBR(STR, START, STOP, NUM, NCOL) C#SPAD - CALL SPAD (STR, LEN) C#SPOSTV - LEN3=SPOSTV(STR1, STR2, STR3, MAX, ERROR) C#SPREFX - CALL SPREFX(STR1, STR2, STR3, STR4) C#SPREV - LEN3=SPREV (STR1, STR2, STR3, MAX, ERROR) C#SREPT - LEN2=SREPT (STR1, NUM, STR2, MAX, ERROR) C#SSAME - ICOL=SSAME (STR1, STR2, LORR) C#SSAMEX - ICOL=SSAMEX(STR1, STR2, LOOR) C#SSUFX - CALL SSUFX (STR1, STR2, STR3, STR4) C#SSWAP - LEN4=SSWAP (STR1, STR2, STR3, STR4, MAX, ERROR) C#STRGET - LEN =STRGET(LUN STR, MAX) C#STRPUT - ERR =STRPUT(LUN, STR) C#STRIM - LEN =STRIM (STR) C#TYPE - C =TYPE (CHAR) C#UNFOLD - CALL UNFOLD (STR) CFILE=DEFIN.RAT ===== GENERAL CHARACTER SET DEFINITIONS =============== C C CGENERAL COMMENTS: C#ROUTINES THAT PRODUCE AN OUTPUT STRING GENERALY ALLOW A 'MAX' SIZE C FOR THE OUTPUT STRING TO BE SPECIFIED. THE OUTPUT IS CUT TO 'MAX' C CHARACTERS IF NECESSARY; IF IT IS,THE INTEGER 'ERROR' IS SET TO YES C (OTHERWISE TO NO) TO ALERT THAT TRUNCATION WAS NECESSARY. C ONE EXTRA ARRAY ELEMENT AT THE END OF THE STRING IS ALWAYS NECESSARY C (BEYOND MAX) FOR THE EOS. CSUBROUTINE CALLS SPECIFYING A SPECIFIC ARRAY ELEMENT (EG. STR(I)) CAUSE C ACTION TO BE TAKEN (AND RETURN VALUES AND MAX TO BE CALCULATED, IF C APPROPRIATE FROM THE SPECIFIED ELEMENT, NOT THE WHOLE STRING (FROM ELEMENT C 1) SINCE ONLY THE STRING STARTING AT THE SPECIFIED ELEMENT IS KNOWN C TO THE SUBROUTINE. EG J=SLEN(STRI)) SETS J TO THE NUMBER OF ELEMENTS C BETWEEN I AND EOS. C C ALLDIG - RETURN YES IF STR IS ALL DIGITS C INTEGER FUNCTION ALLDIG ( STR ) C LOGICAL * 1 STR ( 1 ), TYPE INTEGER I C ALLDIG = 0 IF(.NOT.( STR ( 1 ) .EQ. 0 )) GOTO 20000 RETURN 20000 CONTINUE DO 20002 I = 1, 32767 IF(.NOT.( STR ( I ) .EQ. 0 )) GOTO 20004 GOTO 20003 20004 CONTINUE IF(.NOT.( TYPE ( STR ( I ) ) .NE. - 20 )) GOTO 20006 RETURN 20006 CONTINUE 20005 CONTINUE 20002 CONTINUE 20003 CONTINUE ALLDIG = 1 C RETURN END C C FOLD TO CONVERT TOKENS TO LOWER CASE C15MAY77 C SUBROUTINE FOLD ( TOKEN ) C LOGICAL * 1 TOKEN ( 1 ) INTEGER I C DO 20008 I = 1, 32767 IF(.NOT.( TOKEN ( I ) .EQ. 0 )) GOTO 20010 RETURN 20010 CONTINUE IF(.NOT.( TOKEN ( I ) .GE. 65 .AND. TOKEN ( I ) .LE. 90 )) GOTO $20012 TOKEN ( I ) = TOKEN ( I ) + 32 20012 CONTINUE 20011 CONTINUE C 20008 CONTINUE 20009 CONTINUE RETURN END C C INDEX - FIND CHARACTER C IN STRING STR C15MAY77 C INTEGER FUNCTION INDEX ( STR, C ) C LOGICAL * 1 C, STR ( 1 ) C DO 20014 INDEX = 1, 32767 IF(.NOT.( STR ( INDEX ) .EQ. 0 )) GOTO 20016 GOTO 20015 20016 CONTINUE IF(.NOT.( STR ( INDEX ) .EQ. C )) GOTO 20018 RETURN 20018 CONTINUE 20017 CONTINUE 20014 CONTINUE 20015 CONTINUE INDEX = 0 C RETURN END C C SCOMM - USED BY SDECAT, SSUFX, SPREFX C SUBROUTINE SCOMM ( I, STR1, STR3, STR4 ) C INTEGER I, SMOVE, J LOGICAL * 1 STR1 ( 1 ), STR3 ( 1 ), STR4 ( 1 ) C J = SMOVE ( STR1, 1, I - 1, STR3, 1 ) STR3 ( J + 1 ) = 0 J = SMOVE ( STR1, I, 32767, STR4, 1 ) STR4 ( J + 1 ) = 0 C RETURN END C C SCOMPR - COMPARE TWO STRINGS ALPHABETICALY CRETURN 0 IF EQUAL CRETURN -1 IF STR1 IS CLOSER TO 'A' THEN STR2 CRETURN +1 IF STR1 IS CLOSER TO 'Z' THEN STR2 C INTEGER FUNCTION SCOMPR ( STR1, STR2 ) C INTEGER I, J LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ) C J = 1 I = 1 20020 IF(.NOT.( STR1 ( I ) .EQ. STR2 ( J ))) GOTO 20022 IF(.NOT.( STR1 ( I ) .EQ. 0 )) GOTO 20023 SCOMPR = 0 RETURN 20023 CONTINUE J = J + 1 C 20024 CONTINUE 20021 I = I + 1 GOTO 20020 20022 CONTINUE IF(.NOT.( STR1 ( I ) .LT. STR2 ( J ) )) GOTO 20025 SCOMPR = - 1 GOTO 20026 20025 CONTINUE SCOMPR = + 1 C 20026 CONTINUE RETURN END C C SCOMPX - COMPARE 2 SPECIAL STRINGS ALPHABETICALLY CCOMPAR THE SECTIONS OF 2 STRINGS BEFORE AND AFTER THE 'CHAR' SEPERATOR C INDEPENDENTLY. 0 IS RETURNED IF THE FIRST PART (UP TO 'CHAR')MATCHES C AND THE SECOND PART (FROM 'CHAR' TO EOS) MATCHES. C INTEGER FUNCTION SCOMPX ( STR1, STR2, CHAR ) C CRETURNS -1 IF STR1 IS HIGHER ALPHABETICALLY THEN STR2 CRETURNS 0 IF STR1 IS EQUAL TO STR2 CRETURNS +1 IF STR1 IS LOWER ALPHABETICALLY THEN STR2 C INTEGER I, J LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ), CHAR C J = 1 I = 1 20027 IF(.NOT.( STR1 ( I ) .NE. 0 .AND. STR2 ( J ) .NE. 0)) GOTO 20029 IF(.NOT.( STR1 ( I ) .EQ. CHAR )) GOTO 20030 CONTINUE 20032 IF(.NOT.( STR2 ( J ) .NE. CHAR .AND. STR2 ( J + 1 ) .NE. 0 )) $GOTO 20033 J = J + 1 GOTO 20032 20033 CONTINUE GOTO 20031 20030 CONTINUE IF(.NOT.( STR2 ( J ) .EQ. CHAR )) GOTO 20034 CONTINUE 20036 IF(.NOT.( STR1 ( I ) .NE. CHAR .AND. STR1 ( I + 1 ) .NE. 0 )) $GOTO 20037 I = I + 1 GOTO 20036 20037 CONTINUE GOTO 20035 20034 CONTINUE IF(.NOT.( STR1 ( I ) .NE. STR2 ( J ) )) GOTO 20038 IF(.NOT.( STR1 ( I ) .LT. STR2 ( J ) )) GOTO 20040 SCOMPX = - 1 GOTO 20041 20040 CONTINUE SCOMPX = 1 20041 CONTINUE RETURN 20038 CONTINUE 20035 CONTINUE 20031 CONTINUE J = J + 1 20028 I = I + 1 GOTO 20027 20029 CONTINUE SCOMPX = 0 C RETURN END C C SCOPY - COPY ONE STRING INTO ANOTHER STRING CCOPYING STOPS WHEN THE END OF STR1 IS REACHED, OR WHEN C STR2 GETS TO BE 'MAX' CHAR. LONG (ERROR IS SET). C VALUE OF THE FUCTION IS RETURNED AS THE LENGTH OF STR2. C INTEGER FUNCTION SCOPY ( STR1, STR2, MAX, ERROR ) C INTEGER MAX, ERROR, I LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ) C SCOPY = 0 ERROR = 0 DO 20042 I = 1, 32767 IF(.NOT.( STR1 ( I ) .EQ. 0 )) GOTO 20044 GOTO 20043 20044 CONTINUE IF(.NOT.( SCOPY .GE. MAX )) GOTO 20046 ERROR = 1 GOTO 20043 20046 CONTINUE SCOPY = SCOPY + 1 STR2 ( SCOPY ) = STR1 ( I ) 20047 CONTINUE 20045 CONTINUE C 20042 CONTINUE 20043 CONTINUE STR2 ( SCOPY + 1 ) = 0 C RETURN END C C SCTOI - CONVERT STRING AT IN(I) TO INTEGER, INCREMENT I CSTARTING AT LOCATION 'I', LEADING BLANKS/TABS ARE SKIPPED; C THEN ALL DIGITS UP TO THE NEXT NON-DIGIT (INCLUDING BLANKS) C ARE CONVERTED TO A POSITIVE OR NEGATIVE INTEGER AND RETURNED C AS THE VALUE OF THE FUNCTION. 'I' IS INCREMENTED AND UPON RETURN C POINTS TO THE LOCATION OF THE FIRST NON-DIGIT. C INTEGER FUNCTION SCTOI ( IN, I ) C LOGICAL * 1 IN ( 1 ) INTEGER D, I, SFIND, PM LOGICAL * 1 DIGITS (11) C DATA DIGITS/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,0/ 20048 IF(.NOT.( IN ( I ) .EQ. 32 .OR. IN ( I ) .EQ. 9 )) GOTO 20049 I = I + 1 GOTO 20048 20049 CONTINUE IF(.NOT.( IN ( I ) .EQ. 45 )) GOTO 20050 I = I + 1 PM = - 1 GOTO 20051 20050 CONTINUE PM = + 1 C 20051 CONTINUE SCTOI = 0 20052 IF(.NOT.( IN ( I ) .NE. 0)) GOTO 20054 D = SFIND ( DIGITS, 1, 10, IN ( I ) ) IF(.NOT.( D .EQ. 0 )) GOTO 20055 GOTO 20054 20055 CONTINUE SCTOI = 10 * SCTOI + D - 1 C 20053 I = I + 1 GOTO 20052 20054 CONTINUE IF(.NOT.( PM .LT. 0 )) GOTO 20057 SCTOI = - SCTOI 20057 CONTINUE RETURN END C C SDECAT - BREAK A STRING INTO TWO SUBSTRINGS AT A CHARACTER CSTR1 IS BROKEN INTO STR3 AND STR4 AT THE LEFTMOST OCCURRANCE (IN STR1) OF C ANY CHARACTER THAT IS ALSO ANYWHERE IN STR2. THE "BREAK CHARACTER" C GOES INTO STR4. C SUBROUTINE SDECAT ( STR1, STR2, STR3, STR4 ) C INTEGER I, J, SSAME, SLEN LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ), STR3 ( 1 ), STR4 ( 1 ) C I = SSAME ( STR1, STR2, + 1 ) IF(.NOT.( I .LE. 0 )) GOTO 20059 I = SLEN ( STR1 ) + 1 20059 CONTINUE CALL SCOMM ( I, STR1, STR3, STR4 ) C RETURN END C C SEQL - COMPARE STR1 TO STR2; RETURN YES IF EQUAL, CSTR1 IS COMPARED CHARACTER BY CHARACTER TO STR2; IF THEY MATCH ALL THE WAY C THRU, THE FUNCTION VALUE IS RETURNED AS 'YES', IF NOT, AS 'NO'. C INTEGER FUNCTION SEQL ( STR1, STR2 ) C LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ) INTEGER I C DO 20061 I = 1, 32767 IF(.NOT.( STR1 ( I ) .NE. STR2 ( I ) )) GOTO 20063 GOTO 20062 20063 CONTINUE IF(.NOT.( STR1 ( I ) .EQ. 0 )) GOTO 20065 SEQL = 1 RETURN 20065 CONTINUE 20064 CONTINUE 20061 CONTINUE 20062 CONTINUE SEQL = 0 C RETURN END C C SHELL - TO SORT DEFINE TABLE INTO ALPHABETICAL ORDER FOR RATFOR CSYKES 18 OCT 76,14MAR77 C SUBROUTINE SHELL ( LASTP, NAMPTR, TABLE ) C INTEGER GAP, I, IG, J, K, SCOMPR, N INTEGER LASTP, NAMPTR ( 1 ) LOGICAL * 1 TABLE ( 1 ) C GAP = LASTP / 2 20067 IF(.NOT.( GAP .GT. 0)) GOTO 20069 CONTINUE J = GAP + 1 20070 IF(.NOT.( J .LE. LASTP)) GOTO 20072 CONTINUE I = J - GAP 20073 IF(.NOT.( I .GT. 0)) GOTO 20075 IG = I + GAP IF(.NOT.( SCOMPR ( TABLE ( NAMPTR ( I ) ), TABLE ( NAMPTR ( IG ) $) ) .LE. 0 )) GOTO 20076 GOTO 20075 20076 CONTINUE N = NAMPTR ( I ) NAMPTR ( I ) = NAMPTR ( IG ) NAMPTR ( IG ) = N C 20074 I = I - GAP GOTO 20073 20075 CONTINUE 20071 J = J + 1 GOTO 20070 20072 CONTINUE 20068 GAP = GAP / 2 GOTO 20067 20069 CONTINUE RETURN END C C SINDX - FIND A STRING WITHIN ANOTHER STRING CFUNCTION VALUE IS RETURNED AS THE LOCATION WITHIN STR WHERE C PATN STARTS; OR AS 0, IF PATN DOES NOT OCCUR IN STR. C IF PATN IS NULL, IT IS CONSIDERED TO MATCH AT LOCATION 1. C INTEGER FUNCTION SINDX ( STR, PATN ) C INTEGER J, K LOGICAL * 1 STR ( 1 ), PATN ( 1 ) C SINDX = 1 20078 IF(.NOT.( STR ( SINDX ) .NE. 0)) GOTO 20080 K = SINDX CONTINUE J = 1 20081 IF(.NOT.( PATN ( J ) .NE. 0)) GOTO 20083 IF(.NOT.( PATN ( J ) .NE. STR ( K ) )) GOTO 20084 GOTO 20083 20084 CONTINUE K = K + 1 20085 CONTINUE 20082 J = J + 1 GOTO 20081 20083 CONTINUE IF(.NOT.( PATN ( J ) .EQ. 0 )) GOTO 20086 RETURN 20086 CONTINUE IF(.NOT.( STR ( K ) .EQ. 0 )) GOTO 20088 GOTO 20080 20088 CONTINUE 20087 CONTINUE 20079 SINDX = SINDX + 1 GOTO 20078 20080 CONTINUE SINDX = 0 C RETURN END C C SFIND - FAST SEARCH OF A STRING FOR A CHARACTER CSEARCHES A STRING EITHER FROM LEFT TO RIGHT OR RIGHT TO LEFT, C DEPENDING ON THE RELATIVE VALUES OF START AND STOP, FOR A SPECIFIED C CHARACTER AND RETURNS AS THE FUNCTION VALUE THE COLUMN IN STR WHERE C THE FIRST MATCH IS FOUND; OR AS 0, IF NO CHARACTER IN STR MATCHES CHAR. C THIS IS NOT ANSII FORTRAN BECAUSE OF THE BACKWARD INCREMENT ON THE DO LOOP C BUT IN F4P IS SOMEWHAT FASTER THE STANDARD ROUTINES. C INTEGER FUNCTION SFIND ( STR, START, STOP, CHAR ) C INTEGER START, STOP, I LOGICAL * 1 STR ( 1 ), CHAR C IF(.NOT.( START .GT. STOP )) GOTO 20090 I = - 1 GOTO 20091 20090 CONTINUE I = + 1 20091 CONTINUE DO 20092 SFIND = START, STOP, I IF(.NOT.( STR ( SFIND ) .EQ. CHAR )) GOTO 20094 RETURN 20094 CONTINUE 20092 CONTINUE 20093 CONTINUE SFIND = 0 C RETURN END C C SINSRT - INSERT A STRING INTO ANOTHER STRING CCOPY ALL OF STR1 INTO STR2; IF THIS OVERRUNS THE END OF STR2, C MAKE STR2 LONGER TO HOLD ALL OF STR1. C SUBROUTINE SINSRT ( STR1, STR2 ) C INTEGER I, ENDS LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ) C ENDS = 0 I = 1 20096 IF(.NOT.( STR1 ( I ) .NE. 0)) GOTO 20098 IF(.NOT.( STR2 ( I ) .EQ. 0 )) GOTO 20099 ENDS = 1 20099 CONTINUE STR2 ( I ) = STR1 ( I ) 20097 I = I + 1 GOTO 20096 20098 CONTINUE IF(.NOT.( ENDS .EQ. 1 )) GOTO 20101 STR2 ( I ) = 0 C 20101 CONTINUE RETURN END C C SITOC - CONVERT INTEGER INT TO CHAR STRING IN STR LEFT JUSTIFIED CCONVERT THE POSITIVE OR NEGATIVE INTEGER 'INT' TO A CHARACTER STRING C IN 'STR'. TRUNCATE THE STRING IF IT GOES BEYOND 'SIZE' CHARACTERS. C RETURN THE ACTUAL NUMBER OF CHARACTERS IN 'STR' AS THE VALUE OF THE FUNCTION. C INTEGER FUNCTION SITOC ( INT, STR, SIZE ) C INTEGER IABS, MOD INTEGER D, I, INT, INTVAL, J, K, SIZE LOGICAL * 1 STR ( SIZE ) LOGICAL * 1 DIGITS (11) C DATA DIGITS/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,0/ INTVAL = IABS ( INT ) STR ( 1 ) = 0 I = 1 20103 CONTINUE I = I + 1 D = MOD ( INTVAL, 10 ) STR ( I ) = DIGITS ( D + 1 ) INTVAL = INTVAL / 10 20104 IF(.NOT.( INTVAL .EQ. 0 .OR. I .GE. SIZE )) GOTO 20103 20105 CONTINUE IF(.NOT.( INT .LT. 0 .AND. I .LT. SIZE )) GOTO 20106 I = I + 1 STR ( I ) = 45 20106 CONTINUE SITOC = I - 1 J = 1 20108 IF(.NOT.( J .LT. I)) GOTO 20110 K = STR ( I ) STR ( I ) = STR ( J ) STR ( J ) = K I = I - 1 C 20109 J = J + 1 GOTO 20108 20110 CONTINUE RETURN END C C SJOIN - CONCATINATE A STRING TO THE END OF ANOTHER STRING, CADD STR2 TO THE END OF STR1 (IN STR1). MOVE ALL OF STR2 OR UNTIL C STR1 IS 'MAX' CHARS LONG (IN WHICH CASE, SET ERROR=YES) C RETURN THE VALUE OF THE FUNCTION AS THE NEW LENGTH OF STR1. C INTEGER FUNCTION SJOIN ( STR1, STR2, MAX, ERROR ) C INTEGER MAX, ERROR, I, SLEN, SCOPY LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ) C I = SLEN ( STR1 ) SJOIN = SCOPY ( STR2, STR1 ( I + 1 ), MAX - I, ERROR ) + I C RETURN END C C SLEN - COMPUTE LENGTH OF STRING (NOT INCLUDING THE EOS) C INTEGER FUNCTION SLEN ( STR ) C LOGICAL * 1 STR ( 1 ) C DO 20111 SLEN = 1, 32767 IF(.NOT.( STR ( SLEN ) .EQ. 0 )) GOTO 20113 GOTO 20112 20113 CONTINUE 20111 CONTINUE 20112 CONTINUE SLEN = SLEN - 1 C RETURN END C C SMIDV - SELECT THE MIDDLE OF A STRING CMOVE THE CHARACTERS IN STR1 THAT ARE BETWEEN STR2 AND STR3 (IN STR1) C INTO STR4. TRUNCATE STR4 TO 'MAX' CHARS (AND SET ERROR) IF NECESSARY. C THE VALUE OF THE FUNCTION IS RETURNED AS THE ACTUAL LENGTH OF STR4. C IF EITHER STR2 OR STR3 ARE NOT IN STR1, STR4 IS NULL. C INTEGER FUNCTION SMIDV ( STR1, STR2, STR3, STR4, MAX, ERROR ) C INTEGER MAX, ERROR INTEGER SLEN, SINDX, SMOVE, J, I LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ), STR3 ( 1 ), STR4 ( 1 ) C I = SINDX ( STR1, STR2 ) IF(.NOT.( I .GT. 0 )) GOTO 20115 I = I + SLEN ( STR2 ) J = SINDX ( STR1 ( I ), STR3 ) 20115 CONTINUE IF(.NOT.( I .GT. 0 .AND. J .GT. 0 )) GOTO 20117 IF(.NOT.( J .LE. MAX )) GOTO 20119 J = I + J - 2 ERROR = 0 GOTO 20120 20119 CONTINUE ERROR = 1 J = I + MAX - 1 20120 CONTINUE SMIDV = SMOVE ( STR1, I, J, STR4, 1 ) STR4 ( SMIDV + 1 ) = 0 GOTO 20118 20117 CONTINUE ERROR = 0 SMIDV = 0 STR4 ( 1 ) = 0 C 20118 CONTINUE RETURN END C C SMOVE - MOVE CHARACTERS FROM ONE STRING TO ANOTHER CMOVE THE CHARACTERS IN STR1 BETWEEN 'FROM' & 'TO' (INCLUSIVE) C TO STR2, STARTING AT LOCATION 'START'. NO EOS IS PLACED AT THE C END OF THE MOVED CHARACTERS, SO THEY MUST NOT EXTEND STR2. C IF THE END OF STR1 IS REACHED BEFORE LOCATION 'TO', THE TRANSFER C IS ABORTED. THE VALUE OF THE FUNCTION IS RETURNED AS THE LAST C (RIGHTMOST) LOCATION IN STR2 MODIFIED. C INTEGER FUNCTION SMOVE ( STR1, FROM, TO, STR2, START ) C INTEGER FROM, TO, START, I LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ) C SMOVE = START - 1 DO 20121 I = FROM, TO IF(.NOT.( STR1 ( I ) .EQ. 0 )) GOTO 20123 GOTO 20122 20123 CONTINUE SMOVE = SMOVE + 1 STR2 ( SMOVE ) = STR1 ( I ) 20124 CONTINUE 20121 CONTINUE 20122 CONTINUE IF(.NOT.( SMOVE .LT. START )) GOTO 20125 SMOVE = 0 C 20125 CONTINUE RETURN END C C SNUMBR - FUNCTION TO CONVERT A CHARACTER STRING TO AN INTEGER C CSTARTING AT 'START', EXTRACT A INTEGER FROM 'STR' AND RETURN C IT AS THE VALUE OF THE FUNCTION AND AS 'NUM'; IGNORE BLANKS, BUT QUIT AT THE C FIRST NON-DIGIT/BLANK FOUND, BUT IN ANY CASE DO NOT GO PAST COL. 'STOP'. C RETURN IN 'NCOL' THE NUMBER OF THE NEXT COLUMN TO THE RIGHT IN 'STR'. C INTEGER FUNCTION SNUMBR ( STR, START, STOP, NUM, NCOL ) C INTEGER START, STOP, NUM, I, J, SCTOI, NCOL LOGICAL * 1 STR ( 1 ), TOK ( 7 ), TYPE C J = 1 I = START 20127 IF(.NOT.( J .LE. 7 .AND. I .LE. STOP)) GOTO 20129 IF(.NOT.( STR ( I ) .EQ. 32 )) GOTO 20130 GOTO 20128 20130 CONTINUE IF(.NOT.( TYPE ( STR ( I ) ) .NE. - 20 .AND. STR ( I ) .NE. 45 )) $ GOTO 20132 GOTO 20129 20132 CONTINUE TOK ( J ) = STR ( I ) J = J + 1 20133 CONTINUE 20131 CONTINUE 20128 I = I + 1 GOTO 20127 20129 CONTINUE TOK ( J ) = 0 NCOL = I I = 1 NUM = SCTOI ( TOK, I ) SNUMBR = NUM C RETURN END C C SPAD - FILL A STRING UP TO A SPECIFIED LENGTH WITH BLANKS CPAD THE RIGHTHAND END OF STR WITH BLANKS OUT TO 'LEN'. C STR BECOMES A STRING OF LENGTH 'LEN'. C SUBROUTINE SPAD ( STR, LEN ) C INTEGER LEN, SLEN, I LOGICAL * 1 STR ( 1 ) C I = SLEN ( STR ) + 1 20134 IF(.NOT.( I .LE. LEN)) GOTO 20136 STR ( I ) = 32 20135 I = I + 1 GOTO 20134 20136 CONTINUE STR ( LEN + 1 ) = 0 C RETURN END C C SPOSTV - SELECT THE RIGHT END OF A STRING CMOVE INTO STR3 ALL OF STR1 TO THE RIGHT OF THE END OF STR2(WITHIN STR1) C BUT TRUNCATE STR3 TO 'MAX' CHARS (AND SET ERROR) IF NECESSARY. C THE VALUE OF THE FUNCTION IS RETURNED AS THE ACUTAL NEW LENGTH OF STR3 C STR3 IS NULL IF STR2 IS NOT FOUND WITHIN STR1. C IF STR2 IS NULL, ALL OF STR1 GOES TO STR3. C INTEGER FUNCTION SPOSTV ( STR1, STR2, STR3, MAX, ERROR ) C INTEGER MAX, ERROR, I, SCOPY, SINDX, SLEN LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ), STR3 ( 1 ) C I = SINDX ( STR1, STR2 ) IF(.NOT.( I .LE. 0 )) GOTO 20137 STR3 ( 1 ) = 0 ERROR = 0 SPOSTV = 0 GOTO 20138 20137 CONTINUE I = I + SLEN ( STR2 ) SPOSTV = SCOPY ( STR1 ( I ), STR3, MAX, ERROR ) C 20138 CONTINUE RETURN END C C SPREFX - SEPERATE OUT A PREFIX CMOVE INTO STR3 THAT PART OF STR1 WHICH IS TO THE LEFT OF THE FIRST CHAR ALSO C FOUND (ANYWHERE) IN STR2. MOVE INTO STR4 THE REST OF STR1. STR3 AND STR4 ARE C NEW STRINGS. THE LEFTMOST OCCURRANCE IN STR1 OF ANY CHAR IN STR2 IS THE C "BREAK POINT". THE PIVOT CHARACTER GOES INTO STR4. C IF NONE IS FOUND IN STR2, ALL OF STR1 IS MOVED INTO STR4 AND STR3 IS NULL. C SUBROUTINE SPREFX ( STR1, STR2, STR3, STR4 ) C INTEGER I, SSAME LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ), STR3 ( 1 ), STR4 ( 1 ) C I = SSAME ( STR1, STR2, + 1 ) IF(.NOT.( I .LE. 0 )) GOTO 20139 I = 1 20139 CONTINUE CALL SCOMM ( I, STR1, STR3, STR4 ) C RETURN END C C SPREV - SELECT THE LEFT END OF A STRING CMOVE THE PART OF STR1 BEFORE THE START OF STR2 INTO STR3. C TRUNCATE STR3 TO 'MAX' CHARS (AND SET ERROR) IF NECESSARY. C THE VALUE OF THE FUNCTION IS RETURNED AS THE LENGTH OF STR3. C STR3 IS NULL IF STR2 IS NOT FOUND WITHIN STR1. C IF STR2 IS NULL, ALL OF STR1 GOES TO STR3. C INTEGER FUNCTION SPREV ( STR1, STR2, STR3, MAX, ERROR ) C INTEGER MAX, ERROR, I, SINDX, SMOVE LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ), STR3 ( 1 ) C I = SINDX ( STR1, STR2 ) IF(.NOT.( I .LE. 0 )) GOTO 20141 STR3 ( 1 ) = 0 ERROR = 0 SPREV = 0 GOTO 20142 20141 CONTINUE I = I - 1 IF(.NOT.( I .LE. MAX )) GOTO 20143 ERROR = 0 GOTO 20144 20143 CONTINUE I = MAX ERROR = 1 20144 CONTINUE SPREV = SMOVE ( STR1, 1, I, STR3, 1 ) STR3 ( SPREV + 1 ) = 0 C 20142 CONTINUE RETURN END C C SREPT - DUPLICATE A STRING INTO ANOTHER STRING CFILL STR2 WITH 'NUM' CONCATINATED COPIES OF STR1, BUT TRUNCATE C STR2 AT 'MAX' CHAR(AND SET ERROR) IF NECESSARY. C THE VALUE OF THE FUNCTION IS RETURNED AS THE ACUTAL NEW C LENGTH OF STR2. C INTEGER FUNCTION SREPT ( STR1, NUM, STR2, MAX, ERROR ) C INTEGER NUM, MAX, ERROR, SCOPY, I LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ) C SREPT = 0 I = 1 20145 IF(.NOT.( I .LE. NUM)) GOTO 20147 SREPT = SCOPY ( STR1, STR2 ( SREPT + 1 ), MAX - SREPT, ERROR ) + $SREPT IF(.NOT.( ERROR .EQ. 1 )) GOTO 20148 GOTO 20147 20148 CONTINUE C 20146 I = I + 1 GOTO 20145 20147 CONTINUE RETURN END C C SSAME - FIND FIRST CHARACTER IN STR1 ALSO IN STR2 CSCAN STR1 FROM LEFT TO RIGHT (IF LORR IS >0) OR FROM RIGHT TO LEFT C (IF LTOR IS <0) AND RETURN THE VALUE OF THE FUNCTION AS THE POSITION C IN STR1 WHERE THE FIRST CHARACTER IS FOUND THAT IS ALSO ANYWHERE IN STR2, C OR AS 0, IF NO CHARACTERS IN STR1 ARE FOUND IN STR2. C INTEGER FUNCTION SSAME ( STR1, STR2, LORR ) C INTEGER LORR, SLEN, I LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ) C IF(.NOT.( LORR .GT. 0 )) GOTO 20150 SSAME = 1 GOTO 20151 20150 CONTINUE SSAME = SLEN ( STR1 ) 20151 CONTINUE 20152 IF(.NOT.( SSAME .GT. 0 .AND. STR1 ( SSAME ) .NE. 0 )) GOTO 20153 CONTINUE I = 1 20154 IF(.NOT.( STR2 ( I ) .NE. 0)) GOTO 20156 IF(.NOT.( STR1 ( SSAME ) .EQ. STR2 ( I ) )) GOTO 20157 RETURN 20157 CONTINUE 20155 I = I + 1 GOTO 20154 20156 CONTINUE IF(.NOT.( LORR .GT. 0 )) GOTO 20159 SSAME = SSAME + 1 GOTO 20160 20159 CONTINUE SSAME = SSAME - 1 20160 CONTINUE GOTO 20152 20153 CONTINUE SSAME = 0 C RETURN END C C SSAMEX - FIND FIRST CHARACTER IN STR1 NOT ALSO IN STR2 CSCAN STR1 FROM THE LEFT (IF LORR > 0) OR FROM THE RIGHT (IF LOOR <0) C AND RETURN THE VALUE OF THE FUNCTION AS THE LOCATION WITHIN STR1 OF C THE FIRST CHARACTER NOT FOUND (ANYWHERE) IN STR2 , OR AS 0, C IF EVERYTHING IN STR1 IS IN STR2. C INTEGER FUNCTION SSAMEX ( STR1, STR2, LOOR ) C INTEGER I, LOOR, SLEN LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ) C IF(.NOT.( LORR .GT. 0 )) GOTO 20161 SSAMEX = 1 GOTO 20162 20161 CONTINUE SSAMEX = SLEN ( STR1 ) 20162 CONTINUE 20163 IF(.NOT.( SSAMEX .GT. 0 .AND. STR1 ( SSAMEX ) .NE. 0 )) GOTO $20164 CONTINUE I = 1 20165 IF(.NOT.( STR2 ( I ) .NE. 0)) GOTO 20167 IF(.NOT.( STR1 ( SSAMEX ) .EQ. STR2 ( I ) )) GOTO 20168 GOTO 20167 20168 CONTINUE 20166 I = I + 1 GOTO 20165 20167 CONTINUE IF(.NOT.( STR2 ( I ) .EQ. 0 )) GOTO 20170 RETURN 20170 CONTINUE IF(.NOT.( LORR .GT. 0 )) GOTO 20172 SSAMEX = SSAMEX + 1 GOTO 20173 20172 CONTINUE SSAMEX = SSAMEX - 1 20173 CONTINUE 20171 CONTINUE GOTO 20163 20164 CONTINUE SSAMEX = 0 C RETURN END C C SSUFX - SEPERATE OUT A SUFFEX CMOVE CHARACTERS FROM STR1 INTO STR3 WHICH ARE TO THE RIGHT OF THE FIRST C OCCURANCE OF ANY CHARACTER FROM STR2 IN STR1, SCANNING RIGHT-TO-LEFT. C MOVE THE REMAINDER OF STR1 INTO STR4. FIRST CHARACTER IN STR1 TO MATCH C ANY CHARACTER IN STR2 IS THE "BREAK CHAR", AND IT GOES INTO STR4. C IF NONE IS FOUND IS STR2, ALL OF STR1 GOES INTO STR4 AND STR3 IS NULL. C SUBROUTINE SSUFX ( STR1, STR2, STR3, STR4 ) C INTEGER I, SSAME, SLEN LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ), STR3 ( 1 ), STR4 ( 1 ) C I = SSAME ( STR1, STR2, - 1 ) IF(.NOT.( I .LE. 0 )) GOTO 20174 I = SLEN ( STR1 ) 20174 CONTINUE I = I + 1 C CALL SCOMM ( I, STR1, STR4, STR3 ) C RETURN END C C SSWAP - EXCHANGE PART OF A STRING FOR ANOTHER STRING CMOVE STR1 INTO STR4, EXCEPT THAT THE PART OF STR1 THAT MATCHES STR2 C IS REPLACED BY STR3. THE VALUE OF THE FUNCTION IS RETURNED AS THE C ACTUAL LENGTH OF STR4, OR AS 0, IF STR2 CANNOT BE FOUND. STR4 IS TRUNCATED C TO 'MAX' (AND ERROR IS SET) IF NECESSARY. C ONCE STR4 REACHES 'MAX' LENGTH, SJOIN WILL NOT ADD TO IT. C INTEGER FUNCTION SSWAP ( STR1, STR2, STR3, STR4, MAX, ERROR ) C INTEGER MAX, ERROR, SINDX, SJOIN, SMOVE, I, SLEN LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ), STR3 ( 1 ), STR4 ( 1 ) C I = SINDX ( STR1, STR2 ) IF(.NOT.( I .LE. 0 )) GOTO 20176 STR4 ( 1 ) = 0 ERROR = 0 SSWAP = 0 GOTO 20177 20176 CONTINUE IF(.NOT.( I .GT. MAX )) GOTO 20178 ERROR = 1 I = MAX + 1 GOTO 20179 20178 CONTINUE ERROR = 0 20179 CONTINUE SSWAP = SMOVE ( STR1, 1, I - 1, STR4, 1 ) STR4 ( SSWAP + 1 ) = 0 SSWAP = SJOIN ( STR4, STR3, MAX, ERROR ) I = I + SLEN ( STR2 ) SSWAP = SJOIN ( STR4, STR1 ( I ), MAX, ERROR ) C 20177 CONTINUE RETURN END C C STRGET - READ A STRING FROM A SPECIFIED LUN C INTEGER FUNCTION STRGET ( LUN, STR, MAX ) C INTEGER LUN, MAX, N LOGICAL * 1 STR ( MAX ) C READ ( LUN, 1, END = 100, ERR = 101 ) STRGET, ( STR ( N ), N = 1, $ MAX ) 1 FORMAT ( Q, 132A1 ) STR ( STRGET + 1 ) = 0 RETURN C 100 STRGET = - 3 STR ( 1 ) = 0 RETURN C 101 STRGET = - 1 STR ( 1 ) = 0 RETURN C END C C STRPUT - WRITE A STRING TO A SPECIFIED LUN C INTEGER FUNCTION STRPUT ( LUN, STR ) C INTEGER LUN, I, N, SLEN, MIN0 LOGICAL * 1 STR ( 1 ) C I = MIN0 ( 132, SLEN ( STR ) ) IF(.NOT.( I .GT. 0 )) GOTO 20180 WRITE ( LUN, 1, ERR = 11, END = 11 ) ( STR ( N ), N = 1, I ) 1 FORMAT ( 1X, 132A1 ) GOTO 20181 20180 CONTINUE WRITE ( LUN, 1, ERR = 11, END = 11 ) 20181 CONTINUE STRPUT = 1 RETURN C 11 STRPUT = - 1 RETURN END C C STRIM - REMOVE TRAILING BLANKS FROM THE RIGHT END OF A STRING CREMOVE ANY TRAILING BLANKS FROM THE RIGHT OF STR. THE VALUE OF THE C FUNCTION IS RETURNED AS THE NEW LENGTH OF STR. C INTEGER FUNCTION STRIM ( STR ) C INTEGER SLEN LOGICAL * 1 STR ( 1 ) C STRIM = SLEN ( STR ) 20182 IF(.NOT.( STRIM .GT. 0 .AND. STR ( STRIM ) .EQ. 32 )) GOTO 20183 STRIM = STRIM - 1 GOTO 20182 20183 CONTINUE STR ( STRIM + 1 ) = 0 C RETURN END C C TYPE - RETURN LETTER, DIGIT, OR CHARACTER TYPE C SYKES 14 OCT 76, FASTER VERSION C THIS ONE WORKS IF INTERNAL CHAR. SET IS ASCII C LOGICAL FUNCTION TYPE * 1 ( C ) C LOGICAL * 1 C, TYPES ( 75 ) DATA TYPES / 10 * - 20, 7 * 0, 26 * - 30, 6 * 0, 26 * - 30 / C IF(.NOT.( C .LE. 122 .AND. C .GE. 48 )) GOTO 20184 TYPE = TYPES ( C - 47 ) GOTO 20185 20184 CONTINUE TYPE = 0 20185 CONTINUE IF(.NOT.( TYPE .EQ. 0 )) GOTO 20186 TYPE = C C 20186 CONTINUE RETURN END C C UNFOLD - CONVERT A STRING TO UPPER CASE CSYKES 15MAY77 C WORKS ONLY IF INTERNAL CHARACTER SET IS ASCII C SUBROUTINE UNFOLD ( STR ) C LOGICAL * 1 STR ( 1 ) INTEGER I C DO 20188 I = 1, 32767 IF(.NOT.( STR ( I ) .EQ. 0 )) GOTO 20190 RETURN 20190 CONTINUE IF(.NOT.( STR ( I ) .GE. 97 .AND. STR ( I ) .LE. 122 )) GOTO $20192 STR ( I ) = STR ( I ) - 32 20192 CONTINUE 20191 CONTINUE C 20188 CONTINUE 20189 CONTINUE RETURN END