C C$ ****STRING LIBRARY FILE=STRLIB.RAT C PCN #47, 4 APR 79, ADD ALLDIG,FOLD,SHELL,INDEX,TYPE,UNFOLD C PCN #89, 10 FEB 80, SPEED UP SCOPY,SPAD,SCOMPR,TYPE C C ****CALLING SEQUENCE SUMMARY **** C# ALLDIG - I =ALLDIG(STR) C# FOLD - CALL FOLD (STR) C# EQLS - I =EQLS (VEC, PATSTR) 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 (VEC, 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, VEC, 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, FMTCHR) C# STRIM - LEN =STRIM (STR) C# TYPE - C =TYPE (CHAR) C# UNFOLD - CALL UNFOLD (STR) CFILE=DEFIN.RAT ===== GENERAL CHARACTER SET DEFINITIONS =============== C PCN #73, DEC 79, ADD CARET,TILDE FOR .NOT. C C C$ ****GENERAL COMMENTS: C# NOTE: SOME OF THESE ROUTINES ARE SET UP TO WORK WITH ASCII CHARACTER SET ONLY. C#THEREFORE, IF THE MACHINE'S NATIVE CHARACTER SET IS NOT ASCII, YOU MUST C#USE 'INMAP' TO CONVERT TO ASCII BEFORE USING THESE ROUTINES. OR ELSE REWRITE C#THESE ROUTINES. 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'. CTHESE ROUTINES REQUIRE THAT THE COMPILER MAKE CORRECT COMPARES OF INTEGER C VALUES BETWEEN INTEGERS AND WHATEVER DATA TYPE 'CHARACTER' IS DEFINED TO BE C (LOGICAL*1 IN DEC-LAND). C"STRINGS" ARE VECTORS OF CHARACTERS TERMINATED BY AN 'EOS'. C THE LENGTH OF A STRING IS THE NUMBER OF CHARACTERS IN IT, NOT INCLUDING THE 'EOS'. C"CHARACTERS" ARE SINGLE CHARACTERS, ONE PER STORAGE ELEMENT. C"CHARACTER VECTORS" ARE VECTORS (OR ARRAYS) CONTAINING CHARACTERS BUT WITHOUT C THE TERMINATING 'EOS'. THUS, A PART OF A STRING WHICH DOES NOT INCLUDE THE C 'EOS' IS A CHARACTER VECTOR, AND A VECTOR WITH AN 'EOS' IS A STRING. C C$ ALLDIG - RETURN YES IF STR IS ALL DIGITS C INTEGER FUNCTION ALLDIG ( STR ) C LOGICAL * 1 STR ( 1 ), TYPE INTEGER I C IF (.NOT.( STR ( 1 ) .EQ. 0 )) GOTO 20000 ALLDIG = ( 0 ) RETURN 20000 CONTINUE DO 20002 I = 1, 32767 IF (.NOT.( STR ( I ) .EQ. 0 )) GOTO 20004 ALLDIG = ( 1 ) RETURN 20004 CONTINUE IF (.NOT.( TYPE ( STR ( I ) ) .NE. - 20 )) GOTO 20006 ALLDIG = ( 0 ) RETURN 20006 CONTINUE 20005 CONTINUE C 20002 CONTINUE 20003 CONTINUE END C C$ EQLS - DO ANCHORED COMPARE OF STRING WITH CHAR VECTOR C STARTING AT BEGINNING OF VEC, COMPARE IT WITH PATSTR (WHICH MUST BE A C STRING). IF THE NEXT CHARACTERS OF VEC MATCH 1 FOR 1 THE CHARACTERS OF C PATSTR, RETURN THE VALUE OF THE FUNCTION AS 'YES', ELSE 'NO'. C INTEGER FUNCTION EQLS ( VEC, PATSTR ) C LOGICAL * 1 VEC ( 1 ), PATSTR ( 1 ) C I = 1 20008 IF (.NOT.( PATSTR ( I ) .NE. 0)) GOTO 20010 IF (.NOT.( PATSTR ( I ) .NE. VEC ( I ) )) GOTO 20011 EQLS = ( 0 ) RETURN 20011 CONTINUE 20009 I = I + 1 GOTO 20008 20010 CONTINUE EQLS = ( 1 ) RETURN END C C$ FOLD - CONVERT UPPER CASE LETTERS IN A STRING TO LOWER CASE C15MAY77 C **** ASCII CHARACTER SET ONLY **** C SUBROUTINE FOLD ( STR ) C LOGICAL * 1 STR ( 1 ) INTEGER I C DO 20013 I = 1, 32767 IF (.NOT.( STR ( I ) .EQ. 0 )) GOTO 20015 RETURN 20015 CONTINUE IF (.NOT.( STR ( I ) .GE. 65 .AND. STR ( I ) .LE. 90 )) GOTO $20017 STR ( I ) = STR ( I ) + 32 20017 CONTINUE 20016 CONTINUE C 20013 CONTINUE 20014 CONTINUE RETURN END C C$ INDEX - FIND THE LOCATION OF A CHARACTER WITHIN A STRING C15MAY77 C PCN #95, 11 MAR 80, DON'T USE 'INDEX' AS DO-LOOP INDEX SO F4P IS HAPPY. C THE VALUE OF THE FUNCTION IS RETURNED AS THE NUMBER OF THE ELEMENT C IN 'STR' WHERE THE FIRST OCCURRENCE OF CHARACTER 'C' IS FOUND C (STARTING AT THE LEFT END), OR AS 0, IF C IS NOT IN 'STR'. C INTEGER FUNCTION INDEX ( STR, C ) C LOGICAL * 1 C, STR ( 1 ) C DO 20019 I = 1, 32767 IF (.NOT.( STR ( I ) .EQ. 0 )) GOTO 20021 INDEX = ( 0 ) RETURN 20021 CONTINUE IF (.NOT.( STR ( I ) .EQ. C )) GOTO 20023 INDEX = ( I ) RETURN 20023 CONTINUE 20022 CONTINUE C 20019 CONTINUE 20020 CONTINUE 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 C PCN #89, 10 FEB 80, SPEED UP 50%, REPLACE 'FOR' WITH 'DO'. CRETURN 0 IF EQUAL. (STRINGS MUST BE SAME LENGTH) CRETURN -1 IF STR1 IS CLOSER TO 'A' THEN STR2 CRETURN +1 IF STR1 IS CLOSER TO 'Z' THEN STR2 C **** ASCII CHARACTER SET ONLY **** C INTEGER FUNCTION SCOMPR ( STR1, STR2 ) C INTEGER I, J LOGICAL * 1 STR1 ( 1 ), STR2 ( 1 ) C DO 20025 I = 1, 32767 IF (.NOT.( STR1 ( I ) .EQ. STR2 ( I ) )) GOTO 20027 IF (.NOT.( STR1 ( I ) .EQ. 0 )) GOTO 20029 SCOMPR = ( 0 ) RETURN 20029 CONTINUE GOTO 20028 20027 CONTINUE GOTO 20026 C 20028 CONTINUE 20025 CONTINUE 20026 CONTINUE IF (.NOT.( STR1 ( I ) .LT. STR2 ( I ) )) GOTO 20031 SCOMPR = ( - 1 ) RETURN 20031 CONTINUE SCOMPR = ( + 1 ) RETURN C 20032 CONTINUE 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. CFOR 1ST PART (BEFORE 'CHAR'), THE COMPARE ENDS WHEN EITHER STRING CONTAINS C A 'CHAR'. IT THEN LINES UP THE 'CHAR' IN BOTH STRINGS AND COMPARES THE C SECOND PART OF BOTH STRINGS UNTIL AN EOS IS FOUND IN EITHER STRING. C THE STRINGS DO NOT HAVE TO BE THE SAME LENGTH (EITHER BEFORE OR AFTER THE C 'CHAR') TO BE CONSIDERED A MATCH. C **** ASCII CHARACTER SET ONLY **** CRETURNS -1 IF STR1 IS HIGHER ALPHABETICALLY THEN STR2 CRETURNS 0 IF STR1 IS EQUAL TO STR2, PIVOTING AROUND 'CHAR'. CRETURNS +1 IF STR1 IS LOWER ALPHABETICALLY THEN STR2 C IF STR1="FIRST PART0) OR FROM RIGHT TO LEFT C (IF LORR 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. CALTHOUGH STR2 IS A STRING, IT IS REALLY USED AS A COLLECTION OF SEPERATE C CHARACTERS, NOT AS A STRING WHERE THE ORDER OF THE CHARACTERS WOULD BE C IMPORTANT. C IF STR1="ABCDE7FGH" C STR2="0123456789" C THEN I=SSAME(STR1,STR2,+1) RETURNS: C I=6 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 20157 SSAME = 1 GOTO 20158 20157 CONTINUE SSAME = SLEN ( STR1 ) 20158 CONTINUE 20159 IF (.NOT.( SSAME .GT. 0 .AND. STR1 ( SSAME ) .NE. 0 )) GOTO 20160 I = 1 20161 IF (.NOT.( STR2 ( I ) .NE. 0)) GOTO 20163 IF (.NOT.( STR1 ( SSAME ) .EQ. STR2 ( I ) )) GOTO 20164 RETURN 20164 CONTINUE 20162 I = I + 1 GOTO 20161 20163 CONTINUE IF (.NOT.( LORR .GT. 0 )) GOTO 20166 SSAME = SSAME + 1 GOTO 20167 20166 CONTINUE SSAME = SSAME - 1 20167 CONTINUE GOTO 20159 20160 CONTINUE SSAME = ( 0 ) RETURN C END C C$ SSAMEX - RETURN LOCATION OF 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. CALTHOUGH STR2 IS A STRING, IT IS REALLY USED AS A COLLECTION OF SEPERATE C CHARACTERS, NOT AS A STRING WHERE THE ORDER OF THE CHARACTERS WOULD BE C IMPORTANT. C IF STR1="123456ABC" C STR2="0123456789" C THEN I=SSAMEX(STR1,STR2,+1) RETURNS: C I=7 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 20168 SSAMEX = 1 GOTO 20169 20168 CONTINUE SSAMEX = SLEN ( STR1 ) 20169 CONTINUE 20170 IF (.NOT.( SSAMEX .GT. 0 .AND. STR1 ( SSAMEX ) .NE. 0 )) GOTO $20171 I = 1 20172 IF (.NOT.( STR2 ( I ) .NE. 0)) GOTO 20174 IF (.NOT.( STR1 ( SSAMEX ) .EQ. STR2 ( I ) )) GOTO 20175 GOTO 20174 20175 CONTINUE 20173 I = I + 1 GOTO 20172 20174 CONTINUE IF (.NOT.( STR2 ( I ) .EQ. 0 )) GOTO 20177 RETURN 20177 CONTINUE IF (.NOT.( LORR .GT. 0 )) GOTO 20179 SSAMEX = SSAMEX + 1 GOTO 20180 20179 CONTINUE SSAMEX = SSAMEX - 1 20180 CONTINUE 20178 CONTINUE GOTO 20170 20171 CONTINUE SSAMEX = ( 0 ) RETURN C END C C$ SSUFX - SEPERATE OUT A SUFFEX SUBSTRING CMOVE CHARACTERS FROM STR1 INTO STR3 WHICH ARE TO THE RIGHT OF THE FIRST C OCCURENCE 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. CIF NONE OF THE CHARACTERS IN STR2 IS FOUND IS STR1, ALL OF STR1 GOES INTO C STR4 AND STR3 IS NULL. CALTHOUGH STR2 IS A STRING, IT IS REALLY USED AS A COLLECTION OF SEPERATE C CHARACTERS, NOT AS A STRING WHERE THE ORDER OF THE CHARACTERS WOULD BE C IMPORTANT. C IF STR1="FILENAME.EXT" C STR2=":.;" C THEN SSUFX RETURNS: C STR3="EXT" C STR4="FILENAME." 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 20181 I = SLEN ( STR1 ) 20181 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. STR2 AND STR3 NEED NOT BE SAME C LENGTH. C IF STR1="FILENAME.FTN;3" C STR2="FTN" C STR3="OBJ" C THEN SSWAP RETURNS: C I=14 C STR4="FILENAME.OBJ;3" 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 20183 STR4 ( 1 ) = 0 ERROR = 0 SSWAP = ( 0 ) RETURN 20183 CONTINUE IF (.NOT.( I .GT. MAX )) GOTO 20185 ERROR = 1 I = MAX + 1 GOTO 20186 20185 CONTINUE ERROR = 0 20186 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 ONCE STR4 REACHES 'MAX' LENGTH, SJOIN WILL NOT ADD TO IT. C 20184 CONTINUE RETURN END C C$ STRGET - READ A STRING FROM A SPECIFIED LUN C PCN #77, 6 JAN 80, ALLOW FOR SKIP-RECORD DUMMY READS C PCN #81, 13 JAN 80, FIX SUBSCRIPT ERROR F4P GENERATES IF MAX IS 0. C **CAUTION: THIS ROUTINE TRUSTS FORTRAN TO MOVE INTO THE BUFFER ONLY THAT C **PART OF THE RECORD CALLED FOR BY 'MAX'. DEC'S FORTRAN IV V2.1 (AT LEAST) C **HAS A BUG WHICH CAUSES IT TO ALWAYS READ A FULL RECORD. THEREFORE, IF YOUR C **BUFFER IS SMALLER THEN THE RECORD SIZE, IT READS MORE INTO THE BUFR THEN C **IT HAS ROOM FOR, KLOBBERING GOD-KNOWS-WHAT IN YOUR PROGRAM. BEST TO TEST C **THIS OR ALWAYS GIVE STRGET A BUFFER AS BIG AS THE LARGEST POSSIBLE RECORD. C INTEGER FUNCTION STRGET ( LUN, STR, MAX ) C INTEGER LUN, MAX, N LOGICAL * 1 STR ( 1 ) C IF (.NOT.( MAX .GT. 0 )) GOTO 20187 READ ( LUN, 1, END = 100, ERR = 101 ) STRGET, ( STR ( N ), N = 1, $ MAX ) 1 FORMAT ( Q, 132A1 ) STR ( STRGET + 1 ) = 0 RETURN 20187 CONTINUE READ ( LUN, 1, END = 100, ERR = 101 ) STR ( 1 ) = 0 STRGET = ( 0 ) RETURN C 20188 CONTINUE 100 STR ( 1 ) = 0 STRGET = ( - 3 ) RETURN C 101 STR ( 1 ) = 0 STRGET = ( - 1 ) RETURN C END C C$ STRPUT - WRITE A STRING TO A SPECIFIED LUN C PCN 77, 5 JAN 80, ADD A FORMAT CONTROL CHAR TO CALLING SEQUENCE C INTEGER FUNCTION STRPUT ( LUN, STR, FMTCHR ) C INTEGER LUN, I, N, SLEN, MIN0 LOGICAL * 1 STR ( 1 ), FMTCHR C I = MIN0 ( 132, SLEN ( STR ) ) IF (.NOT.( I .GT. 0 )) GOTO 20189 IF (.NOT.( FMTCHR .EQ. 0 )) GOTO 20191 WRITE ( LUN, 1, ERR = 11, END = 11 ) ( STR ( N ), N = 1, I ) GOTO 20192 20191 CONTINUE WRITE ( LUN, 1, ERR = 11, END = 11 ) FMTCHR, ( STR ( N ), N = 1, $I ) 20192 CONTINUE GOTO 20190 20189 CONTINUE WRITE ( LUN, 1, ERR = 11, END = 11 ) 20190 CONTINUE 1 FORMAT ( 133A1 ) 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 ) 20193 IF (.NOT.( STRIM .GT. 0 .AND. STR ( STRIM ) .EQ. 32 )) GOTO 20194 STRIM = STRIM - 1 GOTO 20193 20194 CONTINUE STR ( STRIM + 1 ) = 0 C RETURN END C C$ TYPE - DETERMINE IF A CHARACTER IS LETTER, DIGIT, OR SPECIAL CHAR C SYKES 14 OCT 76, FASTER VERSION C PCN # 89, 10 FEB 80, SPEED UP 50% BY USING ONLY TABLE LOOKUP. C **** ASCII CHARACTER SET ONLY **** C LOGICAL FUNCTION TYPE * 1 ( C ) C LOGICAL * 1 C, TYPES ( 127 ) DATA TYPES / 47 * 0, 10 * - 20, 7 * 0, 26 * - 30, 6 * 0, 26 * - $30, 5 * 0 / C TYPE = 0 IF (.NOT.( C .GT. 0 )) GOTO 20195 TYPE = TYPES ( C ) 20195 CONTINUE IF (.NOT.( TYPE .EQ. 0 )) GOTO 20197 TYPE = C C 20197 CONTINUE RETURN END C C$ UNFOLD - CONVERT LOWER CASE ALPHABETIC CHARACTERS IN A STRING TO UPPER CASE CSYKES 15MAY77 C **** ASCII CHARACTER SET ONLY **** C SUBROUTINE UNFOLD ( STR ) C LOGICAL * 1 STR ( 1 ) INTEGER I C DO 20199 I = 1, 32767 IF (.NOT.( STR ( I ) .EQ. 0 )) GOTO 20201 RETURN 20201 CONTINUE IF (.NOT.( STR ( I ) .GE. 97 .AND. STR ( I ) .LE. 122 )) GOTO $20203 STR ( I ) = STR ( I ) - 32 C 20203 CONTINUE 20202 CONTINUE 20199 CONTINUE 20200 CONTINUE RETURN END