C--- System dependent routines.
C For use with PCs running linux w/g77 (v0.5.18)
C--- Contains entry points for:
C CONC    (SUB)  Converts filename to system preferred case
C DIRPOS  (SUB)  Return the number of characters in directory spec
C GETDIR  (SUB)  Get the current working directory
C GETTIM  (SUB)  Return time in format hh:mm:ss
C GETUSE  (SUB)  Return the name of the current user
C I2CONV  (FUNC) Convert an INTEGER*2 from IBM byte order to processor byte order.
C I4CONV  (FUNC) Convert an INTEGER*4 from IBM byte order to processor byte order.
C LOCASE  (SUB)  Convert to lower case
C OPENWR  (SUB)  Open wrapup
C PLTTER  (SUB)  Toggle graphics/alpha mode on terminal
C PROMPT  (SUB)  Prompt
C PTEND   (SUB)  Add prefix to file names
C RDFORN  (SUB)  Read a foreign command, i.e., the command line
C SPAWN   (SUB)  Spawn to the operating system
C TRLOG   (SUB)  Translate logical name
C UPC     (SUB)  Convert to upper case
C XCOPY   (SUB)  copy file 'ifile' to 'ofile'
C getrot  (SUB)  get the root directory name
C leave   (SUB)  subroutine to exit from programs
C rdulkc  (SUB)  read a character string
C unlock  (SUB)  dummy subroutine for the vms system call "unlock"
C MOVBYT  (SUB)  Move bytes around
C DIRIMG  (SUB)  make dir *
C*********
C James Peachey, HEASARC/GSFC/NASA, Raytheon STX, 17 July, 1998
C                For Y2K compliance, the following subroutine was
C                replaced by a system independent routine in the
C                file getdat.c:
C
C                    GETDAT  (SUB)  Get current date
C*********
      SUBROUTINE GETTIM (CTIME)
      character(8) CTIME
C---
C Return time in format hh:mm:ss
C uses xanlib/sysdep/sysclnx.c routine gtstime()
C---
C CTIME     O  The current time
C---
      integer h, m, s

      h=0
      m=0
      s=0

      call gtstime(h,m,s)      
      write(ctime,'(i2.2,a1,i2.2,a1,i2.2)')h,':',m,':',s 

      RETURN
      END
C*********
      SUBROUTINE CONC(CBUF)
      CHARACTER CBUF*(*)
C---
C Convert case of CBUF to default case of system.
C For Unix this is lower case.
C---
C CBUF    I/O  The file name to be converted.
C---
      CALL LOCASE(CBUF)
      RETURN
      END
C*********
      SUBROUTINE DIRPOS(CFILE, ISTA, IEND)
      CHARACTER CFILE*(*)
      INTEGER   ISTA, IEND
C---
C CFILE is a full filespec containing the disk and directory names.
C Upon return CFILE(ISTA:IEND) contains only the directory spec.
C---
C CFILE   I    The full file name
C ISTA      O  First valid character in directory spec, can be zero
C IEND      O  Last valid character in directory spec, can be zero
C---
C 1989-Jul-08 - [AFT]
C---
      INTEGER   LENACT
      INTEGER   I, LFILE
C---
      LFILE=LENACT(CFILE)
      IEND=0
      DO 190 I=1,LFILE
         IF(CFILE(I:I).EQ.',') IEND=I
         IF(CFILE(I:I).EQ.'/') IEND=I
  190 CONTINUE
      ISTA=MIN(1,IEND)
      RETURN
      END
C*********
      SUBROUTINE GETDIR(CDIR)
      CHARACTER CDIR*(*)
C---
C CDIR, the current working directory, is returned
C---
C CFILE   O    The current working directory 
C---
C 2000-Jan-04 - [MSJ]
C---
      INTEGER   CLEN

      CLEN = LEN(CDIR)
      CALL XGTCWD(CDIR, CLEN)

      RETURN
      END
C*********
      SUBROUTINE LOCASE(CBUF)
      CHARACTER CBUF*(*)
