1 : C ASSEM1 SOURCE PV 09/11/16 21:15:00 6538 2 : SUBROUTINE ASSEM1 ( IPOIRI,MMATRX,INUINY,ITOPOY,IMINIY,IPOY, 3 : 1 INCTRY,IITOPY) 4 : C 5 : C CE SUBROUTINE SERT A L'ASSEMBLAGE DE MATRICES SYMETRIQUES 6 : C EN VUE D'UNE INVERSION PAR UNE METHODE DE KROUT 7 : C 8 : C EN ENTREE: 9 : C **** IPOIRI: POINTEUR SUR OBJET MRIGIDITE,NON MODIFIE 10 : C EN SORTIE: 11 : C **** INUINV IMINI ITOPO IPOY INCTRY SONT DES POINTEURS DES SEGMENTS 12 : C DE TRAVAIL SERVANT A L'ASSEMBLAGE ILS SONT DETRUITS EN FIN 13 : C D'ASSEMBLAGE OU DE TRIANGULARISATION 14 : C **** MMATRI EST LE POINTEUR DE L'OBJET FUTUR MATRICE TRIANGULARISEE. 15 : IMPLICIT INTEGER(I-N) 16 : -INC CCOPTIO 17 : -INC SMELEME 18 : -INC SMCOORD 19 : SEGMENT,IMIN(NNOE) 20 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 21 : C SEGMENT IPB(NLIGRE) 22 : C 23 : -INC SMRIGID 24 : C 25 : -INC SMMATRI 26 : C 27 : SEGMENT,INUINV(NNGLOB) 28 : SEGMENT,ITOPO(IENNO) 29 : SEGMENT,IITOP(NNOE+1) 30 : SEGMENT,IMINI(INC) 31 : SEGMENT,IPOS(NNOE1) 32 : SEGMENT,INCTRR(NIRI) 33 : SEGMENT,INCTRA(NLIGRE) 34 : C 35 : C **** CES TABLEAUX SERVENT AU REPERAGE DE LA MATRICE POUR L'ASSEMBLAG 36 : C **** IL SERONT TOUS SUPPRIMES EN FIN D'ASSEMBLAGE. 37 : C 38 : C 39 : C **** MAXINC= MAXIMUM DE COMPOSANTES CONCERNANT UN NOEUD 40 : C 41 : C 42 : C **** IITOP(K)=I LE 1ER ELEMENT TOUCHANT LE NOEUD K SE TROUVE EN 43 : C IEME POSITION DANS ITOPO 44 : C **** ITOPO(I)=L: LE 1ER ELEMENT TOUCHANT LE K EME NOEUD DE LA 45 : C ITOPO(I+1)=M MATRICE EST LE LIEME DE L'OBJET GEOMETRIE 46 : C DEFINI PAR LE POINTEUR M 47 : C **** IPOS(I)=J : LA 1 ERE INCONNUE DU NOEUD I EST EN J+1 EME 48 : C POSITION 49 : C **** IMINI(I)=J LA PLUS PETITE INCONNUE QUI EST RELIEE A LA IEME 50 : C EST L'INCONNUE J. 51 : C **** INUINV(I)=J J EST LE NOUVEAU NUMERO DU NOEUD I 52 : C 53 : * DATA MOALFA/'ALFA'/ 54 : CHARACTER*4 CNOHA 55 : DATA CNOHA/'NOHA'/ 56 : DATA IPOIN/1/ 57 : READ (CNOHA,FMT='(A4)') NOHA 58 : NNGLOB=XCOOR(/1)/(IDIM+1) 59 : MRIGID=IPOIRI 60 : SEGACT,MRIGID 61 : NNVA=IRIGEL(/2) 62 : NIRI=NNVA 63 : SEGINI,INCTRR 64 : MVA=IRIGEL(/1) 65 : MELEME=IRIGEL(1,1) 66 : SEGACT MELEME 67 : IF(ITYPEL.NE.27) GO TO 801 68 : SEGDES MELEME 69 : C 70 : C **** ASSEMBLAGE DANS LE CAS DE L'ANALYSE MODALE. ON COMPTE LES POINTS 71 : C **** DANS ICPR 72 : C 73 : SEGINI INUINV,ICPR 74 : IKI=0 75 : DO 700 I=1,NNVA 76 : MELEME=IRIGEL(1,I) 77 : SEGACT MELEME 78 : NBNN=NUM(/1) 79 : NBELEM=NUM(/2) 80 : DO 701 I1=1,NBELEM 81 : DO 701 I2=1,NBNN 82 : IP1=NUM(I2,I1) 83 : IF(ICPR(IP1).NE.0) GO TO 701 84 : IKI=IKI+1 85 : ICPR(IP1)=IKI 86 : 701 CONTINUE 87 : SEGDES MELEME 88 : 700 CONTINUE 89 : C 90 : C **** FABRICATION DU TABLEAU INUINV 91 : C **** ON MET LES POINTS QUI ONT POUR INCONNUE ALFA EN TETE 92 : C 93 : NNOE=IKI 94 : NALFA=0 95 : NBETA=0 96 : DO 710 I=1,NNVA 97 : MELEME=IRIGEL(1,I) 98 : DESCR =IRIGEL(3,I) 99 : SEGACT MELEME,DESCR 100 : NBNN=NUM(/1) 101 : NBELEM=NUM(/2) 102 : NLIGRE=LISINC(/2) 103 : * SEGINI IPB A QUOI CA SERT PV 104 : * DO 703 K=1,NLIGRE 105 : * IPB(NOELEP(K))=K 106 : *703 CONTINUE 107 : DO 711 I1=1,NBELEM 108 : DO 711 I2=1,NBNN 109 : IP1=NUM(I2,I1) 110 : IF(ICPR(IP1).EQ.0) GO TO 711 111 : * IJA=IPB(I2) 112 : * IF(IJA.NE.MOALFA) GO TO 715 113 : * NALFA=NALFA+1 114 : * IKI=NALFA 115 : * GO TO 716 116 : 715 CONTINUE 117 : NBETA=NBETA+1 118 : IKI=NNOE-NBETA+1 119 : 716 CONTINUE 120 : INUINV(IP1)=IKI 121 : ICPR(IP1)=0 122 : 711 CONTINUE 123 : SEGDES MELEME,DESCR 124 : * SEGSUP IPB 125 : 710 CONTINUE 126 : SEGSUP ICPR 127 : ICDOUR=NNOE 128 : GO TO 800 129 : C 130 : C **** ON FABRIQUE UN NOUVEL OBJET GEOMETRIE CONTENANT TOUTES LES 131 : C **** GEOMETRIES ELEMENTAIRES. CET OBJET CONTIENT NNVA OBJETS 132 : C **** GEOMETRIQUES ELEMENTAIRES. PUIS ON ENVOIE DANS NUMOPT QUI 133 : C **** FOURNIT EN RETOUR INUINV(NUM(I,J))=K DONNE LE NOUVEAU 134 : C **** NUMERO LOCAL DU POINT NUM(I,J).K VARIE DE 1 A ICDOUR. 135 : C **** LE PREMIER NOEUD DE L'OBJET GEOMETRIQUE EST LE PREMIER NOEUD 136 : C **** DE LA MATRICE, ETC... 137 : C 138 : 801 CONTINUE 139 : IKK=1 140 : 722 CONTINUE 141 : MELEME=IRIGEL(1,IKK) 142 : SEGACT,MELEME 143 : DESCR=IRIGEL(3,IKK) 144 : SEGACT,DESCR 145 : NLIGRE=LISINC(/2) 146 : DO 720 K=1,NLIGRE 147 : IF(LISINC(K).NE.'LX ') GO TO 721 148 : 720 CONTINUE 149 : SEGDES,MELEME 150 : SEGDES,DESCR 151 : IKK=IKK+1 152 : IF(IKK.LE.NNVA) GO TO 722 153 : DO 4862 I=1,NNVA 154 : MELEME= IRIGEL(1,I) 155 : SEGACT MELEME 156 : if (num(/2).eq.0) goto 4862 157 : IF(ITYPEL.EQ.22) THEN 158 : DESCR=IRIGEL(3,I ) 159 : SEGACT,DESCR 160 : K = 3 161 : if (num(/2).le.2) k=num(/2) 162 : GO TO 4863 163 : ELSE 164 : SEGDES MELEME 165 : ENDIF 166 : 4862 CONTINUE 167 : K=1 168 : do ir=1,nnva 169 : MELEME= IRIGEL(1,ir) 170 : segact meleme 171 : if (num(/2).ne.0.and.itypel.ne.22) goto 4864 172 : enddo 172 : call erreur(5) 173 : 4864 continue 174 : DESCR= IRIGEL(3,ir) 175 : SEGACT MELEME,DESCR 176 : 4863 CONTINUE 177 : 721 IA=NOELEP(K) 178 : I1=NUM(IA,1) 179 : NBSOUS=0 180 : NBNN=1 181 : NBREF=0 182 : NBELEM=1 183 : SEGDES,MELEME,DESCR 184 : SEGINI,MELEME 185 : ITYPEL=1 186 : NUM(1,1)=I1 187 : SEGDES,MELEME 188 : IMELP=MELEME 189 : NBSOUS=NNVA+1 190 : NBREF=0 191 : NBNN=0 192 : NBELEM=0 193 : SEGINI,MELEME 194 : LISOUS(1)=IMELP 195 : DO 12 I=1,NNVA 196 : * write (6,*) ' dans assem1 ',irigel(6,i) 197 : LISOUS(I+1)=IRIGEL(1,I) 198 : * cas du frottement, on met -22 dans itypel pour le savoir dans numopt 199 : IF (IRIGEL(6,i).eq.2) then 200 : IPT8=LISOUS(I+1) 201 : segact IPT8*mod 202 : ipt8.itypel=-22 203 : endif 204 : 12 CONTINUE 205 : SEGDES,MELEME 206 : ICDOUR=0 207 : SEGINI,INUINV 208 : SEGDES,INUINV 208 : CALL NUMOPT(MELEME,INUINV,ICDOUR) 209 : * 210 : * deplacer les multiplicateur present dans les super elements 211 : do 50 ir=1,nnva 212 : ipt5= IRIGEL(1,ir) 213 : segact ipt5 214 : if (ipt5.itypel.ne.28) goto 50 215 : descr=irigel(3,ir) 216 : segact descr 217 : * recherche du plus haut noeud non mult 218 : do 51 iel=1,ipt5.num(/2) 219 : ihaut=0 220 : do 55 il=1,lisinc(/2) 221 : * write (6,*) ' lisinc ',il,lisinc(il) 222 : if (lisinc(il).eq.'LX ') goto 55 223 : ihaut=max(ihaut,inuinv(ipt5.num(noelep(il),iel))) 224 : 55 continue 225 : do 60 il=1,lisinc(/2) 226 : if (lisinc(il).eq.'LX ') then 227 : * un mult ! on le deplace en ihaut 228 : ipmult=inuinv(ipt5.num(noelep(il),iel)) 229 : * write (6,*) ' assem1 ipmult ihaut ',ipmult,ihaut 230 : if (ipmult.gt.ihaut) goto 60 231 : do j=1,inuinv(/1) 232 : if (inuinv(j).gt.ipmult.and.inuinv(j).le.ihaut) 233 : > inuinv(j)=inuinv(j)-1 234 : enddo 235 : inuinv(ipt5.num(noelep(il),iel))=ihaut 236 : endif 237 : 60 continue 238 : 51 continue 239 : 50 continue 240 : * 241 : segact meleme 242 : do i=1,lisous(/1) 243 : ipt8=lisous(i) 244 : segact ipt8 245 : if (ipt8.itypel.eq.-22) then 246 : segact ipt8*mod 247 : ipt8.itypel=22 248 : endif 249 : segdes ipt8 250 : enddo 251 : segdes meleme 252 : SEGACT INUINV 253 : SEGSUP,MELEME 254 : * MELEME=IMELP 255 : * SEGSUP,MELEME 256 : C 257 : C **** CREATION D'UN OBJET GEOMETRIE QU'IL FAUDRA CHANGER EN CAS DE 258 : C **** RENUMEROTATION GENERALE.ON PROFITE DE LA BOUCLE POUR CREE LE 259 : C **** TABLEAU IMIN(I)=J QUI DIT QUE J ELEMENTS TOUCHE LE NOEUD I(NU- 260 : C **** MEROTATION LOCALE). 261 : C 262 : 800 CONTINUE 263 : NNOE=ICDOUR 264 : SEGINI,IMIN 265 : NNOE1=NNOE+1 266 : SEGINI,IPOS 267 : NBSOUS=0 268 : NBREF=0 269 : NBNN=1 270 : NBELEM=ICDOUR 271 : SEGINI,IPT1 272 : IPT1.ITYPEL=IPOIN 273 : DO 16 IRI=1,NNVA 274 : * DO 170 I=1,NNOE 275 : * 170 IPOS(I)=0 276 : MELEME=IRIGEL(1,IRI) 277 : SEGACT,MELEME 278 : N1=NUM(/1) 279 : N2=NUM(/2) 280 : DO 17 I=1,N2 281 : DO 17 J=1,N1 282 : K=NUM(J,I) 283 : M=INUINV(K) 284 : IF(IPOS(M).NE.I) THEN 285 : IMIN(M)=IMIN(M)+1 286 : IPT1.NUM(1,M)=K 287 : IPOS(M)=I 288 : ENDIF 289 : 17 CONTINUE 290 : DO 171 I=1,N2 291 : DO 171 J=1,N1 292 : K=NUM(J,I) 293 : M=INUINV(K) 294 : ipos(m)=0 295 : 171 continue 296 : SEGDES,MELEME 297 : 16 CONTINUE 298 : C 299 : C **** INITIALISATION DE ITOPO. ON UTILISE IMIN POUR SE POSITIONNER 300 : C **** DANS ITOPO . 301 : C 302 : SEGINI,IITOP 303 : IITOP(1)=1 304 : DO 18 I=1,NNOE 305 : IITOP(I+1)=IMIN(I)* 2 + IITOP(I) 306 : 18 CONTINUE 307 : DO 19 I=1,NNOE 308 : 19 IMIN(I)=0 309 : IENNO=IITOP(NNOE+1) 310 : SEGINI,ITOPO 311 : DO 21 IRI=1,NNVA 312 : * DO 220 I=1,NNOE 313 : * 220 IPOS(I)=0 314 : C DESCR=IRIGEL(3,IRI) 315 : C SEGACT,DESCR 316 : C N3=LISINC(/2) 317 : C SEGDES,DESCR 318 : MELEME=IRIGEL(1,IRI) 319 : SEGACT,MELEME 320 : N1=NUM(/1) 321 : N2=NUM(/2) 322 : DO 22 I=1,N2 323 : DO 22 J=1,N1 324 : M=INUINV(NUM(J,I)) 325 : IF(IPOS(M).NE.I) THEN 326 : IMIN(M)=IMIN(M)+1 327 : IUY= 2* ( IMIN(M)-1 ) + IITOP(M) 328 : ITOPO(IUY)=I 329 : ITOPO(IUY+1)=IRI 330 : IPOS(M)=I 331 : ENDIF 332 : 22 CONTINUE 333 : DO 221 I=1,N2 334 : DO 221 J=1,N1 335 : M=INUINV(NUM(J,I)) 336 : IPOS(M)=0 337 : 221 CONTINUE 338 : SEGDES,MELEME 339 : 21 CONTINUE 340 : C 341 : C RECHERCHE DE LA VALEUR PAR DEFAUT DE L'HARMONIQUE DANS LE CAS 342 : C DE L'UTILISATION DE " OPTION MODE FOUR NOHAR " 343 : C 344 : DO 230 IRI=1,NNVA 345 : IHARIR=IRIGEL(5,IRI) 346 : IF( IHARIR . NE. NOHA) THEN 347 : IARDEF = IHARIR 348 : GO TO 231 349 : ENDIF 350 : 230 CONTINUE 350 : CALL ERREUR ( 21) 351 : RETURN 352 : 231 CONTINUE 353 : DO 232 IRI=1,NNVA 354 : IF( IRIGEL(5,IRI) .EQ.NOHA) GO TO 232 355 : IF( IRIGEL(5,IRI).EQ.IARDEF ) GO TO 232 355 : CALL ERREUR (21) 356 : RETURN 357 : 232 CONTINUE 358 : C 359 : C **** RECHERCHE DE LA VALEUR MAXINC QUI PERMET DE DIMENSIONNER INCPOS 360 : C 361 : SEGINI,MIDUA 362 : SEGINI,MIMIK 363 : SEGINI,MHARK 364 : DESCR=IRIGEL(3,1) 365 : SEGACT,DESCR 366 : IMIK(**)=LISINC(1) 367 : IAAR=IRIGEL(5,1) 368 : IF(IAAR.EQ.NOHA) IAAR = IARDEF 369 : IHAR(**)= IAAR 370 : IDUA(**)=LISDUA(1) 371 : MAXINC=1 372 : DO 23 IRI=1,NNVA 373 : DESCR=IRIGEL(3,IRI) 374 : IHARIR=IRIGEL(5,IRI) 375 : IF(IHARIR. EQ.NOHA ) IHARIR = IARDEF 376 : SEGACT,DESCR 377 : NLIGRE=LISINC(/2) 378 : DO 26 I=1,NLIGRE 379 : DO 24 J=1,MAXINC 380 : IF(IMIK(J).NE.LISINC(I)) GO TO 24 381 : IF(IHAR(J).EQ.IHARIR) GO TO 26 382 : 24 CONTINUE 383 : MAXINC=MAXINC+1 384 : IHAR(**)=IHARIR 385 : IMIK(**)=LISINC(I) 386 : IDUA(**)=LISDUA(I) 387 : 26 CONTINUE 388 : SEGDES,DESCR 389 : 23 CONTINUE 390 : NDUA=IDUA(/2) 391 : C 392 : C **** INITIALISATION DE INCPOS ET DE INCTRA. 393 : C 394 : MAXI=MAXINC 395 : SEGINI,MINCPO 396 : DO 29 IRI=1,NNVA 397 : DESCR=IRIGEL(3,IRI) 398 : IHARIR=IRIGEL(5,1) 399 : IF(IHARIR.EQ.NOHA ) IHARIR = IARDEF 400 : SEGACT,DESCR 401 : MELEME=IRIGEL(1,IRI) 402 : SEGACT,MELEME 403 : NLIGRE=LISINC(/2) 404 : SEGINI,INCTRA 405 : INCTRR(IRI)=INCTRA 406 : N2=NUM(/2) 407 : IADS=XCOOR(/1)/(IDIM+1) 408 : DO 34 J=1,NLIGRE 409 : DO 33 K=1,MAXINC 410 : IF(LISINC(J).NE.IMIK(K)) GO TO 33 411 : IF(IHAR(K).EQ.IHARIR) GO TO 32 412 : 33 CONTINUE 413 : 32 CONTINUE 414 : INCTRA(J)=K 415 : DO 31 I=1,N2 416 : IJ=INUINV(NUM(NOELEP(J),I)) 417 : 31 INCPO(K,IJ)=1 418 : 34 CONTINUE 419 : SEGDES,DESCR 420 : SEGDES,INCTRA 421 : SEGDES,MELEME 422 : 29 CONTINUE 423 : C 424 : C **** INITIALISATION DE IPOS 425 : C 426 : IPOS(1)=0 427 : NA=0 428 : DO 37 I=1,NNOE 429 : DO 35 K=1,MAXINC 430 : IF(INCPO(K,I).EQ.0) GO TO 35 431 : NA=NA+1 432 : INCPO(K,I)=NA 433 : 35 CONTINUE 434 : IPOS(I+1)=NA 435 : 37 CONTINUE 436 : SEGDES,MIDUA,MIMIK,MHARK 437 : C 438 : C **** INITIALISATION DE IMINI 439 : C 440 : INC=NA 441 : SEGINI,IMINI 442 : INC1=INC+1 443 : DO 38 I=1,INC 444 : IMINI(I)=INC1 445 : 38 CONTINUE 446 : DO 40 IRI=1,NNVA 447 : MELEME=IRIGEL(1,IRI) 448 : SEGACT,MELEME 449 : DESCR=IRIGEL(3,IRI) 450 : SEGACT,DESCR 451 : INCTRA=INCTRR(IRI) 452 : SEGACT,INCTRA 453 : N1=NOELEP(/1) 454 : N2=NUM(/2) 455 : N3=NUM(/1) 456 : DO 41 I=1,N2 457 : IJ=NNOE+1 458 : DO 42 J=1,N3 459 : IJ1=INUINV(NUM(J,I)) 460 : IJ=MIN(IJ1,IJ) 461 : 42 CONTINUE 462 : IPR=IPOS(IJ)+1 463 : DO 43 JJ=1,N1 464 : IJA=INUINV(NUM(NOELEP(JJ),I)) 465 : IJB=INCTRA(JJ) 466 : IK=INCPO(IJB,IJA) 467 : IMINI(IK)=MIN(IMINI(IK),IPR) 468 : 43 CONTINUE 469 : 41 CONTINUE 470 : SEGDES,DESCR 471 : SEGDES,INCTRA 472 : SEGDES,MELEME 473 : 40 CONTINUE 474 : SEGDES,MRIGID 475 : SEGDES,IPOS 476 : SEGDES,IMINI 477 : SEGDES,ITOPO 478 : SEGDES,IITOP 479 : SEGDES,INUINV 480 : SEGDES,IPT1 481 : SEGDES,MINCPO 482 : SEGSUP,IMIN 483 : SEGDES,INCTRR 484 : INCTRY=INCTRR 485 : SEGINI,MMATRI 486 : NENS=0 487 : IGEOMA=IPT1 488 : IIDUA=MIDUA 489 : IINCPO=MINCPO 490 : IIMIK=MIMIK 491 : IHARK=MHARK 492 : INUINY=INUINV 493 : ITOPOY=ITOPO 494 : IITOPY=IITOP 495 : MMATRX=MMATRI 496 : IMINIY=IMINI 497 : IPOY=IPOS 498 : SEGDES,MMATRI 499 : RETURN 500 : END 501 : 502 : 503 : 504 : 505 : 506 : 507 : 508 : 509 : 510 : 511 : 512 : 513 : 514 : 515 :
© Cast3M 2003 - All rights reserved.
Disclaimer