      subroutine freqcal(geom)
c 
c     Subroutine freqcal 
c  
c     Created:  Sept. 11, 2003 by Yan Zhao
c     Purpose:  Normal mode analysis is performed in this subroutine and 
c     frequencies and normal mode coordinate are calculated from the hessian
c      matrix.
c 
c     Called by:  mlhhook
c     Calls: 
c
      use optimize, only : hess
      use input, only : general, cartgeom
      use files, only : outfile, infile
c
      type (cartgeom) :: geom
      integer  i, j, k, n3tm, ij, m, ii, ll, mm, lstr, lend
      integer  kstr,kend
      double precision temp,zpe
      double precision, dimension(:,:), allocatable :: hessms, u, uu
      double precision, dimension(:), allocatable :: hessc, massvec,nn
      double precision, dimension(:), allocatable :: eigval, uc, freq 
      double precision, dimension(:,:), allocatable :: hessmsa, ua
      double precision, dimension(:), allocatable :: eigvala, uca
      double precision, dimension(:), allocatable :: hessca,freqa
      
      character*1, dimension(:,:), allocatable :: xyz
      character*1, dimension(:),allocatable :: ima, imaa
      integer, dimension(:), allocatable :: ind
c
      n3tm = 3*geom%natoms
c     
c    
      allocate (hessms(n3tm,n3tm),massvec(n3tm),hessc(n3tm*n3tm))
      allocate  (xyz(3,n3tm),ima(n3tm),ind(n3tm),uu(n3tm,n3tm),nn(n3tm))
      allocate (u(n3tm,n3tm),uc(n3tm*n3tm),eigval(n3tm),freq(n3tm))
      allocate (hessmsa(n3tm,n3tm), hessca(n3tm*n3tm),freqa(n3tm))
      allocate (eigvala(n3tm), ua(n3tm,n3tm))
      allocate (uca(n3tm*n3tm), imaa(n3tm))
c
c     get the mass vector 
c
      do i=1, n3tm
         massvec(i)=geom%atmmss(((i-1)/3)+1)
      enddo
c     
c     calculate the mass scaled hessian  
c
      do i=1, n3tm
        do j=1, i
          hessms(i,j)=hess(i,j)/(sqrt(massvec(i)*massvec(j)))
          hessms(j,i)=hessms(i,j)
          hessmsa(i,j)=hessms(i,j)
          hessmsa(j,i)=hessms(j,i)
        enddo
      enddo
      call prjfc(hessms,geom%aucoord,n3tm,geom%atmmss) 
c
c      diagonalize  projected and unprojected hessian 
c 
      ij = 0    
      do i = 1, n3tm
        do j = 1, i
          ij = ij+1
          hessc(ij) = hessms(i,j)  
          hessca(ij) = hessmsa(i,j)
        enddo
      enddo
      call rsp(hessc,n3tm,n3tm,eigval,uc) 
      call rsp(hessca, n3tm, n3tm, eigvala, uca)
      ij = 0
      do i = 1, n3tm
        do j = 1, n3tm
          ij = ij+1
          u(j,i) = uc(ij)
          ua(j,i)= uca(ij)
        enddo
       enddo
c
c    calculate the frequencies from the projected Hessian
c
      do i=1, n3tm 
       if (eigval(i) .ge. 0.0D0) then
        ima(i) = " "
        freq(i) = sqrt( eigval(i)*26422760.0)
       else
        ima(i) = "i"
        freq(i) = sqrt(-1*eigval(i)*26422760.0)
       endif
      enddo
c
c    calculate the frequencies from the unprojected Hessisan
c
      do i=1, n3tm
       if (eigvala(i) .ge. 0.0D0) then
        imaa(i) = " "
        freqa(i) = sqrt( eigvala(i)*26422760.0)
       else
        imaa(i) = "i"
        freqa(i) = sqrt(-1*eigvala(i)*26422760.0)
       endif
      enddo