C---
C Converts CBUF to lower case.
C---
C CBUF    I/O  The character array to convert to lower case
C---
      INTEGER   I, ITMP
C---
      DO 120 I=1,LEN(CBUF)
         ITMP=ICHAR(CBUF(I:I))
         IF(ITMP.GT.64 .AND. ITMP.LT.91) CBUF(I:I)=CHAR(ITMP+32)
  120 CONTINUE
      RETURN
      END
C*********
      SUBROUTINE OPENWR(LUN,CFILE,CSTAT,CACC,CAR,LRECL,IREAD,IER)
      CHARACTER CFILE*(*), CSTAT*(*), CACC*(*), CAR*(*)
      INTEGER   LUN, LRECL, IREAD, IER
C---
C Wrapup routine for the Fortran OPEN statement.  This version will
C force the filename to be case insensitive, UNLESS the the first
C character of CFILE is a backslash.  If the first character is a
C backslash, then it should not be considered part of the filename
C on any system.
C   CFILE can be of the form 'disk,dir/sub,file' in which case, OPENWR
C will create 3 strings and call PTEND to construct the (system-
C dependent) file name.  This provides a system independent way
C to specify file names.
C---
C LUN     I    The logical unit number to be opened
C CFILE   I/O  The name of the file
C CSTAT   I    ='OLD', 'NEW' or 'UNKNOWN'
C CACC    I    ='D' for direct access, 'U' for unformatted, 'E' for append
C CAR     I    Carriage control, 'L' for 'LIST' or 'F'
C LRECL   I    Record length (required for direct access files)
C IREAD   I    <>0 for READONLY, SHARED
C IER       O  <>0 if file not opened
C---
      INTEGER   LENACT
C
      CHARACTER(255) CTMP
      CHARACTER(255) CDISK, CDIR
      CHARACTER(8) CACTION
      CHARACTER CDUM
      LOGICAL   QEXIST
      INTEGER   IFILE, IOS, IS, KP, LFILE, LTMP
C---
   11 FORMAT(A)
C---
      IOS = -1
      LFILE=LENACT(CFILE)
C---
C Special treatment for terminal device.
C---
      IF(LFILE.EQ.0) THEN
C Needs additional check to prevent trashing a terminal
         IF(CAR(1:1).EQ.'L'.OR.CAR(1:1).EQ.'l') THEN
            OPEN(UNIT=LUN, FILE='/dev/tty', STATUS='OLD',
     :        IOSTAT=IOS)
            GOTO 140
         END IF
      END IF
C---
C Sort out file type.
C  0 = sequential access, formatted         " " only
C  1 = direct access => unformatted           "D" + anything
C  2 = sequential access, unformatted         "U" only
C  3 = sequential access, formatted, append   "E" only
C  4 = sequential access, unformatted, append "UE" only
C  5 = direct access, formatted               "DF' only
C
      CTMP=CACC
      CALL UPC(CTMP)
      IF(INDEX(CTMP,'D').NE.0 .AND. INDEX(CTMP,'F').EQ.0) THEN
         IFILE=1
      ELSE IF(INDEX(CTMP,'D').NE.0 .AND. INDEX(CTMP,'F').NE.0) THEN
         IFILE=5
      ELSE IF(INDEX(CTMP,'U').NE.0 .AND. INDEX(CTMP,'E').NE.0) THEN
         IFILE=4
      ELSE IF(INDEX(CTMP,'U').NE.0) THEN
         IFILE=2
      ELSE IF(INDEX(CTMP,'E').NE.0) THEN
         IFILE=3
      ELSE
         IFILE=0
      END IF
C---
C Check for a "+" as the first character of the first name in which case
C force an append
      IF(CFILE(1:1) .EQ. '+') THEN
         IF(IFILE.EQ.0) IFILE=3
         IF(IFILE.EQ.2) IFILE=4
         CFILE=CFILE(2:)
         LFILE=LFILE-1
      END IF
C
      KP=0
      CALL ALF(CFILE, LFILE, KP, CTMP, LTMP)
      IS=1
      IF(LTMP.LT.LFILE) THEN
