MODULE Strings !!

!! string handling

CONTAINS

!!
  subroutine STR_TRIM(RETSTR, STR, RETLEN) !!
!!
!! if RETSTR=STR then RETSTR is not touched
!!
    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=i
    if (retstr .ne. str) then ! avoid copy to retstr if equal
      retstr=str(1:i)
    endif
  end subroutine

!!
  subroutine STR_UPCASE(RETSTR, STR) !!
!!
    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

!!
  subroutine STR_LOWCASE(RETSTR, STR) !!
!!
    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

!!
  subroutine STR_APPEND(STR, LENGTH, ADD) !!
!!
!!  append ADD to STR(1:LENGTH)
!!  when STR too short, it is truncated
!!
    character*(*) str !! (in/out)
    character*(*) add !! (in)
    integer length    !! (in/out)

    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 subroutine

!!
  integer function STR_CMP(str1, str2) !!
!!
!! if strings are equal: return 0
!! else return position of first different character
!!
    character STR1*(*), STR2*(*) !! (in) strings to comapre

    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 function

!!
  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 subroutine

!!
  subroutine STR_SUBSTITUTE(RESULT, STR, OLD, NEW) !!
!!
!! replace all occurences of substring OLD in STR by NEW
!! special case: if NEW=CHAR(0) then a null length string is replaced
!!
    character RESULT*(*), STR*(*) !! (out), (in) strings (must either be equal or not overlap)
    character OLD*(*), NEW*(*)    !! substrings (in)

    integer i,j,k

    i=0
    j=index(str, old)-1
    if (len(new) .eq. 1 .and. new(1:1) .eq. char(0)) then
      k=0
      do while (j .ge. 0)
            if (j .gt. 0) result(k+1:k+j)=str(i+1:i+j)
        i=i+j+len(old)
        k=k+j
        if (i .ge. len(str)) then
          if (k .lt. len(result)) result(k+1:)=' '
          RETURN
        endif
        j=index(str(i+1:), old)-1
      enddo
      if (k .lt. len(result)) result(k+1:)=str(i+1:)
    elseif (len(old) .ge. len(new)) then
      k=0
      do while (j .ge. 0)
            if (j .gt. 0) result(k+1:k+j)=str(i+1:i+j)
        i=i+j+len(old)
        k=k+j
            result(k+1:k+len(new))=new
        k=k+len(new)
        if (i .ge. len(str)) then
          if (k .lt. len(result)) result(k+1:)=' '
          RETURN
        endif
        j=index(str(i+1:), old)-1
      enddo
      if (k .lt. len(result)) result(k+1:)=str(i+1:)
    else
      result=str
      do while (j .ne. 0)
        i=i+j
        result(i+1:)=new//result(i+len(old)+1:)
        i=i+len(new)
        if (i .ge. len(str)) RETURN
        j=index(str(i+1:), old)-1
      enddo
    endif
  end subroutine

!!
  subroutine STR_SPLIT(STR, DELIM, START, END)  !!
!!
!! split string into sequences separated by DELIM
!! for the first sequence set END=0 and START=0 (or START=n for other start position n+1)
!! result: end of list: END=0, START=0
!!         empty sequence: START=END+1
!!         normal sequence: STR(START:END) without delimiter
!!
    character STR*(*), DELIM*(*) !! (in) string, delimiter
    integer START, END  !! (in/out) start/end position

    integer i

    if (end .eq. len(str)) then
      start=0
      end=0
      RETURN
    endif
    if (end .ne. 0) start=end+len(delim)
    i=index(str(start+1:), delim)
    if (i .eq. 0) then
      end=len(str)
    else
      end=start+i-1
    endif
    start=start+1
  end subroutine

!!
  subroutine STR_FMT_REAL(RESULT, RESLEN, X, WIDTH, FIXLEN, DIGITS, TRUNC)   !!
!! 
!! Convert X to RESULT
!! 
!! The number is converted using Fortran format F<WIDTH>.<FIXLEN>.
!! If the number is too large or the number of significant digits is to
!! low, the number digits after the decimal point is changed or, if this is
!! is not possible, an E-format is choosen. If WIDTH is lower than 6, the
!! result length will be larger in some cases.
!!
!! Default format (WIDTH < 0, FIXLEN < -1, DIGITS < 0)
!! 
 
