1 : C FUCHPO SOURCE PV 13/04/12 21:15:40 7756 2 : SUBROUTINE FUCHPO(IP1,IP2,IRET) 3 : C====================================================================== 4 : C fonction: 5 : C sous routine pour fusionner deux champs par points diffus 6 : C 7 : C arguments: 8 : C ip1 (E) pointeur sur le premier des deux champ par point 9 : C ip2 (E) pointeur sur le second des deux champ par point 10 : C iret (S) pointeur sur le champ par point resultat 11 : C 12 : C variables: 13 : C 14 : C * mtrav : - bb(i,j) est la valeur de la ieme inconnue de champ pour 15 : C le jieme noeud du tableau igeo . 16 : C - inco(nnin) contient le nom des nnin inconnues differentes 17 : C - ibin(i,j)=1 ou 0 indique que la ieme inconnue du champ 18 : C existe pour le jieme noeud du tableau igeo . 19 : C - igeo(i) est le numero a mettre dans un objet meleme pour 20 : C referencer le ieme noeud . 21 : C 22 : C * mtra : - nopoin(i) adresse de colonne dans bb et ibin des valeurs 23 : C correspondant au noeud i . 24 : C 25 : C * mtr1 : - ipcom liste des noms des inconnues permet de creer inco . 26 : C 27 : C * mtr2 : - iicom adresse dans ipcom des inconnues correspondant au 28 : C 2ieme ch point . 29 : C 30 : C * mtr3 : - index tableau de correspondance entre les supports geome- 31 : C triques du 1er chpoint et du 2ieme chpoint . 32 : C 33 : C auteur: A de Gayffier 13/06/94 34 : C====================================================================== 35 : IMPLICIT INTEGER(I-N) 36 : IMPLICIT REAL*8(A-H,O-Z) 37 : -INC SMCHPOI 38 : -INC CCOPTIO 39 : -INC SMELEME 40 : -INC SMCOORD 41 : -INC TMTRAV 42 : SEGMENT/MTRA/(NOPOIN(XCOOR(/1)/(IDIM+1))) 43 : SEGMENT MTR1 44 : CHARACTER*4 IPCOM(0) 45 : ENDSEGMENT 46 : SEGMENT/MTR2/(IICOM(0)) 47 : SEGMENT/MTR3/(INDEX(0)) 48 : SEGMENT/MTR4/(IPHAR(0)) 49 : C ordre de grandeur des composantes 50 : SEGMENT/MTR5/(DMOY(NNIN)) 51 : C 52 : DIMENSION IPO(2) 53 : CHARACTER*8 MOT 54 : DATA UN,ZERO/1.D0,0.D0/ 55 : C 56 : segact mcoord 57 : IRET = 0 58 : MCHPO1 = IP1 59 : MCHPO2 = IP2 60 : SEGACT MCHPO1,MCHPO2 61 : C 62 : C verification de la compatibilité des natures 63 : C 64 : NAT1 = MCHPO1.JATTRI(1) 65 : NAT2 = MCHPO2.JATTRI(1) 66 : C 67 : IF ( (NAT1*NAT2) .EQ. 0) THEN 68 : C une des deux nature est indeterminée 68 : CALL ERREUR(650) 69 : SEGDES MCHPO1,MCHPO2 70 : RETURN 71 : ELSE 72 : NANA = (NAT1 + NAT2) / NAT1 / NAT2 73 : IF ((NAT1 .EQ. 2) .AND. (NAT2 .EQ. 2)) THEN 74 : C les deux champ sont discrets: on somme les composantes communes 74 : CALL ADCHPO(IP1,IP2,IRET,1D0,1D0) 75 : RETURN 76 : ELSE IF ((NAT1 .NE. 1) .OR. (NAT2 .NE. 1)) THEN 77 : C les natures ne sont pas compatibles 77 : CALL ERREUR(649) 78 : RETURN 79 : ENDIF 80 : ENDIF 81 : C 82 : C les deux champ sont de nature diffuse 83 : C on moyenne les composantes communes 84 : C 85 : IF ( IP1 .NE. IP2) GOTO 60 86 : C 87 : C *** cas ou les 2 pointeurs ipo1 et ipo2 sont egaux 88 : C 89 : MCHPO1=IP1 90 : SEGACT MCHPO1 91 : NSOUPO=MCHPO1.IPCHP(/1) 92 : NAT=MCHPO1.JATTRI(/1) 93 : SEGINI MCHPOI 94 : DO 10 I=1,NAT 95 : JATTRI(I)=MCHPO1.JATTRI(I) 96 : 10 CONTINUE 97 : IRET=MCHPOI 98 : MOCHDE=MCHPO1.MOCHDE 99 : MTYPOI=MCHPO1.MTYPOI 100 : IFOPOI=IFOUR 101 : DO 50 IA=1,NSOUPO 102 : MSOUP1=MCHPO1.IPCHP(IA) 103 : SEGACT MSOUP1 104 : NC=MSOUP1.NOCOMP(/2) 105 : SEGINI MSOUPO 106 : IPCHP(IA)=MSOUPO 107 : DO 20 IB=1,NC 108 : NOCOMP(IB)=MSOUP1.NOCOMP(IB) 109 : NOHARM(IB)=MSOUP1.NOHARM(IB) 110 : 20 CONTINUE 111 : IGEOC=MSOUP1.IGEOC 112 : MPOVA1=MSOUP1.IPOVAL 113 : SEGACT MPOVA1 114 : N =MPOVA1.VPOCHA(/1) 115 : NC1=MPOVA1.VPOCHA(/2) 116 : IF(NC1.EQ.NC) GOTO 30 117 : C 118 : C erreur pb dimension tableau voir routine adchpo 119 : C 120 : IRET=0 121 : SEGDES MPOVA1,MSOUP1,MCHPO1 122 : SEGSUP MSOUPO,MCHPOI 122 : CALL ERREUR(114) 123 : C on sort de la sous routine 124 : GOTO 666 125 : C 126 : 30 CONTINUE 127 : SEGINI MPOVAL 128 : IPOVAL=MPOVAL 129 : DO 40 IC=1,NC 130 : DO 40 IB=1,N 131 : VPOCHA(IB,IC)=MPOVA1.VPOCHA(IB,IC) 132 : 40 CONTINUE 133 : SEGDES MPOVAL,MPOVA1,MSOUPO,MSOUP1 134 : 50 CONTINUE 135 : C 136 : SEGDES MCHPOI,MCHPO1 137 : C on sort de la sous routine 138 : GOTO 666 139 : C 140 : C *** cas ou les pointeurs ip1 et ip2 sont differents 141 : C 142 : 60 CONTINUE 143 : MCHPO1=IP1 144 : MCHPO2=IP2 145 : IPO(1)=IP1 146 : IPO(2)=IP2 147 : SEGACT MCHPO1,MCHPO2 148 : MOT=MCHPO1.MTYPOI 149 : IF(MOT.NE.MCHPO2.MTYPOI) THEN 150 : MOT='ET OU +' 151 : ENDIF 152 : SEGDES MCHPO1,MCHPO2 153 : C 154 : C on verifie que les nbres de sous paquets sont egaux 155 : C 156 : MCHPO1=IP1 157 : MCHPO2=IP2 158 : SEGACT MCHPO1,MCHPO2 159 : NSOUP1=MCHPO1.IPCHP(/1) 160 : NSOUP2=MCHPO2.IPCHP(/1) 161 : NAT1 = MCHPO1.JATTRI(/1) 162 : NAT2 = MCHPO2.JATTRI(/1) 163 : IF(NSOUP1.EQ.NSOUP2) GO TO 75 164 : SEGDES MCHPO1,MCHPO2 165 : C traitement par la methode générale 166 : GO TO 300 167 : C 168 : C on regarde si les supports geometriques sont identiques a une 169 : C permutation pres 170 : C 171 : 75 SEGINI MTR3 172 : DO 100 IA=1,NSOUP1 173 : MSOUP1=MCHPO1.IPCHP(IA) 174 : SEGACT MSOUP1 175 : DO 80 IB=1,NSOUP2 176 : MSOUP2=MCHPO2.IPCHP(IB) 177 : SEGACT MSOUP2 178 : IF(MSOUP1.IGEOC.EQ.MSOUP2.IGEOC) GO TO 90 179 : SEGDES MSOUP2 180 : 80 CONTINUE 181 : C 182 : C il n y a pas egalite des supports geometriques a une permutation 183 : C pres 184 : C 185 : SEGDES MSOUP1,MCHPO1,MCHPO2 186 : SEGSUP MTR3 187 : C traitement par la methode générale 188 : GO TO 300 189 : C 190 : 90 CONTINUE 191 : C la permutation est rangée dans index 192 : INDEX(**)=IB 193 : SEGDES MSOUP1,MSOUP2 194 : 100 CONTINUE 195 : C 196 : C *** cas ou il y a egalite des supports geometriques a une permutation 197 : C pres 198 : C 199 : NSOUPO=NSOUP1 200 : NAT=MAX(NAT1,NAT2,1) 201 : SEGINI MCHPOI 202 : JATTRI(1) = 1 203 : IRET=MCHPOI 204 : MTYPOI=MOT 205 : MOCHDE=MCHPO1.MOCHDE 206 : IFOPOI=IFOUR 207 : C 208 : DO 250 IA=1,NSOUP1 209 : MSOUP1=MCHPO1.IPCHP(IA) 210 : MSOUP2=MCHPO2.IPCHP(INDEX(IA)) 211 : SEGACT MSOUP1,MSOUP2 212 : C 213 : C comparaison des noms des composantes 214 : C 215 : SEGINI MTR1,MTR4 216 : NC1=MSOUP1.NOCOMP(/2) 217 : NC2=MSOUP2.NOCOMP(/2) 218 : DO 130 IB=1,NC1 219 : IPCOM(**)=MSOUP1.NOCOMP(IB) 220 : IPHAR(**)=MSOUP1.NOHARM(IB) 221 : 130 CONTINUE 222 : SEGINI MTR2 223 : DO 160 IB=1,NC2 224 : DO 140 IC=1,NC1 225 : IF(MSOUP2.NOCOMP(IB).NE.MSOUP1.NOCOMP(IC)) GOTO 140 226 : IF(MSOUP2.NOHARM(IB).EQ.MSOUP1.NOHARM(IC)) GOTO 150 227 : 140 CONTINUE 228 : C la composante du IB n'est pas commune 229 : IPCOM(**)=MSOUP2.NOCOMP(IB) 230 : IPHAR(**)=MSOUP2.NOHARM(IB) 231 : IICOM(**)=IPCOM(/2) 232 : GO TO 160 233 : 150 CONTINUE 234 : C la composante est commune 235 : IICOM(**)=IC 236 : 160 CONTINUE 237 : C 238 : MPOVA1=MSOUP1.IPOVAL 239 : MPOVA2=MSOUP2.IPOVAL 240 : SEGACT MPOVA1,MPOVA2 241 : N1=MPOVA1.VPOCHA(/1) 242 : N2=MPOVA2.VPOCHA(/1) 243 : NCX1=MPOVA1.VPOCHA(/2) 244 : NCX2=MPOVA2.VPOCHA(/2) 245 : IF(NCX1.NE.NC1) GOTO 170 246 : IF(NCX2.NE.NC2) GOTO 170 247 : IF(N1.NE.N2) GOTO 170 248 : GOTO 180 249 : 170 CONTINUE 250 : SEGDES MSOUP1,MSOUP2,MPOVA1,MPOVA2,MCHPO1,MCHPO2 251 : SEGSUP MTR1,MTR2,MTR3,MCHPOI,MTR4 252 : C 253 : C pb avec les dimensions des chpoints 254 : C 254 : CALL ERREUR(114) 255 : IRET=0 256 : C on sort de la sous routine 257 : GOTO 666 258 : C 259 : 180 CONTINUE 260 : N=N1 261 : NC=IPCOM(/2) 262 : SEGINI MPOVAL 263 : NNIN = NC 264 : SEGINI MTR5 265 : C 266 : C mise a 0 de vpocha 267 : C 268 : * DO 190 IB=1,N 269 : * DO 190 IC=1,NC 270 : * VPOCHA(IB,IC)=ZERO 271 : * 190 CONTINUE 272 : C 273 : C addition des chpoints 274 : C 275 : C on place les valeurs de MCHPO1 276 : DO 210 IC=1,NC1 277 : DO 200 IB=1,N 278 : VPOCHA(IB,IC) = MPOVA1.VPOCHA(IB,IC)+VPOCHA(IB,IC) 279 : DMOY(IC) = DMOY(IC) + ABS(VPOCHA(IB,IC)/N) 280 : 200 CONTINUE 281 : IF (IIMPI.EQ.123) 282 : & write (IOIMP,*) ' ic dmoy(ic) ',ic,dmoy(ic) 283 : 210 CONTINUE 284 : C 285 : DO 230 IC=1,NC2 286 : IIC=IICOM(IC) 287 : DO 220 IB=1,N 288 : IF ( IIC .LE. NC1 ) THEN 289 : C il s'agit d'ne composante commune 290 : XX1 = MPOVA2.VPOCHA(IB,IC) 291 : XX2 = VPOCHA(IB,IIC) 292 : DXX = ABS ( XX2 - XX1) 293 : * SXX = MIN(ABS ( XX1 + XX2 ) / 2.D0,1.D-50) 294 : SXX = DMOY(IIC) 295 : IF ( (DXX / SXX) .LT. 1.D-3) THEN 296 : VPOCHA(IB,IIC)= ( XX1 + XX2 ) / 2.D0 297 : ELSE 298 : C les valeurs des champ diffus au meme point sont différentes 299 : IF (IIMPI.EQ.123) 300 : & write (IOIMP,*) xx1,xx2,SXX 300 : CALL ERREUR(651) 301 : SEGDES MSOUP1,MSOUP2,MPOVA1,MPOVA2,MCHPO1,MCHPO2 302 : SEGSUP MTR1,MTR2,MTR3,MCHPOI,MTR4 303 : C on sort 304 : GOTO 666 305 : ENDIF 306 : ELSE 307 : C composantes non communes 308 : VPOCHA(IB,IIC) = MPOVA2.VPOCHA(IB,IC)+VPOCHA(IB,IIC) 309 : ENDIF 310 : 220 CONTINUE 311 : 230 CONTINUE 312 : SEGDES MPOVA2 313 : SEGDES MPOVA1 314 : C 315 : SEGINI MSOUPO 316 : DO 240 IB=1,NC 317 : NOCOMP(IB)=IPCOM(IB) 318 : NOHARM(IB)=IPHAR(IB) 319 : 240 CONTINUE 320 : SEGSUP MTR1,MTR2,MTR4 321 : IPOVAL=MPOVAL 322 : SEGDES MPOVAL 323 : IPT2=MSOUP1.IGEOC 324 : **** SEGINI,IPT1=IPT2 325 : IPT1 = IPT2 326 : IGEOC=IPT1 327 : SEGDES IPT1 328 : IPCHP(IA)=MSOUPO 329 : SEGDES MSOUPO,MSOUP1,MSOUP2 330 : SEGSUP MTR5 331 : 250 CONTINUE 332 : C 333 : SEGSUP MTR3 334 : SEGDES MCHPOI,MCHPO1,MCHPO2 335 : C on sort 336 : GOTO 666 337 : C 338 : C *** cas ou les supports geometriques ne sont pas identiques 339 : C a une permutation pres 340 : C 341 : 300 CONTINUE 342 : C 343 : C **** a-t-on affaires a des champoints vides? 344 : C 345 : MCHPOI=IP1 346 : SEGACT MCHPOI 347 : NS1=IPCHP(/1) 348 : MCHPO2=IP2 349 : SEGACT MCHPO2 350 : NS2=MCHPO2.IPCHP(/1) 351 : IF(NS1*NS2.NE.0) GO TO 3001 352 : SEGDES MCHPOI,MCHPO2 353 : IF(NS1+NS2.NE.0) THEN 354 : C un seul des chpoints est vide 355 : IF(NS1.EQ.0) IP1=IP2 355 : CALL ECRCHA('GEOM') 355 : CALL ECROBJ('CHPOINT ',IP1) 355 : CALL COPIER 355 : CALL LIROBJ('CHPOINT',IRET,1,IRETOU) 356 : ELSE 357 : C les deux chpoints sont vides 358 : NSOUPO=0 359 : NAT=1 360 : SEGINI MCHPOI 361 : IRET = MCHPOI 362 : ENDIF 363 : RETURN 364 : 3001 CONTINUE 365 : C 366 : SEGINI MTRA,MTR1,MTR4 367 : C 368 : C mise a zero de nopoin 369 : C 370 : * DO 305 IA=1,XCOOR(/1)/(IDIM+1) 371 : * NOPOIN(IA)=0 372 : * 305 CONTINUE 373 : C 374 : MCHPOI=IP1 375 : SEGACT MCHPOI 376 : MSOUPO=IPCHP(1) 377 : SEGACT MSOUPO 378 : IPCOM(**)=NOCOMP(1) 379 : IPHAR(**)=NOHARM(1) 380 : SEGDES MSOUPO,MCHPOI 381 : NC=1 382 : IK=0 383 : C 384 : C creation de nopoin et de ipcom 385 : C 386 : DO 360 ICH=1,2 387 : MCHPOI=IPO(ICH) 388 : SEGACT MCHPOI 389 : NSOUPO=IPCHP(/1) 390 : C 391 : C boucle sur les sous references d 1 chpoint 392 : C 393 : DO 350 IA=1,NSOUPO 394 : MSOUPO=IPCHP(IA) 395 : SEGACT MSOUPO 396 : MELEME=IGEOC 397 : SEGACT MELEME 398 : NBNN =NUM(/1) 399 : NBELEM=NUM(/2) 400 : DO 310 IB=1,NBELEM 401 : K=NUM(1,IB) 402 : IF(NOPOIN(K).NE.0) GO TO 310 403 : IK=IK+1 404 : NOPOIN(K)=IK 405 : 310 CONTINUE 406 : SEGDES MELEME 407 : NCBBB=NOCOMP(/2) 408 : DO 330 IB=1,NCBBB 409 : NC=IPCOM(/2) 410 : DO 320 IC=1,NC 411 : IF(IPCOM(IC).NE.NOCOMP(IB)) GO TO 320 412 : IF(IPHAR(IC).EQ.NOHARM(IB)) GO TO 330 413 : 320 CONTINUE 414 : IPCOM(**)=NOCOMP(IB) 415 : IPHAR(**)=NOHARM(IB) 416 : NC=NC+1 417 : 330 CONTINUE 418 : SEGDES MSOUPO 419 : 350 CONTINUE 420 : SEGDES MCHPOI 421 : 360 CONTINUE 422 : C 423 : NNIN=NC 424 : NNNOE=IK 425 : SEGINI MTRAV 426 : C 427 : C initialisation a zero des tableaux 428 : C 429 : SEGINI MTR5 430 : C 431 : * DO 370 IB=1,NNNOE 432 : * DO 370 IA=1,NNIN 433 : * BB(IA,IB)=ZERO 434 : * IBIN(IA,IB)=0 435 : * IMOY(IA,IB) = 0 436 : * 370 CONTINUE 437 : C 438 : C creation de inco 439 : C 440 : DO 380 IA=1,NNIN 441 : INCO(IA)=IPCOM(IA) 442 : NHAR(IA)=IPHAR(IA) 443 : 380 CONTINUE 444 : C 445 : C creation de bb,ibin,igeo 446 : C 447 : DO 450 ICH=1,2 448 : MCHPOI=IPO(ICH) 449 : SEGACT MCHPOI 450 : NSOUPO=IPCHP(/1) 451 : DO 430 IA=1,NSOUPO 452 : MSOUPO=IPCHP(IA) 453 : SEGACT MSOUPO 454 : MELEME=IGEOC 455 : SEGACT MELEME 456 : MPOVAL=IPOVAL 457 : SEGACT MPOVAL 458 : NBELEM=NUM(/2) 459 : N=VPOCHA(/1) 460 : NC=VPOCHA(/2) 461 : NC1=NOCOMP(/2) 462 : C 463 : DO 420 IB=1,NC1 464 : DO 390 IC=1,NNIN 465 : IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 390 466 : IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 400 467 : 390 CONTINUE 468 : 400 CONTINUE 469 : DO 411 ID=1,NBELEM 470 : DMOY(IB)=DMOY(IB)+ABS(VPOCHA(ID,IB)/NBELEM) 471 : 411 CONTINUE 472 : DO 410 ID=1,NBELEM 473 : KI=NOPOIN(NUM(1,ID)) 474 : IGEO(KI)=NUM(1,ID) 475 : IF ( IBIN(IC,KI) .EQ. 1) THEN 476 : C la valeur au point est defini dans les deux champs 477 : XX1 = BB(IC,KI) 478 : XX2 = VPOCHA(ID,IB) 479 : DXX = ABS ( XX2 - XX1 ) 480 : SXX = DMOY(IB) 481 : IF ( DXX .LE. (1.D-4*SXX)) THEN 482 : BB(IC,KI) = ( XX1 + XX2 ) / 2.D0 483 : ELSE 484 : C les valeurs des champs au meme point sont différentes 485 : IF (IIMPI.EQ.123) 486 : & write (IOIMP,*) xx1,xx2,sxx 486 : CALL ERREUR (651) 487 : SEGSUP MTRAV,MTRA,MTR1,MTR4,MTR5 488 : GOTO 666 489 : ENDIF 490 : ELSE 491 : BB(IC,KI)=BB(IC,KI)+VPOCHA(ID,IB) 492 : * DMOY(IC) = DMOY(IC) +ABS(BB(IC,KI)/NNNOE) 493 : ENDIF 494 : IBIN(IC,KI)=1 495 : 410 CONTINUE 496 : 420 CONTINUE 497 : SEGDES MELEME,MSOUPO,MPOVAL 498 : 430 CONTINUE 499 : SEGDES MCHPOI 500 : 450 CONTINUE 501 : ITRAV=MTRAV 502 : SEGDES MTRAV 503 : C 504 : C reconstuction de la partition 505 : C 505 : CALL CRECHP(ITRAV,ICHPOI) 506 : C 507 : SEGSUP MTRAV,MTRA,MTR1,MTR4,MTR5 508 : IRET=ICHPOI 509 : MCHPOI=ICHPOI 510 : MCHPO1 = IP1 511 : MCHPO2 = IP2 512 : SEGACT MCHPOI,MCHPO1,MCHPO2 513 : NAT1 = MCHPO1.JATTRI(/1) 514 : NAT2 = MCHPO2.JATTRI(/1) 515 : NAT=MAX(NAT1,NAT2,1) 516 : NSOUPO = IPCHP(/1) 517 : SEGADJ MCHPOI 518 : IRET=MCHPOI 519 : MTYPOI=MOT 520 : JATTRI(1) = 1 521 : SEGDES MCHPOI,MCHPO1,MCHPO2 522 : C 523 : 666 CONTINUE 524 : RETURN 525 : END 526 : 527 : 528 : 529 : 530 : 531 : 532 : 533 : 534 :
© Cast3M 2003 - All rights reserved.
Disclaimer