C----
C---- $Id: tools.f,v 1.2 1995/11/10 14:16:32 hooft Exp $
C----
C---- Most of the routines here are tools from WHAT IF.
C----
      INTEGER FUNCTION GVFLEN(TEXT)
C///
C-------------------------------------------------------------------------------
C----                                                                       ----
C---- RETURNS THE LENGTH OF TEXT                                            ----
C---- THE LENGTH IS DEFINED AS THE SEQUENCE NUMBER IN TEXT OF THE LAST      ----
C---- NON-BLANK CHARACTER. UNDEFINED CHARACTERS ARE ASSUMED TO BE BLANK.    ----
C----                                                                       ----
C---- TEXT IS A CHARACTER STRING OF ANY LENGTH                              ----
C---- DO NOT FORGET TO DECLARE GVFLEN AS AN INTEGER IN THE CALLING ROUTINE  ----
C----                                                                       ----
C-------------------------------------------------------------------------------
C\\\
      IMPLICIT         NONE
      CHARACTER*(*)    TEXT
      INTEGER          I, ICH
C----
C---- Initiate
C----
      GVFLEN=0
C----
C---- Measure the length
C----
      DO 10 I=LEN(TEXT),1,-1
         ICH=ICHAR(TEXT(I:I))
         IF (ICH.NE.ICHAR(' ').AND.ICH.NE.0) THEN
            GVFLEN=I
            RETURN
         END IF
   10 CONTINUE

      RETURN
      END
      INTEGER FUNCTION LENSTR(TEXT)
      IMPLICIT      NONE
      CHARACTER*(*) TEXT
      INTEGER       GVFLEN
      LENSTR=MAX(1,GVFLEN(TEXT))
      RETURN
      END
      INTEGER FUNCTION LENGTH(TEXT)
      IMPLICIT      NONE
      CHARACTER*(*) TEXT
      INTEGER       GVFLEN
      LENGTH=GVFLEN(TEXT)
      RETURN
      END
      SUBROUTINE ERROR
      STOP 'Abnormal termination'
      END
      SUBROUTINE GVSCLC (TEXT)
C///
C-------------------------------------------------------------------------------
C----                                                                       ----
C---- CONVERTS A UPPER CAST TEXT TO LOWER CAST                              ----
C---- NON CHARACTERS REMAIN UNALTERED                                       ----
C----                                                                       ----
C---- THIS ROUTINE IS BY VIRTUE OF ITS NATURE NOT WRITTEN IN FORTRAN 77.    ----
C----                                                                       ----
C-------------------------------------------------------------------------------
C\\\
      IMPLICIT      NONE
      CHARACTER*(*) TEXT
      INTEGER       GVFLEN, LENTXT, L, NUMUPP
      CHARACTER*1   LOWER(26)
      SAVE          LOWER
      DATA LOWER  /'a','b','c','d','e','f','g','h','i','j','k','l','m',
     +             'n','o','p','q','r','s','t','u','v','w','x','y','z'/
C----
C---- INITIALIZE
C----
      LENTXT=GVFLEN(TEXT)
C----
C---- LOOP OVER THE LENGTH OF THE TEXT
C----
      IF (LENTXT.GT.0) THEN
         DO 20 L=1,LENTXT
C----------
C---------- FOR EVERY CHARACTER IN THE TEXT, LOOP OVER THE ALPHABET
C----------
            NUMUPP=INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',TEXT(L:L))
            IF (NUMUPP.NE.0) TEXT(L:L)=LOWER(NUMUPP)
   20    CONTINUE
      END IF

      RETURN
      END
      SUBROUTINE LOWERCASE (T1,T2)
      IMPLICIT      NONE 
      CHARACTER*(*) T1,T2
      T2=T1
      CALL GVSCLC (T2)
      RETURN
      END
      SUBROUTINE GVSCUC (TEXT)
C///
C-------------------------------------------------------------------------------
C----                                                                       ----
C---- CONVERTS A LOWER CAST TEXT TO UPPER CAST                              ----
C---- NON CHARACTERS REMAIN UNALTERED                                       ----
C----                                                                       ----
C---- THIS ROUTINE IS BY NATURE OF ITS PURPOSE NOT WRITTEN IN FORTRAN 77.   ----
C----                                                                       ----
C-------------------------------------------------------------------------------
C\\\
      IMPLICIT      NONE
      CHARACTER*(*) TEXT
      INTEGER       GVFLEN, I, ICH, LENTXT
