C EXTVEC    SOURCE    CHAT      05/01/12    23:54:36     5004           
C     SUBROUTINE EXTVEC (MATRED, ILDIM, IPLVAL)
************************************************************************        
*                                                                               
*                                EXTVEC                                       
*                             -----------                                       
*                                                                               
* FONCTION:                                                                     
* ---------                                                                     
*                                                                               
*     EXTRACTE LES VALEURS PROPRES ET VECTEURS PROPRES DU SYSTEME REDUIT. LE
*     SYSTEME EST TRIANGULAIRE SUPERIEUR. IL SUFFIT DE REMONTER LES EQUATIONS
*     POUR OBTENIR LES VECTEURS PROPRES, APRES AVOIR FAIT UN DECALAGE. DANS
*     CE CAS, LE VECTEUR PROPRE FAIT PARTIE DU NOYAU. LES VALEURS DIAGONALES
*     SONT LES VALEURS PROPRES. 
*
* MODE D'APPEL:                                 
* -------------
*                                                                               
*     CALL EXTVEC (MATRED, ILDIM, IPLVAL)
*                                                                               
* PARAMETRES:   (E)=ENTREE   (S)=SORTIE                                         
* -----------                                                                   
*                                                                               
*     IPLVAL  ENTIER    (S)  POINTEUR DE L'OBJET 'LISTREEL' CONTENANT
*                            LA SUITE DE VALEURS PROPRES OBTENUES.
*     MATRED  TABLEAU   (E)  CONTIENT LES COORDONNEES DU SYSTEME 
*                            REDUIT (XMAT)
*                       (S)  CONTIENT EN PLUS LES COORDONNEES DES
*                            VECTEURS PROPRES DANS LA BASE REDUITE.
*                            (MATVEC)
*
* AUTEUR, DATE DE CREATION:                                                     
* -------------------------                                                     
*                                                                               
*   C. LE BIDEAU  09 / 2001  ( FORTRAN + ESOPE )                                       
*
***********************************************************************

      SUBROUTINE EXTVEC (MATRED, ILDIM, IPLVAL)
                      
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)

-INC  CCOPTIO
-INC  SMLCHPO
-INC  SMLREEL

******
*     -- VARIABLES LOCALES --
***
      SEGMENT MATRED
         REAL*8 MATVEC (N, N),MATVE1(N,N), XMAT(N, N)
      END SEGMENT
      POINTEUR IPLVAL.MLREEL,IPLVA1.MLREEL
      INTEGER ILDIM
      
      SEGACT MATRED*MOD
      JG = ILDIM
      SEGINI IPLVA1
      
******
*     ON RECUPERE UNE VALEUR PROPRE 
***
      DO 5 IB5 =1, ILDIM
         DO 8 IB8=1,ILDIM
            MATVEC(IB5,IB8)=0.D0
 8       CONTINUE
 5    CONTINUE
      DO 10 IB10=1, ILDIM
            XCM=XMAT(IB10, IB10)
            IPLVAL.PROG(IB10)=XCM
*            write(6,*)'valeur propre=',XCM
 10      CONTINUE
* initialisation de matve1
         do 1 icol=1,ildim
         do 1 ilig=1,ildim
          matve1(ilig,icol)=xmat(ilig,icol)
    1   continue

       DO 100 IB100=1,ILDIM         
******
*     ON DECALE LA MATRICE DANS MATVE1
***
         IC100=ILDIM - IB100 + 1
         IPLVA1.PROG(IC100) = 1.D0
         DO 200 IB200 = 1, IC100-1
            MATVE1(IB200,IB200)=XMAT(IB200,IB200)-XMAT(IC100,IC100)
 200     CONTINUE
******
*     ON LEVE LES INDETERMINATIONS EN REMPLACANT TOUS
*     LES ZEROS DE LA DIAGONALE PAR DES 1
***
      DO 300 IB300=1, ILDIM
            RP = MATVE1(IB300,IB300)/XMAT(IC100,IC100)
            IF (ABS(RP).LT. 1.D-10)THEN
*            write(6,*) ' on leve une indetermination ib300',ib300
               MATVE1(IB300,IB300)=1.D0
            END IF
 300  CONTINUE
******
*     ON RESOUD LE SYSTEME TRIANGULAIRE
***
      DO 400 IB400=1, IC100-1
         IC400 = IC100-IB400
** INDICE LIGNE VECTEUR ET LIGNE MATRICE
         XR=0.D0
******
*     SOMME DES TERMES QU'ON CONNAIT
***
         DO 500 IB500 = IC400+1, IC100
            XR = XR + MATVE1(IC400,IB500)*IPLVA1.PROG(IB500)
 500     CONTINUE
         IPLVA1.PROG(IC400)=-1.D0*XR/MATVE1(IC400,IC400)
 400  CONTINUE
      DO 600 IB600=1, IC100
         MATVEC(IB600, IC100)=IPLVA1.PROG(IB600)
*         WRITE(6,*)'VECTEUR PROPRE NUMERO ',IC100
*         WRITE(6,*)'COMPOSANTE    ',MATVEC(IB600, IC100)
 600  CONTINUE      
 100  CONTINUE
      
      SEGSUP IPLVA1
      
      END