C Discovered a 'system independent' file specification.  Decode.
         CDISK=CTMP
         CALL ALF(CFILE, LFILE, KP, CTMP, LTMP)
         CDIR=CTMP
         CALL ALF(CFILE, LFILE, KP, CTMP, LTMP)
         CFILE=CTMP
         CALL PTEND(CDISK, CDIR, CFILE)
         LFILE=LENACT(CFILE)
      ELSE
         IF(CFILE(1:1).EQ.CHAR(92)) THEN
C If first chacter is a backslash, then ignore it (and possible case conv.)
            IS=2
         END IF
      END IF
C---
      IF(IREAD.EQ.0) THEN
C- Read/Write
         CACTION='BOTH'
      ELSE
C- READONLY
         CACTION='READ'
      END IF

C If CSTAT='NEW' check whether the file already exists and if so ask the
C user whether to overwrite it.

      CTMP = CSTAT
      CALL UPC(CTMP)
      INQUIRE(FILE=CFILE(IS:LFILE), EXIST=QEXIST)
      IF ( QEXIST .AND. CTMP .EQ. 'NEW' ) THEN
         CALL EDICOM('SAV', 3)
         CTMP=CFILE(IS:LFILE)//' exists, reuse it?'
         CALL PROMPT(CTMP, 0)
         READ(*,11,ERR=900,END=900) CDUM
         CALL EDICOM('RES', 3)
         CALL UPC(CDUM)
         IF(CDUM(1:1).EQ.'Y') THEN
            OPEN(UNIT=LUN, FILE=CFILE(IS:LFILE), STATUS='UNKNOWN')
            CLOSE(UNIT=LUN, STATUS='DELETE')
         ENDIF
      ENDIF
C---
      IF(IFILE.EQ.1) THEN
         OPEN(UNIT=LUN, FILE=CFILE(IS:LFILE), STATUS=CSTAT,
     :    ACCESS='DIRECT', RECL=LRECL, 
     :    IOSTAT=IOS)
      ELSE IF(IFILE.EQ.2) THEN
         OPEN(UNIT=LUN, FILE=CFILE(IS:LFILE), STATUS=CSTAT,
     :    FORM='UNFORMATTED',
     :    IOSTAT=IOS)
      ELSE IF(IFILE.EQ.3) THEN
         OPEN(UNIT=LUN, FILE=CFILE(IS:LFILE), STATUS=CSTAT,
     :    IOSTAT=IOS)
c>>> MJT -- Move to end of file
1        continue
         read(lun,'()',end=2)
         go to 1
2        continue
      ELSE IF(IFILE.EQ.4) THEN
         OPEN(UNIT=LUN, FILE=CFILE(IS:LFILE), STATUS=CSTAT,
     :    FORM='UNFORMATTED',
     :    IOSTAT=IOS)
c>>> MJT -- Move to end of file
3        continue
         read(lun,'()',end=4)
         go to 3
4        continue
c MJT 30July96 adding explicit ifile=5 condition!
      ELSE IF(IFILE.EQ.5) THEN
         OPEN(UNIT=LUN, FILE=CFILE(IS:LFILE), STATUS=CSTAT,
     :    ACCESS='DIRECT', RECL=LRECL, FORM='FORMATTED',
     :    IOSTAT=IOS)
      ELSE
         OPEN(UNIT=LUN, FILE=CFILE(IS:LFILE), STATUS=CSTAT,
     :    IOSTAT=IOS)
      END IF
C
  140 IF(IOS.EQ.0) THEN
         INQUIRE(UNIT=LUN,NAME=CTMP)
         IF (LENACT(CTMP).GT.LEN(CFILE)) THEN
            WRITE (*,*)'CFILE in OPENWR is too short!'
            WRITE (*,*)'Opening file ',CTMP(1:LENACT(CTMP))
            WRITE (*,*)'Press RETURN to continue'
            READ (*,*)
         ELSE
            CFILE = CTMP
         ENDIF
      END IF

  900 CONTINUE
      IER=IOS
      RETURN
      END
C*********
      SUBROUTINE PLTTER(CTYPE)
      CHARACTER CTYPE*(*)
