1 : C SESPC4 SOURCE CHAT 09/10/09 21:24:22 6519 2 : C SESPA4 SOURCE CHAT 05/01/13 03:14:42 5004 3 : C SESPA4 SOURCE WP 94/12/07 4 : C SUBROUTINE SESPA4 ( IPLVEC, IPMPHI ) 5 : ************************************************************************ 6 : * 7 : * SESPC4 inspiré de SESPA4 8 : * ----------- 9 : * 10 : * FONCTION: 11 : * --------- 12 : * 13 : * CALCUL D'UNE APPROXIMATION DES VECTEURS PROPRES, A PARTIR 14 : * DE LEUR PROJECTION IPMPHI SUR LE SOUS-ESPACE IPLVEC. 15 : * 16 : * MODE D'APPEL: 17 : * 17 : * CALL SESPA4 ( IPLVEC, IPMPHI ) 18 : * 19 : * PARAMETRES: (E)=ENTREE (S)=SORTIE 20 : * ----------- 21 : * 22 : * IPLVEC ENTIER (E) POINTEUR DE L'OBJET 'LISTCHPO' CONTENANT 23 : * (S) LA SUITE DE 'CHPOINT' X(i) 24 : * 25 : * IPMPHI ENTIER (E) POINTEUR SUR L'OBJET 'MATRIX' PHI 26 : * 27 : * 28 : * AUTEUR, DATE DE CREATION: 29 : * ------------------------- 30 : * 31 : * A.M. JOLIVALT, W. PASILLAS 29 / 07 / 94. ( ESOPE ) 32 : * 33 : ************************************************************ 34 : 35 : SUBROUTINE SESPC4 ( IPLVEC, IPMPHI, ILAMBI ) 36 : 37 : IMPLICIT INTEGER(I-N) 38 : IMPLICIT REAL*8 (A-H,O-Z) 39 : 40 : -INC CCOPTIO 41 : -INC SMLCHPO 42 : 43 : * SEGMENT ,MATRIX 44 : * REAL*8 A(N,N) 45 : * ENDSEGMENT 46 : -INC SMRIGID 47 : 48 : ****** 49 : * -- ARGUMENTS -- 50 : *** 51 : POINTEUR IPLVEC.MLCHPO 52 : * POINTEUR IPMPHI.MATRIX 53 : POINTEUR IPMPHI.XMATRI 54 : POINTEUR ILAMBI.XMATRI 55 : 56 : 57 : ****** 58 : * -- VARIABLES LOCALES -- 59 : *** 60 : POINTEUR IPLVE1.MLCHPO 61 : INTEGER ILDIM, IPCHP1, IPCHPO, IPCHP2 62 : REAL*8 ALPHA,XVALPI 63 : CHARACTER*4 MOTCLE 64 : LOGICAL MODC 65 : 66 : 67 : ****** 68 : * -- CHAQUE VECTEUR DE IPLVE1 EST UNE COMBINAISON 69 : * LINEAIRE DES VECTEURS DE IPLVEC, PONDEREE PAR 70 : * LES COEFFICIENTS DE IPMPHI -- 71 : *** 72 : MODC = .false. 72 : CALL MOTS1( IPLMOT, MOTCLE ) 73 : N1 = 0 74 : SEGINI ,IPLVE1 75 : 76 : SEGACT ,IPLVEC ,IPMPHI 77 : SEGACT ,ILAMBI 78 : 79 : ILDIM = IPLVEC.ICHPOI(/1) 80 : 81 : ***** on construit le IB100^ieme mode ******************************** 82 : DO 100 IB100 = 1, ILDIM 83 : 84 : ALPHA = IPMPHI.RE( 1, IB100,1 ) 85 : IPCHP1 = IPLVEC.ICHPOI( 1 ) 85 : CALL MUCHPO ( IPCHP1, ALPHA, IPCHPO, 1 ) 86 : IF ( IERR .NE. 0 ) RETURN 87 : IPLVE1.ICHPOI(**) = IPCHPO 88 : 89 : *------ on somme les contributions des vecteurs ib200=1,ildim 90 : DO 200 IB200 = 2, ILDIM 91 : ALPHA = IPMPHI.RE( IB200, IB100,1 ) 92 : IPCHP1 = IPLVE1.ICHPOI( IB100 ) 93 : IPCHP2 = IPLVEC.ICHPOI( IB200 ) 93 : CALL COMBI2 ( IPCHP1, 1.D0, IPCHP2, ALPHA, IPCHPO ) 94 : IF ( IERR .NE. 0 ) RETURN 95 : IPLVE1.ICHPOI( IB100 ) = IPCHPO 95 : CALL DTCHPO ( IPCHP1 ) 96 : IF ( IERR .NE. 0 ) RETURN 97 : 98 : 200 CONTINUE 99 : 100 : *------- Normalisation 101 : * on a deja construit les parties Reelles et Imaginaires du vecteur 102 : if(MODC) goto 90 103 : 104 : XVALPI = ILAMBI.RE(1, IB100,1) 105 : 106 : if(XVALPI .eq. 0.D0) then 107 : * il s agit d un mode Réel' 108 : MODC = .false. 108 : call NORMA1( IPCHPO, IPLMOT, MOTCLE, IPCHP1 ) 109 : IPLVE1.ICHPOI( IB100 ) = IPCHP1 109 : CALL DTCHPO ( IPCHPO ) 110 : 111 : * il s'agit d'un mode Complexe => on stocke le vecteur Reel, 112 : * on calule le vecteur imaginaire, puis on normalise ce vecteur Complexe 113 : * enfin on les ecrit, avant de passer au(x) suivant(s) 114 : else 115 : * il s agit d un mode Complexe' 116 : MODC = .true. 117 : ICHP1R = IPCHPO 118 : endif 119 : 120 : goto 100 121 : 122 : 90 CONTINUE 122 : call NORM1C(ICHP1R,IPCHPO,IPLMOT,MOTCLE,ICHP2R,ICHP2I) 123 : IPLVE1.ICHPOI( IB100 - 1 ) = ICHP2R 124 : IPLVE1.ICHPOI( IB100 ) = ICHP2I 125 : MODC = .false. 126 : 127 : 100 CONTINUE 128 : ***** fin de boucle sur les modes ************************************ 129 : 130 : 131 : ****** 132 : * -- ON DETRUIT IPLVEC -- 133 : *** 134 : DO 300 IB300 = 1, ILDIM 135 : IPCHPO = IPLVEC.ICHPOI( IB300 ) 135 : CALL DTCHPO( IPCHPO ) 136 : IF ( IERR .NE. 0 ) RETURN 137 : 300 CONTINUE 137 : CALL DTLCHP ( IPLVEC ) 138 : IF ( IERR .NE. 0 ) RETURN 139 : 140 : ****** 141 : * -- ON RETOURNE IPLVEC -- 142 : *** 143 : IPLVEC = IPLVE1 144 : SEGDES ,IPLVEC, IPMPHI 145 : SEGSUP ,IPMPHI 146 : 147 : RETURN 148 : END 149 : 150 : 151 : 152 :
© Cast3M 2003 - All rights reserved.
Disclaimer