C----
C---- INITIALIZE
C----
      IF (TEXT(1:1).EQ.'$') RETURN
      LENTXT=GVFLEN(TEXT)
C----
C---- LOOP OVER THE LENGTH OF THE TEXT
C----
      IF (LENTXT.GT.0) THEN
         DO 20 I=1,LENTXT
            ICH=ICHAR(TEXT(I:I))
            IF (ICH.GE.ICHAR('a').AND.ICH.LE.ICHAR('z'))
     +       TEXT(I:I)=CHAR(ICH-ICHAR('a')+ICHAR('A'))
   20    CONTINUE
      END IF

      RETURN
      END
      SUBROUTINE IQSORTS(ARR,NARR,SWAP)
      IMPLICIT INTEGER(A-Z)
      INTEGER ARR(NARR)
      EXTERNAL SWAP
      DIMENSION LSTACK(20),RSTACK(20)

      LSTACK(1)=1
      RSTACK(1)=NARR
      SP=1
      DO WHILE (SP.GT.0)
        L=LSTACK(SP)
        R=RSTACK(SP)
        SP=SP-1
17      CONTINUE
          I=L
          J=R
          IM=(I+J)/2
          CURRENT=ARR(IM)
27        CONTINUE
            DO WHILE (ARR(I).LT.CURRENT)
              I=I+1
            ENDDO
            DO WHILE (ARR(J).GT.CURRENT)
              J=J-1
            ENDDO
            IF (I.LE.J) THEN
              IF (I.NE.J) THEN
                CALL SWAP(I,J)
                IS=ARR(I)
                ARR(I)=ARR(J)
                ARR(J)=IS
              ENDIF
              I=I+1
              J=J-1
            ENDIF
            IF (I.LE.J) GOTO 27
C         UNTL I>=J
          IF ((J-L).LT.(R-I)) THEN
            IF (I.LT.R) THEN
              SP=SP+1
              LSTACK(SP)=I
              RSTACK(SP)=R
            ENDIF
            R=J
          ELSE
            IF (L.LT.J) THEN
              SP=SP+1
              LSTACK(SP)=L
              RSTACK(SP)=J
            ENDIF
            L=I
          ENDIF
          IF (L.LT.R) GOTO 17
C       UNTL L>=R
      ENDDO
      RETURN
      END

      SUBROUTINE AQSORTS(ARR,NARR,SWAP)
      IMPLICIT INTEGER(A-Z)
      REAL ARR(NARR),CURRENT,IS
      EXTERNAL SWAP
      DIMENSION LSTACK(20),RSTACK(20)

      LSTACK(1)=1
      RSTACK(1)=NARR
      SP=1
      DO WHILE (SP.GT.0)
        L=LSTACK(SP)
        R=RSTACK(SP)
        SP=SP-1
17      CONTINUE
          I=L
          J=R
          IM=(I+J)/2
          CURRENT=ARR(IM)
27        CONTINUE
            DO WHILE (ARR(I).LT.CURRENT)
              I=I+1
            ENDDO
            DO WHILE (ARR(J).GT.CURRENT)
              J=J-1
            ENDDO
            IF (I.LE.J) THEN
              IF (I.NE.J) THEN
                CALL SWAP(I,J)
                IS=ARR(I)
                ARR(I)=ARR(J)
                ARR(J)=IS
              ENDIF
              I=I+1
              J=J-1
            ENDIF
            IF (I.LE.J) GOTO 27
C         UNTL I>=J
          IF ((J-L).LT.(R-I)) THEN
            IF (I.LT.R) THEN
              SP=SP+1
              LSTACK(SP)=I
              RSTACK(SP)=R
            ENDIF
            R=J
          ELSE
            IF (L.LT.J) THEN
              SP=SP+1
              LSTACK(SP)=L
              RSTACK(SP)=J
            ENDIF
            L=I
          ENDIF
          IF (L.LT.R) GOTO 17
