* PACKAGE LEIGEN  !" $BNO3X(B $B8GM-CM2r@O(B
*
*"  [HIS] 92/12/14(takepiro) $B!V9TNs7W;;%=%U%H%&%'%"!W;HMQ(B
*"        92/12/18(takepiro)  Numerical Recipies $B;HMQ(B
*"        93/05/10(takepiro)  $B%(%i!<=hCVJQ99(B
*"        93/06/11(takepiro)  $B8GM-4X?t7W;;%9%$%C%AF3F~(B
*
**********************************************************************
      SUBROUTINE LEIGEN
     M            ( AMAT   , 
     O              EIGVLR , EIGVLI  ,
     O              EIGVCR , EIGVCI  ,
     O              IERR   , 
     I              MATDIM , OEIVEC    )
*
#ifdef SYS_IBMS
      INCLUDE   (ZCDIM)                      !" 
      INCLUDE   (ZLDIM)                      !" $B3J;RE@?t(B, $BGH?t(B
#else
#include        "zcdim.F"                    !" 
#include        "zldim.F"                    !" $B78?t9TNs$NBg$-$5(B
#endif
*
*   [MODIFY] 
      REAL      AMAT  ( MATDMX, MATDMX )     !" $B78?t9TNs(B
*
*   [OUTPUT] 
      REAL      EIGVLR( MATDMX )             !" $B8GM-CM<B?tIt(B
      REAL      EIGVLI( MATDMX )             !" $B8GM-CM5u?tIt(B
      REAL      EIGVCR( MATDMX, MATDMX )     !" $B8GM-%Y%/%H%k<B?tIt(B
      REAL      EIGVCI( MATDMX, MATDMX )     !" $B8GM-%Y%/%H%k5u?tIt(B
      INTEGER   IERR                         !" $B%5%V%k!<%A%s%(%i!<%3!<%I(B
*
*   [INPUT] 
      INTEGER   MATDIM                       !" $B7W;;$9$k<!85(B
      LOGICAL   OEIVEC                       !" $B8GM-4X?t7W;;%9%$%C%A(B
*
*   [INTERNAL WORK] 
      COMMON    /COMWRK/  Z
*
      REAL      SCALE ( MATDMX )             !" $B%9%1!<%j%s%0>pJs(B
      INTEGER   LOW, IGH                     !" 
      REAL      INT   ( MATDMX )             !" $B%X%C%;%s%Y%k%0JQ49>pJs(B
      REAL      Z     ( MATDMX, MATDMX )     !" $B8GM-%Y%/%H%k(B
*
      CHARACTER HERR*8                       !" $B%(%i!<HV9f=PNOMQJ8;zJQ?t(B
      INTEGER   NERR                         !" $BJ8;zNs$ND9$5(B
      INTEGER   LENC                         !" $BJ8;z$ND9$5$rJV$94X?t(B
*
      SAVE      
*
*"  < 1. $B%P%i%s%7%s%0(B >
*
      CALL BALANC
     I      (  MATDMX , MATDIM , 
     M         AMAT   ,
     O         LOW    , IGH    ,SCALE  )
*
*"  < 2. $B%X%C%;%s%Y%k%09TNsJQ49(B >
*
      CALL ELMHES
     I      (  MATDMX , MATDIM , 
     I         LOW    , IGH    , 
     M         AMAT   , INT      )
*
      CALL ELTRAN
     I      (  MATDMX , MATDIM , 
     I         LOW    , IGH    , 
     I         AMAT   , INT    , 
     O         Z                 )

*
*"  < 3. $B8GM-CM$N7W;;(B >
*
      CALL HQR2
     I      (  MATDMX , MATDIM , 
     I         LOW    , IGH    , 
     I         AMAT   , 
     O         EIGVLR , EIGVLI , 
     M         Z      , 
     O         IERR              )
*
      IF ( IERR .NE. 0 ) THEN
         WRITE( HERR , '(I5)' ) IERR
         CALL CLADJ( HERR )
         NERR = LENC( HERR )
         CALL MSGDMP( 'W', 'LEIGEN', 
     &         'IERR = '//HERR(1:NERR)//' : EIGENVALUES NOT CORRECT ' )
      ENDIF
*
*"  < 4. $B8GM-%Y%/%H%k$N7W;;(B >
*
      IF ( OEIVEC ) THEN
         CALL BALBAK
     I      (  MATDMX , MATDIM , 
     I         LOW    , IGH    , 
     I         SCALE  , MATDIM , 
     M         Z                  )
      ENDIF
*
*"  < 5. $B8GM-%Y%/%H%k$NJB$SBX$((B > 
*
      CALL EIGSRT
     M      (  EIGVLR , EIGVLI , 
     O         EIGVCR , EIGVCI ,
     I         Z      , 
     I         MATDIM , OEIVEC   )
*
*"  < 5. $B=*N;(B > 
*
      RETURN
      END
************************************************************************
      SUBROUTINE EIGSRT      !" $B8GM-CM8GM-%Y%/%H%kJB$YJQ$((B
     M      (  EIGVLR , EIGVLI , 
     O         EIGVCR , EIGVCI , 
     I         Z      , 
     I         MATDIM , OEIVEC   )
*
#ifdef SYS_IBMS
      INCLUDE   (ZCDIM)                      !" 
      INCLUDE   (ZLDIM)                      !" $B3J;RE@?t(B, $BGH?t(B
#else
#include        "zcdim.F"                    !" 
#include        "zldim.F"                    !" $B78?t9TNs$NBg$-$5(B
#endif
*
*   [OUTPUT] 
      REAL      EIGVLR( MATDMX )             !" $B8GM-CM<B?tIt(B
      REAL      EIGVLI( MATDMX )             !" $B8GM-CM5u?tIt(B
      REAL      EIGVCR( MATDMX, MATDMX )     !" $B8GM-%Y%/%H%k<B?tIt(B
      REAL      EIGVCI( MATDMX, MATDMX )     !" $B8GM-%Y%/%H%k5u?tIt(B
*
*   [INPUT]
      REAL      Z     ( MATDMX, MATDMX )     !" $B8GM-%Y%/%H%k(B
*
      INTEGER   MATDIM                       !" $B7W;;$9$k<!85(B
      LOGICAL   OEIVEC                       !" $B8GM-4X?t7W;;%9%$%C%A(B
*
*   [INTERNAL WORK]
      INTEGER   J, K
      INTEGER   INDX  ( MATDMX )             !" $B=gHV3JG<G[Ns(B
*
*" < 1. $B8GM-%Y%/%H%k$NF~$l49$((B >
*
      IF ( OEIVEC )THEN
         DO 1000 K = 1, MATDIM
            IF ( EIGVLI(K) .EQ. 0.0 ) THEN
               DO 1100 J = 1, MATDIM
                  EIGVCR( J,K ) = Z( J,K )
                  EIGVCI( J,K ) = 0.
 1100          CONTINUE
*
            ELSE IF ( EIGVLI(K) .GE. 0.0 ) THEN
               DO 1200 J = 1, MATDIM
                  EIGVCR( J,K ) =  Z( J,K ) 
                  EIGVCI( J,K ) =  Z( J,K+1 )
 1200          CONTINUE
*
            ELSE
               DO 1300 J = 1, MATDIM
                  EIGVCR(J,K) =    EIGVCR( J,K-1 )
                  EIGVCI(J,K) =  - EIGVCI( J,K-1 )
 1300          CONTINUE
            ENDIF
 1000    CONTINUE
      ENDIF
*
*"  < 2. $B8GM-CM$N%=!<%H(B >
*
      CALL INDEXX                                   !" $B8GM-CM<B?tIt$N>.$5$$=g(B
     I       ( MATDIM , EIGVLR ,
     O         INDX              )
*
      CALL COPY( Z, EIGVLR, MATDIM )             !" $B8GM-CM<B?tIt(B
      DO 2100 J = 1, MATDIM                         !" $B8GM-CM<B?tIt$NBg$-$$=g(B
         EIGVLR( J ) = Z( INDX( MATDIM-J+1 ),1  )
 2100 CONTINUE
*
      CALL COPY( Z, EIGVLI, MATDIM )             !" $B8GM-CM5u?tIt(B
      DO 2200 J = 1, MATDIM                         !" $B8GM-CM<B?tIt$NBg$-$$=g(B
         EIGVLI( J ) = Z( INDX( MATDIM-J+1 ),1 )
 2200 CONTINUE
*
*"  < 3. $B8GM-%Y%/%H%k$N%=!<%H(B >
*
      IF ( OEIVEC )THEN                 
         CALL COPY( Z, EIGVCR, MATDMX*MATDIM )  !" $B8GM-%Y%/%H%k<B?tIt(B
         DO 2300 K = 1, MATDIM                     !" $B8GM-CM<B?tIt$NBg$-$$=g(B
            DO 2300 J = 1, MATDIM
               EIGVCR( J,K ) = Z( J,INDX( MATDIM-K+1 ) )
 2300    CONTINUE
*
         CALL COPY( Z, EIGVCI, MATDMX*MATDIM )  !" $B8GM-%Y%/%H%k5u?tIt(B
         DO 2400 K = 1, MATDIM                     !" $B8GM-CM<B?tIt$NBg$-$$=g(B
            DO 2400 J = 1, MATDIM
               EIGVCI( J,K ) = Z( J,INDX( MATDIM-K+1 ) )
 2400    CONTINUE
      ENDIF
*
      RETURN
      END
