- Rearranged directory structure for forking out ANSTO

- Refactored site specific stuff into a site module
- PSI specific stuff is now in the PSI directory.
- The old version has been tagged with pre-ansto

tecs/str.f

@@ -0,0 +1,131 @@
+!! string handling
+!!
+	subroutine STR_TRIM(RETSTR, STR, RETLEN) !!
+!!
+!! if RETSTR=STR then RETSTR is not touched
+!!
+!! Arguments:
+	character*(*) STR, RETSTR !! in,out
+	integer RETLEN    	!! out
+	integer i
+
+	i=len(str)
+	if (str(1:1) .gt. ' ') then
+10	  if (str(i:i) .le. ' ') then
+	    i=i-1
+	    goto 10
+	  endif
+	else
+20	  if (str(i:i) .le. ' ') then
+	    if (i .gt. 1) then
+	      i=i-1
+	      goto 20
+	    endif
+	  endif
+	endif
+	retlen=min(len(retstr),i)
+	if (retstr .ne. str) then ! avoid copy to retstr if equal
+	  retstr=str(1:i)
+	endif
+	end
+
+!!
+	subroutine STR_UPCASE(RETSTR, STR) !!
+!!
+!! Arguments:
+	character STR*(*), RETSTR*(*)	!! in,out
+	integer i, ch
+
+	retstr=str
+	do i=1,len(retstr)
+	  ch=ichar(retstr(i:i))
+	  if (ch .ge. ichar('a') .and. ch .le. ichar('z')) then
+	    retstr(i:i)=char(ch-(ichar('a')-ichar('A')))
+	  endif
+	enddo
+	end
+
+!!
+	subroutine STR_LOWCASE(RETSTR, STR) !!
+!!
+!! Arguments:
+	character STR*(*), RETSTR*(*)	!! in,out
+	integer i, ch
+
+	retstr=str
+	do i=1,len(retstr)
+	  ch=ichar(retstr(i:i))
+	  if (ch .ge. ichar('A') .and. ch .le. ichar('Z')) then
+	    retstr(i:i)=char(ch+(ichar('a')-ichar('A')))
+	  endif
+	enddo
+	end
+
+!!
+	subroutine STR_APPEND(str, length, add) !!
+!!
+	implicit none
+
+	character*(*) str, add !!
+	integer length         !!
+
+	if (len(add)+length .gt. len(str)) then
+	  if (length .lt. len(str)) then
+	    str(length+1:)=add
+	    length=len(str)
+	  endif
+	else
+	  str(length+1:length+len(add))=add
+	  length=length+len(add)
+	endif
+	end
+
+!!
+	integer function STR_CMP(str1, str2) !!
+!!
+!! if strings are equal: return 0
+!! else return position of first different character
+
+	character str1*(*), str2*(*) !!
+
+	integer i
+
+	do i=0,min(len(str1),len(str2))-1
+	  if (str1(i+1:i+1) .ne. str2(i+1:i+1)) then
+	    str_cmp=i+1
+	    return
+	  endif
+	enddo
+	do i=len(str1),len(str2)-1
+	  if (str2(i+1:i+1) .ne. ' ') then
+	    str_cmp=i+1
+	    return
+	  endif
+	enddo
+	do i=len(str2),len(str1)-1
+	  if (str1(i+1:i+1) .ne. ' ') then
+	    str_cmp=i+1
+	    return
+	  endif
+	enddo
+	str_cmp=0
+	return
+	end
+
+!!
+	subroutine STR_FIRST_NONBLANK(STR, POS) !!
+!!
+!! Arguments:
+	character*(*) STR       !! in
+	integer POS             !! out
+	integer i
+
+	do i=1,len(str)
+	  if (str(i:i) .gt. ' ') then
+	    pos=i
+	    return
+	  endif
+	enddo
+	pos=0
+	end
+