C Interface routines for wATCOM Version 9.5 f77\32 : SLIBWC.FOR c modeled from SLIBSUN.F: FUNCTION CALL NAMES WERE CHANGED, INCLUDE LIBRARIES WERE CHANGED, SUBROUTINE CHTIME WAS MOVED FROM C C OTHER VERSIONS. 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 Mar 1989 C OPENLU modified, 30 Oct 1991 C C installation notes: calls included for command line arguments and C capability to end gracefully on ^C. ULIB,BLAS,SLIBSUN, and DPI or SPINV can C be combined into a single library: C C f77 -O -c calfit.f subfit.f blas.f ulib.f calcat.f dpi.f spinv.f slibsun.f C ar cr splib.a ulib.o blas.o slibsun.o spinv.o C ranlib splib.a C f77 -o spfit calfit.o subfit.o splib.a C f77 -o spcat calcat.o splib.a C f77 -o calmrg calmrg.o splib.a C C NOTE: other f77 options may be needed to enable use of floating point C processor C SUBROUTINE CHTIME(STR) C C SUBROUTINE TO RETURN 30 CHARACTERS WITH THE TIME AND DATE C INCLUDE 'FSUBLIB.FI' CHARACTER*(*) STR INTEGER*2 HR,MIN,SEC,HSEC,YR,MO,DAY CALL GETTIM(HR,MIN,SEC,HSEC) CALL GETDAT(YR,MO,DAY) WRITE(STR,100) HR,MIN,SEC,HSEC,MO,DAY,YR 100 FORMAT(I3,':',I2,':',I2,'.',I2,I4,'/',I2,'/',I4) RETURN 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 INCLUDE 'FSUBLIB.FI' INCLUDE 'FSIGNAL.FI' C Get NFILE names with extent given in CEXT C Put names in CFIL C C gets file names from command line or interactively C function IARGC() returns the number of command line arguments C subroutine GETARG(I,FIL) gets the I-th command line argument C and returns it in string file C CHARACTER*(*) CFIL(*),CEXT(*) INTEGER NFILE CHARACTER EXT*3,EXTQ*3,FIL*63,EXTDOT*1 INTEGER*4 IARG INTEGER K,NARG,NLEN,J,IEXT,ICHAR,IEXTQ LOGICAL QUERY C define character which delimits EXT field EXTDOT='.' C get first parameter NARG=IARGC() QUERY=NARG.LE.0 IF(QUERY) THEN NARG=NFILE WRITE(*,*) ' Enter file name ' READ(*,100) FIL ELSE IARG=1 CALL IGETARG(IARG,FIL) ENDIF 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 IARG=2,NARG IF(QUERY) THEN WRITE(*,*) ' Enter file name ' READ(*,100,END=50) FIL ELSE CALL IGETARG(IARG,FIL) ENDIF K=INDEX(FIL,EXTDOT) IF(K.EQ.0) GO TO 50 EXT=FIL(K+1:) DO 30 J=1,NFILE EXTQ=CEXT(J) DO 40 K=1,3 IEXT =ICHAR( EXT(K:K)) IEXTQ=ICHAR(EXTQ(K:K)) C compare upper and lower case IF(IEXT.NE.IEXTQ.AND.IEXT+32.NE.IEXTQ) GO TO 30 40 CONTINUE CFIL(J)=FIL GO TO 20 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',IOSTAT=IOCHK) ELSE IF(CHSW.EQ.'W') THEN OPEN(LU,FILE=FNAME,ERR=99,STATUS='UNKNOWN',IOSTAT=IOCHK) ELSE IF(CHSW.EQ.'WB') THEN OPEN(LU,FILE=FNAME,ERR=85,STATUS='UNKNOWN', : FORM='UNFORMATTED',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*4 FSIGNAL,SIGINT,FLAG,I INTEGER RQEXIT,BRKFLG,IVAL EXTERNAL BRKQR COMMON /BRKCOM/ BRKFLG SAVE /BRKCOM/ IF(IVAL.EQ.0) THEN RQEXIT=BRKFLG ELSE FLAG=-1 SIGINT=2 I=FSIGNAL(SIGINT,BRKQR) BRKFLG=0 RQEXIT=0 ENDIF RETURN END SUBROUTINE BRKQR INTEGER BRKFLG COMMON /BRKCOM/ BRKFLG SAVE /BRKCOM/ BRKFLG=-1 RETURN END