C       UNTIL L>=R
      ENDDO
      RETURN
      END

      SUBROUTINE IQSORT(ARR,NARR)
      IMPLICIT INTEGER(A-Z)
      INTEGER ARR(NARR)
      DIMENSION LSTACK(20),RSTACK(20)

      LSTACK(1)=1
      RSTACK(1)=NARR
      SP=1
      DO WHILE (SP.GT.0)
        L=LSTACK(SP)
        R=RSTACK(SP)
        SP=SP-1
17      CONTINUE
          I=L
          J=R
          IM=(I+J)/2
          CURRENT=ARR(IM)
27        CONTINUE
            DO WHILE (ARR(I).LT.CURRENT)
              I=I+1
            ENDDO
            DO WHILE (ARR(J).GT.CURRENT)
              J=J-1
            ENDDO
            IF (I.LE.J) THEN
              IF (I.NE.J) THEN
                IS=ARR(I)
                ARR(I)=ARR(J)
                ARR(J)=IS
              ENDIF
              I=I+1
              J=J-1
            ENDIF
            IF (I.LE.J) GOTO 27
C         UNTL I>=J
          IF ((J-L).LT.(R-I)) THEN
            IF (I.LT.R) THEN
              SP=SP+1
              LSTACK(SP)=I
              RSTACK(SP)=R
            ENDIF
            R=J
          ELSE
            IF (L.LT.J) THEN
              SP=SP+1
              LSTACK(SP)=L
              RSTACK(SP)=J
            ENDIF
            L=I
          ENDIF
          IF (L.LT.R) GOTO 17
C       UNTL L>=R
      ENDDO
      RETURN
      END

      SUBROUTINE AQSORT(ARR,NARR)
      IMPLICIT INTEGER(A-Z)
      REAL ARR(NARR),CURRENT,IS
      DIMENSION LSTACK(20),RSTACK(20)

      LSTACK(1)=1
      RSTACK(1)=NARR
      SP=1
      DO WHILE (SP.GT.0)
        L=LSTACK(SP)
        R=RSTACK(SP)
        SP=SP-1
17      CONTINUE
          I=L
          J=R
          IM=(I+J)/2
          CURRENT=ARR(IM)
27        CONTINUE
            DO WHILE (ARR(I).LT.CURRENT)
              I=I+1
            ENDDO
            DO WHILE (ARR(J).GT.CURRENT)
              J=J-1
            ENDDO
            IF (I.LE.J) THEN
              IF (I.NE.J) THEN
                IS=ARR(I)
                ARR(I)=ARR(J)
                ARR(J)=IS
              ENDIF
              I=I+1
              J=J-1
            ENDIF
            IF (I.LE.J) GOTO 27
C         UNTL I>=J
          IF ((J-L).LT.(R-I)) THEN
            IF (I.LT.R) THEN
              SP=SP+1
              LSTACK(SP)=I
              RSTACK(SP)=R
            ENDIF
            R=J
          ELSE
            IF (L.LT.J) THEN
              SP=SP+1
              LSTACK(SP)=L
              RSTACK(SP)=J
            ENDIF
            L=I
          ENDIF
          IF (L.LT.R) GOTO 17
C       UNTIL L>=R
      ENDDO
      RETURN
      END
      SUBROUTINE SVDFIT(X,Y,SIG,NDATA,A,MA,U,V,W,MP,NP,CHISQ,FUNCS)
      PARAMETER(NMAX=1000,MMAX=50,TOL=1.E-5)
      EXTERNAL FUNCS
      DIMENSION X(NDATA),Y(NDATA),SIG(NDATA),A(MA),V(NP,NP),
     *    U(MP,NP),W(NP),B(NMAX),AFUNC(MMAX)
      DO 12 I=1,NDATA
        CALL FUNCS(X(I),AFUNC,MA)
        TMP=1./SIG(I)
        DO 11 J=1,MA
          U(I,J)=AFUNC(J)*TMP
11      CONTINUE
        B(I)=Y(I)*TMP
12    CONTINUE
      CALL SVDCMP(U,NDATA,MA,MP,NP,W,V)
      WMAX=0.
      DO 13 J=1,MA
        IF(W(J).GT.WMAX)WMAX=W(J)
13    CONTINUE
      THRESH=TOL*WMAX
      DO 14 J=1,MA
        IF(W(J).LT.THRESH)W(J)=0.
