From:	CRDGW2::CRDGW2::MRGATE::"SMTP::CRVAX.SRI.COM::RELAY-INFO-VAX" 18-SEP-1990 04:40:47.91
To:	MRGATE::"ARISIA::EVERHART"
CC:	
Subj:	VMS strlen (and others) - SOURCE CODE

Received:  by crdgw1.ge.com (5.57/GE 1.73)
	 id AA07677; Mon, 17 Sep 90 19:42:45 EDT
Received: From UCBVAX.BERKELEY.EDU by CRVAX.SRI.COM with TCP; Mon, 17 SEP 90 11:44:29 PDT
Received: by ucbvax.Berkeley.EDU (5.63/1.42)
	id AA07054; Mon, 17 Sep 90 11:26:06 -0700
Received: from USENET by ucbvax.Berkeley.EDU with netnews
	for info-vax@kl.sri.com (info-vax@kl.sri.com)
	(contact usenet@ucbvax.Berkeley.EDU if you have questions)
Date: 16 Sep 90 23:38:10 GMT
From: usc!samsung!sol.ctr.columbia.edu!cica!templon@apple.com  (Jeffrey Templon)
Organization: Indiana University
Subject: VMS strlen (and others) - SOURCE CODE
Message-Id: <5220@cica.cica.indiana.edu>
Sender: info-vax-request@kl.sri.com
To: info-vax@kl.sri.com

Gee, it's nice to actually be able to POST something WRITTEN BY YOURSELF.
I saw the request for VMS strlen function a while back; I ran into the same
problem.  I had to write a parser for some code to be used by our group, but
it had to be understandable by everybody in the group, which ruled out all
languages but FORTRAN.  Faced with having to do lots of FORTRAN text
manipulations, I wrote a small library, loosely based on the functions in
Kernighan & Ritchie's C book.  Here they are, below.  There are no restrictions
on usage of this code EXCEPT the GNU General Public License, a copy of which
can be obtained from the Free Software Foundation or by ftp from
prep.ai.mit.edu.  Have fun and hope this helps.

					Jeff Templon
--------------------------------------------------
file CHARAC.FOR follows - written in VAX/VMS fortran
author Jeffrey A. Templon, Indiana University Cyclotron Facility
--------------------------------------------------
c
c     charac.for - subroutine package which performs several
c     character-oriented i/o operations not supported in raw FORTRAN.
c     Modeled somewhat after the C language character i/o functions.
c
c     subroutine list:
c     getline - get a line of input from a file and return it as a string
c     extract - return characters, from an input string, found between two
c        specified delimiters
c     strlen - return nonblank length of string argument.  FORTRAN length
c        function simply returns declared length of string!!
c     nofrontblanks - returns string which is same as passed argument but
c        with leading blanks trimmed
c     atoi - convert string argument to integer
c     atof - convert string argument to floating
c
C***********************************************************************
C
C	G E T L I N E  function
C
C	Returns the next input line found in file assigned to LUN.
C	Converts all lowercase characters to UPPERCASE before passing
C	to calling routine.
C
C	LINE_LENGTH contains the number of characters found on the
C	input line (using the q edit descriptor.) END_OF_FILE is
C	a logical variable which is .TRUE. if GETLINE found an
C	end-of-file record upon attempting to read.
C
C	Written:	24 June 1987		J. A. Templon
C
C***********************************************************************
C	
	character*(*) function getline(lun, line_length, end_of_file)
C
	IMPLICIT NONE
C
	character*90  input_line
	integer*2     lun, line_length, i
	logical*1     end_of_file
C
	read (lun, 100, end=120) line_length, input_line
 100	format(q, a90)
C
	do i=1, min(90,line_length)
		if((ichar(input_line(i:i)) .ge. 97) .and.
	1		(ichar(input_line(i:i)) .le. 122))
	2		input_line(i:i)=char(ichar(input_line(i:i))-32)
	end do
