C***********************************************************************
C    PROGRAM "RANK OF COMBINED Z-MATRIX" BY ROBERT FRACZKIEWICZ        *
C    DEPARTMENT OF CHEMISTRY, UNIVERSITY OF HOUSTON, 1992              *
C    CHEM86@JETSON.UH.EDU                                              *
C***********************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION NR(2000),NC(2000),NFO(2000),Z(2000),NRK(150,100),
     1 AK(150,100),NRW(150,100),NRC(150,100),NONZ(150),NROW(4),
     2 NCOL(4),NPO(4),DATIN(4)
      CHARACTER*60 NAME,CR
      DO 180 I=1,2000
  180 NFO(I)=0
      NZO=0
      NQ=0
      PRINT *
      PRINT *,'           RANK OF COMBINED Z-MATRIX                   '
      PRINT *,'            RANKZ VERSION 1.0 (1992)                   '
      PRINT *
      PRINT *,'INPUT THE TOTAL NUMBER OF INDEPENDENT FORCE CONSTANTS'
      READ(*,*) NF
      NRANK=NF
  200 PRINT *,'INPUT THE name OF THE FILE (WITHOUT EXTENSION !!!)     '
      PRINT *,'WHERE THE Z-MATRIX IS STORED AND PRESS .       '
      PRINT *,'THE ".ZMAT" EXTENSION WILL BE AUTOMATICALLY ASSUMED.   '
      PRINT *,'THE LENGTH OF THE name CANNOT EXCEED 50 CHARACTERS.    '
      READ(*,'(A60)') NAME
      NAMLEN = LSTNBL(NAME)
      PRINT *,'INPUT THE DIMENSION OF THE Z-MATRIX'
      READ(*,*) NNQ
      OPEN(UNIT=15, FILE=NAME(1:NAMLEN)//'.ZMAT',
     1     ERR=9991, STATUS='OLD') 
  190 NOZ=0
  191 READ(15,18) (NROW(L),NCOL(L),NPO(L),DATIN(L),L=1,4)
   18 FORMAT(4(3I3,F9.6))
      DO 196 L=1,4
       IF(NROW(L))198,196,193
  193  NOZ=NOZ+1
       NR(NZO+NOZ)=NQ+NROW(L)
       NC(NZO+NOZ)=NQ+NCOL(L)
       NFO(NZO+NOZ)=NPO(L)
       Z(NZO+NOZ)=DATIN(L)
  196 CONTINUE
      GO TO 191
  198 NZO=NZO+NOZ
      NQ=NQ+NNQ
      CLOSE(UNIT=15)
      PRINT *,'END OF DATA ? '
      READ(*,'(A60)') CR
      IF(CR(1:1).EQ.'Y'.OR. CR(1:1).EQ.'y') GO TO 199
      GO TO 200      
  199 PRINT *,'THE RESULTS OF THE PROGRAM WILL BE STORED IN THE'
      PRINT *,'OUTPUT FILE WITH EXTENSION ".RAOUT" .'
      OPEN(UNIT=16, FILE=NAME(1:NAMLEN)//'.RAOUT',
     1 STATUS='NEW') 
      DO 100 I=1,150
       NONZ(I)=0
       DO 100 J=1,50
        NRK(I,J)=0
  100   AK(I,J)=0.0
      DO 10 L=1,NZO
       K=NFO(L)
       NONZ(K)=NONZ(K)+1
       NRW(K,NONZ(K))=NR(L)
       NRC(K,NONZ(K))=NC(L)
       NRK(K,NONZ(K))=NQ*(NR(L)-1)+NC(L)
       AK(K,NONZ(K))=Z(L)
   10 CONTINUE
      DO 40 K=1,NF
       IF(NONZ(K).EQ.0) THEN
        NRANK=NRANK-1
        WRITE(16,41) K
   41   FORMAT(1X,I3,' - TH FORCE CONSTANT NOT PRESENT')
       ELSE
        KOL=1
        AMAX=AK(K,1)
        DO 50 J=2,NONZ(K)
         IF(ABS(AK(K,J)).GT.ABS(AMAX)) THEN
          AMAX=AK(K,J)
          KOL=J
         ENDIF
   50   CONTINUE
        IF(AMAX.EQ.0.0) THEN
         NRANK=NRANK-1
         WRITE(16,42) K
   42    FORMAT(1X,I3,' - TH FORCE CONSTANT LINEARLY DEPENDENT') 
        ELSE
        KK=NRK(K,KOL)
         IF(KK.NE.K) THEN
          DO 60 L=1,NF
           DO 60 I=1,NONZ(L)
            KX=NRK(L,I)
            IF(KX.EQ.KK) NRK(L,I)=K
  60        IF(KX.EQ.K) NRK(L,I)=KK
         ENDIF
         DO 70 J=1,NONZ(K)
          L=NRK(K,J)
          DO 70 I=K+1,NF
           DO 70 M=1,NONZ(I)
            IF(NRK(I,M).EQ.K) THEN
             DO 71 N=1,NONZ(I)
              IF(NRK(I,N).EQ.L) AK(I,N)=AK(I,N)-AK(I,M)*AK(K,J)/
     1AK(K,KOL)
              IF(ABS(AK(I,N)).LT.9.0E-07) AK(I,N)=0.0
   71        CONTINUE
            ENDIF
   70    CONTINUE
        ENDIF
       ENDIF
   40 CONTINUE
      WRITE(16,45) NAME,NRANK
   45 FORMAT(1X,'FILE : ',A14,/1X,'RANK OF THE COMBINED Z-MATRIX = ',i3)
      CLOSE(UNIT=6)
      STOP 1
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 9991 PRINT *
      PRINT *,
     1 'INPUT OPERATION UNSUCCESFUL. CANNOT FIND Z-MATRIX FILE '//
     2 NAME(1:NAMLEN)//'.ZMAT'
      STOP 3
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      END

      
C  -------------------  LSTNBL -----
C  Routine which finds last nonblank character in a character variable
C

      INTEGER FUNCTION LSTNBL(CHRVAR)
      CHARACTER*(*) CHRVAR
      INTEGER I, L

      L = LEN(CHRVAR)
      
      DO 100 I = L, 1, -1
        IF(CHRVAR(I:I) .NE. ' ')GOTO 200
100   CONTINUE

200   LSTNBL = I
      RETURN
      END