14    CONTINUE
      CALL SVBKSB(U,W,V,NDATA,MA,MP,NP,B,A)
      CHISQ=0.
      DO 16 I=1,NDATA
        CALL FUNCS(X(I),AFUNC,MA)
        SUM=0.
        DO 15 J=1,MA
          SUM=SUM+A(J)*AFUNC(J)
15      CONTINUE
        CHISQ=CHISQ+((Y(I)-SUM)/SIG(I))**2
16    CONTINUE
      RETURN
      END
      SUBROUTINE SVDCMP(A,M,N,MP,NP,W,V)
      PARAMETER (NMAX=100)
      DIMENSION A(MP,NP),W(NP),V(NP,NP),RV1(NMAX)
      G=0.0
      SCALE=0.0
      ANORM=0.0
      DO 25 I=1,N
        L=I+1
        RV1(I)=SCALE*G
        G=0.0
        S=0.0
        SCALE=0.0
        IF (I.LE.M) THEN
          DO 11 K=I,M
            SCALE=SCALE+ABS(A(K,I))
11        CONTINUE
          IF (SCALE.NE.0.0) THEN
            DO 12 K=I,M
              A(K,I)=A(K,I)/SCALE
              S=S+A(K,I)*A(K,I)
12          CONTINUE
            F=A(I,I)
            G=-SIGN(SQRT(S),F)
            H=F*G-S
            A(I,I)=F-G
            IF (I.NE.N) THEN
              DO 15 J=L,N
                S=0.0
                DO 13 K=I,M
                  S=S+A(K,I)*A(K,J)
13              CONTINUE
                F=S/H
                DO 14 K=I,M
                  A(K,J)=A(K,J)+F*A(K,I)
14              CONTINUE
15            CONTINUE
            ENDIF
            DO 16 K= I,M
              A(K,I)=SCALE*A(K,I)
16          CONTINUE
          ENDIF
        ENDIF
        W(I)=SCALE *G
        G=0.0
        S=0.0
        SCALE=0.0
        IF ((I.LE.M).AND.(I.NE.N)) THEN
          DO 17 K=L,N
            SCALE=SCALE+ABS(A(I,K))
17        CONTINUE
          IF (SCALE.NE.0.0) THEN
            DO 18 K=L,N
              A(I,K)=A(I,K)/SCALE
              S=S+A(I,K)*A(I,K)
18          CONTINUE
            F=A(I,L)
            G=-SIGN(SQRT(S),F)
            H=F*G-S
            A(I,L)=F-G
            DO 19 K=L,N
              RV1(K)=A(I,K)/H
19          CONTINUE
            IF (I.NE.M) THEN
              DO 23 J=L,M
                S=0.0
                DO 21 K=L,N
                  S=S+A(J,K)*A(I,K)
21              CONTINUE
                DO 22 K=L,N
                  A(J,K)=A(J,K)+S*RV1(K)
22              CONTINUE
23            CONTINUE
            ENDIF
            DO 24 K=L,N
              A(I,K)=SCALE*A(I,K)
24          CONTINUE
          ENDIF
        ENDIF
        ANORM=MAX(ANORM,(ABS(W(I))+ABS(RV1(I))))
25    CONTINUE
      DO 32 I=N,1,-1
        IF (I.LT.N) THEN
          IF (G.NE.0.0) THEN
            DO 26 J=L,N
              V(J,I)=(A(I,J)/A(I,L))/G
26          CONTINUE
            DO 29 J=L,N
              S=0.0
              DO 27 K=L,N
                S=S+A(I,K)*V(K,J)
27            CONTINUE
              DO 28 K=L,N
                V(K,J)=V(K,J)+S*V(K,I)
28            CONTINUE
29          CONTINUE
          ENDIF
          DO 31 J=L,N
            V(I,J)=0.0
            V(J,I)=0.0
31        CONTINUE
        ENDIF
        V(I,I)=1.0
        G=RV1(I)
        L=I
32    CONTINUE
      DO 39 I=N,1,-1
        L=I+1
        G=W(I)
        IF (I.LT.N) THEN
          DO 33 J=L,N
            A(I,J)=0.0
33        CONTINUE
        ENDIF
        IF (G.NE.0.0) THEN
          G=1.0/G
          IF (I.NE.N) THEN
            DO 36 J=L,N
              S=0.0
              DO 34 K=L,M
                S=S+A(K,I)*A(K,J)
