1 : C IMPED SOURCE BP208322 13/05/23 21:15:00 7774 2 : SUBROUTINE IMPED 3 : *---------------------------------------------------------------------* 4 : * __________________________ * 5 : * | | * 6 : * | OPERATEUR IMPEDANCE | * 7 : * |________________________| * 8 : * * 9 : *---------------------------------------------------------------------* 10 : * * 11 : * SYNTAXE : * 12 : * * 13 : * * 14 : * RIG1 = IMPE RIG2 (RIG3) (REEL1)(| 'MASSE' | ) (FLAM); * 15 : * | 'RAIDEUR' | * 16 : * | 'AMORTISSEMENT' | * 17 : * | 'QUELCONQUE' LISREEL1 | * 18 : * 19 : * CREATION : DC 2004 20 : * MODIFS : #6131 BP 2008 : correction dans le cas 'AMOR' en Fourier 21 : * #6644 et #6653 BP 2010 : reecriture pour etre conforme au 22 : * partionnement des matrices 23 : * #6838 BP 2011 : reecriture car erreur lors de l assemblage si 24 : * non correspondance primale - duale 25 : * #7774 BP 05/2013 : extension au cas Fourier sur les ddls 26 : * symetriques seuls ( IMPE 'AMOR' C^n ) 27 : * + large choix d'inconnues 28 : * + prise en compte des MULTiplicateurs LX 29 : * 30 : *---------------------------------------------------------------------* 31 : IMPLICIT INTEGER(I-N) 32 : IMPLICIT REAL*8(A-H,O-Z) 33 : * 34 : -INC SMRIGID 35 : -INC CCOPTIO 36 : -INC SMLREEL 37 : -INC SMLENTI 38 : -INC SMELEME 39 : -INC SMCOORD 40 : * 41 : EXTERNAL LONG 42 : PARAMETER(NBMO=24) 43 : CHARACTER*4 MOPRIM(NBMO),MODUAL(NBMO) 44 : CHARACTER*4 MOPRII(NBMO),MODUAI(NBMO) 45 : CHARACTER*4 LISMOT(4),LISMO2(1) 46 : CHARACTER*8 LISMO3(3) 47 : REAL*8 XOME,COEFA,COEFB,COEFC,COEFD,XCOEF2 48 : LOGICAL FLAGFO,FLUT,FLRI23 49 : CHARACTER*4 MOP1,MOD1,MOP2,MOD2,MOP3,MOD3 50 : * 51 : * on utilise les noms reels NOMDD et NOMDU de CCHAMP (cf bdata) 52 : DATA MOPRIM / 'UX ','UY ','UZ ','UR ','UZ ','UT ', 53 : . 'RX ','RY ','RZ ','RT ','RS ','ALFA', 54 : . 'P ','PI ','BETA','FBET','T ','RR ', 55 : . 'TINF','TSUP','TH ','FC ','PQ ','TP '/ 56 : DATA MODUAL / 'FX ','FY ','FZ ','FR ','FZ ','FT ', 57 : . 'MX ','MY ','MZ ','MT ','MS ','FALF', 58 : . 'FP ','FPI ','FBET','BETA','Q ','MR ', 59 : . 'QINF','QSUP','FLUX','ED ','FPQ ','FTP '/ 60 : * on definit les noms imaginaires correspondants 61 : DATA MOPRII / 'IUX ','IUY ','IUZ ','IUR ','IUZ ','IUT ', 62 : . 'IRX ','IRY ','IRZ ','IRT ','IRS ','IALF', 63 : . 'IP ','IPI ','IBET','IFBE','IT ','IRR ', 64 : . 'ITIN','ITSU','ITH ','IFC ','IPQ ','ITP '/ 65 : DATA MODUAI / 'IFX ','IFY ','IFZ ','IFR ','IFZ ','IFT ', 66 : . 'IMX ','IMY ','IMZ ','IMT ','IMS ','IFAL', 67 : . 'IFP ','IFPI','IFBE','IBET','IQ ','IMR ', 68 : . 'IQIN','IQSU','IFLU','IED ','IFPQ','IFTP'/ 69 : DATA LISMOT/ 'MASS','RAID','AMOR','QUEL'/ 70 : DATA LISMO2/ 'FLAM'/ 71 : DATA LISMO3/ 'MASSE ','RIGIDITE','AMOR '/ 72 : * 73 : * 74 : *---- Initialisations et lectures des objets -------------------------* 75 : * 76 : IRET = 1 77 : idimp1=IDIM+1 78 : * 79 : * Matrices 80 : * 80 : CALL LIROBJ('RIGIDITE',IPOIR2,1,IRETOU) 81 : IF(IRETOU.EQ.0) RETURN 82 : * 82 : CALL LIROBJ('RIGIDITE',IPOIR3,0,IRETOU) 83 : IF (IRETOU.NE.0) THEN 84 : FLAGFO = .true. 85 : ELSE 86 : FLAGFO = .false. 87 : ENDIF 88 : * 89 : * Coef multiplicatif (Vitesse de Rotation par ex.) 90 : XOME=1.D0 90 : CALL LIRREE(XOME,0,IRETOX) 91 : * 92 : * Quel Cas ? 'MASS','RAID','AMOR','QUEL'? 93 : NUMLIS = 0 93 : CALL LIRMOT(LISMOT,4,NUMLIS,0) 94 : * 95 : * Quel type de matrice en sortie ? 96 : NUMLI2 = 0 96 : CALL LIRMOT(LISMO2,1,NUMLI2,0) 97 : IFLAM=0 98 : IF(NUMLI2.EQ.1) IFLAM = 1 99 : * 100 : * Dans le cas quelconque, on a besoin d une listreel 101 : IF (NUMLIS.EQ.4) THEN 102 : if (FLAGFO) then 103 : write(6,*) 'Le cas QUELconque ne fonctionne qu avec' 104 : & ,' 1 matrice en entrée actuellement (et pas 2) !!!' 104 : call erreur (19) 105 : return 106 : endif 106 : CALL LIROBJ('LISTREEL',ICOEF,1,IRETOU) 107 : MLREEL =ICOEF 108 : SEGACT MLREEL 109 : NCOEF = PROG(/1) 110 : if (NCOEF.lt.4) then 111 : write(6,*) 'Le cas QUELconque ne fonctionne qu avec' 112 : & ,' 1 listreel d au moins 4 valeurs !!!' 112 : call erreur (21) 113 : return 114 : endif 115 : COEFA = PROG(1) 116 : COEFB = PROG(2) 117 : COEFC = PROG(3) 118 : COEFD = PROG(4) 119 : SEGDES MLREEL 120 : ENDIF 121 : * 122 : * 123 : *---- Activation de(s) matrice(s) d'entree -------------------------* 124 : * 125 : RI2 = IPOIR2 126 : SEGACT RI2 127 : NRIGE2 = RI2.IRIGEL(/1) 128 : NRIGEL2= RI2.IRIGEL(/2) 129 : 130 : IF (FLAGFO) THEN 131 : RI3 = IPOIR3 132 : SEGACT RI3 133 : NRIGE3 = RI3.IRIGEL(/1) 134 : NRIGEL3= RI3.IRIGEL(/2) 135 : * Tests de Compatibilité avec RI2 136 : * BP: on decide de n'en garder que tres peu 137 : IF ( ((RI2.MTYMAT).NE.(RI3.MTYMAT)) .or. 138 : & ((RI2.IFORIG).NE.(RI3.IFORIG)) ) THEN 139 : WRITE(6,*) 'Plantage: RIGIDITES non compatibles !!!' 140 : WRITE(6,*) 'MTYMAT,IFORIG' 141 : WRITE(6,*) (RI2.MTYMAT),(RI2.IFORIG) 142 : WRITE(6,*) (RI3.MTYMAT),(RI3.IFORIG) 142 : call erreur (21) 143 : RETURN 144 : ENDIF 145 : * FLRI23 = meme support entre RI2 et RI3 ? 146 : FLRI23=.false. 147 : if(NRIGEL2.ne.NRIGEL3) goto 23 148 : do k=1,NRIGEL2 149 : if((RI2.irigel(1,k)).ne.(RI3.irigel(1,k))) goto 23 150 : if((RI2.irigel(2,k)).ne.(RI3.irigel(2,k))) goto 23 151 : if((RI2.coerig(k)).ne.(RI3.coerig(k))) goto 23 152 : enddo 153 : FLRI23=.true. 154 : 23 continue 155 : ELSE 156 : * on n a pas lu de 2eme matrice RI3 : on utilise RI2 157 : RI3=RI2 158 : FLRI23=.true. 159 : NRIGE3 = NRIGE2 160 : NRIGEL3= NRIGEL2 161 : ENDIF 162 : * 163 : * 164 : *---- Quel Cas ? 1='MASS',2='RAID',3='AMOR',4='QUEL'? --------------* 165 : * 166 : * si on lu un mot clé, on lutilise 167 : IF (NUMLIS.NE.0) THEN 168 : ICAS = NUMLIS 169 : ELSE 170 : * sinon par defaut on va faire une IMPEDANCE 'RAIDEUR' [K 0 ; 0 K] 171 : ICAS = 2 172 : * sauf si on a reconnu le type de la matrice d entree, 173 : * auquel cas on choisit le cas le + vraisemblable 174 : IF ((RI2.MTYMAT).EQ.LISMO3(3)) THEN 175 : ICAS = 3 176 : ELSEIF ((RI2.MTYMAT).EQ.LISMO3(1)) THEN 177 : ICAS = 1 178 : ELSEIF ((RI2.MTYMAT).EQ.LISMO3(2)) THEN 179 : ICAS = 2 180 : ENDIF 181 : ENDIF 182 : * 183 : if(IRETOX.ne.0.and.ICAS.eq.2) write(6,*) 'Cas Raideur:' 184 : & ,' Le coefficient multiplicatif n est pas pris en compte !!!' 185 : * 186 : * 187 : *---- on verifie que l'on n'a pas de multiplicateur 188 : * dans les cas autres que RAIDEUR ------------------------------* 189 : * 190 : IF (ICAS.NE.2) THEN 191 : DO 24 k=1,NRIGEL2 192 : ipt2 = RI2.IRIGEL(1,k) 193 : segact,ipt2 194 : c detection des elements de type MULTiplicateur de Lagrange 195 : if (ipt2.itypel.eq.22) then 196 : write(ioimp,*) 'Les liaisons avec MULTiplicateur ne sont' 197 : & ,' compatibles qu avec l option RAIDEUR de IMPE' 197 : call ERREUR(19) 198 : RETURN 199 : endif 200 : segdes,ipt2 201 : 24 CONTINUE 202 : ENDIF 203 : 204 : * 205 : * 206 : *---- Creation de la matrice de sortie ----------------------------* 207 : * 208 : NRIGE = NRIGE2 209 : if (ICAS.eq.1.or.ICAS.eq.2) then 210 : NRIGEL = NRIGEL2 + NRIGEL3 211 : elseif (ICAS.eq.4) then 212 : NRIGEL = NRIGEL2 213 : else 214 : if (FLRI23) then 215 : NRIGEL = NRIGEL2 216 : else 217 : NRIGEL = NRIGEL2 + NRIGEL3 218 : endif 219 : endif 220 : * 221 : SEGINI,RI1 222 : * Pour les besoins d une analyse de 'FLAM'bage on ecrit matrice de type masse 223 : IF (IFLAM.EQ.1) THEN 224 : RI1.MTYMAT = LISMO3(1) 225 : ELSE 226 : RI1.MTYMAT = RI2.MTYMAT 227 : ENDIF 228 : RI1.IFORIG = RI2.IFORIG 229 : * 230 : * 231 : *---- Aiguillage selon le cas ----------------------------------------* 232 : * 233 : * MASS,RAID,AMOR,QUEL 234 : GOTO ( 100, 200, 300, 400),ICAS 235 : * 236 : * 237 : *---- Cas MASS [-M 0 ; 0 -M] ----------------------------------------* 238 : 100 CONTINUE 239 : 240 : *---- 1er quadrant ---- 241 : *-----Boucle sur les matrices de rigidite elementaires de RI2 242 : DO 101 IMA=1,NRIGEL2 243 : 244 : IMA1 = IMA 245 : * COERIG 246 : XCOEF2 = (XOME**2) * RI2.COERIG(IMA) 247 : RI1.COERIG(IMA1) = -1.D0 * XCOEF2 248 : * IRIGEL(1,:)= meleme 249 : RI1.IRIGEL(1,IMA1) = RI2.IRIGEL(1,IMA) 250 : RI1.IRIGEL(2,IMA1) = RI2.IRIGEL(2,IMA) 251 : * IRIGEL(3,:) = descr 252 : DES2 = RI2.IRIGEL(3,IMA) 253 : RI1.IRIGEL(3,IMA1) = DES2 254 : * IRIGEL(4,:) = XMATRI 255 : RI1.IRIGEL(4,IMA1) = RI2.IRIGEL(4,IMA) 256 : * IRIGEL(5,:) = nhar 257 : RI1.IRIGEL(5,IMA1) = RI2.IRIGEL(5,IMA) 258 : * IRIGEL(6,:) = < = > 259 : RI1.IRIGEL(6,IMA1) = RI2.IRIGEL(6,IMA) 260 : * IRIGEL(7,:) = symetrie 261 : RI1.IRIGEL(7,IMA1) = RI2.IRIGEL(7,IMA) 262 : 263 : 101 CONTINUE 264 : *-----fin de Boucle sur les matrices de rigidite elementaires de RI2 265 : 266 : 267 : *---- 4eme quadrant ---- 268 : *-----Boucle sur les matrices de rigidite elementaires de RI3 269 : DO 102 IMA=1,NRIGEL3 270 : 271 : IMA1 = NRIGEL2 + IMA 272 : * COERIG 273 : XCOEF3 = (XOME**2) * RI3.COERIG(IMA) 274 : RI1.COERIG(IMA1) = -1.D0 * XCOEF3 275 : * IRIGEL(1,:)= meleme 276 : RI1.IRIGEL(1,IMA1) = RI3.IRIGEL(1,IMA) 277 : RI1.IRIGEL(2,IMA1) = RI3.IRIGEL(2,IMA) 278 : * IRIGEL(3,:) = descr 279 : DES3 = RI3.IRIGEL(3,IMA) 280 : segact,DES3 281 : NLIGRP= DES3.LISINC(/2) 282 : NLIGRD= DES3.LISDUA(/2) 283 : segini,DES1=DES3 284 : * on change le nom des Primal 285 : do 112 ILIGRP = 1,NLIGRP 286 : MOP3=DES3.LISINC(ILIGRP) 287 : do IBMO = 1,NBMO 288 : if (MOP3.eq.(MOPRIM(IBMO))) then 289 : DES1.LISINC(ILIGRP) = MOPRII(IBMO) 290 : goto 112 291 : endif 292 : enddo 293 : LMOP3=LONG(MOP3) 294 : if(LMOP3.ge.4) then 295 : write(ioimp,*) 'Pas de composante imaginaire connue ', 296 : & 'associée à ',MOP3 297 : write(ioimp,*) 'Veuillez choisir un nom d inconnue ', 298 : & 'primale standard ou de moins de 4 caracteres' 299 : MOTERR(1:4)=MOP3 299 : call erreur(108) 300 : RETURN 301 : endif 302 : c on construit un nom imaginaire a partir du nom fourni 303 : write(MOP1,FMT='(A,A)') 'I',MOP3(1:3) 304 : write(ioimp,*) '!!! On définit par défaut ',MOP1, 305 : & ' comme inconnue imaginaire de ',MOP3 306 : DES1.LISINC(ILIGRP) = MOP1 307 : 112 continue 308 : * on change le nom des Dual 309 : do 121 ILIGRD = 1,NLIGRD 310 : MOD3=DES3.LISDUA(ILIGRD) 311 : if(MOD3.eq.'FLX ') goto 121 312 : do IBMO = 1,NBMO 313 : if (MOD3.eq.(MODUAL(IBMO))) then 314 : DES1.LISDUA(ILIGRD) = MODUAI(IBMO) 315 : goto 121 316 : endif 317 : enddo 318 : LMOD3=LONG(MOD3) 319 : if(LMOD3.ge.4) then 320 : write(ioimp,*) 'Pas de composante imaginaire connue ', 321 : & 'associée à ',MOD3 322 : write(ioimp,*) 'Veuillez choisir un nom d inconnue ', 323 : & 'duale standard ou de moins de 4 caracteres' 324 : MOTERR(1:4)=MOD3 324 : call erreur(108) 325 : RETURN 326 : endif 327 : c on construit un nom imaginaire a partir du nom fourni 328 : write(MOD1,FMT='(A,A)') 'I',MOD3(1:3) 329 : write(ioimp,*) '!!! On définit par défaut ',MOD1, 330 : & ' comme inconnue imaginaire de ',MOD3 331 : DES1.LISDUA(ILIGRD) = MOD1 332 : 121 continue 333 : segdes,DES3,DES1 334 : RI1.IRIGEL(3,IMA1) = DES1 335 : * IRIGEL(4,:) = XMATRI 336 : RI1.IRIGEL(4,IMA1) = RI3.IRIGEL(4,IMA) 337 : * IRIGEL(5,:) = +nhar 338 : RI1.IRIGEL(5,IMA1) = abs(RI3.IRIGEL(5,IMA)) 339 : * IRIGEL(6,:) = < = > 340 : RI1.IRIGEL(6,IMA1) = RI3.IRIGEL(6,IMA) 341 : * IRIGEL(7,:) = symetrie 342 : RI1.IRIGEL(7,IMA1) = RI3.IRIGEL(7,IMA) 343 : 344 : 102 CONTINUE 345 : *-----fin de Boucle sur les matrices de rigidite elementaires de RI2 346 : 347 : GOTO 900 348 : * 349 : * 350 : *---- Cas RAID [K 0 ; 0 K] ----------------------------------------* 351 : 200 CONTINUE 352 : 353 : *---- 1er quadrant ---- 354 : *-----Boucle sur les matrices de rigidite elementaires de RI2 355 : DO 201 IMA=1,NRIGEL2 356 : 357 : IMA1 = IMA 358 : * COERIG 359 : XCOEF2 = RI2.COERIG(IMA) 360 : RI1.COERIG(IMA1) = XCOEF2 361 : * IRIGEL(1,:)= meleme 362 : RI1.IRIGEL(1,IMA1) = RI2.IRIGEL(1,IMA) 363 : RI1.IRIGEL(2,IMA1) = RI2.IRIGEL(2,IMA) 364 : * IRIGEL(3,:) = descr 365 : DES2 = RI2.IRIGEL(3,IMA) 366 : RI1.IRIGEL(3,IMA1) = DES2 367 : * IRIGEL(4,:) = XMATRI 368 : RI1.IRIGEL(4,IMA1) = RI2.IRIGEL(4,IMA) 369 : * IRIGEL(5,:) = nhar 370 : RI1.IRIGEL(5,IMA1) = RI2.IRIGEL(5,IMA) 371 : * IRIGEL(6,:) = < = > 372 : RI1.IRIGEL(6,IMA1) = RI2.IRIGEL(6,IMA) 373 : * IRIGEL(7,:) = symetrie 374 : RI1.IRIGEL(7,IMA1) = RI2.IRIGEL(7,IMA) 375 : 376 : 201 CONTINUE 377 : *-----fin de Boucle sur les matrices de rigidite elementaires de RI2 378 : 379 : 380 : *---- 4eme quadrant ---- 381 : *-----Boucle sur les matrices de rigidite elementaires de RI3 382 : DO 202 IMA=1,NRIGEL3 383 : 384 : IMA1 = NRIGEL2 + IMA 385 : * COERIG 386 : XCOEF3 = RI3.COERIG(IMA) 387 : RI1.COERIG(IMA1) = XCOEF3 388 : * IRIGEL(1,:)= meleme 389 : RI1.IRIGEL(1,IMA1) = RI3.IRIGEL(1,IMA) 390 : cbp RI1.IRIGEL(2,IMA1) = RI3.IRIGEL(2,IMA) 391 : cbp .....debut modif du meleme ......................................... 392 : cbp : s'il s'agit d'une relation avec multiplicateur, il est peut etre 393 : c deja utilise (en tout cas comme on a changé les noms dinconnue, 394 : c il y a un risque de le retrouver dans une autre matrice) 395 : c => par securite, on duplique le noeud associe au LX 396 : IPT3 = RI3.IRIGEL(1,IMA) 397 : segact,IPT3 398 : IF(IPT3.ITYPEL.eq.22) THEN 399 : segact,MCOORD*mod 400 : segini,IPT1=IPT3 401 : c on suppose le LX en 1ere position (comme toujours a priori) 402 : nmult = IPT3.NUM(/2) 403 : IP1 = XCOOR(/1) / idimp1 404 : NBPTS = IP1 + nmult 405 : segadj,MCOORD 406 : DO jmult=1,nmult 407 : c creation d'un nouveau point associé au LX 408 : IP3 = IPT3.NUM(1,jmult) 409 : iref3 = (IP3-1)*idimp1 410 : iref1 = IP1 *idimp1 411 : XCOOR(iref1 +1) = XCOOR(iref3 +1) 412 : XCOOR(iref1 +2) = XCOOR(iref3 +2) 413 : if(idim.eq.3) XCOOR(iref1 +3) = XCOOR(iref3 +3) 414 : XCOOR(iref1 + idimp1) = XCOOR(iref3 + idimp1) 415 : IP1 = IP1 + 1 416 : IPT1.NUM(1,jmult) = IP1 417 : ENDDO 418 : segdes,IPT1,IPT3 419 : RI1.IRIGEL(1,IMA1) = IPT1 420 : ELSE 421 : segdes,IPT3 422 : RI1.IRIGEL(1,IMA1) = IPT3 423 : ENDIF 424 : cbp .....fin modif du meleme .......................................... 425 : * IRIGEL(3,:) = descr 426 : DES3 = RI3.IRIGEL(3,IMA) 427 : segact,DES3 428 : NLIGRP= DES3.LISINC(/2) 429 : NLIGRD= DES3.LISDUA(/2) 430 : segini,DES1=DES3 431 : * on change le nom des Primal 432 : do 212 ILIGRP = 1,NLIGRP 433 : MOP3=DES3.LISINC(ILIGRP) 434 : c on ne change pas le nom des inconnues LX, mais leur noeud 435 : if(MOP3.eq.'LX ') goto 212 436 : do IBMO = 1,NBMO 437 : if (MOP3.eq.(MOPRIM(IBMO))) then 438 : DES1.LISINC(ILIGRP) = MOPRII(IBMO) 439 : goto 212 440 : endif 441 : enddo 442 : LMOP3=LONG(MOP3) 443 : if(LMOP3.ge.4) then 444 : write(ioimp,*) 'Pas de composante imaginaire connue ', 445 : & 'associée à ',MOP3 446 : write(ioimp,*) 'Veuillez choisir un nom d inconnue ', 447 : & 'primale standard ou de moins de 4 caracteres' 448 : MOTERR(1:4)=MOP3 448 : call erreur(108) 449 : RETURN 450 : endif 451 : c on construit un nom imaginaire a partir du nom fourni 452 : write(MOP1,FMT='(A,A)') 'I',MOP3(1:3) 453 : write(ioimp,*) '!!! On définit par défaut ',MOP1, 454 : & ' comme inconnue imaginaire de ',MOP3 455 : DES1.LISINC(ILIGRP) = MOP1 456 : 212 continue 457 : * on change le nom des Dual 458 : do 221 ILIGRD = 1,NLIGRD 459 : MOD3=DES3.LISDUA(ILIGRD) 460 : if(MOD3.eq.'FLX ') goto 221 461 : do IBMO = 1,NBMO 462 : if (MOD3.eq.(MODUAL(IBMO))) then 463 : DES1.LISDUA(ILIGRD) = MODUAI(IBMO) 464 : goto 221 465 : endif 466 : enddo 467 : LMOD3=LONG(MOD3) 468 : if(LMOD3.ge.4) then 469 : write(ioimp,*) 'Pas de composante imaginaire connue ', 470 : & 'associée à ',MOD3 471 : write(ioimp,*) 'Veuillez choisir un nom d inconnue ', 472 : & 'duale standard ou de moins de 4 caracteres' 473 : MOTERR(1:4)=MOD3 473 : call erreur(108) 474 : RETURN 475 : endif 476 : c on construit un nom imaginaire a partir du nom fourni 477 : write(MOD1,FMT='(A,A)') 'I',MOD3(1:3) 478 : write(ioimp,*) '!!! On définit par défaut ',MOD1, 479 : & ' comme inconnue imaginaire de ',MOD3 480 : DES1.LISDUA(ILIGRD) = MOD1 481 : 221 continue 482 : segdes,DES3,DES1 483 : RI1.IRIGEL(3,IMA1) = DES1 484 : * IRIGEL(4,:) = XMATRI 485 : RI1.IRIGEL(4,IMA1) = RI3.IRIGEL(4,IMA) 486 : * IRIGEL(5,:) = +nhar 487 : RI1.IRIGEL(5,IMA1) = abs(RI3.IRIGEL(5,IMA)) 488 : * IRIGEL(6,:) = < = > 489 : RI1.IRIGEL(6,IMA1) = RI3.IRIGEL(6,IMA) 490 : * IRIGEL(7,:) = symetrie 491 : RI1.IRIGEL(7,IMA1) = RI3.IRIGEL(7,IMA) 492 : 493 : 202 CONTINUE 494 : *-----fin de Boucle sur les matrices de rigidite elementaires de RI2 495 : 496 : GOTO 900 497 : 498 : * 499 : *---- Cas AMOR [0 -C ; C 0] ----------------------------------------* 500 : 300 CONTINUE 501 : * 502 : *---- 2eme quadrant = -\bar{C} ---- 503 : 504 : *-----Boucle sur les matrices de rigidite elementaires de RI2 505 : DO 301 IMA=1,NRIGEL2 506 : 507 : IMA1 = IMA 508 : * COERIG 509 : XCOEF2 = XOME * RI2.COERIG(IMA) 510 : RI1.COERIG(IMA1) = XCOEF2 511 : * IRIGEL(1,:)= meleme 512 : RI1.IRIGEL(1,IMA1) = RI2.IRIGEL(1,IMA) 513 : RI1.IRIGEL(2,IMA1) = RI2.IRIGEL(2,IMA) 514 : 515 : * IRIGEL(3,:) = descr 516 : DES2 = RI2.IRIGEL(3,IMA) 517 : segact,DES2 518 : NLIGRP= DES2.LISINC(/2) 519 : NLIGRD= DES2.LISDUA(/2) 520 : if (NLIGRP.ne.NLIGRD) then 520 : call ERREUR(756) 521 : return 522 : endif 523 : * on crée un nouveau DESCR 2 fois plus long 524 : segini,DES1=DES2 525 : NLIG = NLIGRP 526 : NLIGRP = 2 * NLIG 527 : NLIGRD = 2 * NLIG 528 : segadj,DES1 529 : * on ajoute les noeuds + les noms de la partie imaginaire 530 : do 311 ILIG = 1,NLIG 531 : DES1.NOELEP(NLIG+ILIG) = DES1.NOELEP(ILIG) 532 : DES1.NOELED(NLIG+ILIG) = DES1.NOELED(ILIG) 533 : MOP2 = DES2.LISINC(ILIG) 534 : do IBMO = 1,NBMO 535 : if (MOP2.eq.(MOPRIM(IBMO))) then 536 : if ((DES2.LISDUA(ILIG)).ne.(MODUAL(IBMO))) then 537 : write(6,*) 'non concordance entre l inconnue primale ' 538 : write(6,*) MOP2,' et duale ',DES2.LISDUA(ILIG) 538 : call erreur(717) 539 : return 540 : endif 541 : if ((DES2.NOELEP(ILIG)).ne.(DES2.NOELED(ILIG))) then 542 : write(6,*) 'non concordance entre le noeud primal ' 543 : write(6,*) DES2.NOELEP(ILIG),' et dual ',DES2.NOELED(ILIG) 543 : call erreur(717) 544 : return 545 : endif 546 : * on ajoutes les inconnues imaginaires + les noeuds associés 547 : DES1.LISINC(NLIG+ILIG) = MOPRII(IBMO) 548 : DES1.LISDUA(NLIG+ILIG) = MODUAI(IBMO) 549 : goto 311 550 : endif 551 : enddo 552 : c on n'a pas trouve le primal dans la liste, 553 : c on fabrique les noms primal et dual maginaire depuis reel 554 : c la concordance n'est plus assuree 555 : LMOP2=LONG(MOP2) 556 : if(LMOP2.ge.4) then 557 : write(ioimp,*) 'Pas de composante imaginaire connue ', 558 : & 'associée à ',MOP2 559 : write(ioimp,*) 'Veuillez choisir un nom d inconnue ', 560 : & 'primale standard ou de moins de 4 caracteres' 561 : MOTERR(1:4)=MOP2 561 : call erreur(108) 562 : RETURN 563 : endif 564 : c on construit un nom imaginaire a partir du nom fourni 565 : write(MOP1,FMT='(A,A)') 'I',MOP2(1:3) 566 : write(ioimp,*) '!!! On définit par défaut ',MOP1, 567 : & ' comme inconnue imaginaire de ',MOP2 568 : DES1.LISINC(NLIG+ILIG) = MOP1 569 : c idem pour le dual 570 : MOD2=DES2.LISDUA(ILIG) 571 : LMOD2=LONG(MOD2) 572 : if(LMOD2.ge.4) then 573 : write(ioimp,*) 'Pas de composante imaginaire connue ', 574 : & 'associée à ',MOD2 575 : write(ioimp,*) 'Veuillez choisir un nom d inconnue ', 576 : & 'duale standard ou de moins de 4 caracteres' 577 : MOTERR(1:4)=MOD2 577 : call erreur(108) 578 : RETURN 579 : endif 580 : c on construit un nom imaginaire a partir du nom fourni 581 : write(MOD1,FMT='(A,A)') 'I',MOD2(1:3) 582 : write(ioimp,*) '!!! On définit par défaut ',MOD1, 583 : & ' comme inconnue duale imaginaire de ',MOD2 584 : DES1.LISDUA(NLIG+ILIG) = MOD1 585 : 311 continue 586 : segdes,DES1 587 : RI1.IRIGEL(3,IMA1) = DES1 588 : 589 : * on regarde si UT existe 590 : FLUT= .false. 591 : JG = NLIG 592 : segini,MLENTI 593 : IF (FLAGFO) THEN 594 : do ILIG = 1,NLIG 595 : if ((DES2.LISINC(ILIG)).eq.'UT ') then 596 : LECT(ILIG) = 1 597 : FLUT= .true. 598 : endif 599 : enddo 600 : ENDIF 601 : segdes,DES2 602 : 603 : * IRIGEL(4,:) = XMATRI 604 : * on cree une nouvelle matrice 605 : XMATR2 = RI2.IRIGEL(4,IMA) 606 : segact,XMATR2 607 : NELRIG = XMATR2.RE(/3) 608 : segini,XMATR1 609 : IF (FLUT) THEN 610 : * -- 2eme quadrant = -\bar{C} -- 611 : do j=1,NLIG 612 : j1 = NLIG+j 613 : if (LECT(j).eq.1) then 614 : * la colonne j pointe vers la composante UT 615 : do i=1,NLIG 616 : do k=1,NELRIG 617 : XMATR1.RE(i,j1,k) = XMATR2.RE(i,j,k) 618 : enddo 619 : enddo 620 : else 621 : do i=1,NLIG 622 : do k=1,NELRIG 623 : XMATR1.RE(i,j1,k) = -1.D0 * XMATR2.RE(i,j,k) 624 : enddo 625 : enddo 626 : endif 627 : enddo 628 : ELSE 629 : * -- 2eme quadrant = -{C} -- 630 : do k=1,NELRIG 631 : do j=1,NLIG 632 : j1 = NLIG+j 633 : do i=1,NLIG 634 : XMATR1.RE(i,j1,k) = -1.D0 * XMATR2.RE(i,j,k) 635 : enddo 636 : enddo 637 : enddo 638 : ENDIF 639 : * si possible, tous les quadrants dans la meme sous-rigidite 640 : if (FLRI23) then 641 : XMATR3 = RI3.IRIGEL(4,IMA) 642 : segact,XMATR3 643 : IF (FLUT) THEN 644 : * -- 3eme quadrant = +\bar{C} -- 645 : do j=1,NLIG 646 : if (LECT(j).eq.1) then 647 : * la colonne j pointe vers la composante UT 648 : do i=1,NLIG 649 : i1 = NLIG+i 650 : do k=1,NELRIG 651 : XMATR1.RE(i1,j,k) = -1.D0 * XMATR3.RE(i,j,k) 652 : enddo 653 : enddo 654 : else 655 : do i=1,NLIG 656 : i1 = NLIG+i 657 : do k=1,NELRIG 658 : XMATR1.RE(i1,j,k) = XMATR3.RE(i,j,k) 659 : enddo 660 : enddo 661 : endif 662 : enddo 663 : ELSE 664 : * -- 3eme quadrant = +{C} -- 665 : do k=1,NELRIG 666 : do j=1,NLIG 667 : do i=1,NLIG 668 : i1 = NLIG+i 669 : XMATR1.RE(i1,j,k) = XMATR3.RE(i,j,k) 670 : enddo 671 : enddo 672 : enddo 673 : ENDIF 674 : segdes,XMATR3 675 : endif 676 : segdes,XMATR1,XMATR2 677 : RI1.IRIGEL(4,IMA1) = XMATR1 678 : 679 : segsup,MLENTI 680 : 681 : * IRIGEL(5,:) = nhar 682 : RI1.IRIGEL(5,IMA1) = RI2.IRIGEL(5,IMA) 683 : * IRIGEL(6,:) = < = > 684 : RI1.IRIGEL(6,IMA1) = RI2.IRIGEL(6,IMA) 685 : * IRIGEL(7,:) = symetrie 686 : IF (FLAGFO.or.FLUT) THEN 687 : RI1.IRIGEL(7,IMA1) = 2 688 : ELSEIF((RI2.IRIGEL(7,IMA)).eq.0) THEN 689 : RI1.IRIGEL(7,IMA1) = 1 690 : ELSE 691 : RI1.IRIGEL(7,IMA1) = 2 692 : ENDIF 693 : 694 : 301 CONTINUE 695 : *-----fin de Boucle sur les matrices de rigidite elementaires de RI2 696 : 697 : *---- 3eme quadrant (s'il n'pas pu etre rempli dans la boucle 301) ---- 698 : if(FLRI23) goto 309 699 : 700 : *-----Boucle sur les matrices de rigidite elementaires de RI3 701 : DO 302 IMA=1,NRIGEL3 702 : 703 : IMA1 = NRIGEL2 + IMA 704 : * COERIG 705 : XCOEF3 = XOME * RI3.COERIG(IMA) 706 : RI1.COERIG(IMA1) = XCOEF3 707 : * IRIGEL(1,:)= meleme 708 : RI1.IRIGEL(1,IMA1) = RI3.IRIGEL(1,IMA) 709 : RI1.IRIGEL(2,IMA1) = RI3.IRIGEL(2,IMA) 710 : 711 : * IRIGEL(3,:) = descr 712 : DES3 = RI3.IRIGEL(3,IMA) 713 : segact,DES3 714 : NLIGRP= DES3.LISINC(/2) 715 : NLIGRD= DES3.LISDUA(/2) 716 : if (NLIGRP.ne.NLIGRD) then 716 : call ERREUR(756) 717 : return 718 : endif 719 : * on crée un nouveau DESCR 2 fois plus long 720 : segini,DES1=DES3 721 : NLIG = NLIGRP 722 : NLIGRP = 2 * NLIG 723 : NLIGRD = 2 * NLIG 724 : segadj,DES1 725 : * on ajoute les noeuds + les noms de la partie imaginaire 726 : do 312 ILIG = 1,NLIG 727 : DES1.NOELEP(NLIG+ILIG) = DES1.NOELEP(ILIG) 728 : DES1.NOELED(NLIG+ILIG) = DES1.NOELED(ILIG) 729 : MOP3 = DES3.LISINC(ILIG) 730 : do IBMO = 1,NBMO 731 : if (MOP3.eq.(MOPRIM(IBMO))) then 732 : if ((DES3.LISDUA(ILIG)).ne.(MODUAL(IBMO))) then 733 : write(6,*) 'non concordance entre l inconnue primale ' 734 : write(6,*) DES3.LISINC(ILIG),' et duale ',DES3.LISDUA(ILIG) 734 : call erreur(717) 735 : return 736 : endif 737 : if ((DES3.NOELEP(ILIG)).ne.(DES3.NOELED(ILIG))) then 738 : write(6,*) 'non concordance entre le noeud primal ' 739 : write(6,*) DES3.NOELEP(ILIG),' et dual ',DES3.NOELED(ILIG) 739 : call erreur(717) 740 : return 741 : endif 742 : * on ajoutes les inconnues imaginaires + les noeuds associés 743 : DES1.LISINC(NLIG+ILIG) = MOPRII(IBMO) 744 : DES1.LISDUA(NLIG+ILIG) = MODUAI(IBMO) 745 : goto 312 746 : endif 747 : enddo 748 : c on n'a pas trouve le primal dans la liste, 749 : c on fabrique les noms primal et dual maginaire depuis reel 750 : c la concordance n'est plus assuree 751 : LMOP3=LONG(MOP3) 752 : if(LMOP3.ge.4) then 753 : write(ioimp,*) 'Pas de composante imaginaire connue ', 754 : & 'associée à ',MOP3 755 : write(ioimp,*) 'Veuillez choisir un nom d inconnue ', 756 : & 'primale standard ou de moins de 4 caracteres' 757 : MOTERR(1:4)=MOP3 757 : call erreur(108) 758 : RETURN 759 : endif 760 : c on construit un nom imaginaire a partir du nom fourni 761 : write(MOP1,FMT='(A,A)') 'I',MOP3(1:3) 762 : write(ioimp,*) '!!! On définit par défaut ',MOP1, 763 : & ' comme inconnue imaginaire de ',MOP3 764 : DES1.LISINC(NLIG+ILIG) = MOP1 765 : c idem pour le dual 766 : MOD3=DES3.LISDUA(ILIG) 767 : LMOD3=LONG(MOD3) 768 : if(LMOD3.ge.4) then 769 : write(ioimp,*) 'Pas de composante imaginaire connue ', 770 : & 'associée à ',MOD3 771 : write(ioimp,*) 'Veuillez choisir un nom d inconnue ', 772 : & 'duale standard ou de moins de 4 caracteres' 773 : MOTERR(1:4)=MOD3 773 : call erreur(108) 774 : RETURN 775 : endif 776 : c on construit un nom imaginaire a partir du nom fourni 777 : write(MOD1,FMT='(A,A)') 'I',MOD3(1:3) 778 : write(ioimp,*) '!!! On définit par défaut ',MOD1, 779 : & ' comme inconnue duale imaginaire de ',MOD3 780 : DES1.LISDUA(NLIG+ILIG) = MOD1 781 : 312 continue 782 : segdes,DES1 783 : RI1.IRIGEL(3,IMA1) = DES1 784 : 785 : * on regarde si UT existe 786 : FLUT= .false. 787 : JG = NLIG 788 : segini,MLENTI 789 : IF (FLAGFO) THEN 790 : do ILIG = 1,NLIG 791 : if ((DES3.LISINC(ILIG)).eq.'UT ') then 792 : LECT(ILIG) = 1 793 : endif 794 : enddo 795 : ENDIF 796 : segdes,DES3 797 : 798 : * IRIGEL(4,:) = XMATRI 799 : * on cree une nouvelle matrice 800 : XMATR3 = RI3.IRIGEL(4,IMA) 801 : segact,XMATR3 802 : NELRIG = XMATR3.RE(/3) 803 : segini,XMATR1 804 : IF (FLUT) THEN 805 : * -- 3eme quadrant = +\bar{C} -- 806 : do j=1,NLIG 807 : if (LECT(j).eq.1) then 808 : * la colonne j pointe vers la composante UT 809 : do i=1,NLIG 810 : i1 = NLIG+i 811 : do k=1,NELRIG 812 : XMATR1.RE(i1,j,k) = -1.D0 * XMATR3.RE(i,j,k) 813 : enddo 814 : enddo 815 : else 816 : do i=1,NLIG 817 : i1 = NLIG+i 818 : do k=1,NELRIG 819 : XMATR1.RE(i1,j,k) = XMATR3.RE(i,j,k) 820 : enddo 821 : enddo 822 : endif 823 : enddo 824 : ELSE 825 : * -- 3eme quadrant = +{C} -- 826 : do k=1,NELRIG 827 : do j=1,NLIG 828 : do i=1,NLIG 829 : i1 = NLIG+i 830 : XMATR1.RE(i1,j,k) = XMATR3.RE(i,j,k) 831 : enddo 832 : enddo 833 : enddo 834 : ENDIF 835 : segdes,XMATR1,XMATR3 836 : RI1.IRIGEL(4,IMA1) = XMATR1 837 : 838 : segsup,MLENTI 839 : 840 : * IRIGEL(5,:) = +nhar 841 : RI1.IRIGEL(5,IMA1) = abs(RI3.IRIGEL(5,IMA)) 842 : * IRIGEL(6,:) = < = > 843 : RI1.IRIGEL(6,IMA1) = RI3.IRIGEL(6,IMA) 844 : * IRIGEL(7,:) = symetrie (2: quelconque) 845 : RI1.IRIGEL(7,IMA1) = 2 846 : 847 : 302 CONTINUE 848 : *-----fin de Boucle sur les matrices de rigidite elementaires de RI2 849 : 850 : 309 CONTINUE 851 : 852 : GOTO 900 853 : 854 : 855 : * 856 : *---- Cas QUELconque [a*K b*K ; c*K d*K] ----------------------------------------* 857 : 400 CONTINUE 858 : 859 : *-----Boucle sur les matrices de rigidite elementaires de RI2 860 : DO 401 IMA=1,NRIGEL2 861 : 862 : IMA1 = IMA 863 : * COERIG 864 : XCOEF2 = RI2.COERIG(IMA) 865 : RI1.COERIG(IMA1) = XCOEF2 866 : * IRIGEL(1,:)= meleme 867 : RI1.IRIGEL(1,IMA1) = RI2.IRIGEL(1,IMA) 868 : RI1.IRIGEL(2,IMA1) = RI2.IRIGEL(2,IMA) 869 : 870 : * IRIGEL(3,:) = descr 871 : DES2 = RI2.IRIGEL(3,IMA) 872 : segact,DES2 873 : NLIGRP= DES2.LISINC(/2) 874 : NLIGRD= DES2.LISDUA(/2) 875 : if (NLIGRP.ne.NLIGRD) then 875 : call ERREUR(756) 876 : return 877 : endif 878 : * on crée un nouveau descr 2 fois plus long 879 : segini,DES1=DES2 880 : NLIG = NLIGRP 881 : NLIGRP = 2 * NLIG 882 : NLIGRD = 2 * NLIG 883 : segadj,DES1 884 : do ILIG = 1,NLIG 885 : do IBMO = 1,NBMO 886 : if ((DES2.LISINC(ILIG)).eq.(MOPRIM(IBMO))) then 887 : if ((DES2.LISDUA(ILIG)).ne.(MODUAL(IBMO))) then 888 : write(6,*) 'non concordance entre l inconnue primale ' 889 : write(6,*) DES2.LISINC(ILIG),' et duale ',DES2.LISDUA(ILIG) 889 : call erreur(717) 890 : return 891 : endif 892 : * on ajoutes les inconnues imaginaires + les noeuds associés 893 : DES1.LISINC(NLIG+ILIG) = MOPRII(IBMO) 894 : DES1.NOELEP(NLIG+ILIG) = DES1.NOELEP(ILIG) 895 : DES1.LISDUA(NLIG+ILIG) = MODUAI(IBMO) 896 : DES1.NOELED(NLIG+ILIG) = DES1.NOELED(ILIG) 897 : endif 898 : enddo 899 : enddo 900 : segdes,DES1 901 : RI1.IRIGEL(3,IMA1) = DES1 902 : 903 : * IRIGEL(4,:) = XMATRI 904 : * on cree une nouvelle matrice 905 : XMATR2 = RI2.IRIGEL(4,IMA) 906 : segact,XMATR2 907 : NELRIG = XMATR2.RE(/3) 908 : segini,XMATR1 909 : if(COEFA.eq.0.D0) goto 411 910 : * -- 1er quadrant -- 911 : do j=1,NLIG 912 : do i=1,NLIG 913 : do k=1,NELRIG 914 : XMATR1.RE(i,j,k) = COEFA * XMATR2.RE(i,j,k) 915 : enddo 916 : enddo 917 : enddo 918 : 411 continue 919 : if(COEFB.eq.0.D0) goto 412 920 : * -- 2nd quadrant -- 921 : do j=1,NLIG 922 : j1=NLIG+j 923 : do i=1,NLIG 924 : do k=1,NELRIG 925 : XMATR1.RE(i,j1,k) = COEFB * XMATR2.RE(i,j,k) 926 : enddo 927 : enddo 928 : enddo 929 : 412 continue 930 : if(COEFC.eq.0.D0) goto 413 931 : * -- 3eme quadrant -- 932 : do i=1,NLIG 933 : i1 = NLIG+i 934 : do j=1,NLIG 935 : do k=1,NELRIG 936 : XMATR1.RE(i1,j,k) = COEFC * XMATR2.RE(i,j,k) 937 : enddo 938 : enddo 939 : enddo 940 : 413 continue 941 : if(COEFD.eq.0.D0) goto 414 942 : * -- 2nd quadrant -- 943 : do i=1,NLIG 944 : i1 = NLIG+i 945 : do j=1,NLIG 946 : j1=NLIG+j 947 : do k=1,NELRIG 948 : XMATR1.RE(i1,j1,k) = COEFD * XMATR2.RE(i,j,k) 949 : enddo 950 : enddo 951 : enddo 952 : 414 continue 953 : 954 : segdes,XMATR1,XMATR2 955 : RI1.IRIGEL(4,IMA1) = XMATR1 956 : 957 : * IRIGEL(5,:) = nhar 958 : RI1.IRIGEL(5,IMA1) = RI2.IRIGEL(5,IMA) 959 : * IRIGEL(6,:) = < = > 960 : RI1.IRIGEL(6,IMA1) = RI2.IRIGEL(6,IMA) 961 : * IRIGEL(7,:) = symetrie 962 : RI1.IRIGEL(7,IMA1) = 2 963 : 964 : 401 CONTINUE 965 : *-----fin de Boucle sur les matrices de rigidite elementaires de RI2 966 : 967 : GOTO 900 968 : 969 : 970 : *---- Desactivations des objets -------------------------------------* 971 : 900 CONTINUE 972 : * 973 : SEGDES,RI1,RI2 974 : IF(FLAGFO) SEGDES,RI3 975 : 976 : *---- Verification de l'unicite de la relation supportée par un 977 : * multiplicateur de lagrange s'il existe -------------* 978 : 979 : 980 : 981 : * 982 : *---- Ecriture de la rigidite de sortie -----------------------------* 983 : IPOIRF = RI1 983 : IF(IRET.EQ.1) CALL ECROBJ('RIGIDITE',IPOIRF) 984 : * 985 : RETURN 986 : * 987 : END 988 : 989 : 990 : 991 : 992 :
© Cast3M 2003 - All rights reserved.
Disclaimer