c
c      calculate the normal mode coordinates in cartesian coordinates
c
      do i = 1, n3tm
        temp = 0
       do j = 1, n3tm
        if (freq(i) .le. 5.0) then 
          u(j,i)= ua(j,i)
        endif
        uu(j,i) = u(j,i)/sqrt(massvec(j))
        temp = temp + uu(j,i)* uu(j,i)
       enddo
        nn(i) = sqrt(temp) 
      enddo        
      do i = 1, n3tm
       do j = 1, n3tm
        uu(j,i) = uu(j,i)/nn(i)
       enddo
      enddo
c
c      write out the frequencies and normal mode
c
      do i=1, n3tm
       ind(i) = i
       xyz(1,i) = 'X'
       xyz(2,i) = 'Y'
       xyz(3,i) = 'Z'
      enddo
      write(outfile,3300)
      do m = n3tm, 1, -2
       lstr = m
       lend = m-1
       if (lend .le. 1) lend = 1 
       write(outfile,4000) (n3tm+1-ind(ii), ii=lstr,lend,-1)
       write(outfile,4100) (freq(ii),ima(ii),ii=lstr,lend,-1)
       write(outfile,4200) ((xyz(mm,ll),mm=1,3),ll=lstr,lend,-1)
       na = 1
       do i = 1, n3tm, 3
         kstr = i
         kend = i+2
         write(outfile,4300) na,((u(k,l), k=kstr,kend),l=lstr,lend,-1) 
         na = na + 1
       enddo
      enddo
      write(outfile,3400)
      do m = n3tm, 1, -2
        lstr = m
        lend = m-1
        if (lend .le. 1) lend = 1
        write(outfile,4000) (n3tm+1-ind(ii), ii=lstr,lend,-1)
        write(outfile,4100) (freq(ii),ima(ii),ii=lstr,lend,-1)
        write(outfile,4200) ((xyz(mm,ll),mm=1,3),ll=lstr,lend,-1)
        na = 1
        do i = 1, n3tm, 3
         kstr = i
         kend = i+2
         write(outfile,4300) na,((uu(k,l), k=kstr,kend),l=lstr,lend,-1)
         na = na + 1
        enddo
       enddo

      write(outfile,3500)
      do m = n3tm, 1, -2
        lstr = m
        lend = m-1
        if (lend .le. 1) lend = 1
        write(outfile,4000) (n3tm+1-ind(ii), ii=lstr,lend,-1)
        write(outfile,4100) (freqa(ii),imaa(ii),ii=lstr,lend,-1)
        write(outfile,4200) ((xyz(mm,ll),mm=1,3),ll=lstr,lend,-1)
        na = 1
        do i = 1, n3tm, 3
         kstr = i
         kend = i+2
         write(outfile,4300) na,((ua(k,l), k=kstr,kend),l=lstr,lend,-1)
         na = na + 1
        enddo
       enddo
       
       zpe=0.0
       do ii = 1, 3*n3tm
         if (freq(ii) .gt. 20) then
          zpe=zpe + freq(ii) 
         endif
       enddo
       zpe = 0.5 * zpe 
c       write (outfile, *) "ZPE in cm-1:   ", zpe
       zpe = zpe/349.75
c       write (outfile, *) "ZPE in kcal/mol:   ", zpe 
            
        
 3300 FORMAT(/1X,'Frequencies and normalized eigenvector components ',
     *       /1X,'in mass-scaled space-fixed cartesian coordinates')
 3400 FORMAT(//1X,'Frequencies and normalized eigenvector components ',
     *       /1X,'in cartesian coordinates')
 3500 FORMAT(//1X,'Frequencies and normalized eigenvector components',
     *  /1X,'in mass-scaled space-fixed cartesian coordinates(unprj)')

 4000  FORMAT(/,1X,4HMode,16X,I3,27X,I3)
 4100  FORMAT(1X,'omega (cm**-1)',2X,F9.2,1X,A1,(19X,F9.2,1X,A1))
 4200  FORMAT(/,1X,4HAtom,2(3(8X,A1),3X))
 4300  FORMAT(1X,I3,5X,2(3(F7.3,2X),3X))
 2001  Format(t20,d15.8,t40,d15.8,t60,d15.8) 
       return
      end


      SUBROUTINE PRJFC(F,xparam,nvar,atmass) 