C
	getline = input_line(1:min(90,line_length))
	end_of_file = .FALSE.
	return
C
C	***  End-of-file handled here  ***
C
 120	continue
C
	end_of_file = .TRUE.
	getline = ' '
	line_length = 0
	return
	end
C
C***********************************************************************
C
C	Routine:	EXTRACT
C
C	Purpose is to extract from a given character string [LINE]
C	a substring [STRING] which is found between two delimiting
C	strings [LDEL on the left and RDEL on right.]
C
C	If LDEL is passed as two backslashes '\\' then EXTRACT will
C	use the beginning of LINE as the left-hand delimiter.
C
C	If both LDEL and RDEL are found in LINE, STRING will contain
C	the characters found between (EXCLUSIVE) these two; FOUND is
C	set to .TRUE.
C
C	If LDEL is found but not RDEL, STRING will contain the part
C	of the line residing after LDEL (exclusive of LDEL, inclusive
C	of the end of LINE.) FOUND again set to .TRUE.
C
C	Leading blanks found after directly after LDEL are stripped.
C
C	If LDEL is not found, STRING set to ' ', FOUND set to .FALSE.
C
C	Written:	23 June 1987		J. A. Templon
C
C***********************************************************************
C
	subroutine extract(line, ldel, rdel, string, found)
C
	IMPLICIT NONE
C
	character*(*) line		! line in which to look
	character*(*) ldel, rdel	! left and right hand delimeters
	character*(*) string		! returned string found between
	logical*1     found		! .TRUE. if found something
	integer*2     offset		! offset of first char in STRING
	integer*2     last		! offset of last char in STRING
	integer*2     lastused		! last nonblank char offset
	integer       strlen		! function returning nonblank length
	integer       j			! loop index
C
C	***  First zero out STRING - appears to come up full of NULLs  ***
C
	do j = 1, len(string)
		string(j:j) = ' '
	end do
C
C	***  Strip blanks from end of LDEL  ***
C
	if (ldel .eq. '\\') then	! don't care about left hand side
		lastused = strlen(rdel)
		last = index(line, rdel(1:lastused)) - 1
		if (last .eq. -1) then
			found = .FALSE.
			string = ' '
			return
		endif
		found = .TRUE.
		offset = 1
	else if (ldel .eq. ' ') then
		type*,
     2	'EXTRACT--Cannot use blank string for left-hand delimiter'
		type*, 'Use double backslash ''\\'' if you don''t care'
		type*, 'about the left-hand delimiter'
		found = .FALSE.
		string = ' '
		return
	else					! care about LDEL, RDEL find not mandatory
		lastused = strlen(ldel)
		offset = index(line, ldel(1:lastused)) ! find LDEL in LINE
		if (offset .eq. 0) then
			found = .FALSE.		! not there
			string = ' '
			return
		endif
		found = .TRUE.			! found it
		offset = offset + lastused	! to first char of STRING
C
C	***  Strip blanks from rdel too  ***
C
		lastused = strlen(rdel)
		last = index(line, rdel(1:lastused))
		if (last .eq. 0) then			! can't find RDEL;
			last = strlen(line)
		else
			last = last - 1		! use last char before RDEL
		endif
	endif
C
C	***  Strip leading blanks, nulls, tabs  ***
C
	do while ((line(offset:offset) .eq. char(0) .or.
     2	   line(offset:offset) .eq. char(9) .or.
     3	     line(offset:offset) .eq. char(32)) .and. offset .lt. last)
		offset = offset + 1
	end do
C
C	***  Strip trailing blanks, nulls, and tabs  ***
C
	do while ((line(last:last) .eq. char(0) .or. line(last:last)
     2	   .eq. char(9) .or. line(last:last) .eq. char(32))
     3	     .and. last .gt. offset)
C
		last = last - 1
	end do
C
C
	do j = offset, last, 1
		string(j+1-offset:j+1-offset) = line(j:j)
	end do
