1 : C PROCH2 SOURCE BP208322 09/03/20 21:15:15 6331 2 : SUBROUTINE PROCH2 (FREQ,IPRIGI,IPMASS,INF0,IPMODE,IALEAT, 3 : & LIMAGE, INSYM, MTAB3,I) 4 : ************************************************************************ 5 : * 6 : * P R O C H 2 7 : * ----------- 8 : * 9 : * FONCTION: 10 : * --------- 11 : * 12 : * RECHERCHE D'UN MODE PROPRE. 13 : * 14 : * MODE D'APPEL: 15 : * ------------- 16 : * 16 : * CALL PROCH2 (FREQ,IPRIGI,IPMASS,INF0,IPMODE,IALEAT,LIMAGE,INSYM) 17 : * 18 : * PARAMETRES: (E)=ENTREE (S)=SORTIE 19 : * ----------- 20 : * 21 : * FREQ REEL DP (E) FREQUENCE A APPROCHER PAR UNE FREQUENCE 22 : * PROPRE. 23 : * IPRIGI ENTIER (E) POINTEUR DE L'OBJET 'RIGIDITE' CONTENANT 24 : * LA MATRICE DE RIGIDITE. 25 : * IPMASS ENTIER (E) POINTEUR DE L'OBJET 'RIGIDITE' CONTENANT 26 : * LA MATRICE MASSE. 27 : * INF0 ENTIER (E) NOMBRE DE TERMES DIAGONAUX NEGATIFS DE LA 28 : * 'RIGIDITE' "K" DECOMPOSEE EN L.D.LT . 29 : * CE NOMBRE N'EST PAS NUL A CAUSE DE LA FACON 30 : * DONT SONT INTRODUITS LES BLOCAGES DES 31 : * D.D.L. (MULTIPLICATEURS DE LAGRANGE "LX"). 32 : * IPMODE ENTIER (S) POINTEUR DE L'OBJET 'SOLUTION' CONTENANT 33 : * LE MODE PROPRE TROUVE. 34 : * INSYM ENTIER (E) INDICATEUR DE LA NON SYMETRIE DE LA RIGIDITE 35 : * NON SYMETRIQUE: MODES COMPLEXES 36 : * MTAB3 TABLE (S) TABLE D'UN COUPLE SOLUTION 37 : * 38 : * LEXIQUE: (ORDRE ALPHABETIQUE) 39 : * -------- 40 : * 41 : * CONVRG LOGIQUE VOIR LE SOUS-PROGRAMME "ITINV". 42 : * FREDEC REEL DP FREQUENCE DE DECALAGE EFFECTIVE (EN GENERAL, 43 : * EGALE A "FREQ") 44 : * FREQPP REEL DP FREQUENCE PROPRE CALCULEE PROCHE DE "FREQ". 45 : * IPKW2M ENTIER POINTEUR DE LA 'RIGIDITE' "DECALEE" K - W2.M 46 : * IPRX ENTIER POINTEUR DU 'CHPOINT' QUI CONTIENT DES NOMBRES 47 : * ALEATOIRES, PUIS UN VECTEUR PROPRE REEL. 48 : * IPIX ENTIER POINTEUR DU 'CHPOINT' CONTENANT UN VECTEUR 49 : * PROPRE IMAGINAIRE EN FIN D'ITERATIONS 50 : * ITERMX ENTIER VOIR LE SOUS-PROGRAMME "ITINV". 51 : * NUMACC ENTIER VOIR LE SOUS-PROGRAMME "ITINV". 52 : * OMEGA2 REEL DP PULSATION PROPRE TROUVEE AU CARRE. 53 : * PRECI1 REEL SP VOIR LE SOUS-PROGRAMME "ITINV". 54 : * PRECI2 REEL SP VOIR LE SOUS-PROGRAMME "ITINV". 55 : * PROPRE REEL DP VOIR LE SOUS-PROGRAMME "ITINV". 56 : * W2 REEL DP PULSATION AU CARRE A APPROCHER. 57 : * 58 : * MODE DE FONCTIONNEMENT: 59 : * ----------------------- 60 : * 61 : * LE CALCUL D'UN VECTEUR PROPRE SE FAIT PAR LA METHODE DES 62 : * ITERATIONS INVERSES (DITE AUSSI DE LA PUISSANCE INVERSE), AVEC 63 : * DECALAGE INITIAL ("SHIFTING"). 64 : * 65 : * SOUS-PROGRAMMES APPELES: 66 : * ------------------------ 67 : * 68 : * ALEAT1, CREMOD, DECALE, DTRIGI, ECCHPO, ECSOLU, ERREUR, ITINV, 69 : * ITINVC, W2FREQ. 70 : * 71 : * AUTEUR, DATE DE CREATION: 72 : * ------------------------- 73 : * 74 : * PASCAL MANIGOT 16 OCTOBRE 1984 75 : * 76 : * MODIFICATION 77 : *------------- 78 : * C. LE BIDEAU JUILLET 2001 79 : * Benoit PRABEL MARS 2009 80 : * 81 : * LANGAGE: 82 : * -------- 83 : * 84 : * FORTRAN77 + ESOPE 85 : * 86 : ************************************************************************ 87 : * 88 : IMPLICIT INTEGER(I-N) 89 : IMPLICIT REAL*8 (A-H,O-Z) 90 : -INC CCREEL 91 : -INC CCOPTIO 92 : -INC SMTABLE 93 : * 94 : PARAMETER (LPROPR = 10) 95 : * 96 : LOGICAL CONVRG,LIMAGE 97 : * 98 : REAL*8 PROPRE(LPROPR),PROPR2(LPROPR) 99 : * 100 : PARAMETER (ITERMX = 30) 101 : PARAMETER (PRECI1 = 1.D-5) 102 : PARAMETER (PRECI2 = 1.D-5) 103 : PARAMETER (DEUXPI = (2.D0*XPI)) 104 : PARAMETER (NUMACC = 5) 105 : * 106 : * -- CREATION DE (K-W2M) -- 107 : * 108 : W2 = (FREQ * DEUXPI) ** 2 109 : IF(LIMAGE) THEN 110 : W2 = SIGN(W2,FREQ) 111 : ENDIF 111 : CALL DECALE (IPRIGI,IPMASS, W2, IPKW2M) 112 : IF (IERR .NE. 0) RETURN 113 : * 114 : * -- INITIALISATION DES ITERATIONS: CREATION D'UN 'CHPOINT' 115 : * ALEATOIRE -- 116 : * 117 : IPRX = 0 118 : * bp (03.2009) : si on souhaite eventuellement fournir 1 CHPOINT 118 : call LIROBJ('CHPOINT',ICHP1,0,IRET1) 119 : if(IRET1.eq.0) then 119 : IF(IALEAT.EQ.0) CALL ALEAT1 (IPKW2M,IALEAT) 120 : IF (IERR.NE.0) RETURN 120 : CALL COPIE2(IALEAT,IPRX) 121 : else 121 : CALL COPIE2(ICHP1,IPRX) 122 : endif 123 : C 124 : C CALCUL DE M*X 125 : C 125 : CALL MUCPRI(IPRX,IPMASS,IPMX) 126 : 127 : IF (IERR .NE. 0) RETURN 128 : IF (IIMPI .EQ. 747) THEN 128 : CALL ECCHPO (IPRX,0) 129 : END IF 130 : * 131 : * -- RESOLUTION PAR ITERATIONS INVERSES -- 132 : * 133 : IF (INSYM .EQ. 0) THEN 133 : CALL ITINV (IPKW2M,IPMASS,IPRX,PROPRE,CONVRG,ITERMX,NUMACC 134 : & ,PRECI1,PRECI2,IPMX) 135 : PROPRE(6) = 0.D0 136 : IF (IERR .NE. 0) RETURN 137 : IF (.NOT.CONVRG) THEN 138 : INTERR(1) = ITERMX 139 : NUMERR = 151 139 : CALL ERREUR (NUMERR) 140 : END IF 141 : ELSE 141 : CALL ITINVC (IPKW2M,IPMASS,IPRX,IPIX,PROPRE,CONVRG,ITERMX,IPMX) 142 : 143 : IF (IERR .NE. 0) RETURN 144 : IF (.NOT.CONVRG) THEN 145 : INTERR(1) = ITERMX 146 : NUMERR = 151 146 : CALL ERREUR (NUMERR) 147 : END IF 148 : END IF 149 : * 150 : * -- NUMERO DU MODE -- 151 : *(relativement a W2=lambda^shift, puisque propre(1) est la valeur shiftée) -- 152 : * 153 : if(PROPRE(1) .lt. 0.) then 154 : NUMOD2 = 0 155 : else 156 : NUMOD2 = 1 157 : endif 158 : * 159 : * -- FREQUENCE PROPRE -- 160 : * 161 : IF (INSYM .EQ. 0 ) THEN 161 : CALL W2FREQ (PROPRE(1),W2, OMEGA2,FREQPP,LIMAGE) 162 : IF (IERR .NE. 0) RETURN 163 : PROPRE(1) = FREQPP 164 : 165 : ELSE 165 : CALL W2FRQC (PROPRE(1), PROPRE(6), W2, XRW2, XIW2, XRFREQ, 166 : & XIFREQ) 167 : IF (IERR .NE. 0) RETURN 168 : * on se débarasse des erreurs d'arrondis de W2FRQC 169 : if (PROPRE(6) .eq. 0.) then 170 : if ( (PROPRE(1) + W2) .lt. 0.) then 171 : PROPRE(1)= 0. 172 : PROPRE(6)= XIFREQ 173 : else 174 : PROPRE(1)= XRFREQ 175 : PROPRE(6)= 0. 176 : endif 177 : else 178 : PROPRE(1)= XRFREQ 179 : PROPRE(6)= XIFREQ 180 : endif 181 : END IF 182 : * 183 : IF (IIMPI .EQ. 747) THEN 184 : IF (INSYM .EQ. 0) THEN 185 : WRITE (IOIMP,*) 'FREQUENCE PROPRE CALCULEE = ',FREQPP 186 : WRITE (IOIMP,*) '-------------------------' 187 : WRITE (IOIMP,*) 'CHPOINT PROPRE:' 187 : CALL ECCHPO (IPRX,0) 188 : ELSE 189 : WRITE (IOIMP,*) 'FREQUENCE PROPRE REELLE CALCULEE = ',XRFREQ 190 : IF (PROPRE(6) .NE. 0) THEN 191 : WRITE (IOIMP,*) 'FREQUENCE PROPRE IMAGINAIRE CALCULEE = ',XIFREQ 192 : END IF 193 : WRITE (IOIMP,*) '-------------------------' 194 : WRITE (IOIMP,*) 'CHPOINT PROPRE REEL:' 194 : CALL ECCHPO (IPRX,0) 195 : IF (PROPRE(6) .NE. 0) THEN 196 : WRITE (IOIMP,*) 'CHPOINT PROPRE IMAGINAIRE:' 196 : CALL ECCHPO (IPIX,0) 197 : END IF 198 : END IF 199 : END IF 200 : * 201 : * -- CREATION DE L'OBJET REPRESENTANT LE MODE -- 202 : * 203 : * NUMOD2 = 0 204 : IF (INSYM .EQ. 0) THEN 204 : * CALL CREMOD (PROPRE,IPRX,IPKW2M,INF0,FREQ,NUMOD2,IPMODE) 204 : CALL CREMOD (PROPRE,IPRX,IPKW2M,INF0,NUMOD2,IPMODE) 205 : IF (IERR .NE. 0) RETURN 206 : ELSE 206 : * CALL CREBAS (PROPR2,IPIX,0,IPKW2M,INF0,FREQ,NUMOD2,MTAB3,I) 206 : CALL CREBAS (PROPRE,IPRX,IPIX,IPKW2M,INF0,NUMOD2,MTAB3,I) 207 : I = I + 1 208 : * dans le Cas d'un mode Reel Double, 209 : * on a stocké dans IPIX le 2eme vecteur du sous espace 210 : if( ((PROPRE(6) .EQ. 0.) .or. (PROPRE(1) .EQ. 0.)) 211 : & .and. (IPIX .ne. 0) ) then 212 : do ipro2=1,LPROPR 213 : PROPR2(ipro2) = PROPRE(ipro2) 214 : enddo 215 : PROPR2(2)=PROPRE(7) 215 : * CALL CREBAS (PROPR2,IPIX,0,IPKW2M,INF0,FREQ,NUMOD2,MTAB3,I) 215 : CALL CREBAS (PROPR2,IPIX,0,IPKW2M,INF0,NUMOD2,MTAB3,I) 216 : I = I + 1 217 : endif 218 : END IF 219 : * 220 : * IMPRESSION DU MODE: 221 : IF (IIMPI.EQ.2) THEN 222 : IF (INSYM .EQ. 0) THEN 223 : WRITE (IOIMP,2000) 224 : 2000 FORMAT ('1MODE PROPRE CALCULE:'/' --------------------'//) 224 : CALL ECMODE (IPMODE) 225 : ELSE 225 : CALL ECTABL (MTAB3) 226 : END IF 227 : ENDIF 228 : * 229 : * -- SUPPRESSION DES OBJETS DE TRAVAIL -- 230 : * 230 : CALL DTRIGI (IPKW2M) 231 : * 232 : END 233 : 234 : 235 : 236 : 237 : 238 : 239 : 240 : 241 :
© Cast3M 2003 - All rights reserved.
Disclaimer