c	io.f 
c	string manipulation commands to tame lazy pulverix.
c	Functions from getxyfromdb.f.
c	Tanya Riseman, NIST cebter for Neutron Research. Nov, 2001

c======= extractfirstword ================================
	logical function extractfirstword(aline, aword, adelim)
c	returns true if a word is found, false if empty line.
c	aline is returned with aword removed from the front.
c	aword is ended by a space or a tab or the character in adelim
c	(typically adelim is a comma, colon or equals sign). 
c	Modified from function extractfirstword in getxyfromdb.f.
c	 Tanya Riseman, Univerisity of Birminghman, U.K., 2000. 

	implicit none

c       passed variables
	character*(*) 	aline, aword
	character*1	adelim

c	functions
	logical 	trim_blank
	integer		inotblank

c	internal variables
	integer 	len_aline, len_aword
cUnused	logical		notblank
	integer		i
	integer		iinotblank

c	strip off leading blanks off aline and put in templine
	if (trim_blank(aline)) then
c	 aline is only blank
	 extractfirstword = .false.
	else
	 len_aline = len(aline)
	 len_aword = len(aword)
	

c	 find end of word in string templine (which has leading blanks removed).
	 iinotblank = inotblank(aline, adelim)
c01Dec10	 iinotblank = inotblank(aline, ',')
cDebug	 write (*,*) 'extractfirstword: iinotblank = ', iinotblank, 
cDebug     &		'"', aline(1:iinotblank), 
cDebug     &		'"  space= "', aline(iinotblank+1:iinotblank+1), '"'
	 if (iinotblank .lt. len(aline) ) then
c	 if ( (iinotblank .gt. 1) .and. 
c     &	     (iinotblank .lt. len(aline)) ) then
	   !! Replace tab and ',' by space
	   aline(iinotblank+1:iinotblank+1) = ' '
	 endif
	 
c	put only the first word of aline in aword. Check for overflow.
	 if (iinotblank .le. len_aword) then
	   aword(1:iinotblank) = aline(1:iinotblank)
	   do i = iinotblank+1, len_aword
	    aword(i:i) = ' '
	   enddo
	   extractfirstword = .true.
	 else
	   aword(1:len_aword) = aline(1:len_aword)
	   extractfirstword = .false.
	 endif

c	 remove aword from beginning of aline
	 aline(1:len_aline-iinotblank) = 
     &		aline(iinotblank+1:len_aline)
	 do i = len_aline- iinotblank+1, len_aline
	  aline(i:i) = ' '
	 enddo
	endif

	return
	end


c======= extractfirstfield================================
	logical function extractfirstfield(aline, aword, adelim, alabel, 
     &		labdelim)
c	returns true if a word is found, false if empty line.
c	aline is returned with aword removed from the front.
c	aword is ended by a space or a tab or the character in adelim
c	(typcially colon, comma or equal sign).
c	A label, indicated by ending with a deliminator labdelim 
c	(: or = typcially), is stripped off the front, before aword.
c	The aword is ended by a space, a tab or adelim.

	implicit none

c       passed variables
	character*(*) aline, aword, alabel
	character*1 labdelim, adelim

c	functions
cUnused	logical 	trim_blank
	logical 	extractfirstword
cUnused	integer		inotblank
        integer		ilen
	
c	internal variables
cNotUsed	integer		iinotblank

	if (extractfirstword(aline, aword, labdelim)) then
		if (len(alabel) .lt. ilen(aword)) then
		  extractfirstfield = .false.
		  write (*,*) 'extractfirstfield: Overflow of label'
		  write (*,*) '  aword =', aword
		  write (*,*) '  len(alabel) =', len(alabel)
		else
		  alabel = aword
		endif
		if (.not. extractfirstword(aline, aword, adelim)) then
		  extractfirstfield = .false.
	  	  write (*,*) 'extractfirstfield: failed with aword' 
		  write (*,*) '  aline = ', aline
		  write (*,*) '  aword =', aword
		endif
	else
	  extractfirstfield = .false.
	  aword = ''
	  alabel = ''
	  write (*,*) 'extractfirstfield: failed on reading label'
	endif

	return
	end

