* PACKAGE LEIGEN  !" $@NO3X(J $@8GM-CM2r@O(J
*
*"  [HIS] 92/12/14(takepiro) $@!V9TNs7W;;%=%U%H%&%'%"!W;HMQ(J
*"        92/12/18(takepiro)  Numerical Recipies $@;HMQ(J
*"        93/05/10(takepiro)  $@%(%i!<=hCVJQ99(J
*"        93/06/11(takepiro)  $@8GM-4X?t7W;;%9%$%C%AF3F~(J
*"        95/06/13(takepiro)  $@8GM-%Y%/%H%k7W;;?tF3F~(J
*
**********************************************************************
      SUBROUTINE LEIGEN
     M            ( AMAT   , 
     O              EIGVLR , EIGVLI ,
     O              EIGVCR , EIGVCI ,
     O              IERR   , 
     I              MATDIM , OEIVEC , NVEC  )
*
#ifdef SYS_IBMS
      INCLUDE   (ZCDIM)                      !" 
      INCLUDE   (ZLDIM)                      !" $@3J;RE@?t(J, $@GH?t(J
#else
#include        "zcdim.F"                    !" 
#include        "zldim.F"                    !" $@78?t9TNs$NBg$-$5(J
#endif
*
*   [MODIFY] 
      REAL      AMAT  ( MATDMX, MATDMX )     !" $@78?t9TNs(J
*
*   [OUTPUT] 
      REAL      EIGVLR( MATDMX )             !" $@8GM-CM<B?tIt(J
      REAL      EIGVLI( MATDMX )             !" $@8GM-CM5u?tIt(J
      REAL      EIGVCR( MATDMX, * )          !" $@8GM-%Y%/%H%k<B?tIt(J
      REAL      EIGVCI( MATDMX, * )          !" $@8GM-%Y%/%H%k5u?tIt(J
      INTEGER   IERR                         !" $@%5%V%k!<%A%s%(%i!<%3!<%I(J
*
*   [INPUT] 
      INTEGER   MATDIM                       !" $@7W;;$9$k<!85(J
      LOGICAL   OEIVEC                       !" $@8GM-4X?t7W;;%9%$%C%A(J
      INTEGER   NVEC                         !" $@8GM-4X?t7W;;?t(J
*
*   [INTERNAL WORK] 
      COMMON    /COMWRK/  Z
*
      REAL      SCALE ( MATDMX )             !" $@%9%1!<%j%s%0>pJs(J
      INTEGER   LOW, IGH                     !" 
      REAL      INT   ( MATDMX )             !" $@%X%C%;%s%Y%k%0JQ49>pJs(J
      REAL      Z     ( MATDMX, MATDMX )     !" $@8GM-%Y%/%H%k(J
*
      CHARACTER HERR*8                       !" $@%(%i!<HV9f=PNOMQJ8;zJQ?t(J
      INTEGER   NERR                         !" $@J8;zNs$ND9$5(J
      INTEGER   LENC                         !" $@J8;z$ND9$5$rJV$94X?t(J
*
      SAVE      
*
*"  < 1. $@%P%i%s%7%s%0(J >
*
      CALL BALANC
     I      (  MATDMX , MATDIM , 
     M         AMAT   ,
     O         LOW    , IGH    ,SCALE  )
*
*"  < 2. $@%X%C%;%s%Y%k%09TNsJQ49(J >
*
      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. $@8GM-CM$N7W;;(J >
*
      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. $@8GM-%Y%/%H%k$N7W;;(J >
*
      IF ( OEIVEC ) THEN
         CALL BALBAK
     I      (  MATDMX , MATDIM , 
     I         LOW    , IGH    , 
     I         SCALE  , MATDIM , 
     M         Z                  )
      ENDIF
*
*"  < 5. $@8GM-%Y%/%H%k$NJB$SBX$((J > 
*
      CALL EIGSRT
     M      (  EIGVLR , EIGVLI , 
     O         EIGVCR , EIGVCI ,
     I         Z      , 
     I         MATDIM , OEIVEC , NVEC  )
*
*"  < 5. $@=*N;(J > 
*
      RETURN
      END
************************************************************************
      SUBROUTINE EIGSRT      !" $@8GM-CM8GM-%Y%/%H%kJB$YJQ$((J
     M      (  EIGVLR , EIGVLI , 
     O         EIGVCR , EIGVCI , 
     I         Z      , 
     I         MATDIM , OEIVEC , NVEC  )
*
#ifdef SYS_IBMS
      INCLUDE   (ZCDIM)                      !" 
      INCLUDE   (ZLDIM)                      !" $@3J;RE@?t(J, $@GH?t(J
#else
#include        "zcdim.F"                    !" 
#include        "zldim.F"                    !" $@78?t9TNs$NBg$-$5(J
#endif
*
*   [OUTPUT] 
      REAL      EIGVLR( MATDMX )             !" $@8GM-CM<B?tIt(J
      REAL      EIGVLI( MATDMX )             !" $@8GM-CM5u?tIt(J
      REAL      EIGVCR( MATDMX, * )          !" $@8GM-%Y%/%H%k<B?tIt(J
      REAL      EIGVCI( MATDMX, * )          !" $@8GM-%Y%/%H%k5u?tIt(J
*
*   [INPUT]
      REAL      Z     ( MATDMX, MATDMX )     !" $@8GM-%Y%/%H%k(J
*
      INTEGER   MATDIM                       !" $@7W;;$9$k<!85(J
      LOGICAL   OEIVEC                       !" $@8GM-4X?t7W;;%9%$%C%A(J
      INTEGER   NVEC                         !" $@8GM-4X?t7W;;?t(J
*
*   [INTERNAL WORK]
      INTEGER   J, K
      INTEGER   INDX  ( MATDMX )             !" $@=gHV3JG<G[Ns(J
      REAL      WORK  ( MATDMX )             !" $@8GM-CMF~$l49$(MQG[Ns(J
*
*
*"  < 1. $@8GM-CM$N%=!<%H(J >
*
      CALL INDEXX                                   !" $@8GM-CM<B?tIt$N>.$5$$=g(J
     I       ( MATDIM , EIGVLR ,
     O         INDX              )
*
      CALL COPY( WORK, EIGVLR, MATDIM )             !" $@8GM-CM<B?tIt(J
      DO 1100 J = 1, MATDIM                         !" $@8GM-CM<B?tIt$NBg$-$$=g(J
         EIGVLR( J ) = WORK( INDX( MATDIM-J+1 )  )
 1100 CONTINUE
*
      CALL COPY( WORK, EIGVLI, MATDIM )             !" $@8GM-CM5u?tIt(J
      DO 1200 J = 1, MATDIM                         !" $@8GM-CM<B?tIt$NBg$-$$=g(J
         EIGVLI( J ) = WORK( INDX( MATDIM-J+1 ) )
 1200 CONTINUE
*
*"  < 2. $@8GM-%Y%/%H%k$NF~$l49$((J, $@%=!<%H(J >
*
      IF ( OEIVEC )THEN                 
         DO 2000 K = 1, NVEC                        !" $@8GM-CM<B?tIt$NBg$-$$=g(J
            IF ( EIGVLI(K) .EQ. 0.0 ) THEN
               DO 2100 J = 1, MATDIM
                  EIGVCR( J,K ) = Z( J,INDX(MATDIM-K+1)  )
                  EIGVCI( J,K ) = 0.
 2100          CONTINUE
*
            ELSE IF ( EIGVLI(K) .GE. 0.0 ) THEN
               DO 2200 J = 1, MATDIM
                  EIGVCR( J,K ) =  Z( J,INDX(MATDIM-K+1) ) 
                  EIGVCI( J,K ) =  Z( J,INDX(MATDIM-K+1)+1 )
 2200          CONTINUE
*
            ELSE
               DO 2300 J = 1, MATDIM
                  EIGVCR(J,K) =    Z( J,INDX(MATDIM-K+1)-1 )
                  EIGVCI(J,K) =  - Z( J,INDX(MATDIM-K+1) )
 2300          CONTINUE
            ENDIF
 2000    CONTINUE 
      ENDIF
*
      RETURN
      END