C                                                                       
C  CALCULATES PROJECTED FORCE CONSTANT MATRIX (F).                      
C  THIS ROUTINE CAME ORIGINALLY FROM POLYRATE. IT IS USED BY PERMISSION
C  OF D. TRUHLAR. THE CURRENT VERSION IS LIFTED FROM GAMESS AND 
C  ADAPTED BY F.JENSEN, ODENSE, DK             
C  IF WE ARE AT A STATIONARY POINT (STPT=.T.), I.E. GNORM .LT. 10,      
C  THEN THE ROTATIONAL AND TRANSLATIONAL MODES ARE PROJECTED OUT        
C  AND THEIR FREQUENCIES BECOME IDENTICAL ZERO. IF NOT AT A STATIONARY  
C  POINT THEN THE MASS-WEIGHTED GRADIENT IS ALSO PROJECTED OUT AND      
C  THE CORRESPONDING FREQUENCY BECOME ZERO.                             
C ************************************************                      
C   X : MASS-WEIGHTED COORDINATE                                        
C   DX: NORMALIZED MASS-WEIGHTED GRADIENT VECTOR                        
C   F : MASS-WEIGHTED FORCE CONSTANT MATRIX                             
C   RM: INVERSION OF SQUARE ROOT OF MASS                                
C   P, COF: BUFFER                                                      
C                                                                       
      use files, only : outfile, infile
      
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION X(nvar),RM(nvar),F(nvar,nvar)   
      DIMENSION P(nvar,nvar),COF(nvar,nvar), atmass(nvar/3) 
      DIMENSION TENS(3,3,3),ROT(3,3),SCR(3,3),ISCR(6),CMASS(3)  
      dimension coord(3,nvar/3),dx(nvar),xparam(nvar)
      PARAMETER (ZERO=0.0d+00, ONE=1.0d+00, EPS=1.0d-14,
     *           CUT5=1.0d-05, CUT8=1.0d-08)                            
      integer l, ij, i, j, ia, ib, ic, ja, jb, jc, ip, jp
C                                                                       
C TOTALLY ASYMMETRIC CARTESIAN TENSOR.                                  
      DATA TENS/ 0.0d+00,  0.0d+00,  0.0d+00,                           
     X           0.0d+00,  0.0d+00, -1.0d+00,                           
     X           0.0d+00,  1.0d+00,  0.0d+00,                           
     Y           0.0d+00,  0.0d+00,  1.0d+00,                           
     Y           0.0d+00,  0.0d+00,  0.0d+00,                           
     Y          -1.0d+00,  0.0d+00,  0.0d+00,                           
     Z           0.0d+00, -1.0d+00,  0.0d+00,                           
     Z           1.0d+00,  0.0d+00,  0.0d+00,                           
     Z           0.0d+00,  0.0d+00,  0.0d+00  /                         
C                                                                       
      natm=nvar/3                                                        
      nc1=nvar
      ij=1
      do 2 i=1,natm                                                    
         coord(1,i)=xparam(ij)
         coord(2,i)=xparam(ij+1)
         coord(3,i)=xparam(ij+2)
         ij=ij+3
2     continue                                                          
C     CALCULATE 1/SQRT(MASS)                                            
      L=0                                                               
      DO 3  I=1, natm 
         TMP=ONE/SQRT(ATMASS(I))                                        
         DO 3 J=1,3                                                     
            L=L+1                                                       
           RM(L)=TMP
3     continue

C     PREPARE GRADIENT                                                  
         DO 4 I=1,nvar                                                   
4        DX(I)=ZERO                                                     
C     FIND CMS AND CALCULATED MASS WEIGHTED COORDINATES                 
      totm=zero                                                         
      cmass(1)=zero                                                     
      cmass(2)=zero                                                     
      cmass(3)=zero                                                     
      DO 6 I=1,NATM                                                     
         TOTM=TOTM+ATMASS(I)                                            
         DO 6 J=1,3                                                     
            CMASS(J)=CMASS(J)+ATMASS(I)*COORD(J,I)                      
