1 : C RIMA SOURCE GOUNAND 13/01/03 21:15:00 7660 2 : subroutine rima 3 : 4 : ******************************************** 5 : * traduction objet rigi en matrik 6 : * ou matrik en rigi 7 : * 8 : ******************************************* 9 : 10 : IMPLICIT INTEGER(I-N) 11 : IMPLICIT REAL*8 (A-H,O-Z) 12 : 13 : -INC CCOPTIO 14 : -INC SMLENTI 15 : POINTEUR NOFSET.MLENTI 16 : -INC SMELEME 17 : POINTEUR MELPRI.MELEME,MELDUA.MELEME 18 : POINTEUR SMLPRI.MELEME,SMLDUA.MELEME 19 : -INC SMRIGID 20 : -INC SMLMOTS 21 : *INC SMMATRIK 22 : 23 : SEGMENT MATRIK 24 : REAL*8 COEMTK(NMATRI) 25 : INTEGER jRIGEL(NRIGE,NMATRI) 26 : INTEGER KSYM,KMINC,KMINCP,KMINCD,KIZM 27 : INTEGER KISPGT,KISPGP,KISPGD 28 : INTEGER KNTTT,KNTTP,KNTTD 29 : INTEGER KIDMAT(NKID) 30 : INTEGER KKMMT(NKMT) 31 : ENDSEGMENT 32 : 33 : SEGMENT jMATRI 34 : CHARACTER*8 LISPRj(NBME),LISDUb(NBME) 35 : INTEGER LIZAFM(NBSOUS,NBME) 36 : INTEGER KSPGP,KSPGD 37 : ENDSEGMENT 38 : 39 : C Stokage matrices elementaires non assemblees (valeurs) 40 : SEGMENT IZAFM 41 : REAL*8 AM(NBEL,NP,MP) 42 : ENDSEGMENT 43 : POINTEUR IPM1.IZAFM,IPM2.IZAFM,IPM3.IZAFM,IPM4.IZAFM 44 : POINTEUR IPM5.IZAFM,IPM6.IZAFM,IPM7.IZAFM,IPM8.IZAFM 45 : POINTEUR IPM9.IZAFM 46 : 47 : C Reperage des inconnues 48 : SEGMENT MINC 49 : CHARACTER*8 LISjNC(NBI) 50 : INTEGER NPOS(NPT+1) 51 : INTEGER MPOS(NPT,NBI+1) 52 : ENDSEGMENT 53 : POINTEUR MINCP.MINC,MINCD.MINC 54 : 55 : SEGMENT PMORS 56 : INTEGER IA (NTT+1) 57 : INTEGER JA (NJA) 58 : ENDSEGMENT 59 : POINTEUR PMS1.PMORS,PMS2.PMORS 60 : 61 : C Segment de stokage 62 : SEGMENT IZA 63 : REAL*8 A(NBVA) 64 : ENDSEGMENT 65 : POINTEUR IZA1.IZA,IZA2.IZA,IZAU.IZA,IZAL.IZA,ISA.IZA 66 : 67 : SEGMENT IDMAT 68 : INTEGER KZA(NTT),NUIA(NTT,2) 69 : INTEGER NUAN(NPT),NUNA(NPT) 70 : INTEGER IDIAG 71 : INTEGER IDESCL(NBLK) 72 : INTEGER IDESCU(NBLK) 73 : INTEGER NLDBLK(NBLK+1) 74 : ENDSEGMENT 75 : 76 : C******************************************************************* 77 : C 78 : C REPERAGE ET STOKAGE DES MATRICES ELEMENTAIRES puis assemblees 79 : C (description par sous-zone associees a un operateur) 80 : C 81 : C IRIGEL(1,I) : POINTEUR SUR L'OBJET GEOMETRIE (Inconnues primales) 82 : C IRIGEL(2,I) : POINTEUR SUR L'OBJET GEOMETRIE (Inconnues duales) 83 : C IRIGEL(3,I) : Non utilise (POINTEUR SUR LE SEGMENT DESCRIPTIF D'UNE 84 : C MATRICE ELEMENTAIRE.(SEGMENT DESCR) 85 : C IRIGEL(4,I) : POINTEUR SUR LE SEGMENT CONTENANT LES POINTEURS 86 : C DES MATRICES DE MRIGIDITE DE CHAQUE ELEMENTS. 87 : C (SEGMENT IMATRI) 88 : C IRIGEL(5,I) : Non utilise 89 : C IRIGEL(6,I) : Non utilise 90 : C IRIGEL(7,1) : 0 LA MATRICE EST SYMETRIQUE 91 : C : 1 LA MATRICE EST ANTISYMETRIQUE 92 : C : 2 LA MATRICE EST NON SYMETRIQUE 93 : C : 3 LA MATRICE EST RECTANGULAIRE avec SPGP # SPGD 94 : C : 4 LA MATRICE EST type 3 et CCt (on ne stoke que C) 95 : C : 5 LA MATRICE EST diagonale 96 : C : 6 LA MATRICE EST deja assemblee en morse 97 : 98 : C KSIM =0 matrice symetrique =2 matrice non symetrique 99 : C KMINC , KMINCP , KMINCD : pointeur sur MINC repartition des inconnues 100 : C totales primales et duales PROFKS PKINC 101 : C KIZM : pointeur sur les connectivites globales 102 : C KISPGT KISPGP KISPGD ; SPG assemble pour inc totales,prim et dua 103 : C KNTTT KNTTP KNTTD ; nb d'inconnues total 104 : 105 : 106 : C KIDMAT: pointeur sur stokage bloc IDMAT (Cholevski) TRIAKS 107 : C KS2B : pointeur sur second membre(IZA)cree ds PROFKS calcule ds KASMBR 108 : C KMORS : pointeur sur profil Morse(PMORS) ASSMT (KALMOR) 109 : C KISA : pointeur sur stokage Morse(IZA) ASSMT (KALMOR) 110 : C KMRST : pointeur sur profil Morse(PMORS)de AAt PROFKS(KALMOR) 111 : C KIST : pointeur sur stokage Morse(IZA) de AAt PROFKS(KALMOR) 112 : C KCLIM : pointeur sur stokage C lim (CHPT) 113 : C KTRING: 0 pas triangulée 1 triangulée 114 : 115 : C nkid=9 : IDMATP,IDMATD,KS2B,KMORS,KISA,KMRST,KIST,KCLIM,KTRING 116 : 117 : C LIZAFM(NBSOUS,.) description par sous-objet geometrique -> IZAFM 118 : C KSPGP , KSPGD : SPG pour les inconnues primales et duales 119 : C nkmt=7 : KMMT,MATRIU,MATRIP,IZDU,IZDP,IZFU,IZFP 120 : C (IZA)(IZA)(IZA)(IZA) 121 : * NPT nb de noeud NBI nb de composantes total NTT nb total de DDL 122 : * MPOS(NPT,NBI+1) = 0 si l'inconnue j n est pas defini au noeud i 123 : * sinon = k rang de cette inconnue pour le noeud i 124 : * MPOS(i,NBI+1) nb d'inconnues au noeud i 125 : * NPOS(NPT) Position de la 1ere inconnue du noeud i 126 : * NPOS et MPOS sont donnes ds la numerotation optimisee 127 : * KZA(NTT) Longueur de chaque ligne de la matrice (diag comprise) 128 : * NUIA(NTT,2) 1/ numero du bloc dans lequel se trouve la ligne i de la 129 : * matrice 130 : * 2/ position du debut de la ligne dans le segment IZA - 1 131 : 132 : C******************************************************************* 133 : 134 : segment iztra 135 : character*4 lisp(l1) 136 : integer itab(l1,l2),ltab(l1) 137 : endsegment 138 : segment jztra 139 : character*4 lisd(l3) 140 : integer jtab(l3,l2),ktab(l3) 141 : endsegment 142 : 143 : 144 : character*8 type,typp 145 : character*4 nomi 146 : * WRITE(IOIMP,*) ' entree dans rima' 147 : impj = 1 148 : * impj = 0 149 : impr=0 150 : 150 : call quetyp(typp,0,iret) 151 : * WRITE(IOIMP,*)' typp ',typp 152 : 153 : if(typp.eq.'MATRIK')then 154 : type = typp 154 : CALL LIROBJ(TYPE,MATRIK,1,IRET) 155 : * WRITE(IOIMP,*)' iret ',iret,' ierr ',ierr 156 : type ='MATRIK' 157 : segact matrik 158 : nmatri = jrigel(/2) 159 : if(impj.eq.0)then 160 : WRITE(IOIMP,*)' MATRIK ' 161 : WRITE(IOIMP,*)' nmatri ',nmatri 162 : nrigel = jrigel(/1) 163 : do ik=1,nmatri 164 : WRITE(IOIMP,*) ik 165 : WRITE(IOIMP,*)(jrigel(il,ik),il=1,nrigel) 166 : WRITE(IOIMP,*)' ' 167 : meleme= jrigel(1,ik) 168 : segact meleme 169 : nbs=lisous(/1) 170 : WRITE(IOIMP,*)' nbre ssobjt mail p',nbs 171 : if(nbs.eq.0) then 172 : nbnn=num(/1) 173 : nbl= num(/2) 174 : do iel=1,nbl 175 : WRITE(IOIMP,*)iel,' ',(num(io,iel),io=1,nbnn) 176 : enddo 177 : endif 178 : if(nbs.ge.1)then 179 : WRITE(IOIMP,*)' ssobjet maill',(lisous(io),io=1,nbs) 180 : do iss=1,nbs 181 : ipt1=lisous(iss) 182 : segact ipt1 183 : nbnn=ipt1.num(/1) 184 : nbl =ipt1.num(/2) 185 : WRITE(IOIMP,*)' nbl ',nbl,' nbnn ',nbnn 186 : do il = 1,nbl 187 : WRITE(IOIMP,*)il,' ',(ipt1.num(iop,il),iop=1 188 : $ ,nbnn) 189 : enddo 190 : segdes ipt1 191 : enddo 192 : endif 193 : segdes meleme 194 : meleme= jrigel(2,ik) 195 : segact meleme 196 : nbs=lisous(/1) 197 : WRITE(IOIMP,*)' nbre ssobjt mail d',nbs 198 : if(nbs.eq.0) then 199 : nbnn=num(/1) 200 : nbl= num(/2) 201 : do iel=1,nbl 202 : WRITE(IOIMP,*)iel,' ',(num(io,iel),io=1,nbnn) 203 : enddo 204 : endif 205 : if(nbs.ge.1)then 206 : WRITE(IOIMP,*)' ssobjet maill',(lisous(io),io=1,nbs) 207 : do iss=1,nbs 208 : ipt1=lisous(iss) 209 : segact ipt1 210 : nbnn=ipt1.num(/1) 211 : nbl =ipt1.num(/2) 212 : WRITE(IOIMP,*)' nbl ',nbl,' nbnn ',nbnn 213 : do il = 1,nbl 214 : WRITE(IOIMP,*)il,' ',(ipt1.num(iop,il),iop=1 215 : $ ,nbnn) 216 : enddo 217 : segdes ipt1 218 : enddo 219 : endif 220 : segdes meleme 221 : enddo 222 : WRITE(IOIMP,*)'ksym kminc kmincd kizm' 223 : WRITE(IOIMP,*) ksym,kminc,kmincd,kizm 224 : WRITE(IOIMP,*)'kispgt kispgp kispgd knttt knttp knttd' 225 : WRITE(IOIMP,*) kispgt,kispgp,kispgd,knttt,knttp,knttd 226 : nkid=kidmat(/1) 227 : WRITE(IOIMP,*)' kidmat ' 228 : WRITE(IOIMP,*)(kidmat(il),il=1,nkid) 229 : nkmt=kkmmt(/1) 230 : WRITE(IOIMP,*)' kkmmt ' 231 : WRITE(IOIMP,*)(kkmmt(il),il=1,nkmt) 232 : do ik=1,nmatri 233 : WRITE(IOIMP,*)' ik ',ik 234 : jmatri = jrigel(4,ik) 235 : segact jmatri 236 : nbme = lisprj(/2) 237 : nbsous = lizafm(/1) 238 : WRITE(IOIMP,*)' nbme nbsous kspgp kspgd ' 239 : WRITE(IOIMP,*) nbme,nbsous,kspgp,kspgd 240 : WRITE(IOIMP,*)' lisprj ' 241 : WRITE(IOIMP,*)(lisprj(il),il=1,nbme) 242 : WRITE(IOIMP,*)' lisdub ' 243 : WRITE(IOIMP,*)(lisdub(il),il=1,nbme) 244 : do im=1,nbme 245 : WRITE(IOIMP,*)' im ',im 246 : do is=1,nbsous 247 : WRITE(IOIMP,*)' is ',is 248 : izafm = lizafm(is,im) 249 : segact izafm 250 : nbel=am(/1) 251 : np=am(/2) 252 : mp=am(/3) 253 : WRITE(IOIMP,*)' nbel np mp' 254 : WRITE(IOIMP,*) nbel,np,mp 255 : do ie=1,nbel 256 : WRITE(IOIMP,*)' iel ',ie 257 : do ip =1,np 258 : WRITE(IOIMP,*)ip,(am(ie,ip,kp),kp=1,mp) 259 : enddo 260 : enddo 261 : segdes izafm 262 : enddo 263 : enddo 264 : segdes jmatri 265 : enddo 266 : endif 267 : 268 : * Ligne suivante inutile cf include SMRIGID 269 : * nrige = 8 270 : nrigel = 0 271 : do ir=1,nmatri 272 : ir7=jrigel(7,ir) 273 : ncmul=1 274 : if (ir7.EQ.4) ncmul=2 275 : jmatri=jrigel(4,ir) 276 : segact jmatri 277 : nbs=lizafm(/1) 278 : nbe=lizafm(/2) 279 : nrigel=nrigel+nbs*nbe*ncmul 280 : enddo 281 : 282 : segini mrigid 283 : jr=0 284 : do ir=1,nmatri 285 : ir7=jrigel(7,ir) 286 : ncmul=1 287 : if (ir7.EQ.4) ncmul=2 288 : mtymat='MATRIK ' 289 : jmatri=jrigel(4,ir) 290 : nbs=lizafm(/1) 291 : nbe=lizafm(/2) 292 : melpri =jrigel(1,ir) 293 : meldua =jrigel(2,ir) 294 : jg=nbs 295 : segini nofset 296 : if (melpri.eq.meldua) then 297 : * Write(ioimp,*) 'Cas melpri=meldua' 298 : meleme=melpri 299 : else 300 : * Write(ioimp,*) 'Cas melpri.ne.meldua' 301 : * On s'arrange pour que les deux maillages aient le même nombre de 302 : * sous-maillages 302 : call fixmel(melpri,meldua,melpr2,meldu2,impr,iret) 303 : if (iret.ne.0) goto 9999 304 : melpri=melpr2 305 : meldua=meldu2 306 : segact melpri,meldua 307 : nbsou1=melpri.lisous(/1) 308 : nbsou2=meldua.lisous(/1) 309 : * write(ioimp,*) 'nbsou1=',nbsou1 310 : * write(ioimp,*) 'nbsou2=',nbsou2 311 : * write(ioimp,*) 'nbs=',nbs 312 : if (nbsou1.ne.nbsou2) goto 9999 313 : if (max(1,nbsou1).ne.nbs) goto 9999 314 : if (nbsou1.eq.0) then 315 : nbnn1=melpri.num(/1) 316 : nbnn2=meldua.num(/1) 317 : nbel1=melpri.num(/2) 318 : nbel2=meldua.num(/2) 319 : if (nbel1.ne.nbel2) goto 9999 320 : nofset.lect(1)=nbnn1 321 : nbnn=nbnn1+nbnn2 322 : nbelem=nbel1 323 : nbref=0 324 : nbsous=0 325 : segini meleme 326 : do ibelem=1,nbelem 327 : do ibnn1=1,nbnn1 328 : num(ibnn1,ibelem)=melpri.num(ibnn1,ibelem) 329 : enddo 330 : do ibnn2=1,nbnn2 331 : num(ibnn2+nbnn1,ibelem)=meldua.num(ibnn2,ibelem) 332 : enddo 333 : enddo 334 : segdes meleme 335 : segdes melpri,meldua 336 : else 337 : nbsous=nbs 338 : nbref=0 339 : nbnn=0 340 : nbelem=0 341 : segini meleme 342 : do isous=1,nbs 343 : smlpri=melpri.lisous(isous) 344 : smldua=meldua.lisous(isous) 345 : segact smlpri,smldua 346 : nbnn1=smlpri.num(/1) 347 : nbnn2=smldua.num(/1) 348 : nbel1=smlpri.num(/2) 349 : nbel2=smldua.num(/2) 350 : if (nbel1.ne.nbel2) goto 9999 351 : nofset.lect(isous)=nbnn1 352 : nbnn=nbnn1+nbnn2 353 : nbelem=nbel1 354 : nbref=0 355 : nbsous=0 356 : segini ipt1 357 : do ibelem=1,nbelem 358 : do ibnn1=1,nbnn1 359 : ipt1.num(ibnn1,ibelem)=smlpri.num(ibnn1 360 : $ ,ibelem) 361 : enddo 362 : do ibnn2=1,nbnn2 363 : ipt1.num(ibnn2+nbnn1,ibelem)=smldua.num(ibnn2 364 : $ ,ibelem) 365 : enddo 366 : enddo 367 : segdes ipt1 368 : segdes smlpri,smldua 369 : lisous(isous)=ipt1 370 : enddo 371 : segdes meleme 372 : endif 373 : endif 374 : * WRITE(IOIMP,*)' meleme ',meleme 374 : * call ecmail(meleme,1) 375 : segact meleme 376 : nbs2 = lisous(/1) 377 : if(nbs2 .eq.0) then 378 : nbs2 = 1 379 : endif 380 : if (nbs.ne.nbs2) then 381 : write(ioimp,*) 'lizafm non compatible avec meleme' 382 : goto 9999 383 : endif 384 : * WRITE(IOIMP,*)' aa ' 385 : do icmul=1,ncmul 386 : do is=1,nbs 387 : do in=1,nbe 388 : jr =jr+1 389 : * WRITE(IOIMP,*)' jr ',jr,ir,is,in 390 : coerig(jr)=1.d0 391 : if(nbs.eq.1) then 392 : irigel(1,jr)=meleme 393 : else 394 : irigel(1,jr)=lisous(is) 395 : endif 396 : * WRITE(IOIMP,*)' bb ' 397 : irigel(2,jr)=0 398 : irigel(5,jr)=0 399 : irigel(6,jr)=0 400 : ii = jrigel(7,ir) 401 : if(ii.le.2) then 402 : irigel(7,jr)=ii 403 : elseif(ii.eq.3)then 404 : * WRITE(IOIMP,*)' support primal dual differents ' 405 : * WRITE(IOIMP,*)' on ne fait rien' 406 : * segsup mrigid 407 : * return 408 : irigel(7,jr)=2 409 : elseif(ii.eq.4)then 410 : irigel(7,jr)=2 411 : icc = 1 412 : elseif(ii.eq.5)then 413 : irigel(7,jr)=2 414 : elseif(ii.eq.6)then 415 : WRITE(IOIMP,* 416 : $ )' matrice de type morse on ne fait rien' 417 : goto 9999 418 : * segsup mrigid 419 : * return 420 : endif 421 : irigel(7,jr)=jrigel(7,ir) 422 : irigel(8,jr)=0 423 : iforig=-1 424 : jmatri = jrigel(4,ir) 425 : izafm=lizafm(is,in) 426 : segact izafm 427 : nbel=am(/1) 428 : nelrig=nbel 429 : if (icmul.eq.1) then 430 : * recopier les matrices élémentaires 431 : nligrp=am(/2) 432 : nligrd=am(/3) 433 : segini descr,xmatri 434 : irigel(3,jr)=descr 435 : irigel(4,jr)=Xmatri 436 : do il=1,nligrp 437 : lisinc(il)=lisprj(in)(1:4) 438 : noelep(il)=il 439 : enddo 440 : do il=1,nligrd 441 : lisdua(il)=lisdub(in)(1:4) 442 : noeled(il)=il+nofset.lect(is) 443 : enddo 444 : do ip=1,nbel 445 : do iu=1,nligrp 446 : do ju=1,nligrd 447 : re(ju,iu,ip)=am(ip,iu,ju) 448 : enddo 449 : enddo 450 : enddo 451 : segdes xmatri,descr 452 : else 453 : * recopier les transposées des matrices élémentaires 454 : nligrd=am(/2) 455 : nligrp=am(/3) 456 : segini descr,xmatri 457 : irigel(3,jr)=descr 458 : irigel(4,jr)=Xmatri 459 : do il=1,nligrp 460 : lisinc(il)=lisdub(in)(1:4) 461 : noelep(il)=il+nofset.lect(is) 462 : enddo 463 : do il=1,nligrd 464 : lisdua(il)=lisprj(in)(1:4) 465 : noeled(il)=il 466 : enddo 467 : do ip=1,nbel 468 : do iu=1,nligrp 469 : do ju=1,nligrd 470 : re(ju,iu,ip)=am(ip,ju,iu) 471 : enddo 472 : enddo 473 : enddo 474 : segdes xmatri,descr 475 : endif 476 : segdes izafm 477 : enddo 478 : enddo 479 : enddo 480 : 481 : segdes meleme 482 : segdes jmatri 483 : segsup nofset 484 : enddo 485 : segdes mrigid 486 : segdes matrik 486 : CALL ECRobj('RIGIDITE',mrigid) 487 : return 488 : elseif(typp.eq.'RIGIDITE') then 489 : type='RIGIDITE' 489 : call lirobj(type,mrigid,1,iret) 490 : * WRITE(IOIMP,*)' rigidite ' 491 : 492 : * On regarde si il y a un autre argument. 493 : * Si ce n'est pas le cas on appele RIMB 494 : * qui termine le travail. 495 : * Modif GBM 496 : 496 : call quetyp(typp,0,iret) 497 : if(typp.ne.'MAILLAGE') then 497 : call RIMB(mrigid) 498 : return 499 : endif 500 : 501 : * fin de modif GBM 18/12/02 502 : 503 : type='MAILLAGE' 503 : call lirobj(type,mele ,1,iret) 504 : * WRITE(IOIMP,*)' mele ',mele,iret 505 : * 506 : * eventuellemnt liste nom composante 507 : * 508 : ico = 0 509 : jmo=0 510 : lmo=0 510 : call quetyp(typp,ico,iret) 511 : if(typp.eq.'LISTMOTS') then 511 : call lirobj(typp,mlmots,0,iret) 512 : segact mlmots 513 : jmo = mots(/1) 514 : lmo = mots(/2) 515 : endif 516 : segact mrigid 517 : nrigel=irigel(/2) 518 : nrige =irigel(/1) 519 : 520 : if(impj.eq.0) then 521 : WRITE(IOIMP,*)' nrigel',nrigel,' nrige ',nrige 522 : WRITE(IOIMP,*)' mtymat ',mtymat 523 : do ir =1,nrigel 524 : WRITE(IOIMP,*)' ir ',ir 525 : WRITE(IOIMP,*)(irigel(ik,ir),ik=1,nrige) 526 : WRITE(IOIMP,*)' ' 527 : meleme=irigel(1,ir) 528 : segact meleme 529 : nbs=lisous(/1) 530 : WRITE(IOIMP,*)' nbre ssobjt mail ',nbs 531 : if(nbs.eq.0) then 532 : nbnn=num(/1) 533 : nbl=num(/2) 534 : do iel=1,nbl 535 : WRITE(IOIMP,*)iel,' ',(num(io,iel),io=1,nbnn) 536 : enddo 537 : endif 538 : if(nbs.ge.1)then 539 : WRITE(IOIMP,*)' ssobjet maill',(lisous(io),io=1,nbs) 540 : do iss=1,nbs 541 : ipt1=lisous(iss) 542 : segact ipt1 543 : nbnn=ipt1.num(/1) 544 : nbl =ipt1.num(/2) 545 : WRITE(IOIMP,*)' nbl ',nbl,' nbnn ',nbnn 546 : do il = 1,nbl 547 : WRITE(IOIMP,*)il,' ',(ipt1.num(iop,il),iop=1 548 : $ ,nbnn) 549 : enddo 550 : segdes ipt1 551 : enddo 552 : endif 553 : segdes meleme 554 : enddo 555 : WRITE(IOIMP,*)' coerig ' 556 : WRITE(IOIMP,*)(coerig(ik),ik=1,nrigel) 557 : WRITE(IOIMP,*)' ichole imgeo1 imgeo2 iforig ' 558 : WRITE(IOIMP,*) ichole,imgeo1,imgeo2,iforig 559 : WRITE(IOIMP,*)' isupeq jrcond jrdepp jrdepd ' 560 : WRITE(IOIMP,*) isupeq,jrcond,jrdepp,jrdepd 561 : WRITE(IOIMP,*)' jrelim jrgard jrtot ' 562 : WRITE(IOIMP,*) jrelim,jrgard,jrtot 563 : do ir=1,nrigel 564 : xmatri = irigel(4,ir) 565 : descr = irigel(3,ir) 566 : segact xmatri,descr 567 : nelrig = re(/3) 568 : nligrp = noelep(/1) 569 : nligrd = noeled(/1) 570 : WRITE(IOIMP,*)' nelrig nligrp nligrd ' 571 : WRITE(IOIMP,*) nelrig,nligrp,nligrd 572 : WRITE(IOIMP,*)' lisinc ' 573 : WRITE(IOIMP,*)(lisinc(io),io=1,nligrp) 574 : WRITE(IOIMP,*)' lisdua ' 575 : WRITE(IOIMP,*)(lisdua(io),io=1,nligrd) 576 : WRITE(IOIMP,*)' noelep ' 577 : WRITE(IOIMP,*)(noelep(io),io=1,nligrp) 578 : WRITE(IOIMP,*)' noeled ' 579 : WRITE(IOIMP,*)(noeled(io),io=1,nligrd) 580 : do ie=1, nelrig 581 : * xmatri = imattt(ie) 582 : * segact xmatri 583 : WRITE(IOIMP,*)' iel ',ie 584 : do ij =1,nligrd 585 : WRITE(IOIMP,*)ij,(re(ij,kj,ie),kj=1,nligrp) 586 : enddo 587 : * segdes xmatri 588 : enddo 589 : segdes xmatri,descr 590 : enddo 591 : endif 592 : 593 : nmatri = nrigel 594 : nrige = 7 595 : nrig = irigel(/1) 596 : nkid=9 597 : nkmt=7 598 : segini matrik 599 : * WRITE(IOIMP,*)' creation matrik',matrik 600 : do in=1,nrigel 601 : jrigel(1,in)=irigel(1,in) 602 : jrigel(2,in)=irigel(1,in) 603 : meleme = irigel(1,in) 604 : segact meleme 605 : jrigel(7,in)=0 606 : if(nrig.gt.6) then 607 : jrigel(7,in)=irigel(7,in) 608 : endif 609 : * WRITE(IOIMP,*)' in ',in,irigel(7,in) 610 : * WRITE(IOIMP,*)' in ',in,irigel(6,in) 611 : if(irigel(6,in).ne.0)then 612 : segsup matrik 613 : WRITE(IOIMP,*)' matrice definie par une inegalite' 614 : return 615 : endif 616 : if(irigel(5,in).ne.0) then 617 : segsup matrik 618 : WRITE(IOIMP,*)' harmonique de fourier non nulle' 619 : return 620 : endif 621 : coef = coerig(in) 622 : descr=irigel(3,in) 623 : segact descr 624 : xmatri = irigel(4,in) 625 : segact xmatri 626 : nbp = noelep(/1) 627 : nbd = noeled(/1) 628 : np = num(/1) 629 : nbme = nbp/np*nbd/np 630 : nbel = num(/2) 631 : mp =np 632 : nbsous=1 633 : segini jmatri 634 : jrigel(4,in)=jmatri 635 : * WRITE(IOIMP,*)' jmatri ',jmatri 636 : 637 : * WRITE(IOIMP,*)' jrigel ',(jrigel(iop,in),iop=1,7) 638 : 639 : 640 : 641 : l1=nbp/np 642 : l2=np 643 : segini iztra 644 : * WRITE(IOIMP,*)' iztra ',iztra,l1,l2 645 : k0 = 1 646 : lisp(1)=lisinc(1) 647 : do io=1,np 648 : itab(1,io)=io 649 : enddo 650 : ltab(1)=1 651 : do j=2,nbp 652 : nomi=lisinc(j) 653 : do l=1,k0 654 : if(nomi.eq.lisp(l))then 655 : k=ltab(l)+1 656 : itab(l,k)=j 657 : ltab(l)=k 658 : go to 30 659 : endif 660 : enddo 661 : k0=k0+1 662 : lisp(k0)=nomi 663 : ltab(k0)=1 664 : itab(k0,1)=j 665 : 30 continue 666 : enddo 667 : l3=nbd/np 668 : l2=np 669 : segini jztra 670 : k0 = 1 671 : lisd(1)=lisdua(1) 672 : do io=1,np 673 : jtab(1,io)=io 674 : enddo 675 : ktab(1)=1 676 : do j=2,nbd 677 : nomi=lisdua(j) 678 : do l=1,k0 679 : if(nomi.eq.lisd(l))then 680 : k=ktab(l)+1 681 : jtab(l,k)=j 682 : ktab(l)=k 683 : go to 31 684 : endif 685 : enddo 686 : k0=k0+1 687 : lisd(k0)=nomi 688 : ktab(k0)=1 689 : jtab(k0,1)=j 690 : 31 continue 691 : enddo 692 : k=0 693 : do lp=1,l1 694 : do ld=1,l3 695 : k=k+1 696 : lisprj(k)=lisp(lp) 697 : * lisdub(k)=lisd(ld) 698 : lisdub(k)=lisp(ld) 699 : if(lmo.ne.0.and.lmo.ge.lp)then 700 : lisprj(k)= mots(lp) 701 : lisdub(k)= mots(ld) 702 : endif 703 : segini izafm 704 : lizafm(1,k)=izafm 705 : kspgp = mele 706 : kspgd = mele 707 : * WRITE(IOIMP,*)' kspgp ',kspgp 708 : do ip =1,nbel 709 : * xmatri = imattt(ip) 710 : * segact xmatri 711 : ll=0 712 : do ki=1,np 713 : do kj=1,np 714 : il= noelep(ki) 715 : jl= noeled(kj) 716 : ii=itab(lp,ki) 717 : jj=jtab(ld,kj) 718 : * am(ip,il,jl)=coef * re(jj,ii) 719 : ll=ll+1 720 : il=noelep(ii) 721 : jl=noelep(jj) 722 : if(ip.eq.1)then 723 : * WRITE(IOIMP,*)' lp ',lp,' ki ',ki,' nop ',il,' ii ',ii,' ip ',ip 724 : * WRITE(IOIMP,*)' ld ',ld,' kj ',kj,' nod ',jl,' jj ',jj 725 : endif 726 : am(ip,il,jl)=coef * re(jj,ii,ip) 727 : ***** am(ip,ki,kj)=coef * re(ii,jj) 728 : enddo 729 : enddo 730 : * segdes xmatri 731 : enddo 732 : * WRITE(IOIMP,*)' finfin ' 733 : segdes izafm 734 : enddo 735 : enddo 736 : * WRITE(IOIMP,*)' fin 1 ' 737 : segsup iztra,jztra 738 : segdes descr,xmatri 739 : segdes jmatri 740 : * WRITE(IOIMP,*)' segdes 1 ' 741 : enddo 742 : segdes mrigid 743 : * WRITE(IOIMP,*)' jrigel ',(jrigel(iop,1 ),iop=1,7) 744 : * WRITE(IOIMP,*)' jrigel ',(jrigel(iop,2 ),iop=1,7) 745 : segdes matrik 746 : * WRITE(IOIMP,*)' segdes 2 ' 746 : CALL ECRobj('MATRIK',matrik) 747 : return 748 : else 749 : WRITE(IOIMP,*)' erreur' 750 : return 751 : endif 752 : * 753 : * Error handling 754 : * 755 : 9999 CONTINUE 756 : WRITE(IOIMP,*) 'An error was detected in subroutine rima' 756 : CALL ERREUR(5) 757 : RETURN 758 : end 759 : 760 : 761 : 762 : 763 : 764 : 765 : 766 : 767 : 768 : 769 : 770 :
© Cast3M 2003 - All rights reserved.
Disclaimer