1 : C QZBASC SOURCE BP208322 12/10/03 21:15:18 7517 2 : SUBROUTINE QZBASC (ALFR, ALFI, BETA, MATZ, MELEME, MCOMP, 3 : & IPBC,ERR) 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8 (A-H,O-Z) 6 : * 7 : ***************************************************************************** 8 : * CREATION D'UNE BASE DE MODES PROPRES COMPLEXES POUR VIBC 9 : * _________________________________________________________________________ 10 : * * 11 : * DATE : 13 avril 1995 12 : * AUTEUR : Nicolas BENECH 13 : * _________________________________________________________________________ 14 : * * 15 : * MODULE(S) APPELANT(S) : VIBRAC 16 : * * 17 : * MODULE(S) APPELE(S) : CRTABL, ACCTAB, ECCTAB, CREPO1, MUCHPO, EPSLON 18 : * _________________________________________________________________________ 19 : * * 20 : * EN ENTREE : 21 : * -ALFR : partie reelle des valeurs propres 22 : * -ALFI : partie imaginaire des valeurs propres 23 : * -BETA : denominateur (reel) des valeurs propres 24 : * (denominateur nul --> valeur propre infinie) 25 : * -MATZ : vecteurs propres complexes 26 : * -MELEME : maillage support des chpoints 27 : * -MCOMP : liste des composantes des chpoints 28 : * _________________________________________________________________________ 29 : * * 30 : * EN SORTIE : 31 : * -IPBC : base de modes complexes 32 : * _________________________________________________________________________ 33 : * * 34 : * REMARQUE : la variable SEUIL definie au début des données générales 35 : * permet d'identifier les valeurs propres infinies, et 36 : * d'annuler le mode correspondant. 37 : * Sa valeur a ete fixee a 100 x EPSLON(1.0D0) pour le moment 38 : ***************************************************************************** 39 : * 40 : -INC CCREEL 41 : *- 42 : -INC CCOPTIO 43 : -INC SMELEME 44 : -INC SMLCHPO 45 : -INC SMLMOTS 46 : -INC SMCHPOI 47 : -INC SMRIGID 48 : -INC SMTABLE 49 : * 50 : REAL*8 XVAL,SEUIL 51 : INTEGER I, J, K, IC, NUMAFF,ERR 52 : LOGICAL MODANN, MODREL, AFFICH,CONV 53 : * 54 : POINTEUR ALFR.XMATRI, ALFI.XMATRI, BETA.XMATRI 55 : POINTEUR MATZ.XMATRI 56 : POINTEUR MCOMP.MLMOTS 57 : * 58 : *----- Ecriture des messages pour verification 59 : * 60 : NUMAFF = 22 61 : AFFICH = ((MOD(IIMPI,NUMAFF) .EQ. 0) .AND. (IIMPI .NE. 0)) 62 : * AFFICH = .TRUE. 63 : * 64 : ******************************************* 65 : * Donnees generales * 66 : ******************************************* 67 : c SEGACT, MATZ, ALFR,ALFI,BETA 68 : * 69 : IF (AFFICH) WRITE (*,*) 'Extraction des donnees generales...' 70 : * 71 : * seuil pour le denominateur d'une valeur propre 72 : * SEUIL = (EPSLON(1.0D0)*100) 73 : SEUIL = 1.D-99 74 : * nombre de modes ... 75 : NBMOD1=ALFR.RE(/2) 76 : * nombre de points ... 77 : SEGACT , MELEME 78 : NBP1=MELEME.NUM(/2) 79 : SEGDES , MELEME 80 : N=NBP1 81 : * nombre de composantes ... 82 : SEGACT, MCOMP 83 : NC = MCOMP.MOTS(/2) 84 : c SEGDES, MCOMP 85 : IF (AFFICH) THEN 86 : WRITE (*,*) 'XPI = ',XPI 87 : WRITE (*,*) 'NC = ',NC 88 : WRITE (*,*) 'NBP1 = N = ', N 89 : WRITE (*,*) 'EPSLON = ',EPSLON(1.0D0) 90 : ENDIF 91 : * 92 : ******************************************* 93 : * Creation de la table BASE_DE_MODES * 94 : ******************************************* 95 : * 96 : IF (AFFICH) WRITE (*,*) 'Creation de la table BASE_DE_MODES...' 97 : * 97 : CALL CRTABL(IPTAB2) 97 : CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0, 98 : & 'MOT',0,0.0D0,'BASE_DE_MODES',.TRUE.,0) 98 : CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,0, 99 : & 'MAILLAGE',0,0.0D0,' ',.TRUE.,MELEME) 100 : * 101 : ******************************************* 102 : * Boucle sur les Modes * 103 : ******************************************* 104 : * 105 : I=1 106 : 80 IF (I .GT. NBMOD1) GOTO 20 107 : * 108 : IF (AFFICH) WRITE (*,*) 'Mode ',I 109 : * 110 : MODREL = (ABS(ALFI.RE(1,I,1)).EQ. 0.0D0) 111 : IF (AFFICH) THEN 112 : IF (MODREL) THEN 113 : WRITE (*,*) 'MODE REEL' 114 : ELSE 115 : WRITE (*,*) 'MODE COMPLEXE' 116 : ENDIF 117 : ENDIF 118 : * 119 : * ---- frequence infinie ? 120 : * 121 : MODANN = (ABS(BETA.RE(1,I,1)).LT.SEUIL) 122 : * ---- oui 123 : IF (MODANN) THEN 124 : 90 WRITE (*,*) 'Attention !!! Mode ',I, 125 : & ' annule : frequence infinie.' 125 : CALL CRTABL(MTAB1) 125 : CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'SOUSTYPE', .TRUE.,0, 126 : & 'MOT',0,0.0D0,'MODE_ANNULE',.TRUE.,0) 126 : CALL ECCTAB(IPTAB2,'ENTIER',I,0.0D0,' ',.TRUE.,0, 127 : & 'TABLE', 0, 0.0D0,' ',.TRUE.,MTAB1) 128 : IF (.NOT. MODREL) THEN 129 : MODREL = .TRUE. 130 : I = I + 1 131 : GO TO 90 132 : ENDIF 133 : * ---- non 134 : ELSE 135 : * 136 : *------- Deformees reelle (1) et imaginaire (2) du mode i 137 : * 138 : * Creation de MPOVA1 et MPOVA2 139 : IF (AFFICH) WRITE (*,*) 'Calcul des deformees ...' 140 : SEGINI, MPOVA1 141 : SEGINI, MPOVA2 142 : DO 30, IC=1,NC 143 : DO 40, K=1,NBP1 144 : MPOVA1.VPOCHA(K,IC)=MATZ.RE((K-1)*NC+IC,I,1) 145 : * IF (MODREL) THEN 146 : * MPOVA2.VPOCHA(K,IC)=0 147 : * ELSE 148 : * MPOVA2.VPOCHA(K,IC)=MATZ.RE((K-1)*NC+IC,I+1,1) 149 : * ENDIF 150 : IF (.not.MODREL) 151 : & MPOVA2.VPOCHA(K,IC)=MATZ.RE((K-1)*NC+IC,I+1,1) 152 : 40 CONTINUE 153 : 30 CONTINUE 154 : SEGDES, MPOVA1 155 : SEGDES, MPOVA2 156 : * 157 : * Creation de MSOUP1 et MSOUP2 158 : IF (AFFICH) WRITE (*,*) 'Creation des MSOUPO ...' 159 : SEGINI, MSOUP1 160 : MSOUP1.IGEOC = MELEME 161 : MSOUP1.IPOVAL = MPOVA1 162 : c SEGACT, MCOMP 163 : DO 50, IC=1,NC 164 : MSOUP1.NOCOMP (IC) = MCOMP.MOTS(IC) 165 : MSOUP1.NOHARM(IC)=NIFOUR 166 : 50 CONTINUE 167 : c SEGDES, MCOMP 168 : SEGDES, MSOUP1 169 : SEGINI, MSOUP2=MSOUP1 170 : MSOUP2.IPOVAL = MPOVA2 171 : SEGDES, MSOUP2 172 : * 173 : * Creation de MCHPO1 et de MCHPO2 174 : IF (AFFICH) WRITE (*,*) 'Creation des CHPOINT ...' 175 : NSOUPO=1 176 : NAT = 2 177 : SEGINI, MCHPO1 178 : MCHPO1.MOCHDE = ' ' 179 : MCHPO1.MTYPOI = ' ' 180 : MCHPO1.IFOPOI = IFOMOD 181 : MCHPO1.IPCHP(1) = MSOUP1 182 : DO 60, J=1,NAT 183 : MCHPO1.JATTRI(J)=0 184 : 60 CONTINUE 185 : SEGDES, MCHPO1 186 : SEGINI, MCHPO2=MCHPO1 187 : MCHPO2.IPCHP(1)=MSOUP2 188 : SEGDES, MCHPO2 189 : * 190 : ************************************************ 191 : * Creation de la table MODE * 192 : ************************************************ 193 : * 194 : *----- valeur propre (reelle ou complexe) 195 : * 196 : * Attention : on enregistre f = w/2pi 197 : * avec iw = landa donc w=-i landa !!! 198 : * 199 : IF (AFFICH) WRITE (*,*) 'Construction de la table MODE ...' 200 : * 200 : CALL CRTABL(MTAB1) 200 : CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0, 201 : & 'MOT',0,0.0D0,'MODE_COMPLEXE',.TRUE.,0) 202 : * 202 : CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'NUMERO_MODE',.TRUE.,0, 203 : & 'ENTIER',I,0.0D0,' ',.TRUE.,0) 203 : CALL CREPO1(0.0D0,0.0D0,0.0D0,IPOIN) 203 : CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'POINT_REPERE',.TRUE.,0, 204 : & 'POINT',0,0.0D0,' ',.TRUE.,IPOIN) 205 : * XVAL=BETA.RE(1,I,1) 205 : * CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'FREQUENCE_DEN',.TRUE.,0, 206 : * & 'FLOTTANT',0,XVAL,' ',.TRUE.,0) 207 : XVAL=(-1*ALFR.RE(1,I,1))/(2*XPI*BETA.RE(1,I,1)) 207 : CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'FREQUENCE_IMAGINAIRE',.TRUE.,0 208 : $ ,'FLOTTANT',0,XVAL,' ',.TRUE.,0) 209 : XVAL=(ALFI.RE(1,I,1))/(2*XPI*BETA.RE(1,I,1)) 209 : CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'FREQUENCE_REELLE',.TRUE.,0, 210 : & 'FLOTTANT',0,XVAL,' ',.TRUE.,0) 211 : * 211 : CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'DEFORMEE_MODALE_REELLE', 212 : & .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,MCHPO1) 212 : CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'DEFORMEE_MODALE_IMAGINAIRE', 213 : & .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,MCHPO2) 214 : * 214 : CALL ECCTAB(IPTAB2,'ENTIER',I,0.0D0,' ',.TRUE.,0,'TABLE', 215 : & 0,0.0D0,' ',.TRUE.,MTAB1) 216 : * 217 : IF (MODREL) GOTO 70 218 : * 219 : *----- Valeur propre complexe conjuguee 220 : * 221 : * 222 : SEGINI, MTAB2=MTAB1 223 : SEGDES, MTAB2 224 : I = I + 1 225 : IF (AFFICH) WRITE (*,*) 'Mode conjugue, no : ',I 225 : CALL ECCTAB(MTAB2,'MOT',0,0.0D0,'NUMERO_MODE',.TRUE.,0, 226 : & 'ENTIER',I,0.0D0,' ',.TRUE.,0) 226 : CALL ECCTAB(MTAB2,'MOT',0,0.0D0,'FREQUENCE_REELLE',.TRUE.,0, 227 : & 'FLOTTANT',0,-1*XVAL,' ',.TRUE.,0) 228 : XVAL=-1.D0 228 : CALL MUCHPO(MCHPO2,XVAL,IRET,1) 228 : CALL ECCTAB(MTAB2,'MOT',0,0.0D0,'DEFORMEE_MODALE_REELLE', 229 : & .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,MCHPO1) 229 : CALL ECCTAB(MTAB2,'MOT',0,0.0D0,'DEFORMEE_MODALE_IMAGINAIRE', 230 : & .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,IRET) 231 : * 231 : CALL ECCTAB(IPTAB2,'ENTIER',I,0.0D0,' ',.TRUE.,0,'TABLE', 232 : & 0,0.0D0,' ',.TRUE.,MTAB2) 233 : * 234 : 70 CONTINUE 235 : ENDIF 236 : I = I + 1 237 : GOTO 80 238 : 20 CONTINUE 239 : * 240 : IF (AFFICH) WRITE (*,*) 'Nettoyage !!!' 241 : SEGSUP, ALFR, ALFI, BETA 242 : SEGSUP, MATZ 243 : SEGSUP, MCOMP 244 : * 245 : ******************************************** 246 : * Creation de la table BASE_MODALE * 247 : ******************************************** 248 : * 249 : IF (AFFICH) WRITE (*,*) 'Creation de la table BASE_MODALE...' 250 : * 250 : CALL CRTABL(IPBC) 250 : CALL ECCTAB(IPBC,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0, 251 : & 'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,0) 251 : CALL ECCTAB(IPBC,'MOT',0,0.0D0,'MODES',.TRUE.,0, 252 : & 'TABLE',0,0.0D0,' ',.TRUE.,IPTAB2) 253 : cbp : on ajoute un indicateur de succes (en plus du message dans vibrac) 254 : CONV=ERR.eq.0 254 : CALL ECCTAB(IPBC,'MOT',0,0.0D0,'CONVERGENCE',.TRUE.,0, 255 : & 'LOGIQUE ',0,0.0D0,' ',CONV,0) 256 : * 257 : RETURN 258 : END 259 : 260 : 261 : 262 : 263 : 264 : 265 :
© Cast3M 2003 - All rights reserved.
Disclaimer