6     CONTINUE                                                          
      DO 7 J=1,3                                                        
7     CMASS(J)=CMASS(J)/TOTM       
      L=0                                                               
      DO 8 I=1,NATM                                                     
         DO 8 J=1,3                                                     
         TMP=SQRT(ATMASS(I))                                            
             L=L+1                                                      
             X(L)=TMP*(COORD(J,I)-CMASS(J))
8     CONTINUE 
C
C 2. COMPUTE INERTIA TENSOR.          
C                                  
      DO 10 I=1,3                                                       
       DO 10 J=1,3                                                      
   10   ROT(I,J)=ZERO                                                   
      DO 20 I=1,NATM                                                    
       L=3*(I-1)+1                                                      
       ROT(1,1)=ROT(1,1)+X(L+1)**2+X(L+2)**2    
       ROT(1,2)=ROT(1,2)-X(L)*X(L+1)       
       ROT(1,3)=ROT(1,3)-X(L)*X(L+2)  
       ROT(2,2)=ROT(2,2)+X(L)**2+X(L+2)**2  
       ROT(2,3)=ROT(2,3)-X(L+1)*X(L+2)      
   20  ROT(3,3)=ROT(3,3)+X(L)**2+X(L+1)**2    
      ROT(2,1)=ROT(1,2)       
      ROT(3,1)=ROT(1,3)        
      ROT(3,2)=ROT(2,3)   
C                                                                       
CHECK THE INERTIA TENSOR.                                               
      CHK=ROT(1,1)*ROT(2,2)*ROT(3,3)                                    
      IF(ABS(CHK).GT.CUT8) GO TO 21                                     


      IF(ABS(ROT(1,1)).GT.CUT8) GO TO 11                                
C X=0                                                                   
      IF(ABS(ROT(2,2)).GT.CUT8) GO TO 12                                
C X,Y=0                                                                 
      IF(ABS(ROT(3,3)).GT.CUT8) GO TO 13                                
      WRITE(6,14) ROT(1,1),ROT(2,2),ROT(3,3)                            
   14 FORMAT(1X,'EVERY DIAGONAL ELEMENTS ARE ZERO ?',3F20.10)           
      RETURN                                                            
C                                                                       
C* 1. X,Y=0 BUT Z.NE.0                                                  
   13 ROT(3,3)=ONE/ROT(3,3)                                             
      GO TO 22                                                          
C Y.NE.0                                                                
   12 IF(ABS(ROT(3,3)).GT.CUT8) GO TO 15                                

C* 2. X,Z=0 BUT Y.NE.0                                                  
      ROT(2,2)=ONE/ROT(2,2)                                             
      GO TO 22                                                          
C X.NE.0                                                                
   11 IF(ABS(ROT(2,2)).GT.CUT8) GO TO 16                                
      IF(ABS(ROT(3,3)).GT.CUT8) GO TO 17                                

C* 3. Y,Z=0 BUT X.NE.0                                                  
      ROT(1,1)=ONE/ROT(1,1)                                             
      GO TO 22                                                          

C* 4. X,Y.NE.0 BUT Z=0                                                  
   16 DET=ROT(1,1)*ROT(2,2)-ROT(1,2)*ROT(2,1)                           
      TRP=ROT(1,1)                                                      
      ROT(1,1)=ROT(2,2)/DET                                             
      ROT(2,2)=TRP/DET                                                  
      ROT(1,2)=-ROT(1,2)/DET                                            
      ROT(2,1)=-ROT(2,1)/DET                                            
      GO TO 22                                                          

C* 5. X,Z.NE.0 BUT Y=0                                                  
   17 DET=ROT(1,1)*ROT(3,3)-ROT(1,3)*ROT(3,1)                           
      TRP=ROT(1,1)                                                      
      ROT(1,1)=ROT(3,3)/DET                                             
      ROT(3,3)=TRP/DET                                                  
      ROT(1,3)=-ROT(1,3)/DET                                            
      ROT(3,1)=-ROT(3,1)/DET                                            
      GO TO 22                                                          

