1 : C PRON SOURCE FD218221 14/01/31 21:15:15 7936 2 : 3 : SUBROUTINE PRON(IPMODE,IPCHE,IPCHT,ISUP,IPOUT) 4 : 5 : IMPLICIT INTEGER(I-N) 6 : IMPLICIT REAL*8 (A-H,O-Z) 7 : 8 : *-------------------------------------------------------------------- * 9 : * * 10 : * Sous-programme appelé par l'opérateur PROI * 11 : * * 12 : * Projection d'un chamelem aux noeuds ou aux points d'integration * 13 : * des elements support du modele * 14 : * Evaluation faite au point courant par utilisation des fonctions * 15 : * de formes du modele associe au champ d origine (lu en option * 16 : * dans PRO2) ou par defaut a partir des fonctions geometriques * 17 : * associées à l'élément d origine * 18 : * * 19 : * __________________________________________________________________* 20 : * * 21 : * ENTREE : * 22 : * IPMODE modele sur lequel on va projeter * 23 : * IPCHE MCHAML de caracteristiques (si le modele comprend * 24 : * des coques) * 25 : * IPCHT MCHAML a projeter (obligatoirement defini aux noeuds) 26 : * ISUP support du resultat 1 noeuds * 27 : * 2 pts d integration contraintes* 28 : * SORTIE : * 29 : * IPOUT MCHAML resultat * 30 : * * 31 : * Projection d'un chamelem sur le support d un modele * 32 : * * 33 : *---------------------------------------------------------------------* 34 : * 35 : -INC CCOPTIO 36 : -INC CCREEL 37 : * 38 : -INC SMCOORD 39 : -INC SMMODEL 40 : -INC SMCHAML 41 : -INC SMELEME 42 : -INC SMCHPOI 43 : -INC SMLCHPO 44 : -INC SMLMOTS 45 : -INC TMTRAV 46 : -INC SMINTE 47 : character*4 nomm 48 : segment snomip 49 : character*4 nomip(0) 50 : endsegment 51 : segment ipcb(nsschp) 52 : segment icpr(2,xcoor(/1)/idim+1) 53 : C 54 : segment info 55 : integer infell(JG) 56 : endsegment 57 : C 58 : segment sicoq 59 : integer icocoq(nbsous),imfr(nbsous),iiele(nbsous) 60 : integer iminte(nbsous),imint1(nbsous),ibnap(nbsous) 61 : integer inbg(nbsous),ibbas(nbsous) 62 : endsegment 63 : C 64 : SEGMENT WRK4 65 : REAL*8 BPSS(3,3),XEL(3,NBN1) ,XU(3),SHP(6,NBN1),S(6) 66 : REAL*8 TXR(3,3,NBN1),XE(3,NBG),XEG(3,NBG3) 67 : ENDSEGMENT 68 : 69 : SEGMENT VECT 70 : REAL*8 VEC1(IDIM) 71 : REAL*8 VEC2(IDIM) 72 : REAL*8 VECN(IDIM,NBN1*2) 73 : ENDSEGMENT 74 : 75 : segment phachm 76 : integer iphach(nsouz) 77 : integer mphach(nsouz) 78 : endsegment 79 : LOGICAL logach 80 : 81 : IPOUT = 0 82 : 83 : MMODEL=IPMODE 84 : SEGACT,MMODEL 85 : NSOUS=KMODEL(/1) 86 : * 87 : if(IPCHE.NE.0) THEN 88 : MCHELM=IPCHE 89 : SEGACT,MCHELM 90 : NCHAM=ICHAML(/1) 91 : endif 92 : * 93 : NBNOE = XCOOR(/1)/(IDIM+1) 94 : * 95 : * Création du maillage provisoire support pour interpolation 96 : * 97 : C ipt2 contiendra les super couche au point de gauss 98 : NBSOUS = NSOUS 99 : NBREF = 0 100 : NBELEM = 0 101 : NBNN = 0 102 : SEGINI IPT2 103 : SEGINI SICOQ 104 : c listmots des phases 105 : ilphmo = -1 106 : jgn = 8 107 : jgm = nsous 108 : segini mlmots 109 : ilphmo = mlmots 110 : jgm = 1 111 : * 112 : * Boucle sur l'ensemble des sous zones du modeles sur lequel on va 113 : * projetter pour initialisations 114 : nponou=0 115 : npcoq =0 116 : * 117 : DO 30 ISOUS = 1, NSOUS 118 : * 119 : IMODEL = KMODEL(ISOUS) 120 : SEGACT,IMODEL 121 : * 122 : MELE = NEFMOD 123 : MELEME = IMAMOD 124 : SEGACT MELEME 125 : NBELE1= NUM(/2) 126 : NBN1 = NUM(/1) 127 : IF(INFMOD(/1).NE.0)THEN 128 : IF(INFMOD(1).NE.0)THEN 129 : NPINT=INFMOD(1) 130 : IBNAP(isous) =NPINT 131 : ELSE 132 : NPINT=0 133 : ibnap(isous)=1 134 : ENDIF 135 : ELSE 136 : NPINT=0 137 : ibnap(isous)=1 138 : ENDIF 139 : C 140 : if(INFMOD(/1).lt.2+isup) then 140 : call elquoi(mele,npint,isup,ipinf,imodel) 141 : if (ierr.ne.0) then 142 : segdes imodel,mmodel 143 : return 144 : endif 145 : info=ipinf 146 : mfr =infell(13) 147 : iele =infell(14) 148 : minte=infell(11) 149 : minte1=infELL(12) 150 : nbg=nbn1 151 : if(isup.eq.2) then 152 : segact minte 153 : nbg=shptot(/3) 154 : segdes minte 155 : elseif(isup.eq.3) then 156 : nbg=infell(6) 157 : elseif(isup.eq.4) then 158 : nbg=infell(3) 159 : elseif(isup.eq.5) then 160 : nbg=infell(4) 161 : endif 162 : segsup info 163 : else 164 : mfr =infele(13) 165 : iele =infele(14) 166 : minte=infmod(2+isup) 167 : minte1=infmod(8) 168 : nbg=nbn1 169 : if(isup.eq.2) then 170 : segact minte 171 : nbg=shptot(/3) 172 : segdes minte 173 : elseif(isup.eq.3) then 174 : nbg=infele(6) 175 : elseif(isup.eq.4) then 176 : nbg=infele(3) 177 : elseif(isup.eq.5) then 178 : nbg=infele(4) 179 : endif 180 : endif 181 : C 182 : imfr(isous)=mfr 183 : iiele(isous)=iele 184 : iminte(isous)=minte 185 : imint1(isous)=minte1 186 : inbg(isous)=nbg 187 : NBSOUS = 0 188 : NBREF = 0 189 : NBELEM = NBELE1 190 : IF (mfr.EQ.3.OR.mfr.EQ.5.OR.mfr.EQ.9) THEN 191 : C 192 : if(IPCHE.eq.0) then 192 : call erreur(404) 193 : segdes meleme ,imodel,mmodel 194 : return 195 : endif 196 : C 197 : C----------------------------coque --------------------- 198 : icocoq(isous) = 1 199 : npcoq = npcoq + 1 200 : C nombre de points par nappes 201 : if(isup.GT.2) then 202 : if(mfr.eq.5) then 203 : C ----------------- cas des coques epaisses 204 : if(nbg.eq.8.or.nbg.eq.6) then 205 : IBNAP(isous)=2 206 : ibbas(isous)=nbg/2 207 : else 208 : IBNAP(isous)=nbg/nbn1*2 209 : endif 210 : else 211 : ibbas(isous) = nbg/ibnap(isous) 212 : endif 213 : elseif(isup.eq.1) then 214 : ibnap(isous)=1 215 : ibbas(isous) = nbn1 216 : elseif(isup.eq.2) then 217 : ibnap(isous)= 1 218 : ibbas(isous) = 1 219 : endif 220 : * 221 : * write(6,*) 'nombre de noeuds par nappe ', 222 : * & ibbas(isous),' nappes ',ibnap(isous) 223 : * 224 : * création du maillage des points supports pour cette sz 225 : * 226 : NBNN = ibbas(isous)*ibnap(isous) 227 : nponou = nponou + nbnn*nbele1 228 : SEGINI IPT1 229 : IPT1.ITYPEL = 28 230 : ipt2.lisous(isous) = ipt1 231 : *write(6,*) 'sz ',isous ,'nbnn nbelem ipt1' ,nbnn,nbelem,ipt1 232 : segdes ipt1 233 : ELSE 234 : C-----------------------------massif ------------------------ 235 : if(isup.GT.2) then 236 : NBNN = NBG 237 : elseif(isup.eq.2) then 238 : NBNN=1 239 : else 240 : NBNN= nbn1 241 : endif 242 : C 243 : SEGINI IPT1 244 : if(isup.eq.2) then 245 : else 246 : IPT1.ITYPEL = 28 247 : endif 248 : ipt2.lisous(isous) = ipt1 249 : segdes ipt1 250 : nponou=nponou+nbnn*nbele1 251 : C 252 : ENDIF 253 : 254 : if (isous.eq.1) then 255 : mots(1) = conmod(17:24) 256 : else 257 : do ipl = 1,jgm 258 : if (mots(ipl).eq.conmod(17:24)) goto 27 259 : enddo 260 : jgm = jgm + 1 261 : mots(jgm) = conmod(17:24) 262 : 27 continue 263 : endif 264 : C 265 : segdes meleme,imodel 266 : * segsup info 267 : 30 CONTINUE 268 : 269 : segadj mlmots 270 : C----------------------------------------------------------- 271 : C 272 : C si il y a des coques ou si l'on veut le champ aux points 273 : C d integration, on va fabriquer des points support provisoires 274 : C 275 : C---------------------------------------------------------- 276 : C write(6,*) ' nombre de points crees ' ,nponou 277 : C (fdp) ajustement de MCOORD pour les noeuds provisoires 278 : C il sera remis a sa taille initiale a la fin du programme 279 : NBPTS = NBNOE + nponou 280 : SEGADJ MCOORD 281 : *----------------------------------------------------------- 282 : * Boucle sur l'ensemble des sous zones du modeles 283 : *------------------------------------------------------------ 284 : inupo =NBNOE 285 : DO 100 ISOUS = 1,NSOUS 286 : IMODEL = KMODEL(ISOUS) 287 : segact imodel 288 : MELEME = IMAMOD 289 : segact meleme 290 : nbele1= num(/2) 291 : nbn1 = num(/1) 292 : ipt1=ipt2.lisous(isous) 293 : segact ipt1*mod 294 : NNB = ibbas(isous) 295 : NBG =inbg(isous) 296 : NBG3=NBG*3 297 : SEGINI WRK4 298 : SEGINI VECT 299 : IF(ICOCOQ(ISOUS).NE.0) THEN 300 : C----------------------------------------------------------- 301 : C -------------------------------LA SZ EST UNE COQUE ------ 302 : C----------------------------------------------------------- 303 : NUCHA = 0 304 : DO 15, NUCH = 1, NCHAM 305 : * 306 : IF ( CONCHE(NUCH).EQ.CONMOD.AND. 307 : & IMACHE(NUCH).EQ.IMAMOD) NUCHA = NUCH 308 : * 309 : 15 CONTINUE 310 : * 311 : IF (NUCHA.NE.0) THEN 312 : MCHAML=ICHAML(NUCHA) 313 : SEGACT,MCHAML 314 : * 315 : MELVA1 = 0 316 : MELVA2 = 0 317 : NCOMP = IELVAL(/1) 318 : DO 20, I = 1, NCOMP 319 : IF (NOMCHE(I)(1:4).EQ.'EPAI') THEN 320 : MELVA1 = IELVAL(I) 321 : SEGACT, MELVA1 322 : ELSEIF (NOMCHE(I)(1:4).EQ.'EXCE') THEN 323 : MELVA2 = IELVAL(I) 324 : SEGACT, MELVA2 325 : ENDIF 326 : 20 CONTINUE 327 : ENDIF 328 : C 329 : MELE = NEFMOD 330 : c coque integree ou pas ? 331 : if(infmod(/1).ne.0)then 332 : npint=infmod(1) 333 : else 334 : npint=0 335 : endif 336 : nbnap=ibnap(isous) 337 : mfr =imfr(isous) 338 : iele =iiele(isous) 339 : minte=iminte(isous) 340 : minte1=imint1(isous) 341 : nbg = inbg(isous) 342 : C 343 : segact minte 344 : if(mfr.eq.5) segact minte1 345 : 346 : nnb = ibbas(isous) 347 : *------------------------------------------------------------------- 348 : * Boucle sur les elements de la sous zone du modele (c est une coque) 349 : *------------------------------------------------------------------- 350 : DO 95 iel=1, NBELE1 351 : ipo=0 351 : call doxe(xcoor,idim,nbn1,num,iel,xel) 352 : * write(6,*) ' coordonnees des noeuds ' 353 : * write(6,2000) ((xel(ik,jk),ik=1,idim),jk=1,nbn1) 354 : * write(6,*) '-------------------- ' 355 : 2000 format(3E12.5) 356 : * on veut les coordonnees aux point d integration et normales 357 : * 358 : IF(ISUP.GT.1) THEN 359 : C --- projection des points d'integration sur la surface moyenne-- 360 : DO 601 ip=1,nnb 361 : do 600 ik=1,idim 362 : xe(ik,ip)=0.D0 363 : DO 602 jk = 1,NBN1 364 : XE(Ik,ip) = XE(Ik,ip) + SHPTOT(1,JK,ip)*(XEL(IK,jk)) 365 : 602 CONTINUE 366 : 600 CONTINUE 367 : 601 CONTINUE 368 : do i=1,nnb 369 : do j=1,idim 370 : xeg(j,i)=xe(j,i) 371 : enddo 372 : enddo 373 : C ELSEIF(isup.eq.2) THEN 374 : C---------------------------- on travaille aux CDG 375 : C do ik=1,idim 376 : C xeg(ik,1)=0.D0 377 : C do ip=1,nbg 378 : C DO jk = 1,NBN1 379 : C XEG(Ik,1) = XEG(Ik,jk) + SHPTOT(1,JK,ip)*(XEL(IK,jk)) 380 : C enddo 381 : C enddo 382 : C enddo 383 : ELSE 384 : C ------- on travaille aux noeuds 385 : do i=1,nbn1 386 : do j=1,idim 387 : xeg(j,i)=xel(j,i) 388 : enddo 389 : enddo 390 : ENDIF 391 : C write(6,*) ' coordonnes des points de base ' 392 : C write(6,2576) (ip,(xeg(il,ip),il=1,3),ip=1,nnb) 393 : C write(6,*) ' ----------------- ' 394 : 2576 format(I4,2X,3E12.5) 395 : 396 : C----------- les normales aux points ad hoc ------------------ 397 : C 398 : *--------------- coque minces 3 noeuds --------------- 399 : if(iele.eq.4) then 400 : C --------coq3 dkt dst ---------------- 401 : do 98 i=1,idim 402 : VEC1(i)=xel(i,2)-xel(i,1) 403 : 98 VEC2(i)=xel(i,3)-xel(i,1) 404 : vecn(1,1) = vec1(2)*vec2(3)-vec1(3)*vec2(2) 405 : vecn(2,1) = vec1(3)*vec2(1)-vec1(1)*vec2(3) 406 : vecn(3,1) = vec1(1)*vec2(2)-vec1(2)*vec2(1) 407 : vnor =sqrt(vecn(1,1)*vecn(1,1)+vecn(2,1)*vecn(2,1) 408 : & +vecn(3,1)*vecn(3,1)) 409 : do 91 i=1,idim 410 : 91 vecn(i,1)=vecn(i,1)/vnor 411 : do 99 j=2,nbn1 412 : do 99 i=1,idim 413 : 99 vecn(i,j)=vecn(i,1) 414 : C petite rectif necessaire pour le tri3 415 : if(isup.eq.2) then 416 : do j=1,idim 417 : xeg(j,1) = XZERO 418 : do ip=1,3 419 : xeg(j,1) = xeg(j,1) + xel(j,ip) 420 : enddo 421 : xeg(j,1)=xeg(j,1)/3.D0 422 : enddo 423 : endif 424 : elseif (iele.eq.8) then 425 : C --------------- coq4 ---------------- 425 : call cq4loc(xel,xe,BPSS,irrt,1) 426 : C ici c est une estimation du plan moyen 427 : * write(6,fmt='(3E12.5)') ((bpss(i,j),i=1,3),j=1,3) 428 : do ip=1,ibbas(isous) 429 : do i=1,3 430 : vecn(i,ip)=bpss(3,i) 431 : enddo 432 : enddo 433 : elseif (iele.eq.2) then 434 : C ---------------- coq2 -------------- 435 : vnor=0.D0 436 : do 92 i=1,idim 437 : VEC1(i)=xel(i,2)-xel(i,1) 438 : 92 vnor=vnor + vec1(i)*vec1(i) 439 : vnor = sqrt(vnor) 440 : vecn(1,1)=-vec1(2)/vnor 441 : vecn(2,1)=vec1(1)/vnor 442 : vecn(1,2)=vecn(1,1) 443 : vecn(2,2)=vecn(2,1) 444 : C 445 : elseif (iele.eq.5.or.iele.eq.10) then 446 : *----------- coques epaisses coq8 coq6 447 : if(isup.eq.1) then 447 : call cq8loc(xel,nbn1,MINTE1.SHPTOT,TXR,irr) 448 : else 448 : call cq8loc(xel,nbn1,SHPTOT,TXR,irr) 449 : endif 450 : 451 : C write(6,*) ' normales aux points ad hoc coques epaisses' 452 : do i=1,nbn1 453 : do k=1,3 454 : vecn(k,i)=txr(k,3,i) 455 : enddo 456 : enddo 457 : 2222 format(I4,3E12.5) 458 : 2001 format(3E10.3) 459 : endif 460 : C-------------------------------------------------- 461 : * write(6,*) ' normales a l element ' 462 : * write(6,fmt='(3E12.5)') ((vecn(l,ip),l=1,3),ip=1,nbn1) 463 : C-------------------------------------------------- 464 : C 465 : do 603 ipoi=1,nnb 466 : if(melva1.ne.0) then 467 : ibmn =MIN(iel,melva1.velche(/2)) 468 : igmn =MIN(ipoi,melva1.velche(/1)) 469 : epai = melva1.velche(igmn,ibmn) 470 : else 471 : epai=0.D0 472 : endif 473 : C 474 : if(melva2.ne.0) then 475 : ibmn =MIN(iel,melva2.velche(/2)) 476 : igmn =MIN(ipoi,melva2.velche(/1)) 477 : exce = melva2.velche(igmn,ibmn) 478 : else 479 : exce =0.D0 480 : endif 481 : C si on projette aux points d integration calcul des coordonnes 482 : C sur l element reel 483 : * on range les points sur les normales et non pas par nappes 484 : * pour ne pas chercher n fois exce et epai attention au MCHAML 485 : * 486 : do 603 inap =1,ibnap(isous) 487 : ipo=ipo+1 488 : inupo = inupo+1 489 : if(ibnap(isous).gt.1) then 490 : C if(npint.ne.0.or.mfr.eq.5) then 491 : igau=(inap-1)*inbg(isous)/ibnap(isous)+1 492 : zzz = dzegau(igau) 493 : else 494 : C zzz = (1.D0*inap-2.D0) 495 : zzz = XZERO 496 : endif 497 : dnor=exce+epai*zzz/2.D0 498 : ipt1.num(ipo,iel) =inupo 499 : do 97 i=1,idim 500 : 97 XCOOR((inupo-1)*(IDIM+1)+i) = xeg(i,ipoi)+vecn(i,ipoi)*dnor 501 : C write(6,2003) iel,ipoi,inupo-nbnoe, 502 : C & ( XCOOR((inupo-1)*(IDIM+1)+i),i=1,3),dnor,igau 503 : 603 continue 504 : C write(6,*) 'ipt1 iel ipo nbp crees ' , 505 : C & ipt1,iel,inap,(inupo-nbnoe) 506 : 507 : 95 CONTINUE 508 : segdes minte 509 : if(mfr.eq.5) segdes minte1 510 : 2003 format(3I4,2X,4e12.5,I4) 511 : SEGDES,MCHAML 512 : if (melva1.ne.0) segdes melva1 513 : if (melva2.ne.0) segdes melva2 514 : C 515 : C 516 : ELSEIF(ICOCOQ(ISOUS).EQ.0) THEN 517 : C--------------------------------------------------------- 518 : C ---------------------------- LA SZ EST UN MASSIF ------ 519 : C--------------------------------------------------------- 520 : IF(ISUP.GT.1) THEN 521 : C ---------------- on travaille aux points d integration 522 : minte=iminte(isous) 523 : segact minte 524 : 2234 format(6e12.5) 525 : C 526 : DO 195 iel=1,nbele1 526 : call doxe(xcoor,idim,nbn1,num,iel,xel) 527 : C ------ PROJECTION 528 : DO 700 ip=1,shptot(/3) 529 : DO ik=1,idim 530 : XU(ik)=0.D0 531 : DO jk = 1,NBN1 532 : XU(Ik) = XU(Ik) + SHPTOT(1,JK,ip)*(XEL(IK,jk)) 533 : ENDDO 534 : ENDDO 535 : inupo=inupo+1 536 : ipt1.num(ip,iel) = inupo 537 : do i=1,idim 538 : XCOOR((inupo-1)*(IDIM+1)+i) = xu(i) 539 : enddo 540 : C write(6,2223) inupo,(xu(i),i=1,idim) 541 : 700 CONTINUE 542 : 195 CONTINUE 543 : segdes minte 544 : 2223 format(I6,2X,3E12.5) 545 : ELSE 546 : C on travaille aux noeuds 547 : do 197 iel=1,nbele1 547 : call doxe(xcoor,idim,nbn1,num,iel,xel) 548 : do j=1,nbn1 549 : inupo=inupo+1 550 : ipt1.num(j,iel) = inupo 551 : do i=1,idim 552 : XCOOR((inupo-1)*(IDIM+1)+i) = xel(i,j) 553 : enddo 554 : enddo 555 : 197 continue 556 : ENDIF 557 : C fin de l'alternative coques ou massifs 558 : ENDIF 559 : C-------------------------------- 560 : segdes meleme,imodel 561 : segdes ipt1 562 : SEGSUP WRK4,VECT 563 : * segsup info 564 : * 565 : 100 CONTINUE 566 : C fin de creation des noeuds supports provisoires 567 : C ENDIF 568 : * segdes ipt2 569 : C--------------//////////////////////////////////------------------ 570 : C maintenant il faut un meleme poi1 de tous les points sur lesquels 571 : C on doit interpoler une valeur 572 : segini,ipt4=ipt2 573 : ipgeom=ipt4 574 : if( isup.ne.2) then 574 : call change(ipgeom,1) 575 : segsup ipt4 576 : endif 576 : C call ecrobj('MAILLAGE',ipgeom) 577 : C---------------------------------------------------------------- 578 : C---------------------------------------------------------------- 579 : *-------------on est pret a faire l interpolation sur ipgeom ---- 580 : C 581 : *write(6,*) ' maillage apres changer poi1 ' ,ipgeom 581 : C call ecmail(ipgeom) 582 : isort=0 583 : 584 : * write(6,*) ' dans pron appel a pro2' 584 : CALL PRO2(IPGEOM,IPCHT,isort,IPOUT,ilphmo) 585 : * write(6,*) ' dans pron sortie de pro2',nsous,ilphmo 586 : if (ierr.ne.0) return 587 : C---------------------------------------------------------------- 588 : C---------------------------------------------------------------- 589 : C---------------------------------------------------------------- 590 : C --- il faut maintenant reconstituer les MCHAML 591 : C --- a partir du chpo construit sur ipgeom ---------------- 592 : C------------ INITIALISATION du MCHAML RESULTAT ------------------ 593 : mlchpo = ipout 594 : segact mlchpo 595 : nsouz = nsous 596 : segini phachm 597 : N1=NSOUS 598 : L1=12 599 : N3=6 600 : SEGINI MCHEL1 601 : MCHEL1.TITCHE='SCALAIRE' 602 : MCHEL1.IFOCHE=IFOUR 603 : 604 : * boucle phases modele 605 : DO 7000 IPHAS = 1,JGM 606 : * write(6,*) 'iphas ',jgm,iphas, ' mots ',mots(iphas),ichpoi(/1) 607 : segini icpr,snomip 608 : * mdata=isort 609 : * segact mdata 610 : mchpoi=ichpoi(iphas) 611 : if (mchpoi.le.0) goto 7000 612 : segact mchpoi 613 : nsschp=ipchp(/1) 614 : segini ipcb 615 : C 616 : do i=1,nsschp 617 : * mchpoi=ipca(i) 617 : C call ecchpo( mchpoi) 618 : * segact mchpoi 619 : msoupo=ipchp(i) 620 : ipcb(i)=msoupo 621 : C write(6,*) i,ipca(i),msoupo 622 : segact msoupo 623 : mpoval=ipoval 624 : segact mpoval 625 : nc = nocomp(/2) 626 : C 627 : C tableau des general des composantes 628 : do ic = 1,nc 629 : nomm= nocomp(ic) 630 : if(nomip(/2).eq.0) then 631 : nomip(**)=nomm 632 : else 633 : do k=1,nomip(/2) 634 : if(nomm.eq.nomip(k)) goto 4322 635 : enddo 636 : nomip(**)=nomm 637 : 4322 continue 638 : endif 639 : enddo 640 : * write(6,*) (nomip(l),l=1,nomip(/2)) 641 : * reperage de la position ses points dans le chpo 642 : ipt5=igeoc 643 : segact ipt5 644 : do j=1,ipt5.num(/2) 645 : icpr(1,ipt5.num(1,j))=j 646 : icpr(2,ipt5.num(1,j))= i 647 : enddo 648 : enddo 649 : C i=icpr(2,k) point k venant du msoupo du msoupo i dans ipcb 650 : 651 : kphach = 0 652 : inupo=0 653 : DO 2100 isous = 1,nsous 654 : imodel= KMODEL(isous) 655 : segact imodel 656 : if (conmod(17:24).ne.mots(iphas)) goto 2100 657 : meleme = imamod 658 : segact meleme 659 : C 660 : ipt5=ipt2.lisous(isous) 661 : segact ipt5 662 : N2 = nomip(/2) 663 : mfr=imfr(isous) 664 : * pour une phase donnée ne cree le mchaml qu une fois par maillage 665 : * distinct 666 : 667 : if (kphach.gt.0) then 668 : do kpha = 1,kphach 669 : if (imamod.eq.iphach(kpha)) then 670 : mchaml = mphach(kpha) 671 : logach = .true. 672 : goto 2105 673 : endif 674 : enddo 675 : * création du nouveau segment MCHAML 676 : SEGINI MCHAML 677 : kphach = kphach + 1 678 : iphach(kphach) = imamod 679 : mphach(kphach) = mchaml 680 : logach = .false. 681 : else 682 : * création du nouveau segment MCHAML 683 : SEGINI MCHAML 684 : kphach = kphach + 1 685 : iphach(kphach) = imamod 686 : mphach(kphach) = mchaml 687 : logach = .false. 688 : endif 689 : 690 : 2105 MCHEL1.IMACHE(isous)=MELEME 691 : MCHEL1.ICHAML(isous)=MCHAML 692 : MCHEL1.CONCHE(isous)=CONMOD 693 : MCHEL1.INFCHE(isous,1)=0 694 : MCHEL1.INFCHE(isous,2)=0 695 : MCHEL1.INFCHE(isous,3)=NIFOUR 696 : IF(isup.eq.1) then 697 : MCHEL1.INFCHE(isous,4)=0 698 : MCHEL1.INFCHE(isous,5)=0 699 : MCHEL1.INFCHE(isous,6)=1 700 : ELSE 701 : MCHEL1.INFCHE(isous,4)=iminte(isous) 702 : MCHEL1.INFCHE(isous,5)=0 703 : MCHEL1.INFCHE(isous,6)=isup 704 : ENDIF 705 : * 706 : if (logach) goto 2100 707 : 708 : N1EL=NUM(/2) 709 : N2PTEL=0 710 : N2EL=0 711 : C 712 : IF(ICOCOQ(ISOUS).EQ.1) THEN 713 : C-------------------------------------------------------- 714 : C boucle sur les composantes et c est une coque 715 : C-------------------------------------------------------- 716 : inocom=0 717 : DO 2200 icomp=1,nomip(/2) 718 : inocom=inocom+1 719 : *write(6,*) 'composante ', nomip(icomp) 720 : idebco = inupo 721 : 722 : C N1PTEL= NUM(/1)*nbnap 723 : N1PTEL= nnb*nbnap 724 : SEGINI MELVAL 725 : IELVAL(inocom)= MELVAL 726 : NOMCHE(inocom)= NOCOMP(icomp) 727 : TYPCHE(inocom)= 'REAL*8' 728 : C 729 : DO 162 NUEL=1,num(/2) 730 : DO 162 NUPT=1,nnb 731 : DO 172 IPOS = 1,nbnap 732 : ipop = (ipos-1)*nnb+nupt 733 : inupo = ipt5.num(ipop,nuel) 734 : jh=icpr (1,inupo) 735 : ipa=icpr(2,inupo) 736 : if(jh.eq.0) go to 172 737 : C il faut verifier si vpocha existe pour ce point 738 : msoupo = ipcb(ipa) 739 : mpoval=ipoval 740 : do l=1,nocomp(/2) 741 : if(nocomp(l).eq.nomip(icomp)) then 742 : vvv=vpocha(jh,icomp) 743 : goto 4557 744 : endif 745 : enddo 746 : vvv=XZERO 747 : 4557 continue 748 : C write(6,2004) NUEL,inupo,jh,ipop, 749 : C & ( XCOOR((inupo+nbnoe-1)*(IDIM+1)+i),i=1,3),vvv 750 : VELCHE(ipop,NUEL) = vvv 751 : 172 CONTINUE 752 : 162 CONTINUE 753 : 754 : if(icomp.lt.nocomp(/2)) inupo =idebco 755 : 2200 continue 756 : 757 : ELSE 758 : C-------------------------------------------------------- 759 : C boucle sur les composantes et c est un massif 760 : C-------------------------------------------------------- 761 : 762 : if(isup.eq.1) then 763 : N1PTEL=NUM(/1) 764 : elseif(isup.eq.2) then 765 : N1PTEL=1 766 : else 767 : N1PTEL= inbg(isous) 768 : endif 769 : C 770 : DO 2220 icomp=1,NOMIP(/2) 771 : * write(6,*) 'composante ', nomip(icomp) 772 : idebco = inupo 773 : C 774 : 775 : SEGINI MELVAL 776 : NOMCHE(icomp)=nomip(icomp) 777 : TYPCHE(icomp)='REAL*8' 778 : IELVAL(icomp)=MELVAL 779 : C 780 : DO 163 NUEL=1,N1EL 781 : DO 163 NUPT=1,N1PTEL 782 : inupo=ipt5.num(nupt,nuel) 783 : jh=icpr(1,inupo) 784 : ipa=icpr(2,inupo) 785 : if(jh.eq.0) go to 163 786 : C il faut verifier si vpocha existe pour ce point 787 : msoupo = ipcb(ipa) 788 : mpoval=ipoval 789 : do l=1,nocomp(/2) 790 : if(nocomp(l).eq.nomip(icomp)) then 791 : vvv=vpocha(jh,icomp) 792 : goto 4558 793 : endif 794 : enddo 795 : vvv=XZERO 796 : 4558 continue 797 : 798 : C write(6,2003) NUEL,inupo,jh, 799 : C & ( XCOOR((inupo+nbnoe-1)*(IDIM+1)+i),i=1,3),vvv 800 : VELCHE(NUPT,NUEL) = vvv 801 : 163 CONTINUE 802 : ipcham= mchaml 803 : ipc1 = melval 803 : call comred(ipc1) 804 : melval = ipc1 805 : segdes melval 806 : if(icomp.lt.nocomp(/2)) inupo =idebco 807 : C ---- fin de la boucle sur les composantes 808 : 2220 continue 809 : segdes mchaml,meleme 810 : 811 : C---------------- fin du traitement des massifs 812 : ENDIF 813 : segdes imodel,meleme 814 : segsup ipt5 815 : C fin de la boucle sur les sous zones du modele 816 : 2100 continue 817 : C destruction des chpo intermediaires 818 : do i=1,ipcb(/1) 819 : msoupo=ipcb(i) 820 : cgf ipt5= igeoc (correction 7284) 821 : mpoval= ipoval 822 : * mchpoi=ipca(i) 823 : segsup mpoval,msoupo 824 : cgf segsup ipt5 (correction 7284) 825 : enddo 826 : segsup mchpoi 827 : segsup ipcb,snomip 828 : segsup icpr 829 : 7000 CONTINUE 830 : C (fdp) re-ajustement de MCOORD a sa taille initiale 831 : NBPTS = NBNOE 832 : SEGADJ MCOORD 833 : C retrait des maillages temporaires du pre-conditionnement 834 : c (leurs numero de noeuds depasse la taille de MCOOR) 834 : call crech1b 835 : C (fdp) suppression du maillage temporaire IPT1 836 : ipt1=ipgeom 837 : segsup ipt1 838 : segsup ipt2 839 : segsup phachm 840 : segdes mchel1,mmodel 841 : if(ipche.ne.0) then 842 : mchelm=ipche 843 : segdes mchelm 844 : endif 845 : IPOUT=MCHEL1 846 : segsup sicoq 847 : 848 : return 849 : END 850 : 851 : 852 : 853 : 854 :
© Cast3M 2003 - All rights reserved.
Disclaimer