1 : C SESPA SOURCE CHAT 05/01/13 03:14:54 5004 2 : C SESPA SOURCE WP 23//08/94 3 : C SUBROUTINE SESPA ( IPLVAL, IPLVEC, NBMOD, IPRIGI, IPMASS ) 4 : ************************************************************************ 5 : * 6 : * SESPA 7 : * ----------- 8 : * 9 : * FONCTION: 10 : * --------- 11 : * 12 : * CONSTRUIT NBMOD ELEMENTS PROPRES EN ITERANT LE SOUS-ESPACE 13 : * IPLVEC, JUSQU'A LA CONVERGENCE DE CELUI-CI. 14 : * 15 : * MODE D'APPEL: 16 : * ------------- 17 : * 17 : * CALL SESPA ( IPLVAL, IPLVEC, NBMOD, IPRIGI, IPMASS ) 18 : * 19 : * PARAMETRES: (E)=ENTREE (S)=SORTIE 20 : * ----------- 21 : * 22 : * IPLVAL ENTIER (S) POINTEUR DE L'OBJET 'LISTREEL' CONTENANT 23 : * LA SUITE DE VALEURS PROPRES OBTENUES. 24 : * IPLVEC ENTIER (E) POINTEUR DE L'OBJET 'LISTCHPO' CONTENANT 25 : * LE SOUS-ESPACE INITIAL. 26 : * IPLVEC ENTIER (S) POINTEUR DE L'OBJET 'LISTCHPO' CONTENANT 27 : * LE SOUS-ESPACE FINAL. EN ORTHONORMALISANT 28 : * LES 'CHPOINT' DE CET ESPACE ON OBTIENT LES 29 : * VECTEURS PROPRES RECHERCHES. 30 : * NBMOD ENTIER (E) NOMBRE DE VECTEURS RECHERCHES. IPLVEC 31 : * CONTIENT PLUS QUE NBMOD 'CHPO', CAR CECI 32 : * PERMET DE CONVERGER PLUS RAPIDEMENT. 33 : * 34 : * IPRIGI ENTIER (E) POINTEUR SUR L'OBJET 'RIGIDITE' K 35 : * IPMASS ENTIER (E) POINTEUR SUR L'OBJET 'RIGIDITE' M 36 : * 37 : * 38 : * AUTEUR, DATE DE CREATION: 39 : * ------------------------- 40 : * 41 : * A.M. JOLIVALT, W. PASILLAS 13 / 07 / 94. ( ESOPE ) 42 : * 43 : *********************************************************************** 44 : 45 : SUBROUTINE SESPA ( IPLVAL, IPLVEC, NBMOD, IPRIGI, IPMASS ) 46 : 47 : IMPLICIT INTEGER(I-N) 48 : IMPLICIT REAL*8 (A-H,O-Z) 49 : 50 : -INC CCOPTIO 51 : -INC SMLCHPO 52 : -INC SMLREEL 53 : 54 : ****** 55 : * -- CONSTANTES -- 56 : *** 57 : PARAMETER ( ITERMX = 40 ) 58 : 59 : ****** 60 : * -- ARGUMENTS -- 61 : *** 62 : POINTEUR IPLVEC.MLCHPO, IPLVAL.MLREEL 63 : INTEGER NBMOD, IPRIGI, IPMASS 64 : 65 : ****** 66 : * -- VARIABLES LOCALES -- 67 : *** 68 : POINTEUR IPLCH1.MLCHPO, IPLCH2.MLCHPO 69 : POINTEUR IPLVA1.MLREEL, IPLVA2.MLREEL 70 : INTEGER ILDIM 71 : LOGICAL BOOL 72 : 73 : 74 : **************************************************************** 75 : * INITIALISATIONS * 76 : **************************************************************** 77 : 78 : SEGACT ,IPLVEC 79 : ILDIM = IPLVEC.ICHPOI( /1 ) 80 : SEGDES ,IPLVEC 81 : 82 : ****** 83 : * -- ON PREND 0.0 COMME PREMIERE APPROXIMATION DES 84 : * VALEURS PROPRES -- 85 : *** 86 : JG = 0 87 : SEGINI ,IPLVA1, IPLVA2 88 : DO 90 IB90 = 1, ILDIM 89 : IPLVA1.PROG(**) = 0.D0 90 : IPLVA2.PROG(**) = 0.D0 91 : 90 CONTINUE 92 : 93 : ****** 94 : * -- ON PREND LA LISTE IPLVEC COMME PREMIERE APPROX 95 : * DES MODES PROPRES -- 96 : *** 97 : N1 = 0 98 : SEGINI ,IPLCH1 99 : SEGACT ,IPLVEC 100 : DO 95 IB95 = 1, ILDIM 101 : IPCHPO = IPLVEC.ICHPOI(IB95) 101 : CALL COPIE2 ( IPCHPO, IPCH1 ) 102 : IF ( IERR .NE. 0 ) RETURN 103 : IPLCH1.ICHPOI(**) = IPCH1 104 : 95 CONTINUE 105 : SEGDES ,IPLVEC, IPLCH1 106 : IPLCH2 = IPLVEC 107 : IPLVEC = 0 108 : 109 : 110 : **************************************************************** 111 : * ITERATION DU SOUS-ESPACE IPLVEC * 112 : **************************************************************** 113 : 114 : ****** 115 : * -- REPETER JUSQU'A: 116 : * * CONVERGER. 117 : * * DEPASSER ITERMX ITERATIONS 118 : *** 119 : DO 100 IB100 = 1, ITERMX 120 : 121 : ****** 122 : * -- MISE A JOUR DE IPLVA1 -- 123 : *** 123 : CALL DTLREE ( IPLVA1 ) 124 : IF ( IERR .NE. 0 ) RETURN 125 : IPLVA1 = IPLVA2 126 : 127 : ****** 128 : * -- MISE A JOUR DE IPLCH1 -- 129 : *** 130 : * -- ON DETRUIT -- 131 : SEGACT ,IPLCH1 132 : DO 200 IB200 = 1, ILDIM 133 : IPCHPO = IPLCH1.ICHPOI(IB200) 133 : CALL DTCHPO (IPCHPO) 134 : IF ( IERR .NE. 0 ) RETURN 135 : 200 CONTINUE 136 : SEGDES ,IPLCH1 136 : CALL DTLCHP ( IPLCH1 ) 137 : IF ( IERR .NE. 0 ) RETURN 138 : 139 : * -- ET ON RECOPIE -- 140 : SEGACT ,IPLCH2 141 : N1 = 0 142 : SEGINI ,IPLCH1 143 : DO 300 IB300 = 1, ILDIM 144 : IPCHPO = IPLCH2.ICHPOI(IB300) 144 : CALL COPIE2 ( IPCHPO, IPCHP1 ) 145 : IF ( IERR .NE. 0 ) RETURN 146 : IPLCH1.ICHPOI(**) = IPCHP1 147 : 300 CONTINUE 148 : SEGDES ,IPLCH1, IPLCH2 149 : 150 : ****** 151 : * -- UNE ITERATION DU SOUS-ESPACE IPLVEC -- 152 : *** 152 : CALL SESPA0 ( IPLCH2, IPLVA2, IPRIGI, IPMASS ) 153 : IF ( IERR .NE. 0 ) RETURN 154 : 155 : ****** 156 : * -- ON TESTE LA CONVERGENCE 157 : *** 157 : CALL SESPA5 ( IPLVA1, IPLVA2, IPLCH1, IPLCH2, 158 : 1 IPMASS, BOOL, NBMOD ) 159 : IF ( IERR .NE. 0 ) RETURN 160 : IF ( BOOL ) THEN 161 : * -- SI ON A CONVERGE, C'EST FINI ! -- 162 : IF ( IIMPI .EQ. 2 ) THEN 163 : WRITE ( IOIMP, 1000 ) IB100 164 : 1000 FORMAT( /1X, 'On a effectue ',I2,' iterations.', /) 165 : ENDIF 166 : GOTO 110 167 : ENDIF 168 : 169 : IF ( IB100 .EQ. ITERMX ) THEN 170 : * -- SI NON, PAS DE CONVERGE, MAIS ON RENVOIE LA SOLUTION ! 171 : 172 : WRITE ( IOIMP, 2000 ) ITERMX 173 : 2000 FORMAT( /1X, 'Pas de convergence apres ',I2,' iterations.', 174 : 1 /1X, 'La solution est quand meme renvoyee.', 175 : 2 /1X, 'L''execution continue ...', / ) 176 : 177 : ENDIF 178 : 100 CONTINUE 179 : 110 CONTINUE 180 : 181 : ** estimation d'une borne superieure de l'erreur sur les valeurs propres 182 : ** (c.f. Argyris, Wilkinson) 183 : segact iplch2, iplva2, iplva1 184 : do 50 ibmod = 1,nbmod 185 : ix = iplch2.ichpoi(ibmod) 186 : xlamda = IPLVA2.PROG( IBMOD) 187 : xlamd0 = IPLVA1.PROG( IBMOD) 187 : call mucpri(ix,ipmass,ixm1) 187 : call mucpri(ix,iprigi,ixk1) 188 : xco1= 1.d0 189 : xco2 = -1d0*xlamda 189 : call adchpo(ixk1,ixm1,ires,xco1, xco2) 189 : call xtx1(ires,xres) 189 : call dtchpo(ixk1) 189 : call dtchpo(ixm1) 189 : call dtchpo(ires) 190 : dlamda = abs(xlamda - xlamd0) 191 : xerr1 = dlamda /abs(xlamda) 192 : xerr2 = (sqrt(abs(xres)))/abs(xlamda) 193 : 194 : IF ( (IIMPI .EQ. 2) .or. (.not. bool)) then 195 : reaerr(1) = xerr1 196 : reaerr(2) = xerr2 197 : interr(1) = ibmod 197 : call erreur(-327) 198 : write (ioimp,2010) 199 : 2010 format (1x) 200 : endif 201 : 202 : 50 continue 203 : segdes iplch2, iplva2,iplva1 204 : 205 : 206 : **************************************************************** 207 : * NETTOYAGE DE LA MEMOIRE * 208 : **************************************************************** 209 : 210 : ****** 211 : * -- ON DETRUIT IPLVA1 ET IPLCH1 212 : *** 212 : CALL DTLREE ( IPLVA1 ) 213 : IF ( IERR .NE. 0 ) RETURN 214 : 215 : SEGACT ,IPLCH1 216 : DO 400 IB400 = 1, ILDIM 217 : IPCHPO = IPLCH1.ICHPOI(IB400) 217 : CALL DTCHPO (IPCHPO) 218 : IF ( IERR .NE. 0 ) RETURN 219 : 400 CONTINUE 220 : SEGDES ,IPLCH1 220 : CALL DTLCHP ( IPLCH1 ) 221 : IF ( IERR .NE. 0 ) RETURN 222 : 223 : ****** 224 : * -- ON RENVOIE LES VALEURS ET VECTEURS PROPRES -- 225 : *** 226 : IPLVEC = IPLCH2 227 : IPLVAL = IPLVA2 228 : 229 : RETURN 230 : END 231 : 232 :
© Cast3M 2003 - All rights reserved.
Disclaimer