!! Arguments
    character*(*) RESULT			!!
    integer RESLEN				!! length of result
    real X					!! number to be converted
    integer WIDTH				!! minimum width
    integer FIXLEN				!! minimum digits after comma
    integer DIGITS				!! minimum significant digits
    integer TRUNC				!! TRUNC=1,3: omit trailing zeros
 						!! TRUNC=0,1: decimal point always shown
 
    parameter bufmax=32
    integer wid, fix, dig, trc
    character*(bufmax) fixbuf, expbuf ! internal buffers
    integer exponent
    real mantissa
    integer f0, fl, e0, el		! start and end of used buffer F/E
    integer fdig, edig		! digits after decimal point F/E format
    integer overhd			! overhead
    integer p			! position of decimal point
    integer digf			! number of digits-1 shown (F-Format)
    integer le, l
 
 
    trc=trunc
    if (mod(trc,2) .eq. 1) then	! defaults
      wid=1
      fix=0
      dig=4
      if (width  .ge. 0) wid=width
    else
      wid=min(8,len(result))
      if (width  .ge. 0) wid=width
      fix=max(0,wid/2-1)
      dig=1
    endif
    if (fixlen .ge. 0) fix=fixlen
    if (digits .ge. 0) dig=digits
 
    wid=min(bufmax, wid, len(result))
    dig=min(bufmax, dig)
 
    if (x .eq. 0) then
      exponent=0
      mantissa=0
    else
      exponent=int(log10(abs(x))+100)-100
      mantissa=x/10.0**exponent
    endif
 
 
    edig=min(max(wid-4,dig-1),len(result)-4)
    fdig=min(max(fix,dig-1-exponent),len(result)-1)
 
! F-Format
 
11  f0=0
    fl=bufmax+1			! in case of write error
    digf=-1
    if (fdig .lt. -exponent) goto 14
    write(fixbuf, 101, err=14) x
101 format (F<bufmax>.<fdig>)
 
! reduce
 
    f0=bufmax-fdig
    if (exponent .gt. 0) f0=f0-exponent
    do while(f0 .gt. 0 .and. fixbuf(f0:f0) .ne. ' ')
      f0=f0-1
    enddo
    fl=bufmax-1
    do while(fixbuf(fl+1:fl+1) .eq. ' ')
      fl=fl-1
    enddo
    overhd=fl+1-f0-len(result)
    do while (fixbuf(fl+1:fl+1) .eq. '0' .and. (overhd .gt. 0 .or. mod(trc,2) .eq. 1))
      fl=fl-1
      overhd=overhd-1
    enddo
    if (fixbuf(fl+1:fl+1) .eq. '.' .and. trc .ge. 2) then
      overhd=overhd-1
    else
      fl=fl+1
    endif
    if (overhd .gt. 0) then
12    if (fdig .ge. overhd) then
        fdig=fdig-overhd
        goto 11		! try again with less digits
      endif
      fl=bufmax+1
    endif
    digf=fdig+exponent

! E-Format mantissa
 
14  if (x .eq. 0 .or. edig .lt. 0) goto 13
 
15  write(expbuf(1:bufmax-4), 102, err=19) mantissa
102 format (F<bufmax-4>.<edig>)
 
    if (exponent .gt. -10) then
      if (exponent .lt. 10 .and. exponent .ge. 0) then
        le=2
      else
        le=3
      endif
    else
      le=4
    endif
 
! reduce
 
    e0=bufmax-6-edig
    if (e0 .gt. 0) then
      if (expbuf(e0:e0) .eq. '1') then  ! 9.9 was rounded to 10
        exponent=exponent+1
        mantissa=mantissa/10.0
        goto 15
      endif
      if (expbuf(e0:e0) .eq. '-') e0=e0-1
    endif
 
    el=bufmax-5
    do while(expbuf(el+1:el+1) .eq. ' ')
      el=el-1
    enddo
    overhd=el+le+1-e0-len(result)
    do while (expbuf(el+1:el+1) .eq. '0' .and. (overhd .gt. 0 .or. trc))
      el=el-1
      overhd=overhd-1
    enddo
    if (expbuf(el+1:el+1) .eq. '.' .and. trc .ge. 2) then
      overhd=overhd-1
    else
      el=el+1
    endif
 
    if (overhd .gt. 0) then
      if (edig .ge. overhd) then
        edig=edig-overhd
        goto 14			! try again with less digits
      endif
      el=bufmax+1
    else
      write(expbuf(el+1:el+le), 103) exponent
