c
c Many of these procedures were written by Antoine M.M. Schreurs,
c systems programmer at the Chemistry Department, University of Utrecht,
c E-mail: schreurs@chem.ruu.nl or schreurs@hutruu54.bitnet 
c
      SUBROUTINE FILESCAN(INFILE,FIELD,OUTFILE,L)
      CHARACTER *(*) INFILE,FIELD,OUTFILE
      character tempfield*10
      INTEGER*4 SYS$FILESCAN,STATUS,FLDFLAGS,STARTPOINTER
      INCLUDE '($FSCNDEF)'
 
      STRUCTURE /VALUELST/
       INTEGER*2 BUFLEN,CODE
       INTEGER*4 BUFADR
       INTEGER*4 ENDMARKER
      END STRUCTURE
 
      RECORD /VALUELST/ VALUE
      VALUE.ENDMARKER = 0
      call upcase(field,tempfield)
      IF(tempFIELD.EQ.'NODE') THEN
         VALUE.CODE = FSCN$_NODE
      ELSE IF(tempFIELD.EQ.'DEVICE') THEN
         VALUE.CODE = FSCN$_DEVICE
      ELSE IF(tempFIELD.EQ.'ROOT') THEN
         VALUE.CODE = FSCN$_ROOT
      ELSE IF(tempFIELD.EQ.'DIRECTORY') THEN
         VALUE.CODE = FSCN$_DIRECTORY
      ELSE IF(tempFIELD.EQ.'NAME') THEN
         VALUE.CODE = FSCN$_NAME
      ELSE IF(tempFIELD.EQ.'TYPE') THEN
         VALUE.CODE = FSCN$_TYPE
      ELSE IF(tempFIELD.EQ.'VERSION') THEN
         VALUE.CODE = FSCN$_VERSION
      ENDIF
      L = 0
      STATUS = SYS$FILESCAN(INFILE,%REF(VALUE),%REF(FLDFLAGS))
      IF (.NOT.STATUS) CALL LIB$SIGNAL(%VAL(STATUS))
      STARTPOINTER = VALUE.BUFADR - %LOC(INFILE)+1
      L = VALUE.BUFLEN
      IF(L.EQ.0) THEN
         OUTFILE = ' '
      ELSE
         OUTFILE = INFILE(STARTPOINTER:STARTPOINTER+L-1)
      ENDIF
      RETURN
      END

      SUBROUTINE GETPAR(N,TEXT,ERROR)
      PARAMETER (MAXSTR=255)
      CHARACTER TEXT*(*),lin*4
      INTEGER LIB$get_foreign,STATUS,ERROR,POINTER,COUNT,FINISH
      CHARACTER LINE*255
      COMMON /getpar___COMLINE/ LINE,POINTER,LL
      logical first_time
      save first_time
      data first_time /.true./
 
      if(first_time) then
        STATUS = lib$get_foreign(line,,LL)
        IF(.NOT.STATUS) CALL LIB$SIGNAL(%VAL(STATUS))
        LL = length(line)
        line = line(1:max(1,LL))
        first_time = .false.
        pointer = 0
      endif
      IF (N.EQ.0) THEN
        error = 0
        return
      else if(n.lt.0) then
        error = 1
5       POINTER = POINTER + 1
        IF (POINTER.GT.LL) RETURN
        IF(LINE(POINTER:POINTER).eq.' ') GOTO 5
        text = line(pointer:)
        error = 0
      ELSE
        TEXT    = ' '
        ERROR   = 1
        POINTER = 1
        COUNT   = 1
        if(ll.eq.0) return
        do while(count.lt.n)
          COUNT = COUNT + 1
10        POINTER = POINTER + 1
          IF (POINTER.GT.LL) RETURN
          IF(LINE(POINTER:POINTER).NE.' ') GOTO 10
20        POINTER = POINTER + 1
          IF(POINTER.GT.LL) RETURN
          IF(LINE(POINTER:POINTER).EQ.' ') GOTO 20
        enddo
        FINISH = POINTER
