C Interface routines for PRIME computer system: SLIBPRM.FOR C C Copyright (C) 1989, California Institute of Technology C All rights reserved. U. S. Government Sponsorship under C NASA Contract NAS7-918 is acknowledged. C C Herbert M. Pickett, 20 March 1989 C OPENLU modified, 30 Oct 1991 C C to enable ^P hot key use uncomment call to MKON$P in main program C SUBROUTINE CHTIME(STR) C C SUBROUTINE TO RETURN 30 CHARACTERS WITH THE TIME AND DATE C CHARACTER*(*)STR INTEGER*2 IA(28),N,HR,MN,SEC CHARACTER*2 DATE(3) EQUIVALENCE (DATE,IA) N=28 CALL TIMDAT(IA,N) MN=IA(4) HR=MN/60 MN=MN-60*HR SEC=IA(5) WRITE(STR,100) DATE,HR,MN,SEC RETURN 100 FORMAT(A,1X,A,', 19',A,1X,I2,':',I2,':',I2) END INTEGER FUNCTION NDBLE(INUM) INTEGER INUM C .. number of REAL*8 words for INUM integer*2 words NDBLE= (INUM+3)/4 RETURN END SUBROUTINE FILGET(CFIL,CEXT,NFILE) C C Get NFILE names with extent given in CEXT C Put names in CFIL C C CHARACTER*(*) CFIL(*),CEXT(*) INTEGER NFILE CHARACTER EXT*3,EXTQ*3,FIL*63,EXTDOT*1 INTEGER NLEN,J,K,IEXT,ICHAR,IEXTQ C define character which delimits EXT field EXTDOT='.' C get first parameter WRITE(*,*) ' Enter file name ' READ(*,100) FIL NLEN=INDEX(FIL,EXTDOT) IF(NLEN.EQ.0) THEN C extdot not found NLEN=INDEX(FIL,' ') IF(NLEN.LE.1) STOP FIL(NLEN:NLEN)=EXTDOT ENDIF C set up defaults DO 10 J=1,NFILE EXT=CEXT(J) 10 CFIL(J)=FIL(1:NLEN)//EXT C find non default values DO 20 I=2,20 WRITE(*,*) ' Enter file name ' READ(*,100,END=50) FIL K=INDEX(FIL,EXTDOT) IF(K.EQ.0) GO TO 50 EXT=FIL(K+1:) DO 30 J=1,NFILE EXTQ=CEXT(J) DO 35 K=1,3 IEXT=ICHAR(EXT(K:K)) IEXTQ=ICHAR(EXTQ(K:K)) IF(IEXT.EQ.IEXTQ) GO TO 35 IF(IEXT+32.EQ.IEXTQ) GO TO 35 GO TO 30 35 CONTINUE CFIL(J)=FIL 30 CONTINUE 20 CONTINUE 50 WRITE(*,'(1X,A)') (CFIL(J),J=1,NFILE) RETURN 100 FORMAT(A) END SUBROUTINE OPENLU(LU,FNAME,CHSW) C fancy file opening and closing INTEGER LU,LUORG,LUIN,IREC,IOCHK PARAMETER (LUORG=10) CHARACTER*8 LULIST CHARACTER*(*) FNAME,CHSW CHARACTER*64 FIL SAVE LULIST DATA LULIST /'CCCCCCCC'/ LUIN=LU IF(CHSW(1:1).EQ.'C') THEN LU=LU-LUORG IF(LU.GT.0.AND.LU.LE.LEN(LULIST)) THEN IF(LULIST(LU:LU).EQ.'R') THEN REWIND (LUIN) ELSE IF(LULIST(LU:LU).EQ.'W') THEN ENDFILE (LUIN) ENDIF CLOSE(LUIN,ERR=50) LULIST(LU:LU)='C' ENDIF ELSE LU=INDEX(LULIST,'C') IF(LU.EQ.0) THEN WRITE(*,*) ' Too many open files' STOP ENDIF LULIST(LU:LU)=CHSW(1:1) LU=LU+LUORG IF(CHSW.EQ.'R') THEN OPEN(LU,FILE=FNAME,ERR=99,STATUS='OLD',IOSTAT=IOCHK) ELSE IF(CHSW.EQ.'RL') THEN OPEN(LU,FILE=FNAME,ERR=80,STATUS='OLD') ELSE IF(CHSW.EQ.'RB') THEN OPEN(LU,FILE=FNAME,ERR=85,STATUS='OLD', : FORM='UNFORMATTED') ELSE IF(CHSW.EQ.'W') THEN OPEN(LU,FILE=FNAME,ERR=99,STATUS='UNKNOWN',IOSTAT=IOCHK) ELSE IF(CHSW.EQ.'WP') THEN C allow others to read my partially written file OPEN(LU,FILE=FNAME,ERR=99,STATUS='UNKNOWN',IOSTAT=IOCHK) ELSE IF(CHSW.EQ.'S') THEN IREC=LUIN*8 OPEN(LU,STATUS='SCRATCH',ACCESS='DIRECT',RECL=IREC,ERR=99 : ,IOSTAT=IOCHK) ELSE WRITE(*,*) ' OPENLU unknown option =',CHSW STOP ENDIF ENDIF 50 RETURN C try to open from default directory for parameter labels 80 FIL='SPECTRA>'//FNAME OPEN(LU,FILE=FIL,ERR=90,STATUS='OLD') RETURN 85 LU=0 RETURN 90 WRITE(*,*) ' Trouble opening ',FIL RETURN 99 WRITE(*,*) ' Trouble opening ',FNAME WRITE(*,*) ' IOSTAT = ',IOCHK STOP END FUNCTION RQEXIT(IVAL) INTEGER RQEXIT,BRKFLG,IVAL COMMON /BRKCOM/ BRKFLG SAVE /BRKCOM/ IF(IVAL.EQ.0) THEN RQEXIT=BRKFLG ELSE C initialize BRKFLG=0 ENDIF RETURN END SUBROUTINE BRKQR(PNTR) INTEGER*4 PNTR INTEGER BRKFLG COMMON /BRKCOM/ BRKFLG SAVE /BRKCOM/ BRKFLG=-1 RETURN END