103   format('E',I<le-1>)
      el=el+le
    endif
 
 
! Compare
 
    l=fl-f0
    if (l .gt. wid .and. &
    &   (edig .gt. digf .or. &
    &    edig .eq. digf .and. l .gt. el-e0 .or. &
    &    l .gt. len(result))) then ! E-format is better
      fixbuf=expbuf
      f0=e0	  
      fl=el
      p=bufmax-4-edig
    else
      p=bufmax-fdig
      if (fix .eq. 0 .and. trc .ge. 2) p=p-1	! Decimal point not needed if fix=0
    endif
 
13  l=fl-f0
    if (l .gt. len(result)) then
      goto 19
    elseif (p-f0 .gt. wid-fix .or. l .ge. wid) then	! Left just
      result=fixbuf(f0+1:fl)
    elseif (fl-p .gt. fix) then			! Right just
      result=fixbuf(fl-wid+1:fl)
      l=wid
    else						! Decimal just
      result=fixbuf(p+fix-wid+1:fl)
      l=fl+wid-p-fix
    endif
    reslen=min(l, len(result))
    return

19  result='******'
    reslen=len(result)
  end subroutine

  subroutine STR_CRC(CRC,BUF) !!
!!
!! Computes a 16-bit Cyclic Redundancy Check for an character string BUF.
!! In the first call CRC should be intitalized -
!! between subsequent call it should be untouched.

    integer CRC        !! (in/out) CRC code
    character BUF*(*)  !! characters


    integer init,ireg,i,j,icrctb(0:255),ichr,ib1,ib2,ib3
    character*1 creg(4)
    save icrctb,init,ib1,ib2,ib3
    equivalence (creg,ireg) ! used to get at the 4 bytes in an integer.
    data init /0/

    integer crc1, crc2

    if (init.eq.0) then ! initialize tables?
      init=1
      ireg=256*(256*ichar('3')+ichar('2'))+ichar('1')
      do j=1,4 ! figure out which component of creg addresses which byte of ireg.
        if (creg(j).eq.'1') ib1=j
        if (creg(j).eq.'2') ib2=j
        if (creg(j).eq.'3') ib3=j
      enddo
      do j=0,255 ! create CRCs of all characters.
        ireg=j*256

        do i=1,8 ! Here is where 8 one-bit shifts, and some XORs with the generator polynomial, are done.
          ichr=ichar(creg(ib2))
          ireg=ireg+ireg
          creg(ib3)=char(0)
          if(ichr.gt.127)ireg=ieor(ireg,4129)
        enddo

        icrctb(j)=ireg
      enddo
    endif
    ireg=crc
    crc1=ichar(creg(ib1))
    crc2=ichar(creg(ib2))

    do j=1,len(buf) ! Main loop over the characters
      ireg=icrctb(ieor(ichar(buf(j:j)),crc2))
      crc2=ieor(ichar(creg(ib2)),crc1)
      crc1=ichar(creg(ib1))
    enddo
    creg(ib1)=char(crc1)
    creg(ib2)=char(crc2)
    crc=ireg
    return
  end subroutine

!!
  subroutine STR_CRC_COMP(CRC, CHR) !!
!!
!! encode CRC (16 bit) as 3 characters in CHR
!!
    integer CRC       !! (in)
    character CHR*3   !! (out)

    integer n,j
    character*41 cs/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ$+-&_'/

    if (crc .lt. 0 .or. crc .gt. 65535) stop 'STR_CRC_COMP: illegal CRC'
    n=crc
    j=mod(n,41)
    chr(1:1)=cs(j+1:j+1)
    n=n/41
    j=mod(n,41)
    chr(2:2)=cs(j+1:j+1)
    j=n/41
    chr(3:3)=cs(j+1:j+1)
  end subroutine

end module