C* 6. Y,Z.NE.0 BUT X=0                                                  
   15 DET=ROT(3,3)*ROT(2,2)-ROT(3,2)*ROT(2,3)                           
      TRP=ROT(3,3)                                                      
      ROT(3,3)=ROT(2,2)/DET                                             
      ROT(2,2)=TRP/DET                                                  
      ROT(3,2)=-ROT(3,2)/DET                                            
      ROT(2,3)=-ROT(2,3)/DET                                            
      GO TO 22                                                          
   21 CONTINUE                                                          

C                                                                       
C 4. COMPUTE INVERSION MATRIX OF ROT.                                   
C
      INFO=0                                                            
      CALL DGEFA(ROT,3,3,ISCR,INFO)                                     
      IF(INFO.NE.0) STOP                                                
      DET=ZERO                                                          
      CALL DGEDI(ROT,3,3,ISCR,DET,SCR,1)                                
C                                                                       
   22 CONTINUE                                                          
C                                                                       
C 5. TOTAL MASS ---> TOTM.                                              
C                                                                       
C 6. COMPUTE P MATRIX                                                   
C    ----------------                                                   
      DO 100 IP=1,NATM                                                  
       INDX=3*(IP-1)                                                    
       DO 100 JP=1,IP                                                   
        JNDX=3*(JP-1)                                                   
        DO 70 IC=1,3                                                    
         JEND=3                                                         
         IF(JP.EQ.IP) JEND=IC                                           
         DO 70 JC=1,JEND                                                
          SUM=ZERO                                                      
          DO 50 IA=1,3                                                  
           DO 50 IB=1,3                                                 
            IF(TENS(IA,IB,IC).EQ.0) GO TO 50                            
            DO 30 JA=1,3                                                
             DO 30 JB=1,3                                               
              IF(TENS(JA,JB,JC).EQ.0) GO TO 30                          
              SUM=SUM+TENS(IA,IB,IC)*TENS(JA,JB,JC)*ROT(IA,JA)*         
     &                X(INDX+IB)*X(JNDX+JB)                             
   30         CONTINUE                                                  
   50       CONTINUE                                                    
          II=INDX+IC                                                    
          JJ=JNDX+JC                                                    
          P(II,JJ)=SUM+DX(II)*DX(JJ)                                    
          IF(IC.EQ.JC) P(II,JJ)=P(II,JJ)+ONE/(RM(II)*RM(JJ)*TOTM)       
   70     CONTINUE                                                      
  100   CONTINUE 
C                                                                       
C 7. COMPUTE DELTA(I,J)-P(I,J)                                          
      DO 110 I=1,NC1                                                    
       DO 110 J=1,I                                                     
        P(I,J)=-P(I,J)                                                  
        IF(I.EQ.J) P(I,J) = ONE +P(I,J)                                 
  110   CONTINUE                                                        
C                                                                       
C 8. NEGLECT SMALLER VALUES THAN 10**-8.                
C                
      DO 120 I=1,NC1                                                    
       DO 120 J=1,I                                                     
        IF(ABS(P(I,J)).LT.CUT8) P(I,J)=ZERO                             
        P(J,I)=P(I,J)                                                   
  120   CONTINUE              
                                          
C                                                                       
C 10. POST AND PREMULTIPLY F BY P.                                      
C     USE COF FOR SCRATCH.  
      DO 150 I=1,NC1                                                    
       DO 150 J=1,NC1                                                   
        SUM=ZERO                                                        
        DO 140 K=1,NC1                                                  
  140    SUM=SUM+F(I,K)*P(K,J)                                          
  150   COF(I,J)=SUM
C                                                                       
C 11. COMPUTE P*F*P.
C                                                    
      DO 200 I=1,NC1                                                    
       DO 200 J=1,NC1                                                   
        SUM=ZERO                                                        
        DO 190 K=1,NC1                                                  
  190    SUM=SUM+P(I,K)*COF(K,J)                                        
  200   F(I,J)=SUM                                                      
