00040036C STRING LIBRARY	FILE=STRLIB.RAT0064C PCN #47, 4 APR 79, ADD ALLDIG,FOLD,SHELL,INDEX,TYPE,UNFOLD0057C PCN #89, 10 FEB 80, SPEED UP SCOPY,SPAD,SCOMPR,TYPE0005C0073C EDITED TO PUT SUBPROGRAM DECLARATIONS IN FRONT OF COMMENTS FOR THAT0075C SUBPROGRAM.  THIS ALLOWS F4 V2.2 TO KEEP COMMENTS IN THE RIGHT PLACE.0015C BOB DENNY0015C 25-MAR-800005C0005C0032C# ALLDIG - I   =ALLDIG(STR)0032C# FOLD   - CALL FOLD  (STR)0040C# EQLS   - I   =EQLS  (VEC, PATSTR)0038C# INDEX  - COL =INDEX (STR, CHAR)^^^^^^^^^^^^^^^^0039C# SCOMPR - I   =SCOMPR(STR1, STR2)0045C# SCOMPX - I   =SCOMPX(STR1, STR2, CHAR)0051C# SCOPY  - LEN2=SCOPY (STR1, STR2, MAX, ERROR)0038C# SCTOI  - NUM =SCTOI (STR, NCOL)0051C# SDECAT - CALL SDECAT(STR1, STR2, STR3, STR4)0039C# SEQL   - I   =SEQL  (STR1, STR2)0051C# SFIND  - COL =SFIND (VEC, START, STOP, CHAR)0049C# SHELL  - CALL SHELL (LASTP, NAMPTR, TABLE)0039C# SINDX  - COL =SINDX (STR1, STR2)0039C# SINSRT - CALL SINSRT(STR1, STR2)0042C# SITOC  - LEN =SITOC (NUM, STR, MAX)^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0051C# SJOIN  - LEN2=SJOIN (STR1, STR2, MAX, ERROR)0032C# SLEN   - LEN =SLEN  (STR)0063C# SMIDV  - LEN4=SMIDV (STR1, STR2, STR3, STR4, MAX, ERROR)0055C# SMOVE  - I   =SMOVE (STR1, FROM, TO, VEC, START)0056C# SNUMBR - NUM =SNUMBR(STR, START, STOP, NUM, NCOL)0037C# SPAD   - CALL SPAD  (STR, LEN)0057C# SPOSTV - LEN3=SPOSTV(STR1, STR2, STR3, MAX, ERROR)0051C# SPREFX - CALL SPREFX(STR1, STR2, STR3, STR4)0057C# SPREV  - LEN3=SPREV (STR1, STR2, STR3, MAX, ERROR)^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0056C# SREPT  - LEN2=SREPT (STR1, NUM, STR2, MAX, ERROR)0045C# SSAME  - ICOL=SSAME (STR1, STR2, LORR)0045C# SSAMEX - ICOL=SSAMEX(STR1, STR2, LOOR)0051C# SSUFX  - CALL SSUFX (STR1, STR2, STR3, STR4)0063C# SSWAP  - LEN4=SSWAP (STR1, STR2, STR3, STR4, MAX, ERROR)0041C# STRGET - LEN =STRGET(LUN STR, MAX)0045C# STRPUT - ERR =STRPUT(LUN, STR, FMTCHR)0032C# STRIM  - LEN =STRIM (STR)0033C# TYPE   - C   =TYPE  (CHAR)0033C# UNFOLD - CALL UNFOLD (STR)^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0076CFILE=DEFIN.RAT  ===== GENERAL CHARACTER SET DEFINITIONS ===============0048C PCN #73, DEC 79, ADD CARET,TILDE FOR .NOT.0005C0005C0022CGENERAL COMMENTS:0085C# NOTE: SOME OF THESE ROUTINES ARE SET UP TO WORK WITH ASCII CHARACTER SET ONLY.0077C#THEREFORE, IF THE MACHINE'S NATIVE CHARACTER SET IS NOT ASCII, YOU MUST0082C#USE 'INMAP' TO CONVERT TO ASCII BEFORE USING THESE ROUTINES. OR ELSE REWRITE0021C#THESE ROUTINES.0072C#ROUTINES THAT PRODUCE AN OUTPUT STRING GENERALY ALLOW A 'MAX' SIZE^^^^^^^^^^^^^^^^^^^0072C FOR THE OUTPUT STRING TO BE SPECIFIED. THE OUTPUT  IS CUT TO 'MAX'0075C CHARACTERS IF NECESSARY; IF IT IS,THE INTEGER 'ERROR' IS SET TO 'YES'0065C (OTHERWISE TO 'NO') TO ALERT THAT TRUNCATION WAS NECESSARY.0074C ONE EXTRA ARRAY ELEMENT AT THE END OF THE STRING IS ALWAYS NECESSARY0033C (BEYOND MAX) FOR THE 'EOS'.0076CSUBROUTINE CALLS SPECIFYING A SPECIFIC ARRAY ELEMENT (EG. STR(I)) CAUSE0075C   ACTION TO BE TAKEN (AND RETURN VALUES AND MAX TO BE CALCULATED,  IF^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0082C  APPROPRIATE FROM THE SPECIFIED ELEMENT,  NOT THE WHOLE STRING (FROM ELEMENT0074C  1) SINCE ONLY THE STRING STARTING AT THE SPECIFIED ELEMENT IS KNOWN0075C  TO THE SUBROUTINE. EG J=SLEN(STRI)) SETS J TO THE NUMBER OF ELEMENTS0026C BETWEEN I AND 'EOS'.0078CTHESE ROUTINES REQUIRE THAT THE COMPILER MAKE CORRECT COMPARES OF INTEGER0081C VALUES BETWEEN INTEGERS AND WHATEVER DATA TYPE 'CHARACTER' IS DEFINED TO BE0030C (LOGICAL*1 IN DEC-LAND).0064C"STRINGS" ARE VECTORS OF CHARACTERS TERMINATED BY AN 'EOS'.^^0088C THE LENGTH OF A STRING IS THE NUMBER OF CHARACTERS IN IT, NOT INCLUDING THE 'EOS'.0065C"CHARACTERS" ARE SINGLE CHARACTERS, ONE PER STORAGE ELEMENT.0082C"CHARACTER VECTORS" ARE VECTORS (OR ARRAYS) CONTAINING CHARACTERS BUT WITHOUT0080C THE TERMINATING 'EOS'. THUS, A PART OF A STRING WHICH DOES NOT INCLUDE THE0074C 'EOS' IS A CHARACTER VECTOR, AND A VECTOR WITH AN 'EOS' IS A STRING.0005C0041      INTEGER FUNCTION ALLDIG ( STR )0046C ALLDIG - RETURN YES IF STR IS ALL DIGITS0005C0005C^^^^^^^^^^^^^^^^^^^^^0037      LOGICAL * 1 STR ( 1 ), TYPE0019      INTEGER I0005C0051      IF (.NOT.( STR ( 1 ) .EQ. 0 )) GOTO 200000024      ALLDIG = ( 0 )0016      RETURN001820000 CONTINUE0032      DO 20002  I = 1, 327670051      IF (.NOT.( STR ( I ) .EQ. 0 )) GOTO 200040024      ALLDIG = ( 1 )0016      RETURN001820004 CONTINUE0063      IF (.NOT.( TYPE ( STR ( I ) ) .NE. - 20 )) GOTO 200060024      ALLDIG = ( 0 )0016      RETURN001820006 CONTINUE001820005 CONTINUE0005C001820002 CONTINUE001820003 CONTINUE0013      END0005^^^00040047      INTEGER FUNCTION EQLS ( VEC, PATSTR )0005C0072C EQLS - FUNCTION TO DO ANCHORED COMPARE OF STRING WITH CHAR VECTOR.0075C STARTING AT BEGINNING OF VEC, COMPARE IT WITH PATSTR (WHICH MUST BE A0077C  STRING). IF THE NEXT CHARACTERS OF VEC MATCH 1 FOR 1 THE CHARACTERS OF0068C  PATSTR, RETURN THE VALUE OF THE FUNCTION AS 'YES', ELSE 'NO'.0005C0005C0045      LOGICAL * 1 VEC ( 1 ), PATSTR ( 1 )0005C0016       I = 1005320008 IF (.NOT.( PATSTR ( I ) .NE. 0)) GOTO 20010^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0062      IF (.NOT.( PATSTR ( I ) .NE. VEC ( I ) )) GOTO 200110022      EQLS = ( 0 )0016      RETURN001820011 CONTINUE002020009 I = I + 1 0020      GOTO 20008001820010 CONTINUE0022      EQLS = ( 1 )0016      RETURN0013      END000500040033      SUBROUTINE FOLD ( STR )0005C0066C FOLD - CONVERT UPPER CASE LETTERS IN A STRING TO LOWER CASE.0012C15MAY770041C  **** ASCII CHARACTER SET ONLY ****0005C0005C0031      LOGICAL * 1 STR ( 1 )0019      INTEGER I0005C0032      DO 20013  I = 1, 32767^^^^^^^^^^^^^^^^^^^^^^0051      IF (.NOT.( STR ( I ) .EQ. 0 )) GOTO 200150016      RETURN001820015 CONTINUE0071      IF (.NOT.( STR ( I ) .GE. 65 .AND. STR ( I ) .LE. 90 )) GOTO 0015     $200170036      STR ( I ) = STR ( I ) + 32001820017 CONTINUE001820016 CONTINUE0005C001820013 CONTINUE001820014 CONTINUE0016      RETURN0013      END000500040043      INTEGER FUNCTION INDEX ( STR, C )0005C0063C INDEX - FIND THE LOCATION OF A CHARACTER WITHIN A STRING.0012C15MAY77^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0072C THE VALUE OF THE FUNCTION IS RETURNED AS THE NUMBER OF THE ELEMENT0068C  IN 'STR' WHERE THE FIRST OCCURRENCE OF CHARACTER 'C' IS FOUND0065C  (STARTING AT THE LEFT END), OR AS 0, IF C IS NOT IN 'STR'.0005C0005C0034      LOGICAL * 1 C, STR ( 1 )0005C0036      DO 20019  INDEX = 1, 327670055      IF (.NOT.( STR ( INDEX ) .EQ. 0 )) GOTO 200210023      INDEX = ( 0 )0016      RETURN001820021 CONTINUE0055      IF (.NOT.( STR ( INDEX ) .EQ. C )) GOTO 200230016      RETURN001820023 CONTINUE001820022 CONTINUE^^^0005C001820019 CONTINUE001820020 CONTINUE0013      END000500040050      SUBROUTINE SCOMM ( I, STR1, STR3, STR4 )0005C0043C SCOMM - USED BY SDECAT, SSUFX, SPREFX0005C0005C0029      INTEGER I, SMOVE, J0056      LOGICAL * 1 STR1 ( 1 ), STR3 ( 1 ), STR4 ( 1 )0005C0047      J = SMOVE ( STR1, 1, I - 1, STR3, 1 )0028      STR3 ( J + 1 ) = 00047      J = SMOVE ( STR1, I, 32767, STR4, 1 )0028      STR4 ( J + 1 ) = 00005C0016      RETURN0013      END000500040048      INTEGER FUNCTION SCOMPR ( STR1, STR2 )0005C^^^^^0049C SCOMPR - COMPARE TWO STRINGS ALPHABETICALY.0064C PCN #89, 10 FEB 80, SPEED UP 50%, REPLACE 'FOR' WITH 'DO'.0053CRETURN 0 IF EQUAL. (STRINGS MUST BE SAME LENGTH)0049CRETURN -1 IF STR1 IS CLOSER TO 'A' THEN STR20049CRETURN +1 IF STR1 IS CLOSER TO 'Z' THEN STR20041C  **** ASCII CHARACTER SET ONLY ****0005C0005C0022      INTEGER I, J0044      LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 )0005C0032      DO 20025  I = 1, 327670061      IF (.NOT.( STR1 ( I ) .EQ. STR2 ( I ) )) GOTO 20027^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0052      IF (.NOT.( STR1 ( I ) .EQ. 0 )) GOTO 200290024      SCOMPR = ( 0 )0016      RETURN001820029 CONTINUE0020      GOTO 20028001820027 CONTINUE0020      GOTO 200260005C001820028 CONTINUE001820025 CONTINUE001820026 CONTINUE0061      IF (.NOT.( STR1 ( I ) .LT. STR2 ( I ) )) GOTO 200310026      SCOMPR = ( - 1 )0016      RETURN001820031 CONTINUE0026      SCOMPR = ( + 1 )0016      RETURN0005C001820032 CONTINUE0013      END000500040054      INTEGER FUNCTION SCOMPX ( STR1, STR2, CHAR )0005C^^^^^^^^^^^^^^^^^^0056C SCOMPX - COMPARE 2 SPECIAL STRINGS ALPHABETICALLY.0075CCOMPAR THE SECTIONS OF 2 STRINGS BEFORE AND AFTER THE 'CHAR' SEPERATOR0075C  INDEPENDENTLY. 0 IS RETURNED IF THE FIRST PART (UP TO 'CHAR')MATCHES0058C  AND THE SECOND PART (FROM 'CHAR' TO 'EOS') MATCHES.0079CFOR 1ST PART (BEFORE 'CHAR'), THE COMPARE ENDS WHEN EITHER STRING CONTAINS0076C A 'CHAR'. IT THEN LINES UP THE 'CHAR' IN BOTH STRINGS AND COMPARES THE0073C SECOND PART OF BOTH STRINGS UNTIL AN EOS IS FOUND IN EITHER STRING.^^^^^^^^^^^^^^^^^^^^0079C THE STRINGS DO NOT HAVE TO BE THE SAME LENGTH (EITHER BEFORE OR AFTER THE0039C 'CHAR') TO BE CONSIDERED A MATCH.0041C  **** ASCII CHARACTER SET ONLY ****0058CRETURNS -1 IF STR1 IS HIGHER ALPHABETICALLY THEN STR20065CRETURNS  0 IF STR1 IS EQUAL TO STR2, PIVOTING AROUND 'CHAR'.0057CRETURNS +1 IF STR1 IS LOWER ALPHABETICALLY THEN STR20038C	IF	STR1="FIRST PART<SECOND PART"0015C		CHAR='<"0052C   THEN IF	STR2="FIRST<SECOND"	SCOMPX RETURNS 00035C		STR2="F<S"		SCOMPX RETURNS 0^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0038C		STR2="AA<BB"		SCOMPX RETURNS +10005C0005C0022      INTEGER I, J0050      LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ), CHAR0005C0015      J = 10016       I = 1007520033 IF (.NOT.( STR1 ( I ) .NE. 0 .AND. STR2 ( J ) .NE. 0)) GOTO 200350055      IF (.NOT.( STR1 ( I ) .EQ. CHAR )) GOTO 200360018      CONTINUE007320038 IF (.NOT.( STR2 ( J ) .NE. CHAR .AND. STR2 ( J + 1 ) .NE. 0 )) 0020     $GOTO 200390019      J = J + 10020      GOTO 20038001820039 CONTINUE0020      GOTO 20037001820036 CONTINUE^^^^^^^^^^^^^^^^^^^^0055      IF (.NOT.( STR2 ( J ) .EQ. CHAR )) GOTO 200400018      CONTINUE007320042 IF (.NOT.( STR1 ( I ) .NE. CHAR .AND. STR1 ( I + 1 ) .NE. 0 )) 0020     $GOTO 200430019      I = I + 10020      GOTO 20042001820043 CONTINUE0020      GOTO 20041001820040 CONTINUE0061      IF (.NOT.( STR1 ( I ) .NE. STR2 ( J ) )) GOTO 200440061      IF (.NOT.( STR1 ( I ) .LT. STR2 ( J ) )) GOTO 200460026      SCOMPX = ( - 1 )0016      RETURN001820046 CONTINUE0026      SCOMPX = ( + 1 )0016      RETURN001820047 CONTINUE^^^^^^^^^001820044 CONTINUE001820041 CONTINUE001820037 CONTINUE0019      J = J + 1002020034 I = I + 1 0020      GOTO 20033001820035 CONTINUE0024      SCOMPX = ( 0 )0016      RETURN0005C0013      END000500040059      INTEGER FUNCTION SCOPY ( STR1, STR2, MAX, ERROR )0005C0049C SCOPY - COPY ONE STRING INTO ANOTHER STRING0040C PCN 89, 10FEB 80, MAKE 30% FASTER.0059CCOPYING STOPS WHEN THE END OF STR1 IS REACHED, OR WHEN0054C STR2 GETS TO BE 'MAX' CHAR. LONG (ERROR IS SET).^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0061C VALUE OF THE FUCTION IS RETURNED AS THE LENGTH OF STR2.0005C0005C0031      INTEGER MAX, ERROR, I0044      LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 )0005C0019      ERROR = 00032      DO 20048  I = 1, 327670052      IF (.NOT.( STR1 ( I ) .EQ. 0 )) GOTO 200500020      GOTO 20049001820050 CONTINUE0045      IF (.NOT.( I .GT. MAX )) GOTO 200520019      ERROR = 10020      GOTO 20049001820052 CONTINUE0033      STR2 ( I ) = STR1 ( I )001820053 CONTINUE001820051 CONTINUE0005C001820048 CONTINUE001820049 CONTINUE^^^^^^^^0024      STR2 ( I ) = 00005C0027      SCOPY = ( I - 1 )0016      RETURN0013      END000500040042      INTEGER FUNCTION SCTOI ( IN, I )0005C0062C SCTOI - CONVERT STRING AT IN(I) TO INTEGER, INCREMENT I.0078CSTARTING AT LOCATION 'I' IN STRING 'IN', LEADING BLANKS/TABS ARE SKIPPED;0065C THEN ALL DIGITS UP TO THE NEXT NON-DIGIT (INCLUDING BLANKS)0066C ARE CONVERTED TO A POSITIVE OR NEGATIVE INTEGER AND RETURNED0070C AS THE VALUE OF THE FUNCTION. 'I' IS INCREMENTED AND UPON RETURN^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0052C POINTS TO THE LOCATION OF THE FIRST NON-DIGIT.0005C0005C0030      LOGICAL * 1 IN ( 1 )0033      INTEGER D, I, SFIND, PM0033      LOGICAL * 1 DIGITS (11)0005C0064      DATA DIGITS/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,0/007220054 IF (.NOT.( IN ( I ) .EQ. 32 .OR. IN ( I ) .EQ. 9 )) GOTO 200550019      I = I + 10020      GOTO 20054001820055 CONTINUE0051      IF (.NOT.( IN ( I ) .EQ. 45 )) GOTO 200560019      I = I + 10018      PM = - 10020      GOTO 20057001820056 CONTINUE0018      PM = + 10005C^^^^^^^001820057 CONTINUE0020       SCTOI = 0004920058 IF (.NOT.( IN ( I ) .NE. 0)) GOTO 200600047      D = SFIND ( DIGITS, 1, 10, IN ( I ) )0043      IF (.NOT.( D .EQ. 0 )) GOTO 200610020      GOTO 20060001820061 CONTINUE0036      SCTOI = 10 * SCTOI + D - 10005C002020059 I = I + 1 0020      GOTO 20058001820060 CONTINUE0044      IF (.NOT.( PM .LT. 0 )) GOTO 200630025      SCTOI = - SCTOI001820063 CONTINUE0016      RETURN0013      END000500040054      SUBROUTINE SDECAT ( STR1, STR2, STR3, STR4 )0005C^^^^^^^^^^^^^^0065C SDECAT - BREAK A STRING INTO TWO SUBSTRINGS AT A CHARACTER.0068CSTR1 IS BROKEN INTO STR3 AND STR4 AT THE LEFTMOST OCCURRENCE OF0073C ANY CHARACTER  THAT IS ALSO ANYWHERE IN STR2. THE "BREAK CHARACTER"0075C GOES INTO STR4. ALTHOUGH STR2 IS A STRING, IT IS USED AS A COLLECTION0048C OF 1 OR MORE CHARACTERS TO BE CHECKED FOR.0028C	IF	STR1="FILENAME.EXT"0017C		STR2=":.;"0026C	THEN SDECAT RETURNS:0022C		STR3="FILENAME"0018C		STR4=".EXT"0005C0005C0035      INTEGER I, J, SSAME, SLEN^^^^^^^^^^^^^^^^^^^^^^^^^^^0068      LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ), STR3 ( 1 ), STR4 ( 1 )0005C0039      I = SSAME ( STR1, STR2, + 1 )0043      IF (.NOT.( I .LE. 0 )) GOTO 200650031      I = SLEN ( STR1 ) + 1001820065 CONTINUE0044      CALL SCOMM ( I, STR1, STR3, STR4 )0005C0016      RETURN0013      END000500040046      INTEGER FUNCTION SEQL ( STR1, STR2 )0005C0055C SEQL - COMPARE STR1 TO STR2; RETURN YES IF EQUAL,0079CSTR1 IS COMPARED CHARACTER BY CHARACTER TO STR2; IF THEY MATCH ALL THE WAY^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0069C THRU, THE FUNCTION VALUE IS RETURNED AS 'YES', IF NOT, AS 'NO'.0057C  THEY MUST BOTH BE STRINGS, AND OF THE SAME LENGTH.0005C0005C0044      LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 )0019      INTEGER I0005C0032      DO 20067  I = 1, 327670061      IF (.NOT.( STR1 ( I ) .NE. STR2 ( I ) )) GOTO 200690022      SEQL = ( 0 )0016      RETURN001820069 CONTINUE0052      IF (.NOT.( STR1 ( I ) .EQ. 0 )) GOTO 200710022      SEQL = ( 1 )0016      RETURN0005C001820071 CONTINUE001820070 CONTINUE001820067 CONTINUE^^^^^^^^^^001820068 CONTINUE0013      END000500040051      SUBROUTINE SHELL ( LASTP, NAMPTR, TABLE )0005C0069C SHELL - TO SORT DEFINE TABLE INTO ALPHABETICAL ORDER FOR RATFOR0028CSYKES 18 OCT 76,14MAR770005C0005C0045      INTEGER GAP, I, IG, J, K, SCOMPR, N0037      INTEGER LASTP, NAMPTR ( 1 )0033      LOGICAL * 1 TABLE ( 1 )0005C0026       GAP = LASTP / 2004420073 IF (.NOT.( GAP .GT. 0)) GOTO 200750018      CONTINUE0022       J = GAP + 1004620076 IF (.NOT.( J .LE. LASTP)) GOTO 200780018      CONTINUE^^^^^^^^^^^^^^^0022       I = J - GAP004220079 IF (.NOT.( I .GT. 0)) GOTO 200810022      IG = I + GAP0075      IF (.NOT.( SCOMPR ( TABLE ( NAMPTR ( I ) ), TABLE ( NAMPTR ( IG )0035     $ ) ) .LE. 0 )) GOTO 200820020      GOTO 20081001820082 CONTINUE0026      N = NAMPTR ( I )0038      NAMPTR ( I ) = NAMPTR ( IG )0027      NAMPTR ( IG ) = N0005C002220080 I = I - GAP 0020      GOTO 20079001820081 CONTINUE002020077 J = J + 1 0020      GOTO 20076001820078 CONTINUE002420074 GAP = GAP / 2 0020      GOTO 20073001820075 CONTINUE^^0016      RETURN0013      END000500040059      INTEGER FUNCTION SFIND ( VEC, START, STOP, CHAR )0005C0072C SFIND - BOUNDED FAST SEARCH OF A CHARACTER VECTOR FOR A CHARACTER.0067CSEARCHES A VECTOR, EITHER FROM LEFT TO RIGHT OR RIGHT TO LEFT,0074C  DEPENDING ON THE RELATIVE VALUES OF START AND STOP, FOR A SPECIFIED0078C  CHARACTER, AND RETURNS AS THE FUNCTION VALUE THE ELEMENT IN 'VEC' WHERE0080C  THE FIRST MATCH IS FOUND; OR AS 0, IF NO CHARACTER IN VEC MATCHES 'CHAR'.^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0080C THIS IS NOT ANSII FORTRAN BECAUSE OF THE BACKWARD INCREMENT ON THE DO LOOP0059C BUT IN F4P IS SOMEWHAT FASTER THEN STANDARD ROUTINES.0024C	IF	VEC="ABCDEAFGH"0038C		I=SFIND(VEC,1,8,BIGC)	RETURNS 30038C		I=SFIND(VEC,8,1,BIGC)	RETURNS 30038C		I=SFIND(VEC,1,8,BIGZ)	RETURNS 00038C		I=SFIND(VEC,2,7,BIGA)	RETURNS 60005C0005C0032      INTEGER START, STOP, I0037      LOGICAL * 1 VEC ( 1 ), CHAR0005C0050      IF (.NOT.( START .GT. STOP )) GOTO 200840017      I = - 10020      GOTO 20085001820084 CONTINUE^^^^^^^^0017      I = + 1001820085 CONTINUE0042      DO 20086  SFIND = START, STOP, I0058      IF (.NOT.( VEC ( SFIND ) .EQ. CHAR )) GOTO 200880016      RETURN001820088 CONTINUE001820086 CONTINUE001820087 CONTINUE0023      SFIND = ( 0 )0016      RETURN0005C0013      END000500040046      INTEGER FUNCTION SINDX ( STR, PATN )0005C0079C SINDX - FIND THE LOCATION OF A SPECIFIED SUBSTRING WITHIN ANOTHER STRING.0070CTHE FUNCTION VALUE IS RETURNED AS THE LOCATION WITHIN 'STR' WHERE^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0065C  'PATN ' STARTS; OR AS 0, IF 'PATN' DOES NOT OCCUR IN'STR'.0066C  IF 'PATN' IS NULL, IT IS CONSIDERED TO MATCH AT LOCATION 1.0026C	IF	STR1="ABADAFABCD"0017C		PATN="ABC"0005C0005C0022      INTEGER J, K0043      LOGICAL * 1 STR ( 1 ), PATN ( 1 )0005C0020       SINDX = 1005420090 IF (.NOT.( STR ( SINDX ) .NE. 0)) GOTO 200920019      K = SINDX0018      CONTINUE0016       J = 1005120093 IF (.NOT.( PATN ( J ) .NE. 0)) GOTO 200950060      IF (.NOT.( PATN ( J ) .NE. STR ( K ) )) GOTO 200960020      GOTO 20095001820096 CONTINUE0019      K = K + 1001820097 CONTINUE002020094 J = J + 1 0020      GOTO 20093001820095 CONTINUE0052      IF (.NOT.( PATN ( J ) .EQ. 0 )) GOTO 200980016      RETURN001820098 CONTINUE0051      IF (.NOT.( STR ( K ) .EQ. 0 )) GOTO 201000020      GOTO 20092001820100 CONTINUE001820099 CONTINUE002820091 SINDX = SINDX + 1 0020      GOTO 20090001820092 CONTINUE0023      SINDX = ( 0 )0016      RETURN0005C0013      END000500040042      SUBROUTINE SINSRT ( STR1, STR2 )0005C^^^^^^^^^^^^^^^^^^^^^^^^^^^0050C SINSRT - INSERT A STRING INTO ANOTHER STRING0066CCOPY ALL OF STR1 INTO STR2; IF THIS OVERRUNS THE END OF STR2,0077C   MAKE STR2 LONGER TO HOLD ALL OF STR1.  OTHERWISE, NO 'EOS' AT THE END0027C   OF THE COPIED PART.0005C0005C0025      INTEGER I, ENDS0044      LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 )0005C0018      ENDS = 00016       I = 1005120102 IF (.NOT.( STR1 ( I ) .NE. 0)) GOTO 201040052      IF (.NOT.( STR2 ( I ) .EQ. 0 )) GOTO 201050018      ENDS = 1001820105 CONTINUE0033      STR2 ( I ) = STR1 ( I )^^002020103 I = I + 1 0020      GOTO 20102001820104 CONTINUE0046      IF (.NOT.( ENDS .EQ. 1 )) GOTO 201070024      STR2 ( I ) = 00005C001820107 CONTINUE0016      RETURN0013      END000500040051      INTEGER FUNCTION SITOC ( INT, STR, SIZE )0005C0070C SITOC - CONVERT INTEGER  INT  TO STRING IN  STR, LEFT JUSTIFIED.0073CCONVERT THE POSITIVE OR NEGATIVE INTEGER 'INT' TO A CHARACTER STRING0072C IN 'STR'. TRUNCATE THE STRING IF IT GOES BEYOND 'SIZE' CHARACTERS.^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0083C RETURN THE ACTUAL NUMBER OF CHARACTERS IN 'STR' AS THE VALUE OF THE FUNCTION.0005C0005C0027      INTEGER IABS, MOD0047      INTEGER D, I, INT, INTVAL, J, K, SIZE0034      LOGICAL * 1 STR ( SIZE )0033      LOGICAL * 1 DIGITS (11)0005C0064      DATA DIGITS/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,0/0031      INTVAL = IABS ( INT )0023      STR ( 1 ) = 00015      I = 1001820109 CONTINUE0019      I = I + 10032      D = MOD ( INTVAL, 10 )0038      STR ( I ) = DIGITS ( D + 1 )0030      INTVAL = INTVAL / 10^^^006520110 IF (.NOT.( INTVAL .EQ. 0 .OR. I .GE. SIZE )) GOTO 20109001820111 CONTINUE0063      IF (.NOT.( INT .LT. 0 .AND. I .LT. SIZE )) GOTO 201120019      I = I + 10024      STR ( I ) = 45001820112 CONTINUE0023      SITOC = I - 10016       J = 1004220114 IF (.NOT.( J .LT. I)) GOTO 201160023      K = STR ( I )0031      STR ( I ) = STR ( J )0023      STR ( J ) = K0019      I = I - 10005C002020115 J = J + 1 0020      GOTO 20114001820116 CONTINUE0016      RETURN0013      END00050004^^^^^^^^^^^^^^^^^^^^^^^^^^^0059      INTEGER FUNCTION SJOIN ( STR1, STR2, MAX, ERROR )0005C0064C SJOIN - CONCATINATE A STRING TO THE END OF ANOTHER STRING,0069CADD STR2 TO THE END OF STR1 (IN STR1). MOVE ALL OF STR2 OR UNTIL0062C  STR1 IS 'MAX' CHARS LONG (IN WHICH CASE, SET ERROR=YES)0066C  RETURN THE VALUE OF THE FUNCTION AS THE NEW LENGTH OF STR1.0005C0005C0044      INTEGER MAX, ERROR, I, SLEN, SCOPY0044      LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 )0005C0027      I = SLEN ( STR1 )^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0068      SJOIN = SCOPY ( STR2, STR1 ( I + 1 ), MAX - I, ERROR ) + I0005C0016      RETURN0013      END000500040039      INTEGER FUNCTION SLEN ( STR )0005C0076C SLEN - FUNCTION TO RETURN THE LENGTH OF STRING (NOT INCLUDING THE EOS)0005C0005C0031      LOGICAL * 1 STR ( 1 )0005C0032      DO 20117  I = 1, 327670051      IF (.NOT.( STR ( I ) .EQ. 0 )) GOTO 201190026      SLEN = ( I - 1 )0016      RETURN0005C001820119 CONTINUE001820117 CONTINUE001820118 CONTINUE0013      END00050004^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0071      INTEGER FUNCTION SMIDV ( STR1, STR2, STR3, STR4, MAX, ERROR )0005C0061C SMIDV - SELECT A SUBSTRING FROM THE MIDDLE OF A STRING.0073CMOVE THE CHARACTERS IN STR1 THAT ARE BETWEEN STR2 AND STR3 (IN STR1)0076C  INTO STR4. TRUNCATE STR4 TO 'MAX' CHARS (AND SET ERROR) IF NECESSARY.0074C  THE VALUE OF THE FUNCTION IS RETURNED AS THE ACTUAL LENGTH OF STR4.0060C  IF EITHER STR2 OR STR3 ARE NOT IN STR1, STR4 IS NULL.0028C	IF	STR1="DEV:FILE.EXT"0015C		STR2=":"0015C		STR3="."0025C	THEN SMIDV RETURNS:^^^^^^^^^0029C		I=4,        ERROR='NO'0018C		STR4="FILE"0005C0005C0028      INTEGER MAX, ERROR0042      INTEGER SLEN, SINDX, SMOVE, J, I0068      LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ), STR3 ( 1 ), STR4 ( 1 )0005C0034      I = SINDX ( STR1, STR2 )0043      IF (.NOT.( I .GT. 0 )) GOTO 201210031      I = I + SLEN ( STR2 )0040      J = SINDX ( STR1 ( I ), STR3 )001820121 CONTINUE0058      IF (.NOT.( I .GT. 0 .AND. J .GT. 0 )) GOTO 201230045      IF (.NOT.( J .LE. MAX )) GOTO 201250023      J = I + J - 20019      ERROR = 0^0020      GOTO 20126001820125 CONTINUE0019      ERROR = 10025      J = I + MAX - 1001820126 CONTINUE0047      SMIDV = SMOVE ( STR1, I, J, STR4, 1 )0032      STR4 ( SMIDV + 1 ) = 00020      GOTO 20124001820123 CONTINUE0019      ERROR = 00019      SMIDV = 00024      STR4 ( 1 ) = 00005C001820124 CONTINUE0016      RETURN0013      END000500040063      INTEGER FUNCTION SMOVE ( STR1, FROM, TO, VEC, START )0005C0077C SMOVE - BOUNDED MOVE OF CHARACTERS FROM A STRING OR VECTOR TO A VECTOR.^^^^^^^^^^^^^^^^^^^^^^^^^^^0066CMOVE THE CHARACTERS IN STR1 BETWEEN 'FROM' & 'TO' (INCLUSIVE)0070C  TO VEC, STARTING AT LOCATION 'START'. NO 'EOS' IS PLACED AT THE0035C  END OF THE MOVED CHARACTERS.0071C  IF THE END OF STR1 IS REACHED BEFORE LOCATION 'TO', THE TRANSFER0069C  IS STOPPED.  THE VALUE OF THE FUNCTION IS RETURNED AS THE LAST0044C  (RIGHTMOST) LOCATION IN VEC MODIFIED.0005C0005C0036      INTEGER FROM, TO, START, I0043      LOGICAL * 1 STR1 ( 1 ), VEC ( 1 )0005C0027      SMOVE = START - 10032      DO 20127  I = FROM, TO^^^^0052      IF (.NOT.( STR1 ( I ) .EQ. 0 )) GOTO 201290020      GOTO 20128001820129 CONTINUE0027      SMOVE = SMOVE + 10036      VEC ( SMOVE ) = STR1 ( I )001820130 CONTINUE001820127 CONTINUE001820128 CONTINUE0051      IF (.NOT.( SMOVE .LT. START )) GOTO 201310023      SMOVE = ( 0 )0016      RETURN0005C001820131 CONTINUE0016      RETURN0013      END000500040065      INTEGER FUNCTION SNUMBR ( STR, START, STOP, NUM, NCOL )0005C0068C SNUMBR - FUNCTION TO CONVERT A CHARACTER VECTOR TO AN INTEGER.^^^^^^^^^^^^^^^^0065CSTARTING AT 'START', EXTRACT A INTEGER FROM 'STR' AND RETURN0083C  IT AS THE VALUE OF THE FUNCTION AND AS 'NUM'; IGNORE BLANKS, BUT QUIT AT THE0081C  FIRST NON-DIGIT/BLANK FOUND, BUT IN ANY CASE DO NOT GO PAST COLUMN 'STOP'.0076C  RETURN IN 'NCOL' THE NUMBER OF THE NEXT COLUMN TO THE RIGHT IN 'STR'.0005C0005C0053      INTEGER START, STOP, NUM, I, J, SCTOI, NCOL0048      LOGICAL * 1 STR ( 1 ), TOK ( 7 ), TYPE0005C0015      J = 10020       I = START^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^006020133 IF (.NOT.( J .LE. 7 .AND. I .LE. STOP)) GOTO 201350052      IF (.NOT.( STR ( I ) .EQ. 32 )) GOTO 201360020      GOTO 20134001820136 CONTINUE0075      IF (.NOT.( TYPE ( STR ( I ) ) .NE. - 20 .AND. STR ( I ) .NE. 45 )0022     $) GOTO 201380020      GOTO 20135001820138 CONTINUE0031      TOK ( J ) = STR ( I )0019      J = J + 1001820139 CONTINUE001820137 CONTINUE002020134 I = I + 1 0020      GOTO 20133001820135 CONTINUE0023      TOK ( J ) = 00018      NCOL = I0015      I = 1^^^^^^^^^^^^^^^^^^^^^^^^^^^0032      NUM = SCTOI ( TOK, I )0005C0026      SNUMBR = ( NUM )0016      RETURN0013      END000500040038      SUBROUTINE SPAD ( STR, LEN )0005C0063C SPAD - FILL A STRING UP TO A SPECIFIED LENGTH WITH BLANKS0065C PCN # 89, 10 FEB 80, SPEED UP 13%, REPLACE 'FOR' WITH 'DO'.0059CPAD THE RIGHTHAND END OF STR WITH BLANKS OUT TO 'LEN'.0044C  STR BECOMES A STRING OF LENGTH 'LEN'.0005C0005C0030      INTEGER LEN, SLEN, I0031      LOGICAL * 1 STR ( 1 )0005C0030      I = SLEN ( STR ) + 1^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0045      IF (.NOT.( I .LE. LEN )) GOTO 201400030      DO 20142  J = I, LEN0024      STR ( J ) = 32001820142 CONTINUE001820143 CONTINUE001820140 CONTINUE0029      STR ( LEN + 1 ) = 00005C0016      RETURN0013      END000500040066      INTEGER FUNCTION SPOSTV ( STR1, STR2, STR3, MAX, ERROR )0005C0066C SPOSTV - SELECT A SUBSTRING FROM  THE RIGHT END OF A STRING.0076CMOVE INTO STR3 ALL OF STR1 TO THE RIGHT OF THE END OF STR2(WITHIN STR1)0069C  BUT TRUNCATE STR3 TO 'MAX' CHARS (AND SET ERROR) IF NECESSARY.^^^^^0077C  THE VALUE OF THE FUNCTION IS RETURNED AS THE ACUTAL NEW LENGTH OF STR30053C  STR3 IS NULL IF STR2 IS NOT FOUND WITHIN STR1.0049C  IF STR2 IS NULL, ALL OF STR1 GOES TO STR3.0028C	IF	STR1="FILENAME.EXT"0015C		STR2="."0050C	THEN SPOSTV RETURNS     I=3,      ERROR='NO'0017C		STR3="EXT"0005C0005C0051      INTEGER MAX, ERROR, I, SCOPY, SINDX, SLEN0056      LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ), STR3 ( 1 )0005C0034      I = SINDX ( STR1, STR2 )0043      IF (.NOT.( I .LE. 0 )) GOTO 201440024      STR3 ( 1 ) = 00019      ERROR = 00024      SPOSTV = ( 0 )0016      RETURN001820144 CONTINUE0031      I = I + SLEN ( STR2 )0057      SPOSTV = SCOPY ( STR1 ( I ), STR3, MAX, ERROR )0005C001820145 CONTINUE0016      RETURN0013      END000500040054      SUBROUTINE SPREFX ( STR1, STR2, STR3, STR4 )0005C0057C SPREFX - SEPERATE A PREFIX SUBSTRING FROM A STRING.0081CMOVE INTO STR3 THAT PART OF STR1 WHICH IS TO THE LEFT OF THE FIRST CHAR ALSO0082C FOUND (ANYWHERE) IN STR2. MOVE INTO STR4 THE REST OF STR1. STR3 AND STR4 ARE^^^^^^^0077C NEW STRINGS. THE LEFTMOST OCCURRANCE IN STR1 OF ANY CHAR IN STR2 IS THE0056C "BREAK POINT". THE BREAK CHARACTER GOES INTO STR4.0078C IF NONE OF THE CHARACTERS IN STR2 IS FOUND IN STR1, ALL OF STR1 IS MOVED0034C  INTO STR4 AND STR3 IS NULL.0077CALTHOUGH STR2 IS A STRING, IT IS REALLY USED AS A COLLECTION OF SEPERATE0076C CHARACTERS, NOT AS A STRING WHERE THE ORDER OF THE CHARACTERS WOULD BE0016C IMPORTANT.0028C	IF	STR1="FILENAME.EXT"0017C		STR2=":.;"0026C	THEN SPREFX RETURNS:0022C		STR3="FILENAME"^^^^^0018C		STR4=".EXT"0005C0005C0026      INTEGER I, SSAME0068      LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ), STR3 ( 1 ), STR4 ( 1 )0005C0039      I = SSAME ( STR1, STR2, + 1 )0043      IF (.NOT.( I .LE. 0 )) GOTO 201460015      I = 1001820146 CONTINUE0044      CALL SCOMM ( I, STR1, STR3, STR4 )0005C0016      RETURN0013      END000500040065      INTEGER FUNCTION SPREV ( STR1, STR2, STR3, MAX, ERROR )0005C0063C SPREV - SELECT A SUBSTRING FROM THE LEFT END OF A STRING.^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0070CMOVE THE PART OF STR1 TO THE LEFT OF THE START OF STR2 INTO STR3.0065C  TRUNCATE STR3 TO 'MAX' CHARS (AND SET ERROR) IF NECESSARY.0067C  THE VALUE OF THE FUNCTION IS RETURNED AS THE LENGTH OF STR3.0053C  STR3 IS NULL IF STR2 IS NOT FOUND WITHIN STR1.0049C  IF STR2 IS NULL, ALL OF STR1 GOES TO STR3.0030C	IF	STR1="FILENAME.EXT;2"0018C		STR2=".EXT"0025C	THEN SPREV RETURNS:0028C		I=8,       ERROR='NO'0022C		STR3="FILENAME"0005C0005C0045      INTEGER MAX, ERROR, I, SINDX, SMOVE^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0056      LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ), STR3 ( 1 )0005C0034      I = SINDX ( STR1, STR2 )0043      IF (.NOT.( I .LE. 0 )) GOTO 201480024      STR3 ( 1 ) = 00019      ERROR = 00023      SPREV = ( 0 )0016      RETURN001820148 CONTINUE0019      I = I - 10045      IF (.NOT.( I .LE. MAX )) GOTO 201500019      ERROR = 00020      GOTO 20151001820150 CONTINUE0017      I = MAX0019      ERROR = 1001820151 CONTINUE0047      SPREV = SMOVE ( STR1, 1, I, STR3, 1 )0032      STR3 ( SPREV + 1 ) = 00005C^^^^^^^^^^^^^^^001820149 CONTINUE0016      RETURN0013      END000500040064      INTEGER FUNCTION SREPT ( STR1, NUM, STR2, MAX, ERROR )0005C0067C SREPT - DUPLICATE A STRING INTO ANOTHER STRING SEVERAL TIMES.0067CFILL STR2 WITH 'NUM' CONCATINATED COPIES OF STR1, BUT TRUNCATE0055C  STR2 AT 'MAX' CHAR (AND SET ERROR) IF NECESSARY.0062C  THE VALUE OF THE FUNCTION IS RETURNED AS THE ACUTAL NEW0022C  LENGTH OF STR2.0019C	IF	STR1="*-*"0014C		STR2=""0048C	THEN	I=SREPT(STR1,5,STR2,9,ERROR)	RETURNS:0029C		I=9,       ERROR='YES'^^^^0023C		STR2="*-**-**-*"0005C0005C0043      INTEGER NUM, MAX, ERROR, SCOPY, I0044      LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 )0005C0019      SREPT = 00016       I = 1004420152 IF (.NOT.( I .LE. NUM)) GOTO 201540075      SREPT = SCOPY ( STR1, STR2 ( SREPT + 1 ), MAX - SREPT, ERROR ) + 0015     $SREPT0047      IF (.NOT.( ERROR .EQ. 1 )) GOTO 201550020      GOTO 20154001820155 CONTINUE0005C002020153 I = I + 1 0020      GOTO 20152001820154 CONTINUE0016      RETURN0013      END00050004^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0053      INTEGER FUNCTION SSAME ( STR1, STR2, LORR )0005C0069C SSAME - RETURN LOCATION OF FIRST CHARACTER IN STR1 ALSO IN STR20071CSCAN STR1 FROM LEFT TO RIGHT (IF LORR IS >0) OR FROM RIGHT TO LEFT0075C  (IF LORR IS <0) AND RETURN THE VALUE OF THE FUNCTION AS THE POSITION0080C  IN STR1 WHERE THE FIRST CHARACTER IS FOUND THAT IS ALSO ANYWHERE IN STR2,0059C  OR AS 0, IF NO CHARACTERS IN STR1 ARE FOUND IN STR2.0077CALTHOUGH STR2 IS A STRING, IT IS REALLY USED AS A COLLECTION OF SEPERATE^^^^^^^^^^^^^^^^^^^^^^^0076C CHARACTERS, NOT AS A STRING WHERE THE ORDER OF THE CHARACTERS WOULD BE0016C IMPORTANT.0025C	IF	STR1="ABCDE7FGH"0024C		STR2="0123456789"0042C	THEN 	I=SSAME(STR1,STR2,+1) RETURNS:0010C		I=60005C0005C0031      INTEGER LORR, SLEN, I0044      LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 )0005C0046      IF (.NOT.( LORR .GT. 0 )) GOTO 201570019      SSAME = 10020      GOTO 20158001820157 CONTINUE0031      SSAME = SLEN ( STR1 )001820158 CONTINUE007520159 IF (.NOT.( SSAME .GT. 0 .AND. STR1 ( SSAME ) .NE. 0 )) GOTO 20160^^0018      CONTINUE0016       I = 1005120161 IF (.NOT.( STR2 ( I ) .NE. 0)) GOTO 201630065      IF (.NOT.( STR1 ( SSAME ) .EQ. STR2 ( I ) )) GOTO 201640016      RETURN001820164 CONTINUE002020162 I = I + 1 0020      GOTO 20161001820163 CONTINUE0046      IF (.NOT.( LORR .GT. 0 )) GOTO 201660027      SSAME = SSAME + 10020      GOTO 20167001820166 CONTINUE0027      SSAME = SSAME - 1001820167 CONTINUE0020      GOTO 20159001820160 CONTINUE0023      SSAME = ( 0 )0016      RETURN0005C0013      END00050004^^^^^^^^^^0054      INTEGER FUNCTION SSAMEX ( STR1, STR2, LOOR )0005C0075C SSAMEX - RETURN LOCATION OF FIRST CHARACTER IN STR1 NOT ALSO IN STR2.0073CSCAN STR1 FROM THE LEFT (IF LORR > 0) OR FROM THE RIGHT (IF LOOR <0)0074C  AND RETURN THE VALUE OF THE FUNCTION AS THE LOCATION WITHIN STR1 OF0066C  THE FIRST CHARACTER NOT FOUND (ANYWHERE) IN STR2 , OR AS 0,0040C  IF EVERYTHING IN STR1 IS IN STR2.0077CALTHOUGH STR2 IS A STRING, IT IS REALLY USED AS A COLLECTION OF SEPERATE^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0076C CHARACTERS, NOT AS A STRING WHERE THE ORDER OF THE CHARACTERS WOULD BE0016C IMPORTANT.0025C	IF	STR1="123456ABC"0024C		STR2="0123456789"0042C	THEN	I=SSAMEX(STR1,STR2,+1)	RETURNS:0010C		I=70005C0005C0031      INTEGER I, LOOR, SLEN0044      LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 )0005C0046      IF (.NOT.( LORR .GT. 0 )) GOTO 201680020      SSAMEX = 10020      GOTO 20169001820168 CONTINUE0032      SSAMEX = SLEN ( STR1 )001820169 CONTINUE007220170 IF (.NOT.( SSAMEX .GT. 0 .AND. STR1 ( SSAMEX ) .NE. 0 )) GOTO ^^^0015     $201710018      CONTINUE0016       I = 1005120172 IF (.NOT.( STR2 ( I ) .NE. 0)) GOTO 201740066      IF (.NOT.( STR1 ( SSAMEX ) .EQ. STR2 ( I ) )) GOTO 201750020      GOTO 20174001820175 CONTINUE002020173 I = I + 1 0020      GOTO 20172001820174 CONTINUE0052      IF (.NOT.( STR2 ( I ) .EQ. 0 )) GOTO 201770016      RETURN001820177 CONTINUE0046      IF (.NOT.( LORR .GT. 0 )) GOTO 201790029      SSAMEX = SSAMEX + 10020      GOTO 20180001820179 CONTINUE0029      SSAMEX = SSAMEX - 1001820180 CONTINUE^^^^001820178 CONTINUE0020      GOTO 20170001820171 CONTINUE0024      SSAMEX = ( 0 )0016      RETURN0005C0013      END000500040053      SUBROUTINE SSUFX ( STR1, STR2, STR3, STR4 )0005C0046C SSUFX - SEPERATE OUT A SUFFEX SUBSTRING.0076CMOVE CHARACTERS FROM STR1 INTO STR3 WHICH ARE TO THE RIGHT OF THE FIRST0076C  OCCURENCE OF ANY CHARACTER FROM STR2 IN STR1, SCANNING RIGHT-TO-LEFT.0077C  MOVE THE REMAINDER OF STR1 INTO STR4. FIRST CHARACTER IN STR1 TO MATCH^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0072C  ANY CHARACTER IN STR2 IS THE "BREAK CHAR", AND IT GOES INTO STR4.0078CIF NONE OF THE CHARACTERS IN STR2 IS FOUND IS STR1, ALL OF STR1 GOES INTO0028C STR4 AND STR3 IS NULL.0077CALTHOUGH STR2 IS A STRING, IT IS REALLY USED AS A COLLECTION OF SEPERATE0076C CHARACTERS, NOT AS A STRING WHERE THE ORDER OF THE CHARACTERS WOULD BE0016C IMPORTANT.0028C	IF	STR1="FILENAME.EXT"0017C		STR2=":.;"0025C	THEN SSUFX RETURNS:0017C		STR3="EXT"0023C		STR4="FILENAME."0005C0005C0032      INTEGER I, SSAME, SLEN^^^^^^^^^^^^^0068      LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ), STR3 ( 1 ), STR4 ( 1 )0005C0039      I = SSAME ( STR1, STR2, - 1 )0043      IF (.NOT.( I .LE. 0 )) GOTO 201810027      I = SLEN ( STR1 )001820181 CONTINUE0019      I = I + 10005C0044      CALL SCOMM ( I, STR1, STR4, STR3 )0005C0016      RETURN0013      END000500040071      INTEGER FUNCTION SSWAP ( STR1, STR2, STR3, STR4, MAX, ERROR )0005C0059C SSWAP - EXCHANGE PART OF A STRING FOR ANOTHER STRING.^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0072CMOVE STR1 INTO STR4, EXCEPT THAT THE PART OF STR1 THAT MATCHES STR20072C  IS REPLACED BY STR3. THE VALUE OF THE FUNCTION IS RETURNED AS THE0081C  ACTUAL LENGTH OF STR4, OR AS 0, IF STR2 CANNOT BE FOUND. STR4 IS TRUNCATED0079C  TO 'MAX' (AND ERROR IS SET) IF NECESSARY. STR2 AND STR3 NEED NOT BE SAME0014C  LENGTH.0030C	IF	STR1="FILENAME.FTN;3"0017C		STR2="FTN"0017C		STR3="OBJ"0025C	THEN SSWAP RETURNS:0011C		I=140028C		STR4="FILENAME.OBJ;3"0005C0005C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0058      INTEGER MAX, ERROR, SINDX, SJOIN, SMOVE, I, SLEN0068      LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ), STR3 ( 1 ), STR4 ( 1 )0005C0034      I = SINDX ( STR1, STR2 )0043      IF (.NOT.( I .LE. 0 )) GOTO 201830024      STR4 ( 1 ) = 00019      ERROR = 00023      SSWAP = ( 0 )0016      RETURN001820183 CONTINUE0045      IF (.NOT.( I .GT. MAX )) GOTO 201850019      ERROR = 10021      I = MAX + 10020      GOTO 20186001820185 CONTINUE0019      ERROR = 0001820186 CONTINUE^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0051      SSWAP = SMOVE ( STR1, 1, I - 1, STR4, 1 )0032      STR4 ( SSWAP + 1 ) = 00050      SSWAP = SJOIN ( STR4, STR3, MAX, ERROR )0031      I = I + SLEN ( STR2 )0056      SSWAP = SJOIN ( STR4, STR1 ( I ), MAX, ERROR )0064C  ONCE STR4 REACHES 'MAX' LENGTH, SJOIN WILL NOT ADD TO IT.0005C001820184 CONTINUE0016      RETURN0013      END000500040051      INTEGER FUNCTION STRGET ( LUN, STR, MAX )0005C0050C STRGET - READ A STRING FROM A SPECIFIED LUN.0058C PCN #77, 6 JAN 80, ALLOW FOR SKIP-RECORD DUMMY READS^^^0072C PCN #81, 13 JAN 80, FIX SUBSCRIPT ERROR F4P GENERATES IF MAX IS 0.0078C **CAUTION: THIS ROUTINE TRUSTS FORTRAN TO MOVE INTO THE BUFFER ONLY THAT0080C **PART OF THE RECORD CALLED FOR BY 'MAX'. DEC'S FORTRAN IV V2.1 (AT LEAST)0082C **HAS A BUG WHICH CAUSES IT TO ALWAYS READ A FULL RECORD. THEREFORE, IF YOUR0080C **BUFFER IS SMALLER THEN THE RECORD SIZE, IT READS MORE INTO THE BUFR THEN0080C **IT HAS ROOM FOR, KLOBBERING GOD-KNOWS-WHAT IN YOUR PROGRAM. BEST TO TEST^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0082C **THIS OR ALWAYS GIVE STRGET A BUFFER AS BIG AS THE LARGEST POSSIBLE RECORD.0005C0005C0029      INTEGER LUN, MAX, N0031      LOGICAL * 1 STR ( 1 )0005C0045      IF (.NOT.( MAX .GT. 0 )) GOTO 201870075      READ ( LUN, 1, END = 100, ERR = 101 ) STRGET, ( STR ( N ), N = 1,0016     $ MAX )00291     FORMAT ( Q, 132A1 )0032      STR ( STRGET + 1 ) = 00016      RETURN001820187 CONTINUE0047      READ ( LUN, 1, END = 100, ERR = 101 )0023      STR ( 1 ) = 00024      STRGET = ( 0 )0016      RETURN0005C^^^^^^^^^001820188 CONTINUE0023100   STR ( 1 ) = 00026      STRGET = ( - 3 )0016      RETURN0005C0023101   STR ( 1 ) = 00026      STRGET = ( - 1 )0016      RETURN0005C0013      END000500040054      INTEGER FUNCTION STRPUT ( LUN, STR, FMTCHR )0005C0049C STRPUT - WRITE A STRING TO A SPECIFIED LUN.0069C PCN 77, 5 JAN 80, ADD A FORMAT CONTROL CHAR TO CALLING SEQUENCE0005C0005C0039      INTEGER LUN, I, N, SLEN, MIN00039      LOGICAL * 1 STR ( 1 ), FMTCHR0005C0040      I = MIN0 ( 132, SLEN ( STR ) )^^^^^^^^^^^^^^^^^^^^^^0043      IF (.NOT.( I .GT. 0 )) GOTO 201890048      IF (.NOT.( FMTCHR .EQ. 0 )) GOTO 201910070      WRITE ( LUN, 1, ERR = 11, END = 11 ) ( STR ( N ), N = 1, I )0020      GOTO 20192001820191 CONTINUE0075      WRITE ( LUN, 1, ERR = 11, END = 11 ) FMTCHR, ( STR ( N ), N = 1, 0013     $I )001820192 CONTINUE0020      GOTO 20190001820189 CONTINUE0046      WRITE ( LUN, 1, ERR = 11, END = 11 )001820190 CONTINUE00261     FORMAT ( 133A1 )0024      STRPUT = ( 1 )0016      RETURN0005C002611    STRPUT = ( - 1 )^^^^^^^^0016      RETURN0013      END000500040040      INTEGER FUNCTION STRIM ( STR )0005C0067C STRIM - REMOVE TRAILING BLANKS FROM THE RIGHT END OF A STRING0071CREMOVE ANY TRAILING BLANKS FROM THE RIGHT OF STR. THE VALUE OF THE0005C0053C  FUNCTION IS RETURNED AS THE NEW LENGTH OF STR.0005C0022      INTEGER SLEN0031      LOGICAL * 1 STR ( 1 )0005C0030      STRIM = SLEN ( STR )007520193 IF (.NOT.( STRIM .GT. 0 .AND. STR ( STRIM ) .EQ. 32 )) GOTO 201940027      STRIM = STRIM - 10020      GOTO 20193001820194 CONTINUE0031      STR ( STRIM + 1 ) = 00005C0016      RETURN0013      END000500040041      LOGICAL FUNCTION TYPE * 1 ( C )0005C0072C TYPE - DETERMINE IF A CHARACTER IS LETTER, DIGIT, OR SPECIAL CHAR.0037C SYKES 14 OCT 76, FASTER VERSION0067C PCN # 89, 10 FEB 80, SPEED UP 50% BY USING ONLY TABLE LOOKUP.0041C  **** ASCII CHARACTER SET ONLY ****0005C0005C0038      LOGICAL * 1 C, TYPES ( 127 )0074      DATA TYPES / 47 * 0, 10 * - 20, 7 * 0, 26 * - 30, 6 * 0, 26 * - 0021     $30, 5 * 0 /0005C0018      TYPE = 0^^^^^^^^^0043      IF (.NOT.( C .GT. 0 )) GOTO 201950028      TYPE = TYPES ( C )001820195 CONTINUE0046      IF (.NOT.( TYPE .EQ. 0 )) GOTO 201970018      TYPE = C0005C001820197 CONTINUE0016      RETURN0013      END000500040035      SUBROUTINE UNFOLD ( STR )0005C0082C UNFOLD - CONVERT LOWER CASE ALPHABETIC CHARACTERS IN A STRING TO UPPER CASE.0018CSYKES 15MAY770041C  **** ASCII CHARACTER SET ONLY ****0005C0005C0031      LOGICAL * 1 STR ( 1 )0019      INTEGER I0005C0032      DO 20199  I = 1, 32767^^^^^^^^^^^^^^^^^^^^0051      IF (.NOT.( STR ( I ) .EQ. 0 )) GOTO 202010016      RETURN001820201 CONTINUE0072      IF (.NOT.( STR ( I ) .GE. 97 .AND. STR ( I ) .LE. 122 )) GOTO 0015     $202030036      STR ( I ) = STR ( I ) - 320005C001820203 CONTINUE001820202 CONTINUE001820199 CONTINUE001820200 CONTINUE0016      RETURN0013      END00050004^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^