C Interface routines for CRAY UNICOS cft77 :slibcray.f 
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: this version has capability for command line arguements
C  and capability to end gracefully on ^C.  ULIB,BLAS,SLIBCRAY, and DPI or 
C  SPINV can be combined into a single library: 
C
C cft77 -O -c calfit.f subfit.f calcat.f 
C cft77 -O -c blas.f ulib.f dpi.f spinv.f slibcray.f
C bld  q splib.a ulib.o blas.o slibcray.o spinv.o
C cf77 -o spfit calfit.o subfit.o splib.a
C cf77 -o spcat calcat.o splib.a
C cf77 -o calmrg calmrg.o splib.a
C
      SUBROUTINE CHTIME(STR) 
C 
C     SUBROUTINE TO RETURN 30 CHARACTERS WITH THE TIME AND DATE 
C 
      CHARACTER*(*)STR 
      INTEGER DATE,CLOCK,IDATE,ITIME 
      CHARACTER*8 CDATE,CTIME 
      EQUIVALENCE (CDATE,IDATE),(CTIME,ITIME) 
      IDATE=DATE() 
      ITIME=CLOCK() 
      STR = CDATE//'  '//CTIME 
      RETURN 
      END 
      INTEGER FUNCTION NDBLE(INUM) 
      INTEGER INUM 
C     .. number of REAL words for INUM integer words  
      NDBLE= INUM 
      RETURN 
      END 
      SUBROUTINE FILGET(CFIL,CEXT,NFILE) 
C 
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 IARG,IARGC,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 GETARG(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 GETARG(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) 
      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.'WB') THEN
            OPEN(LU,FILE=FNAME,ERR=85,STATUS='UNKNOWN',
     :           FORM='UNFORMATTED')
          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='../'//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 
      EXTERNAL BRKQR 
      COMMON /BRKCOM/ BRKFLG 
      SAVE /BRKCOM/ 
      IF(IVAL.EQ.0) THEN 
          RQEXIT=BRKFLG 
      ELSE 
          CALL SIGCTL('REGISTER','SIGINT',BRKQR) 
          BRKFLG=0 
          RQEXIT=0 
      ENDIF 
      RETURN 
      END 
      SUBROUTINE BRKQR 
      INTEGER BRKFLG 
      COMMON /BRKCOM/ BRKFLG 
      SAVE /BRKCOM/ 
      BRKFLG=-1 
      RETURN 
      END