2000  Format(t20,d15.8,t40,d15.8,t60,d15.8)
 
      RETURN                                                            
      END            


      SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO)                               
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION A(LDA,*),IPVT(*)                                        
C                                                                       
C     DGEFA FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION.  
C                                                                       
C     DGEFA IS USUALLY CALLED BY DGECO, BUT IT CAN BE CALLED            
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.          
C     (TIME FOR DGECO) = (1 + 9/N)*(TIME FOR DGEFA) .                   
C                                                                       
C     ON ENTRY                                                          
C                                                                       
C        A       DOUBLE PRECISION(LDA, N)                               
C                THE MATRIX TO BE FACTORED.                             
C                                                                       
C        LDA     INTEGER                                                
C                THE LEADING DIMENSION OF THE ARRAY  A .                
C                                                                       
C        N       INTEGER                                                
C                THE ORDER OF THE MATRIX  A .                           
C                                                                       
C     ON RETURN                                                         
C                                                                       
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS         
C                WHICH WERE USED TO OBTAIN IT.                          
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE       
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER          
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.       
C                                                                       
C        IPVT    INTEGER(N)                                             
C                AN INTEGER VECTOR OF PIVOT INDICES.                    
C                                                                       
C        INFO    INTEGER                                                
C                = 0  NORMAL VALUE.                                     
C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR       
C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES        
C                     INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO  
C                     IF CALLED.  USE  RCOND  IN DGECO FOR A RELIABLE   
C                     INDICATION OF SINGULARITY.                        
C                                                                       
C     LINPACK. THIS VERSION DATED 08/14/78 .                            
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.      
C                                                                       
C     SUBROUTINES AND FUNCTIONS                                         
C                                                                       
C     BLAS DAXPY,DSCAL,IDAMAX                                           
C                                                                       
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING                        
C                                                                       
      INFO = 0                                                          
      NM1 = N - 1                                                       
      IF (NM1 .LT. 1) GO TO 70                                          
      DO 60 K = 1, NM1                                                  
         KP1 = K + 1                                                    
C                                                                       
C        FIND L = PIVOT INDEX                                           
C                                                                       
         L = IDAMAX(N-K+1,A(K,K),1) + K - 1                             
         IPVT(K) = L                                                    
C                                                                       
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED          
C                                                                       
         IF (A(L,K) .EQ. 0.0D+00) GO TO 40                              
C                                                                       
C           INTERCHANGE IF NECESSARY                                    
C                                                                       
            IF (L .EQ. K) GO TO 10                                      
               T = A(L,K)                                               
               A(L,K) = A(K,K)                                          
               A(K,K) = T                                               
   10       CONTINUE                                                    
C                                                                       
C           COMPUTE MULTIPLIERS                                         
C                                                                       
            T = -1.0D+00/A(K,K)                                         
            CALL DSCAL(N-K,T,A(K+1,K),1)                                