C
	return
	end
C
C
	integer function strlen(string)
C
C	A C-language type function which will return the length of
C	the NONBLANK portion of a string; different from FORTRAN
C	function LEN which will return the DECLARED length of the
C	string.
C
	implicit none
	character*(*) string
C
C	***  Strip blanks from end of STRING  ***
C
	strlen = len(string)
	do while (string(strlen:strlen) .eq. ' ' .and. strlen .gt. 0)
		strlen = strlen - 1
	end do
C
	end
C	
C***********************************************************************
C
C	Routine  N O F R O N T B L A N K S . F O R
C
C	Routine to strip leading blanks from a passed string.
C
C
C***********************************************************************
C
	character *(*) function nofrontblanks(string)
C
	IMPLICIT NONE
C
	character*(*) string
	integer   index
	integer   strlen
	integer   len
C
	index = 1
	len = strlen(string)
C
	do while ((string(index:index) .eq. ' ' .or. string(index:index)
     2	.eq. '	') .and. index .lt. len)
		index = index + 1
	end do
C
	nofrontblanks = string(index:len)
C
	return
	end
C
C***********************************************************************
C
C	Routine A T O I . F O R
C
C	Routine to convert a passed string into an integer value.
C
C	All blanks are ignored in the input string, but non-numeric
C	characters other than '+' or '-' will generate an error.
C	Routine returns as integer*4
C
C	Written:	26 June 1987		J. A. Templon
C
C***********************************************************************
C
	integer function atoi(string)
C
	IMPLICIT NONE
C
	include '($ssdef)'		! get system return status codes
C
	character*(*)	string		! argument passed from calling routine
	integer		status		! holds return status from ots$ fn
	integer		ots$cvt_ti_l	! IMPLICIT NONE needs this
C
C	***  %val(4) - integer*4 return
C	***  %val(17) - ignore spaces and blanks  ***
C
	status = ots$cvt_ti_l(string, atoi, %val(4), %val(17))
C
	if (status .eq. ss$_normal) then
		return
	endif
C
	type*, 'Problems in function ATOI'
	type*, 'Problem could be:'
	type*, '	Non-numeric text where numeric text expected'
	type*,
     2	'	Passed string contains decimal point, not an integer'
	type*, '	Integer overflow in conversion to integer'
	type*, 'Invalid text is:  ', string
C
	call exit
	end
C
C
C***********************************************************************
C
C	Routine A T O F . F O R
C
C	Routine to convert a passed string into a floating point value.
C
C	All blanks and tabs are ignored in the input string, but non-numeric
C	characters other than '+', '-', 'E' or 'e' will generate an error.
C	Routine returns as real*4.
C
C	Written:	28 June 1987		J. A. Templon
C
C***********************************************************************
C
	real*4 function atof(string)
C
	IMPLICIT NONE
C
	include '($ssdef)'		! get system return status codes
C
	character*(*)	string		! argument passed from calling routine
	integer		status		! holds return status from ots$ fn
	integer		ots$cvt_t_f	! IMPLICIT NONE needs this
C
C	***  %val(0) - no digits in fraction if no decimal point found  ***
C	***  %val(55) - ignore spaces and blanks;  ***
C	***  allow only e and E exponents; interpret underflow as error;  ***
C	***  round value if necessary; no scale factor  ***
C
	status = ots$cvt_t_f(string, atof, %val(0), , %val(55))
C
	if (status .eq. ss$_normal) then
		return
	endif
C
	type*, 'Problems in function ATOF'
	type*, 'Problem could be:'
	type*, '	Non-numeric text where numeric text expected'
	type*, '	Value outside valid real*4 range'
	type*, 'Invalid text is:  ', string
C
	call exit
	end
C
c  Local Variables: ***
c  mode:fortran ***
c  comment-start: "! "  ***
c  End: ***
--------------------------------------------------
end of file CHARAC.FOR
--------------------------------------------------