c======= inotblank ================================
	integer function inotblank(aline, adelim)
c	returns the position of the last non-blank character before the first
c	blank in string aline.
c	Blank characters may be space or tab or delim
c	(typically colon, comma or equal sign).


	implicit none

c       passed variables
	character*(*) 	aline
	character*1	adelim
	
c	functions
	logical		trim_blank

c	internal variables
	integer 	len_aline
	logical		notblank
	integer		i
	character*1	atab

	atab = char(9)		!! The tab character

	if (trim_blank(aline)) then
c	 aline is only blank
	  inotblank = 0
	  return
	endif
	
	len_aline = len(aline)

c	 find end of word in string templine (which has leading blanks removed).
	 notblank = .true.
	 inotblank = 0
	 i = 0
	 do while ((i .lt. len_aline) .and. (notblank))
	  i = i + 1
c	  Check for space, tab or comma=delim
	  if ((aline(i:i).eq.' ').or.(aline(i:i) .eq. atab) 
     &			.or. (aline(i:i) .eq. adelim)) then 
	    notblank = .false.
	  else 
	    inotblank = inotblank + 1
	  endif
	 enddo
cDebug	  write (*,*) 'inotblank:= ', inotblank, '"', aline, '"'
	return
	end


	
c======= ilen ================================
	integer function ilen(aline)
c	Return the length of the string aline, minus white space at end

	implicit none

c       passed variables
	character*(*) aline
c	character*1	adelim

c	internal variables
	integer len_aline
cNotUsed	integer i
	logical endblank
        character*1	atab
	
	atab = char(9)		!! The tab character

	len_aline = len(aline)

	endblank = .false.
	ilen = len_aline
	do while ((ilen .gt. 1) .and. (.not. endblank))
	  if ((aline(ilen:ilen).eq.' ') .or.
c     &	      (aline(ilen:ilen) .eq. adelim) .or.
c01Dec12     &	      (aline(ilen:ilen) .eq. '	') ) then
     &	      (aline(ilen:ilen) .eq. atab) ) then
	    ilen = ilen - 1
	  else 
	    endblank = .true.
	  endif
	enddo

	if (ilen .eq. 0)  then
	  ilen = 1
	endif

	return
	end


	
c======= trim_blank ================================
	logical function trim_blank(aline)
c	Function from getxyfromdb.f.
c	 Tanya Riseman, Univerisity of Birminghman, U.K., 2000. 
c	return value .true. means completely empty line.
c	Trims off leading blanks (spaces and tabs) and puts 
c	results in aline.

	implicit none

c       passed variables
	character*(*) aline

c	internal variables
	integer len_aline
	integer iblank, i
	logical endblank
        character*1	atab
	
	atab = char(9)		!! The tab character

	len_aline = len(aline)

	endblank = .false.
	iblank = 1
	do while ((iblank .lt. len_aline) .and. (.not. endblank))
	  if ((aline(iblank:iblank).eq.' ') .or.
     &	      (aline(iblank:iblank) .eq. atab)) then 
	    iblank = iblank + 1
	  else 
	    endblank = .true.
	  endif
	enddo
	iblank = iblank -1

c	completely empty line
	if (iblank .eq. len_aline)  then
	  trim_blank = .true.
	else if (iblank .eq. 0) then
c	no blank at the front, so don't shift
	  trim_blank = .false.
	else
c	non-empty line, strip off the blank part in the beginning
	  trim_blank = .false.
	  aline(1:(len_aline-iblank)) = aline(1+iblank:len_aline)
	  do i = len_aline-iblank+1, len_aline
	    aline(i:i)=' '
	  enddo

	endif
