1 : C QZREST SOURCE BP208322 08/12/17 21:15:14 6224 2 : SUBROUTINE QZREST(IPBASR, IPBASC, MTAB1) 3 : * 4 : ***************************************************************************** 5 : * RESTITUTION D'UNE BASE DE MODES COMPLEXES A PARTIR * 6 : * D'UNE BASE DE MODES COMPLEXES DEFINIE * 7 : * RELATIVEMENT A UNE BASE REELLE * 8 : * _________________________________________________________________________ * 9 : * * 10 : * DATE : le 31 Juillet 1995 * 11 : * AUTEUR : Nicolas BENECH * 12 : * _________________________________________________________________________ * 13 : * * 14 : * MODULE(S) APPELANT(S) : VIBRAC * 15 : * * 16 : * MODULE(S) APPELE(S) : ACCTAB, CRTABL, ECCTAB, EXTRA9, EXTR11 * 17 : * _________________________________________________________________________ * 18 : * * 19 : * EN ENTREE : * 20 : * - IPBASR : BASE DE MODES REELS PHYSIQUE * 21 : * - IPBASC : BASE DE MODES COMPLEXES RELATIVE A IPBASR * 22 : * _________________________________________________________________________ * 23 : * * 24 : * EN SORTIE : * 25 : * - MTAB1 : BASE DE MODES COMPLEXES PHYSIQUE * 26 : ***************************************************************************** 27 : * 28 : IMPLICIT INTEGER(I-N) 29 : -INC CCOPTIO 30 : -INC SMCHPOI 31 : -INC SMCOORD 32 : -INC SMELEME 33 : -INC SMLMOTS 34 : -INC SMTABLE 35 : * 36 : REAL*8 XVALRE 37 : LOGICAL LOGRE 38 : CHARACTER*(8) CHARRE 39 : REAL*8 XVAL1, XVAL2, XVAL4 40 : INTEGER I, J, K, NNOEUD, NCOMP, NBMODR, NBMODC, SWAP, PT1, PT2 41 : INTEGER IOBRE 42 : LOGICAL AFFICH 43 : CHARACTER* (8) TYPEMODR, TYPEMODC 44 : CHARACTER*4 MOT1, MOT2 45 : * 46 : POINTEUR IPBASR2.MTABLE, IPBASR3.MTABLE 47 : POINTEUR IPBASC2.MTABLE, IPBASC3.MTABLE 48 : POINTEUR MCHPO5.MCHPOI 49 : * 50 : *----- Ecriture des messages pour verification 51 : NUMAFF = 23 52 : AFFICH = ((MOD(IIMPI, NUMAFF).EQ.0) .AND. (IIMPI.NE.0)) 53 : * AFFICH = .TRUE. 54 : * 55 : *----- Fin faute de donnees 56 : IF (IPBASR*IPBASC .EQ. 0) RETURN 57 : * 58 : *----- Lecture des donnees 59 : IF (AFFICH) WRITE (*,*) 'Lecture des donnees ...' 59 : CALL ACCTAB(IPBASR,'MOT',0,0.0D0,'MODES',.TRUE.,0, 60 : & 'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,IPBASR2) 60 : CALL ACCTAB(IPBASC,'MOT',0,0.0D0,'MODES',.TRUE.,0, 61 : & 'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,IPBASC2) 62 : * 63 : * --- Tri des donnees 64 : IF (AFFICH) WRITE (*,*) 'TEST : ordre des donnees ...' 64 : CALL ACCTAB(IPBASR2,'ENTIER',1,0.0D0,' ',.TRUE.,0, 65 : & 'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,IPBASR3) 65 : CALL ACCTAB(IPBASC2,'ENTIER',1,0.0D0,' ',.TRUE.,0, 66 : & 'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,IPBASC3) 67 : * 67 : CALL ACCTAB(IPBASR3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0, 68 : & 'MOT',IVALRE,XVALRE,TYPEMODR,LOGRE,IOBRE) 68 : CALL ACCTAB(IPBASC3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0, 69 : & 'MOT',IVALRE,XVALRE,TYPEMODC,LOGRE,IOBRE) 70 : IF (AFFICH) THEN 71 : WRITE (*,*) 'TYPEMODR = ',TYPEMODR 72 : WRITE (*,*) 'TYPEMODC = ',TYPEMODC 73 : ENDIF 74 : * 75 : IF (((TYPEMODR.EQ.'MODE_COM') .OR. (TYPEMODR.EQ.'MODE_ANN')) 76 : & .AND. (TYPEMODC.EQ.'MODE')) THEN 77 : IF (AFFICH) WRITE (*,*) 'Permutation !' 78 : SWAP=IPBASR 79 : IPBASR=IPBASC 80 : IPBASC=SWAP 81 : SWAP=IPBASR2 82 : IPBASR2=IPBASC2 83 : IPBASC2=SWAP 84 : TYPEMODR='MODE' 85 : TYPEMODC='MODE_COM' 86 : ENDIF 87 : IF (.NOT. AFFICH) GOTO 1 88 : IF ((TYPEMODR.EQ.'MODE') .AND. ((TYPEMODC.EQ.'MODE_COM') 89 : & .OR. (TYPEMODR.EQ.'MODE_ANN'))) 90 : & THEN 91 : WRITE (*,*) 'OK' 92 : ELSE 93 : WRITE (*,*) 'Erreur !' 94 : ENDIF 95 : 1 CONTINUE 96 : * 97 : ******************************************* 98 : * Donnees fondamentales * 99 : ******************************************* 100 : * --- nombre de modes complexes 101 : SEGACT, IPBASC2 102 : NBMODC = IPBASC2.MLOTAB-2 103 : SEGDES, IPBASC2 104 : * --- nombre de modes reels 105 : SEGACT, IPBASR2 106 : NBMODR = IPBASR2.MLOTAB-2 107 : SEGDES, IPBASR2 108 : * --- nombre de SOUPO dans les chpoints reels 108 : CALL ACCTAB(IPBASR2,'ENTIER',1,0.0D0,' ',.TRUE.,0, 109 : & 'TABLE ',IVALRE,XVALRE,CHARRE,LOGRE,IPBASR3) 109 : CALL ACCTAB(IPBASR3,'MOT',0,0.0D0,'DEFORMEE_MODALE',.TRUE., 110 : & 0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,MCHPO1) 111 : * 112 : SEGACT, MCHPO1 113 : NSOUPO=MCHPO1.IPCHP(/1) 114 : SEGDES, MCHPO1 115 : * 116 : ************************************************* 117 : * Creation de la table MTAB2 BASE_DE_MODES * 118 : ************************************************* 119 : * 120 : IF (AFFICH) WRITE (*,*) 'Creation de la table BASE_DE_MODES ...' 120 : CALL CRTABL(MTAB2) 120 : CALL ECCTAB(MTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0, 121 : & 'MOT',0,0.0D0,'BASE_DE_MODES',.TRUE.,0) 122 : * 122 : CALL ACCTAB(IPBASR2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,0, 123 : & 'MAILLAGE',IVALRE,XVALRE,CHARRE,LOGRE,IPT1) 123 : CALL ECCTAB(MTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,0, 124 : & 'MAILLAGE',0,0.0D0,' ',.TRUE.,IPT1) 125 : * 126 : * 127 : *=========================================* 128 : * Boucle sur les modes Complexes * 129 : *=========================================* 130 : * 131 : DO 20, I=1, NBMODC 132 : IF (AFFICH) WRITE (*,*) 'Boucle sur les MODES ...', I 133 : * 134 : ************************************************ 135 : * Creation de la table MTAB3 du MODE I * 136 : ************************************************ 137 : * 137 : CALL ACCTAB(IPBASC2,'ENTIER',I,0.0D0,' ',.TRUE.,0, 138 : & 'TABLE ',IVALRE,XVALRE,CHARRE,LOGRE,IPBASC3) 139 : SEGINI, MTAB3=IPBASC3 140 : SEGDES, MTAB3 140 : CALL ACCTAB(IPBASC3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0, 141 : & 'MOT',IVALRE,XVALRE,TYPEMODC,LOGRE,IOBRE) 142 : IF (TYPEMODC .EQ. 'MODE_ANN') GOTO 20 143 : * 144 : ***** CALCUL DE LA DEFORMEE MODALE (mchpo3 + i mchpo4) ***** 145 : * 146 : * --- Recup de ALFA_R du mode I (=mchpo2) 146 : CALL ACCTAB(IPBASC3,'MOT',0,0.0D0,'DEFORMEE_MODALE_REELLE', 147 : & .TRUE.,0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,MCHPO2) 148 : * --- Recup de ALFA_I du mode I (=mchpo2) 148 : CALL ACCTAB(IPBASC3,'MOT',0,0.0D0,'DEFORMEE_MODALE_IMAGINAIRE', 149 : & .TRUE.,0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,MCHPO4) 150 : * 151 : * --- Points supports 152 : SEGACT, MCHPO2 153 : MSOUP2 = MCHPO2.IPCHP(1) 154 : SEGDES, MCHPO2 155 : SEGACT, MSOUP2 156 : IPT2 = MSOUP2.IGEOC 157 : SEGDES, MSOUP2 158 : SEGACT, IPT2 159 : NBP2 = IPT2.NUM(/2) 160 : SEGDES, IPT2 161 : * --- composantes (rem : on ne fait rien si plus de 1 composante....) 161 : CALL EXTR11(MCHPO2,MLMOT2) 162 : SEGACT, MLMOT2 163 : MOT2=MLMOT2.MOTS(1) 164 : SEGDES, MLMOT2 165 : * 166 : * --- creation du chpoint Resultat depuis le 1er chpoint mode reel mis à 0 167 : * partie réelle MCHPO3 168 : SEGINI, MCHPO3=MCHPO1 169 : SEGACT, MCHPO1 170 : DO 30, J=1, NSOUPO 171 : IF (AFFICH) WRITE (*,*) 'création MCHPO3: Boucle sur les SOUPO',J 172 : MSOUP1 = MCHPO1.IPCHP(J) 173 : SEGINI, MSOUP3=MSOUP1 174 : MCHPO3.IPCHP(J) = MSOUP3 175 : SEGACT, MSOUP1 176 : MPOVA1 = MSOUP1.IPOVAL 177 : SEGDES, MSOUP1 178 : SEGACT, MPOVA1 179 : N = MPOVA1.VPOCHA(/1) 180 : NC = MPOVA1.VPOCHA(/2) 181 : SEGDES, MPOVA1 182 : SEGINI, MPOVA3 183 : SEGDES, MPOVA3 184 : MSOUP3.IPOVAL = MPOVA3 185 : SEGDES, MSOUP3 186 : * Maillage et nom de Composantes ne seront pas detruits 187 : 30 CONTINUE 188 : SEGDES, MCHPO1,MCHPO3 189 : * 190 : * partie imaginaire MCHPO5 191 : SEGINI, MCHPO5=MCHPO1 192 : SEGACT, MCHPO1 193 : DO 31, J=1, NSOUPO 194 : IF (AFFICH) WRITE (*,*) 'création MCHPO5: Boucle sur les SOUPO',J 195 : MSOUP1 = MCHPO1.IPCHP(J) 196 : SEGINI, MSOUP5=MSOUP1 197 : MCHPO5.IPCHP(J) = MSOUP5 198 : SEGACT, MSOUP1 199 : MPOVA1 = MSOUP1.IPOVAL 200 : SEGDES, MSOUP1 201 : SEGACT, MPOVA1 202 : N = MPOVA1.VPOCHA(/1) 203 : NC = MPOVA1.VPOCHA(/2) 204 : SEGDES, MPOVA1 205 : SEGINI, MPOVA5 206 : SEGDES, MPOVA5 207 : MSOUP5.IPOVAL = MPOVA5 208 : SEGDES, MSOUP5 209 : * Maillage et nom de Composantes ne seront pas detruits 210 : 31 CONTINUE 211 : SEGDES, MCHPO1,MCHPO5 212 : * 213 : * 214 : ****************************************** 215 : * Boucle sur les noeuds supports * 216 : ****************************************** 217 : * 218 : DO 50, K=1, NBP2 219 : 220 : IF (AFFICH) WRITE (*,*) '--- Noeud support ',K,' ---' 221 : SEGACT, IPT2 222 : PT2 = IPT2.NUM(1,K) 223 : SEGDES, IPT2 224 : * --- Contribution a mchpo3 224 : CALL EXTRA9(MCHPO2,PT2,MOT2,KERRE,XVAL2) 225 : * --- Contribution a mchpo5 225 : CALL EXTRA9(MCHPO4,PT2,MOT2,KERR2,XVAL4) 226 : IF (AFFICH) WRITE (*,*) ' alfa_R et alfa_I = ',XVAL2,XVAL4 227 : 228 : * --- on recherche le chpoint reel correspondant 229 : L=1 229 : 60 CALL ACCTAB(IPBASR2,'ENTIER',L,0.0D0,' ',.TRUE., 230 : & 0,'TABLE ',IVALRE,XVALRE,CHARRE,LOGRE,IPBASR3) 230 : CALL ACCTAB(IPBASR3,'MOT',0,0.0D0,'POINT_REPERE',.TRUE., 231 : & 0,'POINT',IVALRE,XVALRE,CHARRE,LOGRE,PT1) 232 : IF (PT1 .NE. PT2) THEN 233 : L=L+1 234 : IF (L .LE. NBMODR) GOTO 60 235 : ELSE 235 : CALL ACCTAB(IPBASR3,'MOT',0,0.0D0,'DEFORMEE_MODALE', 236 : & .TRUE.,0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE, 237 : & MCHPO1) 238 : IF (AFFICH) WRITE (*,*) ' Prise en compte du MCHPO1', L,MCHPO1 239 : * 240 : * --- Sommes... 241 : MSOMM3=0 242 : XVAL1=1.d0 243 : IF (AFFICH) WRITE (*,*) 'Somme ...',MSOMM3,XVAL1,XVAL2 244 : * --- ... pour mchpo3 244 : call ADCHPO(MCHPO3,MCHPO1,MSOMM3,XVAL1,XVAL2) 244 : call DTCHPO(MCHPO3) 245 : MCHPO3=MSOMM3 246 : * --- ... pour mchpo5 246 : call ADCHPO(MCHPO5,MCHPO1,MSOMM5,XVAL1,XVAL4) 246 : call DTCHPO(MCHPO5) 247 : MCHPO5=MSOMM5 248 : * 249 : ENDIF 250 : 251 : 50 CONTINUE 252 : ********************************************* 253 : * Fin de boucle sur les noeuds support * 254 : ********************************************* 255 : * 256 : IF (AFFICH) WRITE (*,*) 'Enregistrement du CHPOINT ...' 257 : * --- enregistrement du chpoint 257 : CALL ECCTAB(MTAB3,'MOT',0,0.0D0,'DEFORMEE_MODALE_REELLE', 258 : & .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,MCHPO3) 259 : * --- enregistrement du chpoint 259 : CALL ECCTAB(MTAB3,'MOT',0,0.0D0,'DEFORMEE_MODALE_IMAGINAIRE', 260 : & .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,MCHPO5) 261 : * --- enregistrement du mode 261 : CALL ECCTAB(MTAB2,'ENTIER',I,0.0D0,' ', 262 : & .TRUE.,0,'TABLE ',0,0.0D0,' ',.TRUE.,MTAB3) 263 : 264 : 20 CONTINUE 265 : ****************************************** 266 : * Fin boucle sur les modes * 267 : ****************************************** 268 : * 269 : * 270 : ****************************************** 271 : * Creation de la table BASE_MODALE * 272 : ****************************************** 273 : * 273 : CALL CRTABL(MTAB1) 273 : CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0, 274 : & 'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,0) 274 : CALL ECCTAB(MTAB1,'MOT',I,0.0D0,'MODES', 275 : & .TRUE.,0,'TABLE ',0,0.0D0,' ',.TRUE.,MTAB2) 276 : * 277 : * --- fin 278 : * 279 : RETURN 280 : END 281 : * 282 : 283 : 284 :
© Cast3M 2003 - All rights reserved.
Disclaimer