34            CONTINUE
              F=(S/A(I,I))*G
              DO 35 K=I,M
                A(K,J)=A(K,J)+F*A(K,I)
35            CONTINUE
36          CONTINUE
          ENDIF
          DO 37 J=I,M
            A(J,I)=A(J,I)*G
37        CONTINUE
        ELSE
          DO 38 J= I,M
            A(J,I)=0.0
38        CONTINUE
        ENDIF
        A(I,I)=A(I,I)+1.0
39    CONTINUE
      DO 49 K=N,1,-1
        DO 48 ITS=1,30
          DO 41 L=K,1,-1
            NM=L-1
            IF ((ABS(RV1(L))+ANORM).EQ.ANORM)  GO TO 2
            IF ((ABS(W(NM))+ANORM).EQ.ANORM)  GO TO 1
41        CONTINUE
1         C=0.0
          S=1.0
          DO 43 I=L,K
            F=S*RV1(I)
            IF ((ABS(F)+ANORM).NE.ANORM) THEN
              G=W(I)
              H=SQRT(F*F+G*G)
              W(I)=H
              H=1.0/H
              C= (G*H)
              S=-(F*H)
              DO 42 J=1,M
                Y=A(J,NM)
                Z=A(J,I)
                A(J,NM)=(Y*C)+(Z*S)
                A(J,I)=-(Y*S)+(Z*C)
42            CONTINUE
            ENDIF
43        CONTINUE
2         Z=W(K)
          IF (L.EQ.K) THEN
            IF (Z.LT.0.0) THEN
              W(K)=-Z
              DO 44 J=1,N
                V(J,K)=-V(J,K)
44            CONTINUE
            ENDIF
            GO TO 3
          ENDIF
          IF (ITS.EQ.30) PAUSE 'No convergence in 30 iterations'
          X=W(L)
          NM=K-1
          Y=W(NM)
          G=RV1(NM)
          H=RV1(K)
          F=((Y-Z)*(Y+Z)+(G-H)*(G+H))/(2.0*H*Y)
          G=SQRT(F*F+1.0)
          F=((X-Z)*(X+Z)+H*((Y/(F+SIGN(G,F)))-H))/X
          C=1.0
          S=1.0
          DO 47 J=L,NM
            I=J+1
            G=RV1(I)
            Y=W(I)
            H=S*G
            G=C*G
            Z=SQRT(F*F+H*H)
            RV1(J)=Z
            C=F/Z
            S=H/Z
            F= (X*C)+(G*S)
            G=-(X*S)+(G*C)
            H=Y*S
            Y=Y*C
            DO 45 NM=1,N
              X=V(NM,J)
              Z=V(NM,I)
              V(NM,J)= (X*C)+(Z*S)
              V(NM,I)=-(X*S)+(Z*C)
45          CONTINUE
            Z=SQRT(F*F+H*H)
            W(J)=Z
            IF (Z.NE.0.0) THEN
              Z=1.0/Z
              C=F*Z
              S=H*Z
            ENDIF
            F= (C*G)+(S*Y)
            X=-(S*G)+(C*Y)
            DO 46 NM=1,M
              Y=A(NM,J)
              Z=A(NM,I)
              A(NM,J)= (Y*C)+(Z*S)
              A(NM,I)=-(Y*S)+(Z*C)
46          CONTINUE
47        CONTINUE
          RV1(L)=0.0
          RV1(K)=F
          W(K)=X
48      CONTINUE
3       CONTINUE
49    CONTINUE
      RETURN
      END
      SUBROUTINE SVBKSB(U,W,V,M,N,MP,NP,B,X)
      PARAMETER (NMAX=100)
      DIMENSION U(MP,NP),W(NP),V(NP,NP),B(MP),X(NP),TMP(NMAX)
      DO 12 J=1,N
        S=0.
        IF(W(J).NE.0.)THEN
          DO 11 I=1,M
            S=S+U(I,J)*B(I)
11        CONTINUE
          S=S/W(J)
        ENDIF
        TMP(J)=S
12    CONTINUE
      DO 14 J=1,N
        S=0.
        DO 13 JJ=1,N
          S=S+V(J,JJ)*TMP(JJ)
13      CONTINUE
        X(J)=S
