Compcolor II Virtual Media

Listing of file='STRUTL.FOR;01' on disk='vmedia/strings_fortran-sector.ccvf'
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C	STRING UTILITY ROUTINES
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C

C..............................................................
C
C	BLOCK DATA FOR THE ROUTINES
C
C	COMMONLY USED DATA CONSTANTS
C
C..............................................................
C
C
C	BLOCK DATA STRING
C	INTEGER MAXLEN
C	BYTE EOS,SPACE,TAB,CHRA,CHRZ,CHR0,CHR9
C	BYTE TEMP(257)
C	COMMON /DATSTR/MAXLEN
C	COMMON /CHRSTR/EOS,SPACE,TAB,CHRA,CHRZ,CHR0,CHR9
C	COMMON /TMPSTR/TEMP
C	DATA MAXLEN/80/
C	DATA EOS,SPACE,TAB/0,' ',9/
C	DATA CHRA,CHRZ,CHR0,CHR9/'A','Z','0','9'/
C	DATA TEMP/257*' '/
C	END

C..............................................................
C
C	SUBROUTINE - CONCATENATE STRINGS
C
C...PURPOSE
C	CONCATENATE TWO STRINGS PRODUCING A THIRD
C
C...REMARKS
C	EITHER OF THE INPUT STRINGS MAY ALSO BE THE OUTPUT
C	STRING, HOWEVER, THE TEMPORARY STRING IS LIMITED TO
C	256 CHARACTERS MAXIMUM.
C
C..............................................................
C
C
	SUBROUTINE CCNSTR(STR1,STR2,STR3)
	BYTE STR1(81),STR2(81),STR3(81),TEMP(257),EOS,SPACE
	COMMON /DATCHR/MAXLEN
	COMMON /CHRSTR/EOS,SPACE
	COMMON /TMPSTR/TEMP
C
	CALL FILSTR(TEMP,SPACE)
	LEN1 = LENSTR(STR1)
	LEN2 = LENSTR(STR2)
C
C		COPY THE FIRST STRING INTO THE TEMPORARY.
C		IT MUST FIT.
C
	DO 100 J=1,LEN1
	   TEMP(J) = STR1(J)
  100	CONTINUE
C
C		NOW THE SECOND STRING, TAKING CARE NOT TO
C		OVERFLOW THE TEMPORARY STRING.
C
	DO 200 J=1,LEN2
	   K = J+LEN1
	   IF(K.GT.256) GO TO 300
	   TEMP(K) = STR2(J)
  200	CONTINUE
C
C		COPY THE RESULT
C
  300	LENGTH = LEN1+LEN2
	IF(LENGTH.GT.MAXLEN) LENGTH = MAXLEN
	TEMP(LENGTH+1) = EOS
	CALL CPYSTR(TEMP,STR3)
	RETURN
	END

C..............................................................
C
C	FUNCTION - COMPARE STRINGS
C
C...PURPOSE
C	COMPARES TWO STRINGS TO SEE IF THEY ARE LESS THAN,
C	EQUAL TO, OR GREATER THAN EACH OTHER.
C
C...REMARKS
C	'LESS THAN' IS IN TERMS OF THE ASCII COLLATING
C	SEQUENCE. THE SHORTER STRING IS 'LESS THAN' IF THE
C	TWO STRINGS ARE IDENTICAL IN THE FIRST FEW CHARACTERS.
C
C..............................................................
C
C
	INTEGER FUNCTION CMPSTR(STR1,STR2)
	BYTE STR1(81),STR2(81)
C
	LEN1 = LENSTR(STR1)
	LEN2 = LENSTR(STR2)
	LENGTH = MIN0(LEN1,LEN2)
C
C		NULL STRINGS ARE EQUAL
C
	IF(LENGTH.LT.1) GO TO 200
C
	DO 100 J=1,LENGTH
	   IF(STR1(J).LT.STR2(J)) GO TO 300
	   IF(STR2(J).GT.STR2(J)) GO TO 400
  100	CONTINUE
C
C		STRINGS ARE EQUAL - CHECK LENGTHS
C
	IF(LEN1.LT.LEN2) GO TO 300
	IF(LEN1.GT.LEN2) GO TO 400
C
C		EQUAL CASE
C
  200	CMPSTR = 0
	RETURN
C
C		LESS THAN CASE
C
  300	CMPSTR = -1
	RETURN
C
C		GREATER THAN CASE
C
  400	CMPSTR = 1
	RETURN
	END

C..............................................................
C
C	SUBROUTINE - COPY STRING
C
C...PURPOSE
C	COPIES A STRING INTO ANOTHER STRING
C
C...REMARKS
C	BLANKS OUT THE STRING FIRST TO AVOID PROBLEMS WITH
C	THE 'EOS'.
C
C..............................................................
C
C
	SUBROUTINE CPYSTR(STR1,STR2)
	BYTE STR1(81),STR2(81),EOS,SPACE
	COMMON /CHRSTR/EOS,SPACE
C
C		NOTE THAT THE EOS IS COPIED TOO
C
	LENGTH = LENSTR(STR1)+1
	DO 100 J=1,LENGTH
	   STR2(J) = STR1(J)
  100	CONTINUE
	RETURN
	END

C..............................................................
C
C	SUBROUTINE - FILL STRING WITH CHARACTER
C
C...PURPOSE
C	FILLS A STRING WITH THE GIVEN CHARACTER
C
C...REMARKS
C	THE WHOLE MAXIMUM LENGTH OF THE STRING IS USED
C
C..............................................................
C
C
	SUBROUTINE FILSTR(STRING,CHAR)
	BYTE STRING(81),CHAR,EOS
	COMMON /DATSTR/MAXLEN
	COMMON /CHRSTR/EOS