30      FINISH = FINISH + 1
        IF (FINISH.GT.LL+1) RETURN
        IF(LINE(FINISH:FINISH).NE.' ') GOTO 30
        TEXT = LINE(POINTER:FINISH-1)
        POINTER = FINISH
        ERROR = 0
      ENDIF
      RETURN
      END
      subroutine image_name(name,ln)
      character name*(*)
      character *132 image,string
      integer*4 status,sys$getjpiw
      INTEGER*4 SYS$FILESCAN,FLDFLAGS,START,stop
      INCLUDE '($FSCNDEF)'
      include '($JPIDEF)'
      structure /item/
        integer*2 buflen
        integer*2 item
        integer*4 bufaddr
        integer*4 ladr
        integer*4 terminator
      end structure
      record /item/ item_list
 
      STRUCTURE /VALUELST/
       INTEGER*2 BUFLEN1,CODE1
       INTEGER*4 BUFADR1
       INTEGER*2 BUFLEN2,CODE2
       INTEGER*4 BUFADR2
       INTEGER*4 ENDMARKER
      END STRUCTURE
 
      RECORD /VALUELST/ VALUE
 
      item_list.buflen     = len(image)
      item_list.item       = jpi$_imagname
      item_list.bufaddr    = %loc(image)
      item_list.terminator = 0
      status = sys$getjpiw(,,,item_list,,,)
      if (.not.status) call lib$signal(%val(status))
 
      call filescan(image,'NAME',name,ln)
      RETURN
      END
      integer*4 function length(str)
      character*(*) str
      character scratch*255
      integer*4 str$trim,void,L
      void=str$trim(scratch,str,L)
      length=L
      end
      integer function lenstr(s)
      character s*(*)
      lenstr = max(1,length(s))
      return
      end
      SUBROUTINE UPCASE(STRING1,STRING2)
      CHARACTER*(*) STRING1,STRING2
      CHARACTER C*1
      STRING2 = STRING1
      DO 10 I=1,Length(string2)
        C = STRING2(I:I)
        IF(C.GE.'a'.AND.C.LE.'z') STRING2(I:I) = CHAR( ICHAR(C)-32)
10    CONTINUE
      RETURN
      END
      SUBROUTINE SET_SYMBOL(SYMBOL,VALUE)
      INTEGER *4 STATUS,LIB$SET_SYMBOL,LIB$SIGNAL
      CHARACTER *(*) SYMBOL,VALUE
      CHARACTER*138 S,V
      CALL UPCASE(SYMBOL,S)
      CALL UPCASE(VALUE,V)
      STATUS = LIB$SET_SYMBOL(S(1:LENGTH(S)),V(1:LENGTH(V)),2) ! GLOBAL
      IF (.NOT.STATUS) CALL LIB$SIGNAL(%VAL(STATUS))
      RETURN
      END
      subroutine wait(delta)
c---- wait for delta seconds (real-time)
      call lib$wait(delta)
      return
      end
      subroutine finish(nunit)
      character datetime*20,cputime*12,image*30
      call image_name(image,li)
      if (nunit.le.0) then
        call settime()
        if (nunit.lt.0) write(-nunit,100) image(1:li),'start',datetime()
      else
        write(nunit,100) image(1:li),'ended',datetime(),cputime()
      endif
100   format(1x,a,x,a,' at ',2a,' CPU_time used')
      return
      end

      character*12 function cputime()
      character*12 sec2time
      cputime = sec2time(second())
      return
      end

      character*12 function sec2time(t)
      integer*2 days,minutes,hours,seconds
      n = nint(t)
      seconds = mod(n,60)
      n = n/60
      minutes = mod(n,60)
      n = n/60
      hours = mod(n,24)
      days = n/24
      write(sec2time,100) days,hours,minutes,seconds
100   format(i3.0,x,i2.2,':',i2.2,':',i2.2)
      return
      end

      real function second()
      integer cpu
      call get___cputime(1,cpu)
      second = 0.01 *(float(cpu)+0.5)
      return
      end

      subroutine settime
      integer cpu
      call get___cputime(2,cpu)
      return
      end

      character*10 function time()
      character *20 dt
      call lib$date_time(dt)
      time = dt(12:)
      return
      end

      character*11 function date()
      call lib$date_time(date)
      return
      end

      character*20 function datetime()
      call lib$date_time(datetime)
      return
      end

!-----------------------------------------------------------------------
      subroutine get___cputime(flag,value)
c
c     vax timer 
c   flag = 1:  return cputime - startvalue
c   flag = 2: set start value,store it in msec,return cputime
c
      integer *4 status,lib$getjpi,len,value
      include '($jpidef)/nolist'
      integer msec
      save msec
      data msec /0/
      integer flag
      status = lib$getjpi(jpi$_cputim,,,value,,)
      if (.not.status) value=0
      if(flag.eq.1) then
        value = value - msec
      else
        msec = value
      endif
      return
      end

      subroutine line_to_words(line,word,nw)