C---
C CTYPE='A' switches terminal into alpha mode.
C CTYPE='G' switches terminal into graphics mode.
C NOTE: Caps.
C---
      CHARACTER CJUNK
      CJUNK = CTYPE(1:1)
      RETURN
      END
C*********
      SUBROUTINE PROMPT(CBUF, LBUF)
      CHARACTER CBUF*(*)
      INTEGER   LBUF
C---
C Write CBUF to the terminal leaving the cursor at the end of CBUF
C when finished.
C---
C CBUF    I    The prompt string
C LBUF    I    The number of valid characters in CBUF (can be zero)
C---
      INTEGER   LENACT
      INTEGER   LB
C---
      LB= LBUF
      IF(LB.EQ.0) LB= LENACT(CBUF)
      IF(LB.GT.0) THEN
         WRITE(*,111) CBUF(:LB)
  111    FORMAT(1X, A, ' ', $)
      ELSE
C Due to a Sun funny, writing nothing to the line should space the
C cursor over one space, to allign with other text.
         WRITE(*,121)
  121    FORMAT(' ',$)
      END IF
      RETURN
      END
C*********
      SUBROUTINE PTEND(CDISK, CDIR, CFILE)
      CHARACTER CDISK*(*), CDIR*(*), CFILE*(*)
C---
C Prefix exTENsion.  Add 'prefix' to file name. Does automatic
C translation of environment variable as "disk".
C---
C CDISK     I    The disk name
C CDIR      I    The directory name
C CFILE     I/O  The file name
C---
C  2-Aug-1988 - [AFT]
C  23-Sep-1990 [KAA] added TRLOG check.
C---
      INTEGER   LENACT
      INTEGER   I, LDISK, LDIR, LFILE, LOUT, LTMP
      character(256) CTMP, CTMP2
C---
C- Check for an environment variable as the disk. If none found
C- then also tries lowercase and uppercase versions.
      CTMP2 = CDISK
      LDISK=LENACT(CDISK)-1
      CALL TRLOG(CTMP2(2:LDISK+1), LDISK, CTMP, LTMP)
      IF (LTMP.EQ.0) THEN
         CALL UPC(CTMP2)
         CALL TRLOG(CTMP2(2:LDISK+1), LDISK, CTMP, LTMP)
      ENDIF
      IF (LTMP.EQ.0) THEN
         CALL LOCASE(CTMP2)
         CALL TRLOG(CTMP2(2:LDISK+1), LDISK, CTMP, LTMP)
      ENDIF
C---
C- Check that created filename will not overrun buffer.
      IF(LTMP.GT.0) THEN
         LDISK=LTMP+1
      ELSE
         LDISK=LENACT(CDISK)+2
      ENDIF
      LDIR =LENACT(CDIR)+1
      LFILE=LENACT(CFILE)
      LOUT=LDISK+LDIR+LFILE
      IF(LOUT.GT.LEN(CFILE)) THEN
         WRITE(*,*) 'PTEND error, not enough room to create filename.'
         RETURN
      END IF
C---
C- Move characters in CFILE
      DO 170 I=0,LFILE-1
        CFILE(LOUT-I:LOUT-I)=CFILE(LFILE-I:LFILE-I)
  170 CONTINUE
C---
C- Finish the job
      IF(LTMP.GT.0) THEN
         CFILE(1:LDISK)=CTMP(:LTMP)//'/'
      ELSE
         CFILE(1:LDISK)='/'//CDISK(:LDISK-2)//'/'
      ENDIF
      CFILE(LDISK+1:LDISK+LDIR)=CDIR(:LDIR-1)//'/'
      RETURN
      END
C*********
      SUBROUTINE RDFORN(CBUF, LBUF)
      CHARACTER CBUF*(*)
      INTEGER   LBUF
C---
C Reads the entire command line.
C---
C CBUF      O  Data from the command line
C LBUF      O  The number of valid characters in CBUF (can be zero)
C---
      INTEGER   NARG, IARGC, I, LENACT