14    CONTINUE
      RETURN
      END
      SUBROUTINE SVDVAR(V,MA,NP,W,CVM,NCVM)
      PARAMETER (MMAX=20)
      DIMENSION V(NP,NP),W(NP),CVM(NCVM,NCVM),WTI(MMAX)
      DO 11 I=1,MA
        WTI(I)=0.
        IF(W(I).NE.0.) WTI(I)=1./(W(I)*W(I))
11    CONTINUE
      DO 14 I=1,MA
        DO 13 J=1,I
          SUM=0.
          DO 12 K=1,MA
            SUM=SUM+V(I,K)*V(J,K)*WTI(K)
12        CONTINUE
          CVM(I,J)=SUM
          CVM(J,I)=SUM
13      CONTINUE
14    CONTINUE
      RETURN
      END
      SUBROUTINE COLLAPSE (TEXT)
      IMPLICIT      NONE 
      CHARACTER*(*) TEXT
      INTEGER       I,J
      J=0
      DO I=1,LEN(TEXT)
         IF (TEXT(I:I).NE.' ') THEN
            J=J+1
            TEXT(J:J)=TEXT(I:I)
         ENDIF
      ENDDO
      IF (J.LT.LEN(TEXT)) TEXT(J+1:)=' '
      RETURN
      END

      SUBROUTINE FILNAM(IN,NAME,TYP,OUT)
      CHARACTER*(*) IN,NAME,TYP,OUT
      CHARACTER*256 TYPE
      IF (LENGTH(TYP).EQ.0) THEN
        TYPE='.'
      ELSE
        TYPE=TYP
        IF (TYP(1:1).NE.'.') TYPE='.'//TYP
      ENDIF
      LI=LENGTH(IN)
      IF (LI.EQ.0) THEN
        OUT=NAME(1:LENGTH(NAME))//TYPE
        RETURN
      ENDIF
      I=0
      DO WHILE(INDEX(IN(I+1:),'/').GT.0)
        I=I+INDEX(IN(I+1:),'/')
      ENDDO
      J=I+INDEX(IN(I+1:),'.')
      LN=LENGTH(NAME)
      IF (I.LT.LI) THEN ! EITHER NAME OR TYPE FIELD PRESENT
        IF (J.GT.I) THEN  ! +TYPE
          IF (I.GT.0) THEN ! +PATH
            IF (J.GT.I+1) THEN ! +NAME
              OUT=IN
            ELSE ! -NAME
              OUT=IN(1:I)//NAME(1:LN)//IN(J:)
            ENDIF
          ELSE ! -PATH
            IF (J.GT.I+1) THEN ! +NAME
              OUT=IN
            ELSE ! -NAME
              OUT=NAME(1:LN)//IN(J:)
            ENDIF
          ENDIF
        ELSE ! -TYPE
            OUT=IN(1:LI)//TYPE
        ENDIF
      ELSE
        OUT=IN(1:LI)//NAME(1:LN)//TYPE
      ENDIF
      RETURN
      END

      SUBROUTINE FILNAM_THISTYPE(IN,NAME,TYP,OUT)
      CHARACTER*(*) IN,NAME,TYP,OUT
      CHARACTER*256 TYPE
      CALL FILNAM(IN,NAME,TYP,OUT)
      TYPE=TYP
      IF (TYPE(1:1).EQ.'.') TYPE=TYPE(2:)
      LI=LENGTH(OUT)+1
 10   CONTINUE
      LI=LI-1
      IF (LI.GT.0.AND.OUT(LI:LI).NE.'.') GOTO 10
      OUT=OUT(1:LI)//TYP
      RETURN
      END

      CHARACTER*10 FUNCTION DATESTR (IDUM)
      IMPLICIT      NONE
      CHARACTER*11  LOCAL
      INTEGER       LEN, IDUM
      CALL CDATESTR (LOCAL,LEN)
      IF (LEN.NE.10) STOP 'CDate returns invalid length'
      DATESTR=LOCAL(1:10)
      RETURN
      END
      CHARACTER*8 FUNCTION TIMESTR (IDUM)
      IMPLICIT      NONE
      CHARACTER*9   LOCAL
      INTEGER       LEN, IDUM
      CALL CTIMESTR (LOCAL,LEN)
      IF (LEN.NE.8) STOP 'CTime returns invalid length'
      TIMESTR=LOCAL(1:8)
      RETURN
      END
      CHARACTER*19 FUNCTION DATETIME (IDUM)
      IMPLICIT     NONE
      CHARACTER*10 DATESTR
      CHARACTER*8  TIMESTR
      CHARACTER*19 LOCAL
      INTEGER      IDUM

      LOCAL(1:10)=DATESTR(0)
      LOCAL(11:11)=' '
      LOCAL(12:19)=TIMESTR(0)
      DATETIME=LOCAL
      RETURN
      END

      SUBROUTINE GET_INT(I,IER)
      CALL GET_FLOAT(R,IER)
      I=NINT(R)
      RETURN
      END

      SUBROUTINE GET_FLOAT(R,IER)
      CHARACTER*80 S
      CALL GET_WORD(S,IER)
      IF (IER.NE.0) THEN 
        R=0
      ELSE
        READ(S,*,ERR=10001) R
      ENDIF
      RETURN