C                                                                       
C           ROW ELIMINATION WITH COLUMN INDEXING                        
C                                                                       
            DO 30 J = KP1, N                                            
               T = A(L,J)                                               
               IF (L .EQ. K) GO TO 20                                   
                  A(L,J) = A(K,J)                                       
                  A(K,J) = T                                            
   20          CONTINUE                                                 
               CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)                  
   30       CONTINUE                                                    
         GO TO 50                                                       
   40    CONTINUE                                                       
            INFO = K                                                    
   50    CONTINUE                                                       
   60 CONTINUE                                                          
   70 CONTINUE                                                          
      IPVT(N) = N                                                       
      IF (A(N,N) .EQ. 0.0D+00) INFO = N                                 
      RETURN                                                            
      END           

      SUBROUTINE DGEDI(A,LDA,N,IPVT,DET,WORK,JOB)                       
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION A(LDA,*),DET(2),WORK(*),IPVT(*)                         
C                                                                       
C     DGEDI COMPUTES THE DETERMINANT AND INVERSE OF A MATRIX            
C     USING THE FACTORS COMPUTED BY DGECO OR DGEFA.                     
C                                                                       
C     ON ENTRY                                                          
C                                                                       
C        A       DOUBLE PRECISION(LDA, N)                               
C                THE OUTPUT FROM DGECO OR DGEFA.                        
C                                                                       
C        LDA     INTEGER                                                
C                THE LEADING DIMENSION OF THE ARRAY  A .                
C                                                                       
C        N       INTEGER                                                
C                THE ORDER OF THE MATRIX  A .                           
C                                                                       
C        IPVT    INTEGER(N)                                             
C                THE PIVOT VECTOR FROM DGECO OR DGEFA.                  
C                                                                       
C        WORK    DOUBLE PRECISION(N)                                    
C                WORK VECTOR.  CONTENTS DESTROYED.                      
C                                                                       
C        JOB     INTEGER                                                
C                = 11   BOTH DETERMINANT AND INVERSE.                   
C                = 01   INVERSE ONLY.                                   
C                = 10   DETERMINANT ONLY.                               
C                                                                       
C     ON RETURN                                                         
C                                                                       
C        A       INVERSE OF ORIGINAL MATRIX IF REQUESTED.               
C                OTHERWISE UNCHANGED.                                   
C                                                                       
C        DET     DOUBLE PRECISION(2)                                    
C                DETERMINANT OF ORIGINAL MATRIX IF REQUESTED.           
C                OTHERWISE NOT REFERENCED.                              
C                DETERMINANT = DET(1) * 10.0**DET(2)                    
C                WITH  1.0 .LE. ABS(DET(1)) .LT. 10.0                   
C                OR  DET(1) .EQ. 0.0 .                                  
C                                                                       
C     ERROR CONDITION                                                   
C                                                                       
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS     
C        A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED.           
C        IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY      
C        AND IF DGECO HAS SET RCOND .GT. 0.0 OR DGEFA HAS SET           
C        INFO .EQ. 0 .                                                  
C                                                                       
C     LINPACK. THIS VERSION DATED 08/14/78 .                            
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.      
C                                                                       
C     SUBROUTINES AND FUNCTIONS                                         
C                                                                       
C     BLAS DAXPY,DSCAL,DSWAP                                            
C     FORTRAN ABS,MOD                                                   
C                                                                       
C     COMPUTE DETERMINANT                                               
C                                                                       
      IF (JOB/10 .EQ. 0) GO TO 70                                       
         DET(1) = 1.0D+00                                               
         DET(2) = 0.0D+00                                               
         TEN = 10.0D+00                                                 
         DO 50 I = 1, N                                                 
            IF (IPVT(I) .NE. I) DET(1) = -DET(1)                        
            DET(1) = A(I,I)*DET(1)                                      
C        ...EXIT                                                        
            IF (DET(1) .EQ. 0.0D+00) GO TO 60                           
   10       IF (ABS(DET(1)) .GE. 1.0D+00) GO TO 20                      
               DET(1) = TEN*DET(1)                                      
               DET(2) = DET(2) - 1.0D+00                                
            GO TO 10                                                    
   20       CONTINUE                                                    
   30       IF (ABS(DET(1)) .LT. TEN) GO TO 40                          
               DET(1) = DET(1)/TEN                                      
               DET(2) = DET(2) + 1.0D+00                                
            GO TO 30                                                    
   40       CONTINUE                                                    
   50    CONTINUE                                                       
   60    CONTINUE                                                       
   70 CONTINUE                                                          
C                                                                       
C     COMPUTE INVERSE(U)                                                
C                                                                       
      IF (MOD(JOB,10) .EQ. 0) GO TO 150                                 
         DO 100 K = 1, N                                                
            A(K,K) = 1.0D+00/A(K,K)                                     
            T = -A(K,K)                                                 
            CALL DSCAL(K-1,T,A(1,K),1)                                  
            KP1 = K + 1                                                 
            IF (N .LT. KP1) GO TO 90                                    
            DO 80 J = KP1, N                                            
               T = A(K,J)                                               
               A(K,J) = 0.0D+00                                         
               CALL DAXPY(K,T,A(1,K),1,A(1,J),1)                        
   80       CONTINUE                                                    
   90       CONTINUE                                                    
  100    CONTINUE                                                       