C---
      NARG= IARGC()
      CBUF=' '
      LBUF= 0
      IF(NARG.GT.0) THEN
         DO 190 I= 1, NARG
            CALL GETARG(I, CBUF(LBUF+1:))
C- Add a space between arguments
            LBUF= LENACT(CBUF)+1
  190    CONTINUE
C- Remove trailing space
         LBUF=LBUF-1
      END IF
      RETURN
      END
C*********
      SUBROUTINE SPAWN(CBUF, LBUF, IER)
      CHARACTER CBUF*(*)
      INTEGER   LBUF, IER
C---
C Spawn to operating system.  If LBUF=0 then this routine should
C spawn a shell and leave the user in the shell until the user logs
C out or exits the shell.  If LBUF<>0 then the system should only
C execute that one command and immediately return to the calling
C routine.
C---
C CBUF    I    The system command to execute
C LBUF    I    The number of valid characters in CBUF (can be zero)
C IER       O  =0 spawn was successful, <>0 otherwise
C---
      CHARACTER(64) CSHELL
      INTEGER   IFIRST, LSHELL
      SAVE CSHELL, IFIRST, LSHELL
      DATA IFIRST/1/
C---
      IER=0
      IF(IFIRST.NE.0) THEN
         IFIRST=0
         CALL TRLOG('SHELL', 5, CSHELL, LSHELL)
         IF(LSHELL.EQ.0) THEN
            CSHELL='/bin/csh'
            LSHELL=8
         END IF
      END IF
      IF(LBUF.GT.0) THEN
         CALL system(CBUF(:LBUF))
      ELSE
         WRITE(*,*) 'Type exit to return.'
         CALL system(CSHELL(:LSHELL))
      END IF
      RETURN
      END
C*********
      SUBROUTINE TRLOG(CBUF, LBUF, CRET, LRET)
      CHARACTER CBUF*(*), CRET*(*)
      INTEGER   LBUF, LRET
C---
C Translate the logical name CBUF(:LBUF) to return CRET(:LRET)
C---
C CBUF    I    The string to translate
C LBUF    I    The number of valid characters in CBUF (can be zero)
C CRET      O  The translated string
C LRET      O  The number of valid characters in CRET (can be zero)
C---
      INTEGER   LENACT
C---
      CALL GETENV(CBUF(:LBUF),CRET)
      LRET=LENACT(CRET)
      RETURN
      END
C*********
      SUBROUTINE UPC(CSTR)
      CHARACTER CSTR*(*)
C---
C Converts character array in CSTR to upper case.
C---
C CSTR    I/O  The string to convert to upper case
C---
      INTEGER   I, ICSTR
C---
      DO 120 I= 1, LEN(CSTR)
         ICSTR= ICHAR(CSTR(I:I))
         IF(ICSTR.GT.96 .AND. ICSTR.LT.123) CSTR(I:I)= CHAR(ICSTR-32)
  120 CONTINUE
      RETURN
      END


C*********
      INTEGER*2 FUNCTION I2CONV(IX)
      INTEGER*2 IX
C---
C Convert an INTEGER*2 from IBM byte order to processor byte order.
C---
C IX      I    The number to be converted
C---
      I2CONV=IX
      RETURN
      END
C*********
      INTEGER FUNCTION I4CONV(ISHF)
      INTEGER ISHF
C---
C Convert an INTEGER*4 from IBM byte order to processor byte order.
C---
C ISHF    I    The number to be converted
C---
      I4CONV=ISHF
      RETURN
      END
C*********
      SUBROUTINE XCOPY(IFILE, OFILE)
C---
C fwj haberl   25-OCT-1990 
C copy file 'ifile' to 'ofile'
C---
      CHARACTER*(*) IFILE, OFILE
      
      character(256) STRING
      INTEGER LSTRING, LENACT, IERR
 
      STRING = 'cp '//IFILE(1:LENACT(IFILE))//' '//
     &                      OFILE(1:LENACT(OFILE))
      LSTRING = LENACT(STRING)
      CALL SPAWN(STRING, LSTRING, IERR)
      RETURN
      END
C*********
      SUBROUTINE MOVBYT (n,a,b)
