1 : C ADCHPO SOURCE CHAT 09/04/08 21:15:01 6355 2 : SUBROUTINE ADCHPO(IPO1,IPO2,IRET,XCO1,XCO2) 3 : C======================================================================= 4 : C 5 : C COMBINAISON LINEAIRE DE 2 CHPS PAR POINTS 6 : C ENTREE 7 : C IPO1=POINTEUR SUR LE 1 CHAMPS PAR POINT 8 : C IPO2=POINTEUR SUR LE 2 CHAMPS PAR POINT 9 : C XCO1 ET XCO2 COEFFICIENTS APPLIQUES SUR LES CHAMPS 10 : C SORTIE 11 : C IRET= POINTEUR SUR LE CHAMP SOMME 12 : C = 0 SI SOMME IMPOSSIBLE 13 : C 14 : C MESSAGE D ERREUR DECLENCHE SI IRET=0 15 : C 16 : C CODE EBERSOLT JUILLET 84 MODIF HAMY NOVEMBRE 84 17 : C 18 : C POUR L INSTANT ON AUTORISE L ADDITION DE CHPOINTS DE SOUS 19 : C TYPE DIFFERENTS ( STOCKES DANS MTYPOI ) 20 : C 21 : C CETTE ROUTINE FAIT APPEL A LA ROUTINE CRECHP 22 : C 23 : C======================================================================= 24 : IMPLICIT INTEGER(I-N) 25 : IMPLICIT REAL*8(A-H,O-Z) 26 : -INC SMCHPOI 27 : -INC CCOPTIO 28 : -INC SMELEME 29 : -INC SMCOORD 30 : -INC TMTRAV 31 : SEGMENT/MTRA/(NOPOIN(XCOOR(/1)/(IDIM+1))) 32 : SEGMENT MTR1 33 : CHARACTER*4 IPCOM(0) 34 : ENDSEGMENT 35 : SEGMENT/MTR2/(IICOM(0)) 36 : SEGMENT/MTR3/(INDEX(max(nsoup1,nsoup2))) 37 : SEGMENT/MTR4/(IPHAR(0)) 38 : SEGMENT/MTR5/(IPOS1(NSOUP1),IPOS2(NSOUP2), 39 : > IZON(XCOOR(/1)/(IDIM+1))) 40 : segment mtr6 41 : character*4 mpcom(ncmax) 42 : integer micom(ncmax),nicom(ncmax) 43 : integer mphar(ncmax) 44 : endsegment 45 : logical errela 46 : C 47 : C----------------------------------------------------------------------- 48 : C --- DESCRIPTION DES SEGMENTS DE TRAVAIL --- 49 : C * MTRAV : - BB(I,J) EST LA VALEUR DE LA IEME INCONNUE DE CHAMP POUR 50 : C LE JIEME NOEUD DU TABLEAU IGEO . 51 : C - INCO(NNIN) CONTIENT LE NOM DES NNIN INCONNUES DIFFERENTES 52 : C - IBIN(I,J)=1 OU 0 INDIQUE QUE LA IEME INCONNUE DU CHAMP 53 : C EXISTE POUR LE JIEME NOEUD DU TABLEAU IGEO . 54 : C - IGEO(I) EST LE NUMERO A METTRE DANS UN OBJET MELEME POUR 55 : C REFERENCER LE IEME NOEUD . 56 : C 57 : C * MTRA : - NOPOIN(I) ADRESSE DE COLONNE DANS BB ET IBIN DES VALEURS 58 : C CORRESPONDANT AU NOEUD I . 59 : C 60 : C * MTR1 : - IPCOM LISTE DES NOMS DES INCONNUES PERMET DE CREER INCO . 61 : C 62 : C * MTR2 : - IICOM ADRESSE DANS IPCOM DES INCONNUES CORRESPONDANT AU 63 : C 2IEME CH POINT . 64 : C 65 : C * MTR3 : - INDEX TABLEAU DE CORRESPONDANCE ENTRE LES SUPPORTS GEOME- 66 : C TRIQUES DU 1ER CHPOINT ET DU 2IEME CHPOINT . 67 : C----------------------------------------------------------------------- 68 : DIMENSION IPO(2),XXT(2) 69 : CHARACTER*8 MOT 70 : C----------------------------------------------------------------------- 71 : C 72 : C MODIFIER ICI SI ON VEUT FAIRE FLO1*CHP1 + FLO2*CHP2 73 : C 74 : C----------------------------------------------------------------------- 75 : XXT(1)=XCO1 76 : XXT(2)=XCO2 77 : XX=XXT(1)+XXT(2) 78 : errela = .false. 79 : werrla = 0.D0 80 : if (iret.eq.-2) errela = .true. 81 : C 82 : IF(IPO1.NE.IPO2) GOTO 60 83 : C 84 : C----------------------------------------------------------------------- 85 : C *** CAS OU LES 2 POINTEURS IPO1 ET IPO2 SONT EGAUX 86 : C----------------------------------------------------------------------- 87 : C 88 : MCHPO1=IPO1 89 : SEGACT MCHPO1 90 : NSOUPO=MCHPO1.IPCHP(/1) 91 : NAT=MCHPO1.JATTRI(/1) 92 : SEGINI MCHPOI 93 : DO 10 I=1,NAT 94 : JATTRI(I)=MCHPO1.JATTRI(I) 95 : 10 CONTINUE 96 : IRET=MCHPOI 97 : MOCHDE=MCHPO1.MOCHDE 98 : MTYPOI=MCHPO1.MTYPOI 99 : IFOPOI=IFOMOD 100 : DO 50 IA=1,NSOUPO 101 : MSOUP1=MCHPO1.IPCHP(IA) 102 : SEGACT MSOUP1 103 : NC=MSOUP1.NOCOMP(/2) 104 : SEGINI MSOUPO 105 : IPCHP(IA)=MSOUPO 106 : DO 20 IB=1,NC 107 : NOCOMP(IB)=MSOUP1.NOCOMP(IB) 108 : NOHARM(IB)=MSOUP1.NOHARM(IB) 109 : 20 CONTINUE 110 : IGEOC=MSOUP1.IGEOC 111 : MPOVA1=MSOUP1.IPOVAL 112 : SEGACT MPOVA1 113 : N =MPOVA1.VPOCHA(/1) 114 : NC1=MPOVA1.VPOCHA(/2) 115 : IF(NC1.EQ.NC) GOTO 30 116 : C 117 : C ERREUR PB DIMENSION TABLEAU VOIR ROUTINE ADCHPO 118 : C 119 : IRET=0 120 : SEGDES MPOVA1,MSOUP1,MCHPO1 121 : SEGSUP MSOUPO,MCHPOI 121 : CALL ERREUR(114) 122 : GOTO 666 123 : 30 CONTINUE 124 : SEGINI MPOVAL 125 : IPOVAL=MPOVAL 126 : DO 40 IC=1,NC 127 : DO 41 IB=1,N 128 : VPOCHA(IB,IC)=XX*MPOVA1.VPOCHA(IB,IC) 129 : 41 CONTINUE 130 : 40 CONTINUE 131 : SEGDES MPOVAL,MPOVA1,MSOUPO,MSOUP1 132 : 50 CONTINUE 133 : SEGDES MCHPOI,MCHPO1 134 : GOTO 666 135 : C 136 : C----------------------------------------------------------------------- 137 : C *** CAS OU LES POINTEURS IPO1 ET IPO2 SONT DIFFERENTS 138 : C----------------------------------------------------------------------- 139 : C 140 : 60 CONTINUE 141 : MCHPO1=IPO1 142 : MCHPO2=IPO2 143 : IPO(1)=IPO1 144 : IPO(2)=IPO2 145 : SEGACT MCHPO1,MCHPO2 146 : MOT=MCHPO1.MTYPOI 147 : IF(MOT.NE.MCHPO2.MTYPOI) THEN 148 : MOT='adchpo' 149 : ENDIF 150 : C 151 : C ON REGARDE SI UN CHAMP EST INCLUS DANS L'AUTRE 152 : C 153 : segact mcoord 154 : MCHPO1=IPO1 155 : MCHPO2=IPO2 156 : SEGACT MCHPO1,MCHPO2 157 : NSOUP1=MCHPO1.IPCHP(/1) 158 : NSOUP2=MCHPO2.IPCHP(/1) 159 : NAT1 = MCHPO1.JATTRI(/1) 160 : NAT2 = MCHPO2.JATTRI(/1) 161 : C 162 : C ON REGARDE SI on peut se passer de repartionner la geometrie 163 : C 164 : SEGINI MTR5 165 : SEGINI MTR3 166 : ncmax2=0 167 : nposr=0 168 : DO 100 IB=1,NSOUP2 169 : MSOUP2=MCHPO2.IPCHP(IB) 170 : SEGACT MSOUP2 171 : ncmax2=max(ncmax2,msoup2.nocomp(/2)) 172 : ipt2=MSOUP2.IGEOC 173 : segact ipt2 174 : do 101 iel=1,ipt2.num(/2) 175 : izon(ipt2.num(1,iel))=ib 176 : 101 continue 177 : 100 continue 178 : ncmax1=0 179 : do 105 ia=1,nsoup1 180 : msoup1=mchpo1.ipchp(ia) 181 : segact msoup1 182 : ncmax1=max(ncmax1,msoup1.nocomp(/2)) 183 : ipt1=msoup1.igeoc 184 : segact ipt1 185 : ib=0 186 : if (ipt1.num(/2).gt.0) ib=izon(ipt1.num(1,1)) 187 : if (ib.eq.0) then 188 : do 106 iel=1,ipt1.num(/2) 189 : if (izon(ipt1.num(1,iel)).ne.0) then 190 : if (iimpi.eq.1954) 191 : > write (ioimp,*) 192 : $ ' adchpo zone 1ch coupe zone 2ch ',ia 193 : $ ,izon(ipt1.num(1,iel)) 194 : goto 109 195 : endif 196 : 106 continue 197 : goto 105 198 : endif 199 : MSOUP2=MCHPO2.IPCHP(IB) 200 : * si meme nombre d'elements on compare les meleme 201 : ipt2=msoup2.igeoc 202 : IF(ipt1.eq.ipt2) GO TO 90 203 : if (ipt1.num(/2).ne.ipt2.num(/2))then 204 : if (iimpi.eq.1954) 205 : > write (ioimp,*) ' adchpo nbel diff ',ipt1.num(/2) 206 : $ ,ipt2.num(/2) 207 : goto 109 208 : endif 209 : do 84 iel=1,ipt1.num(/2) 210 : if (izon(ipt1.num(1,iel)).ne.ib) then 211 : if (iimpi.eq.1954) 212 : > write (ioimp,*) ' adchpo zone mismatch ' 213 : goto 109 214 : endif 215 : 84 continue 216 : 90 CONTINUE 217 : nposr=nposr+1 218 : ipos1(ia)=1 219 : ipos2(ib)=1 220 : INDEX(ia)=IB 221 : 105 CONTINUE 222 : npaq1=0 223 : do 82 ipaq=1,nsoup1 224 : npaq1=npaq1+ipos1(ipaq) 225 : 82 continue 226 : npaq2=0 227 : do 83 ipaq=1,nsoup2 228 : npaq2=npaq2+ipos2(ipaq) 229 : 83 continue 230 : if (iimpi.eq.1954) write (ioimp,*) ' adchpo rapide ' 231 : goto 108 232 : 109 continue 233 : C 234 : C tous les meleme de l'un ne sont pas inclus dans l'autre 235 : C 236 : SEGDES MSOUP1,MCHPO1,MCHPO2 237 : SEGSUP MTR3,MTR5 238 : GO TO 300 239 : 108 continue 240 : C 241 : C *** CAS OU LES SUPPORTS GEOMETRIQUES DE L'UN SONT INCLUS DANS L'AUTRE 242 : C 243 : NSOUPO=NSOUP1+NSOUP2-nposr 244 : NAT=MAX(NAT1,NAT2,1) 245 : SEGINI MCHPOI 246 : IF ( MIN(NAT1,NAT2) .GE. 1) THEN 247 : IF (MCHPO1.JATTRI(1) .EQ. MCHPO2.JATTRI(1)) THEN 248 : JATTRI(1)= MCHPO1.JATTRI(1) 249 : ELSE 250 : JATTRI(1)=0 251 : ENDIF 252 : ELSE 253 : JATTRI(1)=0 254 : ENDIF 255 : IRET=MCHPOI 256 : MTYPOI=MOT 257 : MOCHDE=MCHPO1.MOCHDE 258 : IFOPOI=IFOMOD 259 : ncmax=ncmax1+ncmax2 260 : *goo SEGINI mtr6 261 : nposr=0 262 : DO 250 IA=1,NSOUP1 263 : SEGINI mtr6 264 : if (ipos1(ia).eq.0) goto 250 265 : MSOUP1=MCHPO1.IPCHP(IA) 266 : MSOUP2=MCHPO2.IPCHP(INDEX(IA)) 267 : SEGACT MSOUP1,MSOUP2 268 : C 269 : C COMPARAISON DES NOMS DES COMPOSANTES 270 : C 271 : NC1=MSOUP1.NOCOMP(/2) 272 : NC2=MSOUP2.NOCOMP(/2) 273 : DO 130 IB=1,NC1 274 : mpcom(ib)=MSOUP1.NOCOMP(IB) 275 : mphar(ib)=MSOUP1.NOHARM(IB) 276 : 130 CONTINUE 277 : mc=nc1 278 : DO 160 IB=1,NC2 279 : DO 140 IC=1,NC1 280 : IF(MSOUP2.NOCOMP(IB).NE.MSOUP1.NOCOMP(IC)) GOTO 140 281 : IF(MSOUP2.NOHARM(IB).EQ.MSOUP1.NOHARM(IC)) GOTO 150 282 : 140 CONTINUE 283 : mc=mc+1 284 : mpcom(mc)=MSOUP2.NOCOMP(IB) 285 : mphar(mc)=MSOUP2.NOHARM(IB) 286 : micom(ib)=mc 287 : GO TO 160 288 : 150 CONTINUE 289 : micom(ib)=ic 290 : nicom(ic)=1 291 : 160 CONTINUE 292 : C 293 : MPOVA1=MSOUP1.IPOVAL 294 : MPOVA2=MSOUP2.IPOVAL 295 : SEGACT MPOVA1,MPOVA2 296 : N1=MPOVA1.VPOCHA(/1) 297 : N2=MPOVA2.VPOCHA(/1) 298 : NCX1=MPOVA1.VPOCHA(/2) 299 : NCX2=MPOVA2.VPOCHA(/2) 300 : IF(NCX1.NE.NC1) GOTO 170 301 : IF(NCX2.NE.NC2) GOTO 170 302 : IF(N1.NE.N2) GOTO 170 303 : GOTO 180 304 : 170 CONTINUE 305 : SEGDES MSOUP1,MSOUP2,MPOVA1,MPOVA2,MCHPO1,MCHPO2 306 : SEGSUP MTR6,MCHPOI,MTR3,MTR5 307 : C 308 : C PB AVEC LES DIMENSIONS DES CHPOINTS 309 : C 309 : CALL ERREUR(114) 310 : IRET=0 311 : GOTO 666 312 : * 313 : 180 CONTINUE 314 : * 315 : N=N1 316 : NC=mc 317 : SEGINI MPOVAL 318 : C 319 : C recopier le premier chpo 320 : C 321 : DO 210 IC=1,NC1 322 : if (nicom(ic).eq.0) then 323 : DO 200 IB=1,N 324 : VPOCHA(IB,IC)=XXT(1)*MPOVA1.VPOCHA(IB,IC) 325 : if(errela) VPOCHA(IB,IC)= dabs(VPOCHA(IB,IC)) 326 : 200 CONTINUE 327 : endif 328 : 210 CONTINUE 329 : C 330 : C rajouter le second 331 : C 332 : ipt1=msoup1.igeoc 333 : ipt2=msoup2.igeoc 334 : * si les numerotations sont differentes il faut reordonner 335 : if (ipt1.ne.ipt2) then 336 : do 229 iel=1,ipt2.num(/2) 337 : izon(ipt2.num(1,iel))=iel 338 : 229 continue 339 : DO 230 IC=1,NC2 340 : IIC=micom(ic) 341 : if (iic.gt.nc1) then 342 : DO 221 IB=1,N 343 : VPOCHA(IB,IIC)=XXT(2)* 344 : $ MPOVA2.VPOCHA(izon(ipt1.num(1,ib)),IC) 345 : if(errela) VPOCHA(IB,IIC)= dabs(VPOCHA(IB,IIC)) 346 : 221 CONTINUE 347 : else 348 : DO 220 IB=1,N 349 : VPOCHA(IB,IIC)=XXT(1)*mpova1.VPOCHA(IB,IIC) 350 : $ +XXT(2)*MPOVA2.VPOCHA(izon(ipt1.num(1,ib)) 351 : $ ,IC) 352 : if(errela.and. MPOVA2.VPOCHA(izon(ipt1.num(1,ib) 353 : $ ),IC).ne.0) 354 : $ VPOCHA(IB,IIC)= dabs(VPOCHA(IB,IIC) 355 : $ /MPOVA2.VPOCHA(izon(ipt1.num(1,ib)),IC)) 356 : 220 CONTINUE 357 : endif 358 : 230 CONTINUE 359 : else 360 : * meme pointeur geometrique on se passe de izon 361 : DO 235 IC=1,NC2 362 : IIC=micom(ic) 363 : if (iic.gt.nc1) then 364 : DO 236 IB=1,N 365 : VPOCHA(IB,IIC)=XXT(2)*MPOVA2.VPOCHA(IB,IC) 366 : if(errela) VPOCHA(IB,IIC)= dabs(VPOCHA(IB,IIC)) 367 : 236 CONTINUE 368 : else 369 : DO 237 IB=1,N 370 : VPOCHA(IB,IIC)=XXT(1)*mpova1.VPOCHA(IB,IIC)+ 371 : > XXT(2)*MPOVA2.VPOCHA(IB,IC) 372 : if(errela.and.MPOVA2.VPOCHA(IB,IC).ne.0) 373 : & VPOCHA(IB,IIC)= dabs(VPOCHA(IB,IIC) 374 : $ /MPOVA2.VPOCHA(IB,IC)) 375 : 237 CONTINUE 376 : endif 377 : 235 CONTINUE 378 : endif 379 : SEGDES MPOVA2 380 : SEGDES MPOVA1 381 : C 382 : SEGINI MSOUPO 383 : DO 240 IB=1,NC 384 : NOCOMP(IB)=mpcom(ib) 385 : NOHARM(IB)=mphar(ib) 386 : 240 CONTINUE 387 : IPOVAL=MPOVAL 388 : SEGDES MPOVAL 389 : IPT3=IPT1 390 : IGEOC=IPT3 391 : SEGDES IPT1,ipt2,ipt3 392 : nposr=nposr+1 393 : IPCHP(nposr)=MSOUPO 394 : SEGDES MSOUP1,MSOUP2 395 : SEGSUP MTR6 396 : 250 CONTINUE 397 : *goo SEGSUP MTR6 398 : * il faut maintenant adjoindre les paquets de 1 pas dans 2 ou inversement 399 : DO 251 IA=1,NSOUP1 400 : if (ipos1(ia).ne.0) goto 251 401 : nposr=nposr+1 402 : msoupo=mchpo1.ipchp(ia) 403 : segini,msoup1=msoupo 404 : ipchp(nposr)=msoup1 405 : ipt1=msoup1.igeoc 406 : * segini,ipt2=ipt1 407 : ipt2=ipt1 408 : msoup1.igeoc=ipt2 409 : mpoval=msoup1.ipoval 410 : segact mpoval 411 : n=vpocha(/1) 412 : nc=vpocha(/2) 413 : segini,mpova1 414 : do 254 jb=1,nc 415 : do 2541 ja=1,n 416 : mpova1.vpocha(ja,jb)=xxt(1)*vpocha(ja,jb) 417 : if(errela) MPOVA1.VPOCHA(JA,JB)= 418 : $ dabs(MPOVA1.VPOCHA(JA,JB)) 419 : 2541 continue 420 : 254 continue 421 : msoup1.ipoval=mpova1 422 : segdes ipt1,msoupo,ipt2,mpoval,mpova1 423 : 251 continue 424 : DO 252 IB=1,NSOUP2 425 : if (ipos2(ib).ne.0) goto 252 426 : nposr=nposr+1 427 : msoupo=mchpo2.ipchp(ib) 428 : segini,msoup1=msoupo 429 : ipchp(nposr)=msoup1 430 : ipt1=msoup1.igeoc 431 : * segini,ipt2=ipt1 432 : ipt2=ipt1 433 : msoup1.igeoc=ipt2 434 : mpoval=msoup1.ipoval 435 : segact mpoval 436 : n=vpocha(/1) 437 : nc=vpocha(/2) 438 : segini,mpova1 439 : do 253 jb=1,nc 440 : do 2531 ja=1,n 441 : mpova1.vpocha(ja,jb)=xxt(2)*vpocha(ja,jb) 442 : if(errela) MPOVA1.VPOCHA(JA,JB)= 443 : $ dabs(MPOVA1.VPOCHA(JA,JB)) 444 : 2531 continue 445 : 253 continue 446 : msoup1.ipoval=mpova1 447 : segdes ipt1,msoupo,ipt2,mpoval,mpova1 448 : 252 continue 449 : * verification que les composantes sont bien differentes entre paquets 450 : do 255 isoupo=1,ipchp(/1) 451 : msoup1=ipchp(isoupo) 452 : SEGACT MSOUP1 453 : nc1=msoup1.nocomp(/2) 454 : do 256 jsoupo=isoupo+1,ipchp(/1) 455 : msoup2=ipchp(jsoupo) 456 : SEGACT MSOUP2 457 : nc2=msoup2.nocomp(/2) 458 : if (nc1.ne.nc2) goto 256 459 : do 257 ic1=1,nc1 460 : do 258 ic2=1,nc2 461 : if (msoup1.noharm(ic1).ne.msoup2.noharm(ic2)) 462 : $ goto 258 463 : if (msoup1.nocomp(ic1).eq.msoup2.nocomp(ic2)) 464 : $ goto 257 465 : 258 continue 466 : goto 256 467 : 257 continue 468 : * pas de chance composantes en double 469 : if (iimpi.eq.1954) write (ioimp,*) 470 : $ ' pacquets en double => lent ' 471 : segsup mtr3,mtr5 472 : goto 300 473 : 256 continue 474 : segdes msoup1 475 : 255 continue 476 : SEGSUP MTR3,MTR5 477 : SEGDES MCHPOI,MCHPO1,MCHPO2 478 : GOTO 666 479 : C 480 : C *** CAS OU LES SUPPORTS GEOMETRIQUES NE SONT PAS IDENTIQUES 481 : C *** A UNE PERMUTATION PRES 482 : C 483 : 300 CONTINUE 484 : C 485 : SEGINI MTRA,MTR1,MTR4 486 : C 487 : MCHPOI=IPO1 488 : SEGACT MCHPOI 489 : MSOUPO=IPCHP(1) 490 : SEGACT MSOUPO 491 : IPCOM(**)=NOCOMP(1) 492 : IPHAR(**)=NOHARM(1) 493 : SEGDES MSOUPO,MCHPOI 494 : NC=1 495 : IK=0 496 : C 497 : C CREATION DE NOPOIN ET DE IPCOM 498 : C 499 : DO 360 ICH=1,2 500 : MCHPOI=IPO(ICH) 501 : SEGACT MCHPOI 502 : NSOUPO=IPCHP(/1) 503 : C 504 : C BOUCLE SUR LES SOUS REFERENCES D 1 CHPOINT 505 : C 506 : DO 350 IA=1,NSOUPO 507 : MSOUPO=IPCHP(IA) 508 : SEGACT MSOUPO 509 : MELEME=IGEOC 510 : SEGACT MELEME 511 : NBNN =NUM(/1) 512 : NBELEM=NUM(/2) 513 : C IF(NBNN.NE.1) GOTO 777 514 : DO 310 IB=1,NBELEM 515 : K=NUM(1,IB) 516 : IF(NOPOIN(K).NE.0) GO TO 310 517 : IK=IK+1 518 : NOPOIN(K)=IK 519 : 310 CONTINUE 520 : SEGDES MELEME 521 : NCBBB=NOCOMP(/2) 522 : DO 330 IB=1,NCBBB 523 : NC=IPCOM(/2) 524 : DO 320 IC=1,NC 525 : IF(IPCOM(IC).NE.NOCOMP(IB)) GO TO 320 526 : IF(IPHAR(IC).EQ.NOHARM(IB)) GO TO 330 527 : 320 CONTINUE 528 : IPCOM(**)=NOCOMP(IB) 529 : IPHAR(**)=NOHARM(IB) 530 : NC=NC+1 531 : 330 CONTINUE 532 : SEGDES MSOUPO 533 : 350 CONTINUE 534 : SEGDES MCHPOI 535 : 360 CONTINUE 536 : C 537 : NNIN=NC 538 : NNNOE=IK 539 : SEGINI MTRAV 540 : C 541 : C CREATION DE INCO 542 : C 543 : DO 380 IA=1,NNIN 544 : INCO(IA)=IPCOM(IA) 545 : NHAR(IA)=IPHAR(IA) 546 : 380 CONTINUE 547 : C 548 : C CREATION DE BB,IBIN,IGEO 549 : C 550 : MCHPOI=IPO(1) 551 : SEGACT MCHPOI 552 : NSOUPO=IPCHP(/1) 553 : DO 1430 IA=1,NSOUPO 554 : MSOUPO=IPCHP(IA) 555 : SEGACT MSOUPO 556 : MELEME=IGEOC 557 : SEGACT MELEME 558 : MPOVAL=IPOVAL 559 : SEGACT MPOVAL 560 : NBELEM=NUM(/2) 561 : N=VPOCHA(/1) 562 : NC=VPOCHA(/2) 563 : NC1=NOCOMP(/2) 564 : C 565 : DO 1420 IB=1,NC1 566 : DO 1390 IC=1,NNIN 567 : IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 1390 568 : IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 1400 569 : 1390 CONTINUE 570 : 1400 CONTINUE 571 : DO 1410 ID=1,NBELEM 572 : KI=NOPOIN(NUM(1,ID)) 573 : IGEO(KI)=NUM(1,ID) 574 : IBIN(IC,KI)=1 575 : BB(IC,KI)=XXT(1)*VPOCHA(ID,IB) 576 : 1410 CONTINUE 577 : 1420 CONTINUE 578 : SEGDES MELEME,MSOUPO,MPOVAL 579 : 1430 CONTINUE 580 : SEGDES MCHPOI 581 : MCHPOI=IPO(2) 582 : XSIGN=XXT(2) 583 : SEGACT MCHPOI 584 : NSOUPO=IPCHP(/1) 585 : DO 430 IA=1,NSOUPO 586 : MSOUPO=IPCHP(IA) 587 : SEGACT MSOUPO 588 : MELEME=IGEOC 589 : SEGACT MELEME 590 : MPOVAL=IPOVAL 591 : SEGACT MPOVAL 592 : NBELEM=NUM(/2) 593 : N=VPOCHA(/1) 594 : NC=VPOCHA(/2) 595 : NC1=NOCOMP(/2) 596 : C 597 : DO 420 IB=1,NC1 598 : DO 390 IC=1,NNIN 599 : IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 390 600 : IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 400 601 : 390 CONTINUE 602 : 400 CONTINUE 603 : DO 410 ID=1,NBELEM 604 : KI=NOPOIN(NUM(1,ID)) 605 : IGEO(KI)=NUM(1,ID) 606 : IBIN(IC,KI)=1 607 : BB(IC,KI)=BB(IC,KI)+XXT(2)*VPOCHA(ID,IB) 608 : 410 CONTINUE 609 : 420 CONTINUE 610 : SEGDES MELEME,MSOUPO,MPOVAL 611 : 430 CONTINUE 612 : SEGDES MCHPOI 613 : ITRAV=MTRAV 614 : SEGDES MTRAV 615 : C 616 : C RECONSTUCTION DE LA PARTITION 617 : C 617 : CALL CRECHP(ITRAV,ICHPOI) 618 : C 619 : SEGSUP MTRAV,MTRA,MTR1,MTR4 620 : IRET=ICHPOI 621 : MCHPOI=ICHPOI 622 : MCHPO1 = IPO1 623 : MCHPO2 = IPO2 624 : SEGACT MCHPOI,MCHPO1,MCHPO2 625 : NAT1 = MCHPO1.JATTRI(/1) 626 : NAT2 = MCHPO2.JATTRI(/1) 627 : NAT=MAX(NAT1,NAT2,1) 628 : NSOUPO = IPCHP(/1) 629 : SEGADJ MCHPOI 630 : IRET=MCHPOI 631 : MTYPOI=MOT 632 : IF ( MIN(NAT1,NAT2) .GE. 1) THEN 633 : IF (MCHPO1.JATTRI(1) .EQ. MCHPO2.JATTRI(1)) THEN 634 : JATTRI(1)= MCHPO1.JATTRI(1) 635 : ELSE 636 : JATTRI(1)=0 637 : ENDIF 638 : ELSE 639 : JATTRI(1)=0 640 : ENDIF 641 : SEGDES MCHPOI,MCHPO1,MCHPO2 642 : C 643 : 666 CONTINUE 644 : RETURN 645 : END 646 : 647 : 648 : 649 : 650 : 651 : 652 : 653 :
© Cast3M 2003 - All rights reserved.
Disclaimer