C Interface routines for MICROSOFT FORTRAN 5.1: SLIBPC.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 Mar 1989
C
C  installation notes: 
C  find parameter statement with HEAPLN in CALCAT and CALFIT and
C   comment it out , then remove leading C in the following comment.
C   The value of HEAPLN may have to be adjusted down further
C   if you have less available memory 
C  this version has capability for command line arguements and
C     capability to end gracefully on ^C.  
C
C fl -AH -4I2 -O -c calfit.for subfit.for calcat.for 
C fl -AH -4I2 -O -c blas.for ulib.for dpi.for spinv.for slibpc.for
C lib splib.lib,ulib.obj+blas.obj+slibpc.obj+spinv.obj;
C link/exepack calfit+subfit,spfit,spfit,splib
C link/exepack calcat,spcat,spcat,splib
C link/exepack calmrg+slibpc,calmrg,calmrg
      INCLUDE 'CALPGM.INC'
      INCLUDE 'flib.fi'
      
C
      SUBROUTINE CHTIME(STR)
C
C     SUBROUTINE TO RETURN 30 CHARACTERS WITH THE TIME AND DATE
C
      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
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,NARG
      LOGICAL QUERY
      INTEGER*4 NARGS
      INTEGER*2 INUM,ISTAT
C     define character which delimits EXT field
      EXTDOT='.'
C  get first parameter
      NARG=NARGS()-1
      QUERY=NARG.LE.0
      IF(QUERY) THEN
          NARG=NFILE
          WRITE(*,*) ' Enter file name '
          READ(*,100) FIL
      ELSE
          INUM=1
          CALL GETARG(INUM,FIL,ISTAT)
      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 INUM=2,NARG
          IF(QUERY) THEN
              WRITE(*,*) ' Enter file name '
              READ(*,100,END=50) FIL
          ELSE
              CALL GETARG(INUM,FIL,ISTAT)
          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 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',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 RQEXIT,BRKFLG,IVAL,SIGNALQQ,SIG$INT
      PARAMETER (SIG$INT=2)
      EXTERNAL BRKQC[C]
      COMMON /BRKCOM/ BRKFLG
      SAVE /BRKCOM/
      IF(IVAL.EQ.0) THEN
          RQEXIT=BRKFLG
      ELSE
C         initialize
          RQEXIT=SIGNALQQ(SIG$INT,BRKQC)
          BRKFLG=0
      ENDIF
      RETURN
      END

      FUNCTION BRKQC[C]()
      INTEGER BRKQC,BRKFLG
      COMMON /BRKCOM/ BRKFLG
      SAVE /BRKCOM/
      BRKFLG=-1
      BRKQC=0
      RETURN
      END

      SUBROUTINE BRKQR
      RETURN
      END