c----
c  simple routine to copy bytes back and forth
c---

c--- n is size, a and b are arrays, copies a to b

      character(1) a(n),b(n)
      integer n
      integer i

      do i=1,n
         b(i) = a(i)
      end do

      return

      end
C*********
      subroutine dirimg(cext)
      character*(*) cext
c--
c  just spawn an 'ls' command
c--

      character(256) string
      integer       lstring
      integer       lenact
      integer       ierr

      string = ' ls -l *.'//cext
      lstring = lenact(string)
      call spawn (string,lstring,ierr)
      return
      end
C*********
      SUBROUTINE unlock(io)
 
C dummy subroutine for the vms system call "unlock"  Nick 28.5.91
 
      INTEGER io, i
      i = io
 
      RETURN
      END
C*********
      SUBROUTINE leave
 
C subroutine to exit from programs
 
      CALL exit(0)
 
      RETURN
      END
C*********
      SUBROUTINE getrot(wholename)
 
c get the root directory name
 
      character(100) rootname
      CHARACTER*(*) wholename
      INTEGER lenact
 
      CALL getenv ("HOME",rootname)
      wholename = rootname(:lenact(rootname))//'/'
      RETURN
      END
C*********
      SUBROUTINE rdulkc(lu,string,ieof,iostat)
 
C  read a character string - the VMS version of this routine retries
C  repeatedly if the file is temporarily locked.
 
      INTEGER lu, iostat, io_ok, ieof
      PARAMETER (io_ok=0)
      CHARACTER*(*) string
      iostat=0
 
      ieof = 0
 
      READ (lu,END=100,FMT='(a)',IOSTAT=iostat) string
 
      RETURN
100   CONTINUE
      ieof = 1
      iostat = io_ok
      RETURN
      END
C*********
      SUBROUTINE GETUSE(CUSER, IERR)
      CHARACTER CUSER*(*)
      INTEGER   IERR
C---
C Return the name of the current user
C---
C CUSER     O  The current user id
C IERR      O  =1 if valid, <>0 could not generate user id
C---
      INTEGER   LUSER
C---
      CALL TRLOG('USER', 4, CUSER, LUSER)
      IF(LUSER.EQ.0) THEN
         IERR=1
      ELSE
         IERR=0
      END IF
      RETURN
      END
C*********
      SUBROUTINE DEBUGH
C---
C No UNIX equivalent to VMS command set up
C---
      RETURN
      END
C*********
      SUBROUTINE INITTS
C---
C Initialize the runtime statistics
C---
      INTEGER   TIME
      REAL      TARRAY(2), ETIME, BEGCPU, RSTART
      INTEGER   ISTART, ITBEG
      SAVE ISTART, RSTART
C---
      ISTART = TIME()
      RSTART = ETIME(TARRAY)
      RETURN
C
      ENTRY STTIME(ITBEG, BEGCPU)
C Return the system time when the program was started.
      ITBEG =ISTART
      BEGCPU=RSTART
      RETURN
      END
C*********
      SUBROUTINE GETTS (IVALUE)
      INTEGER   IVALUE(5)
C---
C Get the runtime statistics :
C   IVALUE(1) - Elapsed real time in 10msec tics
C   IVALUE(2) - Elapsed CPU time in 10msec tics
C   IVALUE(3) - Buffered I/O count
C   IVALUE(4) - Direct/block I/O count
C   IVALUE(5) - Page fault count
C **SUN UNIX only gives 1 and 2**
C---
      INTEGER   TIME
      INTEGER   INOW, ISTART
      REAL      TARRAY(2), ETIME, BEGCPU
C---
      INOW = TIME()
      CALL STTIME(ISTART, BEGCPU)
C Under Unix, elapsed time is only accurate to nearest sec.
      IVALUE(1) = (INOW-ISTART)*100
C CPU time includes both user and system mode time
      IVALUE(2) = INT((ETIME(TARRAY)-BEGCPU)*100)
      IVALUE(3) = 0
      IVALUE(4) = 0
      IVALUE(5) = 0
      RETURN
      END
