1 : C EXTVEC SOURCE CHAT 05/01/12 23:54:36 5004 2 : C SUBROUTINE EXTVEC (MATRED, ILDIM, IPLVAL) 3 : ************************************************************************ 4 : * 5 : * EXTVEC 6 : * ----------- 7 : * 8 : * FONCTION: 9 : * --------- 10 : * 11 : * EXTRACTE LES VALEURS PROPRES ET VECTEURS PROPRES DU SYSTEME REDUIT. LE 12 : * SYSTEME EST TRIANGULAIRE SUPERIEUR. IL SUFFIT DE REMONTER LES EQUATIONS 13 : * POUR OBTENIR LES VECTEURS PROPRES, APRES AVOIR FAIT UN DECALAGE. DANS 14 : * CE CAS, LE VECTEUR PROPRE FAIT PARTIE DU NOYAU. LES VALEURS DIAGONALES 15 : * SONT LES VALEURS PROPRES. 16 : * 17 : * MODE D'APPEL: 18 : * ------------- 19 : * 19 : * CALL EXTVEC (MATRED, ILDIM, IPLVAL) 20 : * 21 : * PARAMETRES: (E)=ENTREE (S)=SORTIE 22 : * ----------- 23 : * 24 : * IPLVAL ENTIER (S) POINTEUR DE L'OBJET 'LISTREEL' CONTENANT 25 : * LA SUITE DE VALEURS PROPRES OBTENUES. 26 : * MATRED TABLEAU (E) CONTIENT LES COORDONNEES DU SYSTEME 27 : * REDUIT (XMAT) 28 : * (S) CONTIENT EN PLUS LES COORDONNEES DES 29 : * VECTEURS PROPRES DANS LA BASE REDUITE. 30 : * (MATVEC) 31 : * 32 : * AUTEUR, DATE DE CREATION: 33 : * ------------------------- 34 : * 35 : * C. LE BIDEAU 09 / 2001 ( FORTRAN + ESOPE ) 36 : * 37 : *********************************************************************** 38 : 39 : SUBROUTINE EXTVEC (MATRED, ILDIM, IPLVAL) 40 : 41 : IMPLICIT INTEGER(I-N) 42 : IMPLICIT REAL*8 (A-H,O-Z) 43 : 44 : -INC CCOPTIO 45 : -INC SMLCHPO 46 : -INC SMLREEL 47 : 48 : ****** 49 : * -- VARIABLES LOCALES -- 50 : *** 51 : SEGMENT MATRED 52 : REAL*8 MATVEC (N, N),MATVE1(N,N), XMAT(N, N) 53 : END SEGMENT 54 : POINTEUR IPLVAL.MLREEL,IPLVA1.MLREEL 55 : INTEGER ILDIM 56 : 57 : SEGACT MATRED*MOD 58 : JG = ILDIM 59 : SEGINI IPLVA1 60 : 61 : ****** 62 : * ON RECUPERE UNE VALEUR PROPRE 63 : *** 64 : DO 5 IB5 =1, ILDIM 65 : DO 8 IB8=1,ILDIM 66 : MATVEC(IB5,IB8)=0.D0 67 : 8 CONTINUE 68 : 5 CONTINUE 69 : DO 10 IB10=1, ILDIM 70 : XCM=XMAT(IB10, IB10) 71 : IPLVAL.PROG(IB10)=XCM 72 : * write(6,*)'valeur propre=',XCM 73 : 10 CONTINUE 74 : * initialisation de matve1 75 : do 1 icol=1,ildim 76 : do 1 ilig=1,ildim 77 : matve1(ilig,icol)=xmat(ilig,icol) 78 : 1 continue 79 : 80 : DO 100 IB100=1,ILDIM 81 : ****** 82 : * ON DECALE LA MATRICE DANS MATVE1 83 : *** 84 : IC100=ILDIM - IB100 + 1 85 : IPLVA1.PROG(IC100) = 1.D0 86 : DO 200 IB200 = 1, IC100-1 87 : MATVE1(IB200,IB200)=XMAT(IB200,IB200)-XMAT(IC100,IC100) 88 : 200 CONTINUE 89 : ****** 90 : * ON LEVE LES INDETERMINATIONS EN REMPLACANT TOUS 91 : * LES ZEROS DE LA DIAGONALE PAR DES 1 92 : *** 93 : DO 300 IB300=1, ILDIM 94 : RP = MATVE1(IB300,IB300)/XMAT(IC100,IC100) 95 : IF (ABS(RP).LT. 1.D-10)THEN 96 : * write(6,*) ' on leve une indetermination ib300',ib300 97 : MATVE1(IB300,IB300)=1.D0 98 : END IF 99 : 300 CONTINUE 100 : ****** 101 : * ON RESOUD LE SYSTEME TRIANGULAIRE 102 : *** 103 : DO 400 IB400=1, IC100-1 104 : IC400 = IC100-IB400 105 : ** INDICE LIGNE VECTEUR ET LIGNE MATRICE 106 : XR=0.D0 107 : ****** 108 : * SOMME DES TERMES QU'ON CONNAIT 109 : *** 110 : DO 500 IB500 = IC400+1, IC100 111 : XR = XR + MATVE1(IC400,IB500)*IPLVA1.PROG(IB500) 112 : 500 CONTINUE 113 : IPLVA1.PROG(IC400)=-1.D0*XR/MATVE1(IC400,IC400) 114 : 400 CONTINUE 115 : DO 600 IB600=1, IC100 116 : MATVEC(IB600, IC100)=IPLVA1.PROG(IB600) 117 : * WRITE(6,*)'VECTEUR PROPRE NUMERO ',IC100 118 : * WRITE(6,*)'COMPOSANTE ',MATVEC(IB600, IC100) 119 : 600 CONTINUE 120 : 100 CONTINUE 121 : 122 : SEGSUP IPLVA1 123 : 124 : END 125 : 126 : 127 :
© Cast3M 2003 - All rights reserved.
Disclaimer