C
	DO 100 J=1,MAXLEN
	   STRING(J) = CHAR
  100	CONTINUE
	STRING(MAXLEN+1) = EOS
	RETURN
	END

C..............................................................
C
C	SUBROUTINE - GET STRING
C
C...PURPOSE
C	READS A STRING AND TRIMS OFF TRAILING BLANKS
C
C...REMARKS
C	EXCESS CHARACTERS ARE LOST. A NEW LINE IS ALWAYS READ.
C	AN END-OF-FILE INDICATION IS RETURNED (ALSO ERROR).
C
C..............................................................
C
C
	SUBROUTINE GETSTR(LUN,STRING,EOF)
	BYTE STRING(81)
	LOGICAL EOF
	COMMON /DATSTR/MAXLEN
	COMMON /CHRSTR/EOS
C
	EOF = .FALSE.
	READ(LUN,100,END=1000,ERR=1000)(STRING(K),K=1,MAXLEN)
  100	FORMAT(256A1)
	STRING(MAXLEN+1) = EOS
	CALL TMTSTR(STRING)
	RETURN
C
C		END-OF-FILE OR ERROR CONDITION
C
 1000	EOF = .TRUE.
	RETURN
	END

C..............................................................
C
C	FUNCTION - LENGTH OF STRING
C
C...PURPOSE
C	RETURNS THE LENGTH OF A STRING
C
C...REMARKS
C	THE STRING MAY CONTAIN 'EOS' (=0) BECAUSE ONLY THE
C	LAST OCCURANCE IN THE ARRAY IS FOUND.
C
C..............................................................
C
C
	FUNCTION LENSTR(STRING)
	BYTE STRING(81),EOS
	COMMON /DATSTR/MAXLEN
	COMMON /CHRSTR/EOS
C
C		SEARCH FOR EOS AND RETURN LENGTH IF FOUND
C
	MAXP = MAXLEN+1
	DO 100 J=1,MAXP
	   IF(STRING(J).NE.EOS) GO TO 100
	      LENSTR = J-1
	      RETURN
  100	CONTINUE
C
C		STRING IS EMPTY
C
	LENSTR = 0
	RETURN
	END

C..............................................................
C
C	SUBROUTINE - SUB-STRING
C
C...PURPOSE
C	EXTRACTS A STRING FROM PART OF ANOTHER
C
C...REMARKS
C	THE RESULT MAY BE PLACED BACK IN THE SAME STRING
C
C..............................................................
C
C
	SUBROUTINE SUBSTR(STR1,INDEX,LEN,STR2)
	BYTE STR1(81),STR2(81),EOS,SPACE
	COMMON /CHRSTR/EOS,SPACE
C
C		CHECK FOR NULL RESULT FIRST
C
	LENGTH = LENSTR(STR1)-INDEX+1
	IF((LENGTH.GT.0).AND.(LEN.GT.0)) GO TO 100
	   STR2(1) = EOS
	   RETURN
C
C		TAKE THE SUBSTRING OR THE REST OF THE STRING,
C		WHICHEVER IS THE SHORTER
C
  100	LIM = MIN0(LEN,LENGTH)
	DO 200 K=1,LIM
	   J = INDEX+K-1
	   STR2(K) = STR1(J)
  200	CONTINUE
	RETURN
	END

C..............................................................
C
C	SUBROUTINE - TRIM THE HEAD (FRONT) OF A STRING
C
C...PURPOSE
C	REMOVES LEADING SPACES FROM A STRING
C
C...REMARKS
C	HANDY FOR EXTRACTING WORDS FROM A STRING. REMOVES
C	TABS ALSO.
C..............................................................
C
C
	SUBROUTINE TMHSTR(STRING)
	BYTE STRING(81),EOS,SPACE,TAB
	COMMON /DATSTR/MAXLEN
	COMMON /CHRSTR/EOS,SPACE,TAB
C
	LENGTH = LENSTR(STRING)
	DO 100 J=1,LENGTH
	   NEXT = STRING(J)
	   IF((NEXT.NE.SPACE).AND.(NEXT.NE.TAB)) GO TO 200
  100	CONTINUE
C
C		THE STRING IS ALL WHITE SPACE.
C		CLEAR IT OUT (TO REMOVE ANY OTHER EOS) AND
C		SET IT TO NULL.
C
	STRING(1) = EOS
	RETURN
C
C		MOVE THE STRING LEFT IN THE ARRAY
C
  200	LIM = LENGTH+2-J
	DO 300 K=1,LIM
	   M = J+K-1
	   STRING(K) = STRING(M)
  300	CONTINUE
	RETURN
	END

C..............................................................
C
C	SUBROUTINE - TRIM THE TAIL (END) OF A STRING
C
C...PURPOSE
C	REMOVES TRAILING SPACES AND TABS FROM A STRING
C
C...REMARKS
C	AUTOMATICALLY PERFORMED BY GETSTR
C
C..............................................................
C
C
	SUBROUTINE TMTSTR(STRING)
	BYTE STRING(81),EOS,SPACE,TAB
	COMMON /DATSTR/MAXLEN
	COMMON /CHRSTR/EOS,SPACE,TAB
C
	LENGTH = LENSTR(STRING)
C
C		SEARCH BACKWARDS FOR A NON-SPACE
C
	DO 100 J=1,LENGTH
	   K = LENGTH+1-J
	   NEXT = STRING(K)
C
	   IF((NEXT.NE.SPACE).AND.(NEXT.NE.TAB)) RETURN
C
C		ELSE MOVE THE END OF THE STRING BACK ONE
C
	   STRING(K) = EOS
  100	CONTINUE
	RETURN
	END