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 CTMP*255 CHARACTER CDISK*255, CDIR*255 CHARACTER CACTION*8 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--- 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 CSHELL*64 INTEGER IFIRST, LSHELL SAVE CSHELL, IFIRST, LSHELL DATA IFIRST/1/ C--- 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*4 FUNCTION I4CONV(ISHF) INTEGER*4 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*4 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*4 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*4 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) = (ETIME(TARRAY)-BEGCPU)*100 IVALUE(3) = 0 IVALUE(4) = 0 IVALUE(5) = 0 RETURN END