10001 CONTINUE
      IER=99
      R=0
      RETURN      
      END

      SUBROUTINE GET_WORD(S,IER)
      CHARACTER*(*) S
      COMMON/G_W_C/ ICL,IFI,FILENAME,WORD,NWORD,LINE,LUN
      CHARACTER*132 LINE,FILENAME
      CHARACTER*80 WORD(20)
      INTEGER LUN
      IER=0
      DATA ICL,IFI/0,0/
      DATA FILENAME/' '/
1     CONTINUE
      IF (LENGTH(FILENAME).EQ.0) THEN
        IF (ICL.EQ.0) THEN
          CALL GETARG(0,S)
          ICL=1
        ENDIF
        IF (ICL.GT.IARGC()) THEN
          IER=1
        ELSE
          CALL GETARG(ICL,S) 
        ENDIF 
        ICL=ICL+1
        IF (S(1:1).EQ.'@') THEN
          FILENAME=S(2:)
          IFI=-2
        ENDIF
        IF (S.EQ.'"!"') THEN
          S='!'
        ENDIF
      ENDIF
      IF (LENGTH(FILENAME).NE.0) THEN
        IF (IFI.EQ.-2) THEN
          LUN=12
C          CALL LOWERCASE(FILENAME,FILENAME)
          OPEN(UNIT=LUN,FILE=FILENAME,
     1      STATUS='OLD',ERR=10001)
          IFI=-1
        ENDIF
        DO WHILE (IFI.EQ.-1.OR.IFI.GT.NWORD)
          IFI=1
          READ(LUN,'(A)',END=10002) LINE
          CALL NEW_LINE_TO_WORDS (LINE,WORD,NWORD,40)
          IF (NWORD.GT.0) THEN
            IF (WORD(1).EQ.'!') NWORD=0
            IF (WORD(1).EQ.'WHOLE'.OR.WORD(1).EQ.'WHOLE') THEN
              NWORD=0
              S=LINE(6:)
              RETURN
            ENDIF
          ENDIF
        ENDDO
        S=WORD(IFI)
        IFI=IFI+1
      ENDIF
      RETURN
10001 CONTINUE
      print*,'The offending file is:',FILENAME
      STOP 'Could not open command file, program halted.'
10002 CONTINUE   ! END OF FILE.
      CLOSE(LUN)
      FILENAME=' '
      GOTO 1
      END

      SUBROUTINE NEW_LINE_TO_WORDS(LINE,WORD,NW,MAXRWORD)