cDebug	write (*,*) 'trim_blank: iblank=', iblank, 
cDEbug     &		'"', aline(1:len_aline-iblank), '"'

	return
	end

c======= supper ===================================
	subroutine supper(aword)
c	Modifed function from getxyfromdb.f.
c	 Tanya Riseman, Univerisity of Birminghman, U.K., 2000. 
c	converts string aword into uppercase.
c	Changed name from UPPER so doesn't conflict with function called upper.

	implicit none

c	passed variables
c01Dec	character*80	aword
	character*(*)	aword

c	internal variables
	integer 	i, ia, iz, bigA, iletter
	
	ia = ichar('a')
	iz = ichar('z')
	bigA =ichar('A')
cDebug	write (*,*) 'supper: len, aword=', len(aword), aword
	do i = 1, len(aword)
	  iletter = ichar(aword(i:i))
	  if ((iletter .ge. ia) .and. (iletter.le. iz)) then
	    aword(i:i) = char(bigA - ia + iletter)
	  endif
	enddo

	return
	end

c======= lower ===================================
	subroutine lower(aword)
c	converts string aword into uppercase.

	implicit none

c	passed variables
	character*(*)	aword

c	internal variables
	integer 	i, ia, iz, littleA, iletter
	
	ia = ichar('A')
	iz = ichar('Z')
	littleA =ichar('a')
	do i = 1, len(aword)
	  iletter = ichar(aword(i:i))
	  if ((iletter .ge. ia) .and. (iletter.le. iz)) then
	    aword(i:i) = char(littleA - ia + iletter)
	  endif
	enddo

	return
	end

c======= isblank ===================================
	logical function isblank(aword)

	implicit none

c	passed variables
	character*(*) aword
	
c	local variables
	integer i
	
	if (len(aword) .eq. 0) then
	   isblank = .true.
	else
	  isblank = .true. 
	  do i = 1, len(aword)
	     if (aword(1:i) .ne. ' ') isblank = .false.
	  enddo
	endif
	
	return
	end
	
c============ reportsymmetry ======================================

	subroutine reportsymmetry(ISYSTM)
	implicit none
	integer ISYSTM
	
    	if (ISYSTM .eq. 1) then
	  write(*,*) 'ReportSymmetry: ', ISYSTM, ' is monoclinic'
    	else if (ISYSTM .eq. 2) then
	  write(*,*) 'ReportSymmetry: ', ISYSTM, ' is orthorhombic'
    	else if (ISYSTM .eq. 4) then
	  write(*,*) 'ReportSymmetry: ', ISYSTM, ' is tetragonal'
    	else if (ISYSTM .eq. 5) then
	  write(*,*) 'ReportSymmetry: ', ISYSTM, ' is cubic or isometric'
    	else if (ISYSTM .eq. 6) then
	  write(*,*) 'ReportSymmetry: ', ISYSTM, ' is hexagonal (maybe rhombo)'
    	else if (ISYSTM .eq. 7) then
	  write(*,*) 'ReportSymmetry: ', ISYSTM, ' is triclinic'
    	else 
	  write(*,*) 'ReportSymmetry: ', ISYSTM, ' is unrecognized'
	endif
	
	return
	end


c======== readreal ==================================

	logical function readreal(thereal, 
     &		aline, alabel, labdelim, getlabel, lastOK)
	implicit none
c...	functions
	logical extractfirstfield
	logical extractfirstword
	logical isblank
	integer inotblank
		
c...	passed variables
	real		thereal
	character*(*)	aline, alabel, lastOK
	CHARACTER	labdelim
	logical		getLabel

c...	local variables
	character*80 aword

	
	readreal = .false.
	if (getlabel) then
	 if (extractfirstfield(aline, aword, ',', alabel, labdelim)) then
    	    if (isblank(aword)) then 
	       thereal = 0.0
     	    else 
	       read (aword, *, err=666,end=666) thereal
	    endif
    	    lastOK = 'Last part that was OK areal='//