C                                                                       
C        FORM INVERSE(U)*INVERSE(L)                                     
C                                                                       
         NM1 = N - 1                                                    
         IF (NM1 .LT. 1) GO TO 140                                      
         DO 130 KB = 1, NM1                                             
            K = N - KB                                                  
            KP1 = K + 1                                                 
            DO 110 I = KP1, N                                           
               WORK(I) = A(I,K)                                         
               A(I,K) = 0.0D+00                                         
  110       CONTINUE                                                    
            DO 120 J = KP1, N                                           
               T = WORK(J)                                              
               CALL DAXPY(N,T,A(1,J),1,A(1,K),1)                        
  120       CONTINUE                                                    
            L = IPVT(K)                                                 
            IF (L .NE. K) CALL DSWAP(N,A(1,K),1,A(1,L),1)               
  130    CONTINUE                                                       
  140    CONTINUE                                                       
  150 CONTINUE                                                          
      RETURN                                                            
      END            

      subroutine  dscal(n,da,dx,incx)
c
c     scales a vector by a constant.
c     uses unrolled loops for increment equal to one.
c     jack dongarra, linpack, 3/11/78.
c     modified 3/93 to return if incx .le. 0.
c
      double precision da,dx(1)
      integer i,incx,m,mp1,n,nincx
c
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      nincx = n*incx
      do 10 i = 1,nincx,incx
        dx(i) = da*dx(i)
   10 continue
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dx(i) = da*dx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dx(i) = da*dx(i)
        dx(i + 1) = da*dx(i + 1)
        dx(i + 2) = da*dx(i + 2)
        dx(i + 3) = da*dx(i + 3)
        dx(i + 4) = da*dx(i + 4)
   50 continue
      return
      end
 
      integer function idamax(n,dx,incx)
c
c     finds the index of element having max. absolute value.
c     jack dongarra, linpack, 3/11/78.
c     modified 3/93 to return if incx .le. 0.
c
      double precision dx(1),dmax
      integer i,incx,ix,n
c
      idamax = 0
      if( n.lt.1 .or. incx.le.0 ) return
      idamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      dmax = dabs(dx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(dabs(dx(ix)).le.dmax) go to 5
         idamax = i
         dmax = dabs(dx(ix))
    5    ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
   20 dmax = dabs(dx(1))
      do 30 i = 2,n
         if(dabs(dx(i)).le.dmax) go to 30
         idamax = i
         dmax = dabs(dx(i))
   30 continue
      return
      end
 
       subroutine  dswap (n,dx,incx,dy,incy)
c
c     interchanges two vectors.
c     uses unrolled loops for increments equal one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(1),dy(1),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c       code for unequal increments or equal increments not equal
c         to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dx(ix)
        dx(ix) = dy(iy)
        dy(iy) = dtemp
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c       code for both increments equal to 1
c
c
c       clean-up loop
c
   20 m = mod(n,3)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
   30 continue
      if( n .lt. 3 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,3
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
        dtemp = dx(i + 1)
        dx(i + 1) = dy(i + 1)
        dy(i + 1) = dtemp
        dtemp = dx(i + 2)
        dx(i + 2) = dy(i + 2)
        dy(i + 2) = dtemp
   50 continue
      return
      end

      subroutine daxpy(n,da,dx,incx,dy,incy)
c
c     constant times a vector plus a vector.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(1),dy(1),da
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if (da .eq. 0.0d0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dy(iy) + da*dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dy(i) = dy(i) + da*dx(i)
   30 continue
      if( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,4
        dy(i) = dy(i) + da*dx(i)
        dy(i + 1) = dy(i + 1) + da*dx(i + 1)
        dy(i + 2) = dy(i + 2) + da*dx(i + 2)
        dy(i + 3) = dy(i + 3) + da*dx(i + 3)
   50 continue
      return
      end
       