C
C---  THIS SUBROUTINE MAPS THE INPUT STRING INTO THE ARRAY WORDS AND 
C---  RETURNS THE NUMBER OF WORDS
C---  AS DELIMITER SPACES, TABS AND MINUS (-) SIGNS ARE ALLOWED
C
C IDEA : ????
C SECONDARY IMPLEMENTATION: PAUL VAN DER SLUIS
C TERTIARY IMPLEMENTATION AND OPTIMIZATION: ROB HOOFT
C ALL LOCAL VARIABLES ARE KEPT IN REGISTERS (WITH FORTRAN/OPTIMIZE)
C
C VERSION: HOOFT  9-AUG-1990 11:22:28 
C
      INTEGER WORDLENGTH,MAXWORD,MAXRWORD
      PARAMETER     (WORDLENGTH=80)
      PARAMETER     (MAXWORD=40)
      CHARACTER*(WORDLENGTH) WORD(MAXWORD)
      CHARACTER*(*) LINE
      INTEGER       LETTER, OLDLETTER, ERRFLAG, WORDERRFLAG, NWORD,
     +              L, NEXTLETTER
      DATA          ERRFLAG /0/
      DATA          WORDERRFLAG /0/

      NWORD=0
      LETTER=ICHAR(' ')
      NEXTLETTER=ICHAR(LINE(1:1))
      IP=1
      L=LENGTH(LINE)
      DO I=1,L
         OLDLETTER=LETTER
         LETTER=NEXTLETTER
         IF (I.LT.L) THEN
            NEXTLETTER=ICHAR(LINE(I+1:I+1))
         ELSE
            NEXTLETTER=ICHAR(' ')
         ENDIF
         IF (LETTER.EQ.ICHAR(' ').OR.LETTER.EQ.9) THEN
            IP=1
         ELSE
C----------            
C---------- Split of following if-statements is to fool the optimizer on the
C---------- VAX, Such that the .EQ.  test, which fails most of the time, is
C---------- performed first.
C----------            
            IF (LETTER.EQ.ICHAR('-')) THEN
C-------------
C------------- Could be a minus sign or a hyphen...
C-------------
               IF (NEXTLETTER.LE.ICHAR('9').AND.
     +              NEXTLETTER.GE.ICHAR('0')) THEN
C----------------
C---------------- It is a minus sign...
C----------------
                  IF (OLDLETTER.NE.ICHAR('D').AND.
     +                 OLDLETTER.NE.ICHAR('E').AND.
     +                 OLDLETTER.NE.ICHAR('D').AND.
     +                 OLDLETTER.NE.ICHAR('E')     ) IP=1
C------------------
C------------------ ....and it is not an exponent
C------------------
               ENDIF
            ENDIF
            IF (IP.EQ.1) THEN
               NWORD=NWORD+1
               IF (NWORD.GT.MAXRWORD) THEN
C----------------
C---------------- Number of words requested.
C----------------
                  NW=NWORD-1
                  RETURN
               ENDIF
               IF (NWORD.GT.MAXWORD) THEN
                  IF (ERRFLAG.EQ.0) THEN
                     WRITE(*,*) 'Warning: Too many words on line.'
                     ERRFLAG=1
                  ENDIF
                  NW=NWORD
                  RETURN
               ENDIF
               WORD(NWORD)=' '
            ENDIF
            IF (IP.LE.WORDLENGTH) THEN
               WORD(NWORD)(IP:IP) = CHAR(LETTER)
               IP=IP+1
            ELSE IF (WORDERRFLAG.EQ.0) THEN
               WRITE(*,*) 'Warning: Word too long.'
               WORDERRFLAG=1
            ENDIF
         ENDIF
      ENDDO
      NW=NWORD
      RETURN
      END
      SUBROUTINE GVSRDB (TEXT)
C///
C-------------------------------------------------------------------------------
C----                                                                       ----
C---- SHIFTS ALL CHARACTERS LEFTWARDS IN TEXT UNTIL NO DOUBLE BLANKS LEFT.  ----
C----                                                                       ----
C---- THIS FUNCTION IS WRITTEN IN FORTRAN 77.                               ----
C----                                                                       ----
C-------------------------------------------------------------------------------
C\\\
      IMPLICIT       NONE
      CHARACTER*(*)  TEXT
      INTEGER        I, J
      LOGICAL        WASBLK, ISBLK
C----
C---- Checks
C----
      IF (LEN(TEXT).LE.1) RETURN
C----
C---- DO THE WORK
C----
      WASBLK=.FALSE.
      J=0
      DO 10 I=1,LEN(TEXT)
         ISBLK=(ICHAR(TEXT(I:I)).EQ.ICHAR(' '))
         IF (.NOT.(WASBLK.AND.ISBLK)) THEN
            J=J+1
            IF (J.LT.I) TEXT(J:J)=TEXT(I:I)
         END IF
         WASBLK=ISBLK
  10  CONTINUE
      IF (J.GE.LEN(TEXT)) RETURN
      DO 20 I=J+1,LEN(TEXT)
         TEXT(I:I)=' '
  20  CONTINUE

      RETURN
      END