cccc     &		aword(1:trim_len(aword))// ' with label "'//
cccc     &		alabel(1:trim_len(alabel))// '"' 
     &		aword(1:inotblank(aword, ' '))// ' with label "'//
     &		alabel(1:inotblank(alabel, ' '))// '"' 
	    readreal = .true.
	 endif
	else
	 if (extractfirstword(aline, aword, ' ')) then
    	    if (isblank(aword)) then 
	       thereal = 0.0
     	    else 
	       read (aword, *, err=666,end=666) thereal
	    endif
    	    lastOK = 'Last part that was OK areal='//
     &		aword(1:inotblank(aword, ' '))
cccc     &		aword(1:trim_len(aword))
	    readreal = .true.
	 endif
	
	endif

 666	continue
 
	return
	end
	
c======== readinteger ==================================

	logical function readinteger(theinteger, 
     &		aline, alabel, labdelim, getlabel, lastOK)
	implicit none
c...	functions
	logical extractfirstfield
	logical extractfirstword
	logical isblank
	integer inotblank
	
c...	passed variables
	integer		theinteger
	character*(*)	aline, alabel, lastOK
	CHARACTER	labdelim
	logical		getlabel

c...	local variables
	character*80 aword

	
	readinteger = .false.
	if (getlabel) then
	 if (extractfirstfield(aline, aword, ',', alabel, labdelim)) then
    	    if (isblank(aword)) then 
	       theinteger = 666
     	    else 
	       read (aword, *, err=666,end=666) theinteger
	    endif
    	    lastOK = 'Last part that was OK theinteger='//
     &		aword(1:inotblank(aword, ' '))// ' with label "'//
     &		alabel(1:inotblank(alabel, ' '))// '"' 
ccc     &		aword(1:trim_len(aword))// ' with label "'//
ccc     &		alabel(1:trim_len(alabel))// '"' 
	    readinteger = .true.
	 endif
	else
	 if (extractfirstword(aline, aword, ' ')) then
    	    if (isblank(aword)) then 
	       theinteger = 666
     	    else 
	       read (aword, *, err=666,end=666) theinteger
	    endif
    	    lastOK = 'Last part that was OK theinteger='//
     &		aword(1:inotblank(aword, ' '))
ccc     &		aword(1:trim_len(aword))
	    readinteger = .true.
	 endif
	
	endif

 666	continue
 
	return
	end
	
c======== readstring ==================================

	logical function readstring(thestring, 
     & 		aline, alabel, labdelim, getlabel, lastOK)
	implicit none

c...	functions
	logical extractfirstfield
	logical extractfirstword
	logical isblank
	integer inotblank
	
c...	passed variables
	character*(*)	thestring
	character*(*)	aline, alabel, lastOK
	CHARACTER	labdelim
	logical		getLabel

c...	local variables
	character*80 aword

	
	readstring = .false.
	if (getlabel) then
	 if (extractfirstfield(aline, aword, ',', alabel, labdelim)) then
    	    if (isblank(aword)) then 
	       thestring = '666'
     	    else 
		thestring = aword
	    endif
    	    lastOK = 'Last part that was OK thestring='//
     &		aword(1:inotblank(aword, ' '))// ' with label "'//
     &		alabel(1:inotblank(alabel, ' '))// '"' 
ccc     &		aword(1:trim_len(aword))// ' with label "'//
ccc     &		alabel(1:trim_len(alabel))// '"' 
	    readstring = .true.
	 endif
	else
	 if (extractfirstword(aline, aword, ' ')) then
    	    if (isblank(aword)) then 
	       thestring = '666'
     	    else 
		thestring = aword
	    endif
    	    lastOK = 'Last part that was OK thestring='//
     &		aword(1:inotblank(aword, ' '))
cccc     &		aword(1:trim_len(aword))
	    readstring = .true.
	 endif
	
	endif

 666	continue
 
	return
	end	
