1 : C SESPA3 SOURCE CHAT 09/11/25 21:15:20 6548 2 : ************************************************************************ 3 : * 4 : * SESPA3 5 : * ----------- 6 : * 7 : * FONCTION: 8 : * --------- 9 : * 10 : * CALCUL DE LA LISTE DES VALEURS PROPRES IPLVAL ET DE LA MATRICE 11 : * DES VECTEURS PROPRES PHI DANS LE CAS D'UN PETIT PROBLEME: 12 : * 13 : * K1*V=LAMBDA*M1*V 14 : * * 15 : * 16 : * 17 : * MODE D'APPEL: 18 : * 18 : * CALL SESPA3 ( IPK1 , IPM1 , IPHI , IPLVAL ) 19 : * 20 : * PARAMETRES: (E)=ENTREE (S)=SORTIE 21 : * ----------- 22 : * 23 : * IPK1 ENTIER (E) POINTEUR DE L'OBJET 'MATRIX' REPRESENTANT 24 : * LA MATRICE K1 A DIAGONALISER 25 : * (S) MATRICE DIAGONALISEE 26 : * 27 : * IPM1 ENTIER (E) POINTEUR DE L'OBJET 'MATRIX' REPRESENTANT 28 : * LA MATRICE M1 A DIAGONALISER 29 : * (S) MATRICE DIAGONALISEE 30 : * 31 : * IPLVAL ENTIER (S) POINTEUR LISTE DE REELS DES VALEURS 32 : * PROPRES 33 : * 34 : * IPHI ENTIER (S) POINTEUR DE L'OBJET 'MATRIX' DONT LES COLONNES 35 : * SONT LES VECTEURS PROPRES DU PROBLEME 36 : * 37 : * 38 : * AUTEURS, DATE DE CREATION: 39 : * ------------------------- 40 : * 41 : * A.M. JOLIVALT, W. PASILLAS 16 / 07 / 94. ( ESOPE ) * 42 : ************************************************************ 43 : ****************************************************** 44 : * 45 : * Effectue les transformations de jacobi successives 46 : * th: seuil 47 : * cf: coupling factor 48 : * t1: 1 si test verifié 0 sinon 49 : * t2: 1 si test verifié 0 sinon 50 : * 51 : ******************************************************* 52 : C 53 : SUBROUTINE SESPA3(IPK1,IPM1,IPHI,IPLVAL) 54 : IMPLICIT INTEGER(I-N) 55 : IMPLICIT REAL*8 (A-H,O-Z) 56 : C 57 : C 58 : INTEGER I,J,K,P,Q,T1,T2,T3,IND 59 : REAL*8 ALPHA,GAMMA,TH,CF1,CF2 60 : C 61 : -INC SMLREEL 62 : SEGMENT MATRIX 63 : REAL*8 A(N,N) 64 : ENDSEGMENT 65 : C 66 : C 67 : POINTEUR IPK1.MATRIX, IPM1.MATRIX, IPHI.MATRIX, IPM3.MATRIX 68 : POINTEUR IPK2.MATRIX, IPM2.MATRIX, IPLVAL.MLREEL 69 : C 70 : SEGACT ,IPK1*mod,ipm1*mod 71 : N = IPK1.A(/1) 72 : JG = N 73 : * 74 : SEGINI ,IPHI ,IPK2 ,IPM2 ,IPLVAL 75 : C 75 : * CALL SJACO1(IPHI,N) 76 : do i=1,n 77 : iphi.a(i,i)=1.d0 78 : enddo 79 : C 80 : C 81 : segini,ipm3=ipm1 82 : 83 : * DO 100 K=1,10000 84 : DO 100 K=1, 15 85 : IND=2*K 86 : TH=(1.D1)**(-IND) 87 : * 88 : 88 : call shiftd(ipk1.A,ipk2.A,N*N) 88 : call shiftd(ipm1.A,ipm2.A,N*N) 89 : 89 : call sjjcoi(ipk1.a,ipm1.a,iphi.A,n,th) 90 : 90 : CALL SJACO6(IPK1,IPK2,IPM1,IPM2,T1,N,K) 91 : C 92 : *------------------------------------------------- 93 : *- 1er test: cv des valaeurs propres ------------- 94 : *------------------------------------------------- 95 : IF (T1.EQ.1) THEN 95 : CALL SJACO7(IPK1,T2,N,K) 95 : CALL SJACO7(IPM1,T3,N,K) 96 : C 97 : *------------------------------------------------- 98 : *--- 2 test: rapport des termes diagonaux -------- 99 : *------- et extra diagonaux ---------------- 100 : *------------------------------------------------- 101 : IF ((T2.EQ.1).AND.(T3.EQ.1)) THEN 102 : GOTO 110 103 : ENDIF 104 : C 105 : ENDIF 106 : 100 CONTINUE 107 : 110 CONTINUE 108 : C 108 : CALL SJACO8 (IPHI,IPM3) 109 : * 110 : * -- On met les val propres dans lval -- 111 : * 112 : SEGACT ,IPLVAL*MOD, IPK1, IPM1 113 : DO 300 IB300 = 1, N 114 : XK1 = IPK1.A(IB300,IB300) 115 : XM1 = IPM1.A(IB300,IB300) 116 : XALPHA = XK1 / XM1 117 : IPLVAL.PROG( IB300 ) = XALPHA 118 : 300 CONTINUE 119 : * SEGDES ,IPLVAL 120 : C 121 : SEGSUP ,IPK1, IPM1, IPK2 , IPM2, IPM3 122 : C 123 : RETURN 124 : END 125 : 126 : 127 : 128 : 129 :
© Cast3M 2003 - All rights reserved.
Disclaimer