c
c---  this subroutine maps the input string into the array words and 
c---  returns the number of words
c---  as delimiter spaces and minus (-) signs are allowed
c
c Idea : ????
c Secondary implementation: Paul van der Sluis
c Tertiary implementation and optimization: Rob Hooft
c All local variables are kept in registers (with fortran/optimize)
c
c Version: Hooft  9-AUG-1990 11:22:28 
c
      integer wordlength,maxword
      parameter(wordlength=80,maxword=20)
      character*(wordlength) word(maxword)
      character*(*) line
      integer letter,oldletter,errflag,worderrflag,nword,l
      data errflag /0/
      data worderrflag /0/
      nword=0
      letter=ichar(' ')
      ip=1
      call str$trim(line,line,l)
      do i=1,l
        oldletter=letter
        letter=ichar(line(i:i))
        if (letter.eq.ichar(' ')) then
          ip=1
        else

c- split of following if-statements is to fool the optimizer, such that
c- the .eq.  test, which fails most of the time, is performed first.

          if (letter.eq.ichar('-')) then
            if(
     1          oldletter.ne.ichar('d').and.
     1          oldletter.ne.ichar('e').and.
     2          oldletter.ne.ichar('D').and.
     2          oldletter.ne.ichar('E')) ip=1
          endif
          if(ip.eq.1) then
            nword=nword+1
            if (nword.gt.maxword) then
              if (errflag.eq.0) then
                write(*,*) '%ROB-W-TOOMANWOR, too many words on line.'
                errflag=1
              endif
              nw=nword
              return
            endif
            word(nword)=' '
          endif
          if (ip.le.wordlength) then
            word(nword)(ip:ip) = char(letter)
            ip=ip+1
          else if (worderrflag.eq.0) then
            write(*,*) '%ROB-W-WORTOOLON, word too long.'
            worderrflag=1
          endif
        endif
      enddo
      nw=nword
      return
      end

      subroutine dir_mk(st,step,n)
      open(7,file='mkdir.com',status='new',carriagecontrol='list')
      write(7,'(A)') '$ CREATE/DIRECTORY/LOG -'
      do j1=0,n-1
        n1=nint(st+step*j1)
        if (n1.lt.0) n1=n1+360
        write(7,600) '[.',n1,'],-'      
      enddo
      n1=nint(st+step*n)
      if (n1.lt.0) n1=n1+360
      write(7,600) '[.',n1,']'      
      close(7)
600   format(a,i3.3,a)
      return
      end

      subroutine newfile(lun,name,iostat)
      character*(*) name
      open(lun,file=name(1:lenstr(name)),status='new',iostat=iostat,
     1   carriagecontrol='list')
      return
      end

      subroutine readfile(lun,name,iostat)
      character*(*) name
      open(lun,file=name(1:lenstr(name)),status='old',readonly,
     1 iostat=iostat)
      return
      end

      subroutine waitbinfile(lun)
      i=0
10    continue
      i=i+1
      open(lun,file='square.bin',status='old',iostat=iostat,
     1 access='direct')
      if (iostat.ne.0) then
        if (i.gt.60) stop 'Wait for binfile timed out.'
        write(*,*) 'Waiting for Binfile...'
        call wait(10.0)
        goto 10
      endif      
      return
      end

      subroutine waithisfile(lun)
      i=0
10    continue
      i=i+1
      open(lun,file='square.his',status='old',iostat=iostat,
     1  access='append')
      if (iostat.ne.0) then
        if (i.gt.60) stop 'Wait for hisfile timed out.'
        write(*,*) 'Waiting for Hisfile...'
        call wait(10.0)
        goto 10
      endif      
      return
      end

      subroutine deletefile(name)
      character*(*) name
      integer status,lib$delete_file
      status=lib$delete_file(name)
c      if (.not.status) write(*,*) 'File-Delete operation failed.'
      return
      end

      subroutine renamefile(name,newname)
      character*(*) name,newname
      integer status,lib$rename_file
      status=lib$rename_file(name,newname)
c      if (.not.status) write(*,*) 'File-Rename operation failed.'
      return
      end
     
      subroutine newjob(jobnam,n1,n2,i2)
      character*(*) jobnam
      if (i2.gt.0) then
        write(jobnam,9998) n1,n2
 9998   format('[.',i3.3,']mmsq_',i3.3)
      else
        write(jobnam,9988) n1
 9988   format('mmsq_',i3.3)
      endif
      return
      end
