1 : C TASSP2 SOURCE PV 13/04/17 21:15:07 7767 2 : C 3 : SUBROUTINE TASSP2(ITLAC1,ICPR,ICDOUR,ICOLAC,mena) 4 : C====================================================================== 5 : C CE SOUS PROGRAMME EST APPELE PAR TASSPO ELIMIN OU CONFON 6 : C 7 : C itlac1 est une list de pointeur sur les maillage arguments 8 : C icpr etabli une correspondance entre la numerotation globale 9 : C des noeuds et une numerotation locale qui tient compte de 10 : C l'elimination 11 : C icdour est le max des valeurs de icpr 12 : C 13 : C MODIF OCTOBRE 1988 PAR PV TRAITE TOUS LES MELEME 14 : C QUE SAUVER SAIT TRAITER 15 : C===================================================================== 16 : IMPLICIT INTEGER(I-N) 17 : -INC CCOPTIO 18 : -INC CCGEOME 19 : -INC CCNOYAU 20 : -INC CCPRECO 21 : -INC SMELEME 22 : -INC SMCOORD 23 : -INC SMTABLE 24 : -INC SMCHAML 25 : -INC TMLCHA8 26 : -INC SMCHPOI 27 : -INC SMNUAGE 28 : -INC TMCOLAC 29 : -INC SMMODEL 30 : POINTEUR MCOOR1.MCOORD 31 : SEGMENT TAB1 32 : REAL*8 XCOOR1(ILG) 33 : ENDSEGMENT 34 : SEGMENT ICPR(0) 35 : SEGMENT ITRAV(NPM) 36 : segment itrav2(xcoor(/1)/(idim+1)) 37 : C 38 : CHARACTER*8 TYPE 39 : LOGICAL FLAG 40 : DATA NBNNPR/0/ 41 : C===================================================================== 42 : TYPE=' ' 43 : K=-1 44 : C on recupere dans k -npossi, le nombre de type objet possibles 44 : CALL TYPFIL(TYPE,K) 45 : C la pile icolac est cree 45 : CALL CREPIL(ICOLAC,-K) 46 : SEGACT ICOLAC*MOD 47 : ITLACC=KCOLA(1) 48 : ILISSE=ILISSG 49 : segact ilisse*mod 50 : IF (ITLAC1.NE.0) THEN 51 : SEGSUP ITLACC 52 : KCOLA(1)=ITLAC1 53 : ITLACC=KCOLA(1) 54 : * il faut initialiser ilisse sinon on retrouve deux fois les segments 55 : DO 5468 K=1,ITLAC(/1) 56 : IA=ITLAC(K) 57 : IF(IA.EQ.0) GO TO 5468 58 : ILISEG((IA-1)/npgcd)=K 59 : 5468 CONTINUE 60 : ENDIF 61 : * initialisation avec les maillages preconditionnees 62 : do ip=1,nbemel 63 : ipreme= premel(ip) 64 : if (ipreme.ne.0) then 64 : call ajoun(itlacc,ipreme,ilisse,1) 65 : endif 66 : enddo 67 : C recupere la list des types des objets en memoire 67 : CALL LISTYP(MLCHA8) 68 : C rempli les piles itlacc avec les objet de type mlcha8 68 : CALL FILLPO(ICOLAC,MLCHA8) 69 : SEGSUP MLCHA8 70 : * reinitialise preconditionnement COMP 71 : do ip = 1,30 72 : precle(ip) = ' ' 73 : prepre(ip) = 0 74 : preori(ip) = 0 75 : enddo 76 : * 77 : * complete icolac apres l'examan de chaque pile itlacc 78 : * 78 : CALL FILLPI(ICOLAC) 79 : * 80 : * on ne traite les points que si leur nombre a change 81 : * 82 : nbnnac = xcoor(/1)/(idim+1) 83 : nbnnpr=min(nbnnac,nbnnpr) 84 : * write (6,*) 'nb points avant maintenant ',nbnnpr,nbnnac,locerr 85 : if (mena.eq.1) then 86 : if (nbnnac.le.nbnnpr+10000) goto 570 87 : endif 88 : * write (6,*) ' menage complet ' 89 : nbnnpr = nbnnac 90 : * 91 : * 92 : * TRAVAILLER SUR LES MELEME 93 : * 94 : * 95 : SEGACT ICOLAC*MOD 96 : ITLACC=KCOLA(1) 97 : ITL=ITLAC(/1) 98 : IF (IIMPI.NE.0) WRITE(IOIMP,1111) (ITLAC(I),I=1,ITL) 99 : 1111 FORMAT (/,' LISTE DES OBJETS ACCESSIBLES',/,(10I8)) 100 : C RENUMEROTATION EN FONCTION DU PREMIER OBJET 101 : npm=20 102 : segini itrav,itrav2 103 : C 104 : C boucle sur chaque objet de type maillage 105 : icompt=0 106 : DO 10 IOB=1,ITL 107 : MELEME=ITLAC(IOB) 108 : IF (MELEME.EQ.0) goto 10 109 : SEGACT MELEME*MOD 110 : IF (LISOUS(/1).NE.0) GOTO 60 111 : if (num(/1).gt.npm) then 112 : npm=num(/1) 113 : segadj itrav 114 : endif 115 : C boucle sur chaque element 116 : DO 12 I2=1,NUM(/2) 117 : icompt=icompt+1 118 : do 14 i1=1,num(/1) 119 : itrav(i1)=num(i1,i2) 120 : 14 continue 121 : C boucle sur chaque noeud 122 : DO 13 I1=1,NUM(/1) 123 : IP=NUM(I1,I2) 124 : if (ip.ne.0) then 125 : IF (ICPR(IP).EQ.0) THEN 126 : C on affecte un nouveau numero a ce noeud 127 : ICDOUR=ICDOUR+1 128 : ICPR(IP)=ICDOUR 129 : ENDIF 130 : C on change la reference avec le nouveau numero 131 : NUM(I1,I2)=ICPR(IP) 132 : ENDIF 133 : C VERIFICATION PAS DE NOEUDS DOUBLE DANS UN ELEMENT 134 : if (itrav2(icpr(ip)).eq.icompt) then 135 : DO 11 i3=1,i1-1 136 : if (num(i3,i2).eq.num(i1,i2).and.itrav(i1).ne.itrav(i3)) 137 : > then 138 : INTERR(1)=NUM(I1,I2) 139 : INTERR(2)=MELEME 140 : INTERR(3)=I2 141 : C on signale la creation d'un noeud double 141 : CALL ERREUR(516) 142 : endif 143 : 11 continue 144 : endif 145 : itrav2(icpr(ip))=icompt 146 : 13 CONTINUE 147 : 12 CONTINUE 148 : 60 CONTINUE 149 : SEGDES MELEME 150 : 10 CONTINUE 151 : SEGSUP ITRAV,itrav2 152 : * 153 : * MISE A JOUR DE L'OEIL PAR DEFAUT 154 : * 155 : IF (IOEIL.NE.0) THEN 156 : IF (ICPR(IOEIL).EQ.0) THEN 157 : ICDOUR=ICDOUR+1 158 : ICPR(IOEIL)=ICDOUR 159 : ENDIF 160 : IF (IIMPI.NE.0) WRITE (6,*) ' ANCIEN OEIL ',IOEIL, 161 : > ' NOUVEL OEIL ',ICPR(IOEIL) 162 : IOEIL=ICPR(IOEIL) 163 : ENDIF 164 : * 165 : * MISE A JOUR DE ILGNI si necessaire 166 : * 167 : IF (ILGNI.NE.0) THEN 168 : IF (ICPR(ILGNI).EQ.0) THEN 169 : ICDOUR=ICDOUR+1 170 : ICPR(ILGNI)=ICDOUR 171 : ENDIF 172 : ILGNI=ICPR(ILGNI) 173 : ENDIF 174 : * 175 : * TRAVAILLER SUR LES POINTS DANS LES TABLES (NOUS SOMMES TROP BON) 176 : * 177 : ITLACC=KCOLA(10) 178 : ITL=ITLAC(/1) 179 : IF (IIMPI.NE.0) WRITE(IOIMP,1112) (ITLAC(I),I=1,ITL) 180 : 1112 FORMAT (/,' LISTE DES TABLES ACCESSIBLES',/,(10I8)) 181 : C RENUMEROTATION EN FONCTION DU PREMIER OBJET 182 : DO 110 IOB=1,ITL 183 : MTABLE=ITLAC(IOB) 184 : SEGACT MTABLE*MOD 185 : DO 120 I=1,MLOTAB 186 : IF (MTABTI(I).EQ.'POINT ') THEN 187 : IP=MTABII(I) 188 : IF (IP.EQ.0) write(6,*) 'tassp2 1' 188 : IF (IP.EQ.0) CALL ERREUR(5) 189 : IF (ICPR(IP).EQ.0) THEN 190 : ICDOUR=ICDOUR+1 191 : ICPR(IP)=ICDOUR 192 : ENDIF 193 : MTABII(I)=ICPR(IP) 194 : ENDIF 195 : IF (MTABTV(I).EQ.'POINT ') THEN 196 : IP=MTABIV(I) 197 : if(icpr(IP) .gt.icdour) then 198 : write(6,*) ' pas beau icpr(ip) icdour', icpr(ip) , icdour 198 : CALL ERREUR(5) 199 : endif 200 : IF (IP.EQ.0) write(6,*) 'tassp2 point' 200 : IF (IP.EQ.0) CALL ERREUR(5) 201 : IF (ICPR(IP).EQ.0) THEN 202 : * write(6,*) ' ip icdour ' , ip,icdour 203 : ICDOUR=ICDOUR+1 204 : ICPR(IP)=ICDOUR 205 : ENDIF 206 : MTABIV(I)=ICPR(IP) 207 : ENDIF 208 : 120 CONTINUE 209 : SEGDES MTABLE 210 : 110 CONTINUE 211 : * 212 : * attention a la derniere lecture dans gibiane si c'etait un point! 213 : * 214 : * write(6,*) ' ibpile ,ihpile ', ibpile, ihpile 215 : do ib=ibpile,ihpile 216 : if( jtyobj(ib).eq.'POINT ') then 217 : ip= jpoob4(ib) 218 : * write(6,*) ' on a trouve le point ' , ip 219 : if(icpr(ip).eq.0) then 220 : icdour=icdour+1 221 : icpr(ip)=icdour 222 : endif 223 : jpoob4(ib)=icpr(ip) 224 : endif 225 : enddo 226 : * 227 : * TRAVAILLER SUR LES POINTS DANS LES OBJETS 228 : * 229 : ITLACC=KCOLA(44) 230 : ITL=ITLAC(/1) 231 : IF (IIMPI.NE.0) WRITE(IOIMP,4112) (ITLAC(I),I=1,ITL) 232 : 4112 FORMAT (/,' LISTE DES OBJETS ACCESSIBLES',/,(10I8)) 233 : C RENUMEROTATION EN FONCTION DU PREMIER OBJET 234 : DO 4110 IOB=1,ITL 235 : MTABLE=ITLAC(IOB) 236 : SEGACT MTABLE*MOD 237 : DO 4120 I=1,MLOTAB 238 : IF (MTABTI(I).EQ.'POINT ') THEN 239 : IP=MTABII(I) 240 : IF (IP.EQ.0) write(6,*) 'tassp2 2' 240 : IF (IP.EQ.0) CALL ERREUR(5) 241 : IF (ICPR(IP).EQ.0) THEN 242 : ICDOUR=ICDOUR+1 243 : ICPR(IP)=ICDOUR 244 : ENDIF 245 : MTABII(I)=ICPR(IP) 246 : ENDIF 247 : IF (MTABTV(I).EQ.'POINT ') THEN 248 : IP=MTABIV(I) 249 : IF (IP.EQ.0) write(6,*) 'tassp2 3' 249 : IF (IP.EQ.0) CALL ERREUR(5) 250 : IF (ICPR(IP).EQ.0) THEN 251 : ICDOUR=ICDOUR+1 252 : ICPR(IP)=ICDOUR 253 : ENDIF 254 : MTABIV(I)=ICPR(IP) 255 : ENDIF 256 : 4120 CONTINUE 257 : SEGDES MTABLE 258 : 4110 CONTINUE 259 : 260 : * 261 : * TRAVAll sur les points dans les nuages (grande mansuetude) 262 : * 263 : ITLACC=KCOLA(41) 264 : ITL=ITLAC(/1) 265 : IF (IIMPI.NE.0) WRITE(IOIMP,1121) (ITLAC(I),I=1,ITL) 266 : 1121 FORMAT (/,' LISTE DES NUAGES ACCESSIBLES',/,(10I8)) 267 : DO 7230 IOB=1,ITL 268 : MNUAGE=ITLAC(IOB) 269 : SEGACT MNUAGE 270 : DO 7231 I=1,NUAPOI(/1) 271 : IF(NUATYP(I).EQ.'POINT ')THEN 272 : NUAVIN=NUAPOI(I) 273 : SEGACT NUAVIN*MOD 274 : DO 7233 K=1,NUAINT(/1) 275 : IP=NUAINT(K) 276 : IF (IP.EQ.0) write(6,*) 'tassp2 4' 276 : IF (IP.EQ.0) CALL ERREUR(5) 277 : IF (ICPR(IP).EQ.0) THEN 278 : ICDOUR=ICDOUR+1 279 : ICPR(IP)=ICDOUR 280 : ENDIF 281 : NUAINT(K)=ICPR(IP) 282 : 7233 CONTINUE 283 : SEGDES NUAVIN 284 : ENDIF 285 : 7231 CONTINUE 286 : SEGDES MNUAGE 287 : 7230 CONTINUE 288 : 289 : * TRAVAILLER SUR LES POINTS DANS LES MCHAML 290 : * (NOUS SOMMES VRAIMENT TROP BONS) 291 : * 292 : ITLACC=KCOLA(39) 293 : ITL=ITLAC(/1) 294 : IF (IIMPI.NE.0) WRITE(IOIMP,1113) (ITLAC(I),I=1,ITL) 295 : 1113 FORMAT (/,' LISTE DES MCHAMLS ACCESSIBLES',/,(10I8)) 296 : C RENUMEROTATION EN FONCTION DU PREMIER OBJET 297 : 298 : DO 210 IOB=1,ITL 299 : MCHELM=ITLAC(IOB) 300 : if (mchelm.eq.0) goto 210 301 : SEGACT MCHELM 302 : DO 220 I=1,ICHAML(/1) 303 : MCHAML=ICHAML(I) 304 : SEGACT MCHAML*MOD 305 : DO 230 J=1,TYPCHE(/2) 306 : IF(TYPCHE(J).EQ.'POINTEURPOINT ') THEN 307 : MELVAL = IELVAL(J) 308 : IF(MELVAL.LT.0) GO TO 230 309 : SEGACT MELVAL*MOD 310 : NAL1 = IELCHE(/1) 311 : NAL2 = IELCHE(/2) 312 : DO 240 I2=1,NAL2 313 : DO 250 I1=1,NAL1 314 : IP = IELCHE(I1,I2) 315 : if (ip.lt.0) goto 250 316 : IF(IP.EQ.0) write(6,*)'tassp2 5',nomche(j),conche(i),imache(i) 316 : IF (IP.EQ.0) CALL ERREUR(5) 317 : IF (ICPR(IP).EQ.0) THEN 318 : ICDOUR=ICDOUR+1 319 : ICPR(IP)=ICDOUR 320 : ENDIF 321 : IELCHE(I1,I2)=-ICPR(IP) 322 : 250 CONTINUE 323 : 240 CONTINUE 324 : SEGDES MELVAL 325 : IELVAL(J)=-IELVAL(J) 326 : ENDIF 327 : 230 CONTINUE 328 : * PP ON DESACTIVE 329 : SEGDES MCHAML 330 : 220 CONTINUE 331 : * SEGDES MCHELM 332 : 210 CONTINUE 333 : * on remet tout dans l'etat initial 334 : DO 211 IOB=1,ITL 335 : MCHELM=ITLAC(IOB) 336 : if (mchelm.eq.0) goto 211 337 : * SEGACT MCHELM 338 : DO 221 I=1,ICHAML(/1) 339 : MCHAML=ICHAML(I) 340 : * PP ON REACTIVE 341 : SEGACT MCHAML*MOD 342 : DO 231 J=1,TYPCHE(/2) 343 : IF(TYPCHE(J).EQ.'POINTEURPOINT ') THEN 344 : IELVAL(J)=ABS(IELVAL(J)) 345 : MELVAL = IELVAL(J) 346 : SEGACT MELVAL*MOD 347 : NAL1 = IELCHE(/1) 348 : NAL2 = IELCHE(/2) 349 : DO 241 I2=1,NAL2 350 : DO 251 I1=1,NAL1 351 : IELCHE(I1,I2)=abs(IELCHE(I1,I2)) 352 : 251 CONTINUE 353 : 241 CONTINUE 354 : SEGDES MELVAL 355 : ENDIF 356 : 231 CONTINUE 357 : SEGDES MCHAML 358 : 221 CONTINUE 359 : SEGDES MCHELM 360 : 211 CONTINUE 361 : * 362 : * CAS DE LA DEFORMATION PLANE GENERALISEE on prend les points dans les 363 : * et on met a jour NSDPGE 364 : * 365 : 366 : IF(NSDPGE.NE.0) THEN 367 : nsdpge=0 368 : ITLACC=KCOLA(38) 369 : ITL=ITLAC(/1) 370 : IF (IIMPI.NE.0) WRITE(IOIMP,2121) (ITLAC(I),I=1,ITL) 371 : 2121 FORMAT (/,' LISTE DES MODELES ACCESSIBLES (tassp2)',/,(10I8)) 372 : DO 2122 IOB=1,ITL 373 : MMODEL=ITLAC(IOB) 374 : SEGACT MMODEL 375 : DO 2123 IN=1,KMODEL(/1) 376 : IMODEL=KMODEL(IN) 377 : SEGACT IMODEL*MOD 378 : IP=IPDPGE 379 : IF(IP.GT.0) THEN 380 : IF (ICPR(IP).EQ.0) THEN 381 : * on affecte un nouveau numero a ce noeud 382 : ICDOUR=ICDOUR+1 383 : ICPR(IP)=ICDOUR 384 : ENDIF 385 : * on change la reference avec le nouveau numero 386 : IPDPGE=-ICPR(IP) 387 : IF(NSDPGE.le.-IPDPGE)NSDPGE=-IPDPGE 388 : ENDIF 389 : 2123 CONTINUE 390 : 2122 CONTINUE 391 : DO 2124 IOB=1,ITL 392 : MMODEL=ITLAC(IOB) 393 : SEGACT MMODEL 394 : DO 2125 IN=1,KMODEL(/1) 395 : IMODEL=KMODEL(IN) 396 : SEGACT IMODEL*MOD 397 : IPDPGE=ABS(IPDPGE) 398 : SEGDES IMODEL 399 : 2125 CONTINUE 400 : SEGDES MMODEL 401 : 2124 CONTINUE 402 : ENDIF 403 : C 404 : C travail sur le itlac des points deja sauves 405 : C 406 : IF(IPSAUV.NE.0) THEN 407 : ICOLA1=IPSAUV 408 : SEGACT ICOLA1 409 : ITLAC2=ICOLA1.KCOLA(32) 410 : SEGACT ITLAC2*MOD 411 : IF(ITLAC2.ITLAC(/1).NE.0) THEN 412 : DO 560 K=1,ITLAC2.ITLAC(/1) 413 : If(icpr(ITLAC2.ITLAC(K)).eq.0) then 414 : icdour=icdour+1 415 : icpr(ITLAC2.ITLAC(K))=icdour 416 : endif 417 : ITLAC2.ITLAC(K) = icpr(ITLAC2.ITLAC(K)) 418 : 560 CONTINUE 419 : ENDIF 420 : SEGDES ICOLA1,ITLAC2 421 : ENDIF 422 : 423 : * 424 : C ON MET A LA SUITE LES POINTS NOMMES NON DEJA ACCEDES 425 : C POUR COMPLETER LA NOUVELLE LA NUMEROTATION ICPR 426 : DO 50 I=1,LMNNOM 427 : IF (INOOB2(I).NE.'POINT ') GOTO 50 428 : IP=IOUEP2(I) 429 : IF (IP.EQ.0) GOTO 50 430 : IF (ICPR(IP).NE.0) GOTO 51 431 : ICDOUR=ICDOUR+1 432 : ICPR(IP)=ICDOUR 433 : 51 CONTINUE 434 : IOUEP2(I)=ICPR(IP) 435 : 50 CONTINUE 436 : C ICPR CONTIENT LA NOUVELLE NUMEROTATION (LES POINTS A GARDER) 437 : C LES SEGMENTS D'ELEMENTS ONT ETE MIS A JOUR 438 : C DONC TASSER LES POINTS 439 : SEGACT MCOORD 440 : ILG=ICDOUR*(IDIM+1) 441 : SEGINI TAB1 442 : DO 22 I=ICPR(/1),1,-1 443 : IF (ICPR(I).EQ.0) GOTO 22 444 : DO 21 K=1,IDIM+1 445 : XCOOR1((ICPR(I)-1)*(IDIM+1)+K)=XCOOR((I-1)*(IDIM+1)+K) 446 : 21 CONTINUE 447 : 22 CONTINUE 448 : * IL FAUT GARDER LE MEME POINTEUR SUR MCOORD 449 : NBPTS=ICDOUR 450 : SEGADJ MCOORD 451 : DO 23 K=1,ILG 452 : XCOOR(K)=XCOOR1(K) 453 : 23 CONTINUE 454 : SEGSUP TAB1 455 : C 456 : C petit travail pour les objets configuration! 457 : C 458 : MCOOR1=MCOORD 459 : ITLACC=KCOLA(33) 460 : 461 : ITL=ITLAC(/1) 462 : IF (IIMPI.NE.0) WRITE(IOIMP,1114) (ITLAC(I),I=1,ITL) 463 : 1114 FORMAT (/,' LISTE DES CONFIGURATIONS ACCESSIBLES',/,(10I8)) 464 : DO 70 IOB=1,ITL 465 : MCOORD=ITLAC(IOB) 466 : if (mcoord.eq.mcoor1) then 467 : goto 70 468 : endif 469 : SEGACT MCOORD 470 : IMA=XCOOR(/1) /(IDIM+1) 471 : ILG=ICDOUR*(IDIM+1) 472 : SEGINI TAB1 473 : DO 2201 I=ICPR(/1),IMA+1,-1 474 : IF (ICPR(I).EQ.0) GOTO 2201 475 : DO 2101 K=1,IDIM+1 476 : XCOOR1((ICPR(I)-1)*(IDIM+1)+K)= 477 : > MCOOR1.XCOOR((ICPR(I)-1)*(IDIM+1)+K) 478 : 2101 CONTINUE 479 : 2201 CONTINUE 480 : DO 2200 I=MIN(IMA,ICPR(/1)),1,-1 481 : IF (ICPR(I).EQ.0) GOTO 2200 482 : DO 2100 K=1,IDIM+1 483 : XCOOR1((ICPR(I)-1)*(IDIM+1)+K)=XCOOR((I-1)*(IDIM+1)+K) 484 : 2100 CONTINUE 485 : 2200 CONTINUE 486 : * IL FAUT GARDER LE MEME POINTEUR SUR MCOORD 487 : NBPTS=ICDOUR 488 : SEGADJ MCOORD 489 : DO 2300 K=1,ILG 490 : XCOOR(K)=XCOOR1(K) 491 : 2300 CONTINUE 492 : SEGSUP TAB1 493 : SEGDES MCOORD 494 : 70 CONTINUE 495 : MCOORD=MCOOR1 496 : * on garde icpr pour construire le maillage resultat 497 : * SEGSUP ICPR 498 : ILP=ICDOUR 499 : C------------------------------------------------------------------ 500 : C on travaille sur les champs de points pour signaler le cas 501 : C de points multiples 502 : C 503 : C on recherche les noms des objets 503 : CALL FILLNO(ICOLAC) 504 : C attention fillno desactive icolac 505 : SEGACT ICOLAC*MOD 506 : ITLAC1= KCOLA(1) 507 : ITLACC=KCOLA(2) 508 : SEGACT ITLACC*MOD 509 : ITL=ITLAC(/1) 510 : IF (IIMPI.NE.0) WRITE(IOIMP,1115) (ITLAC(I),I=1,ITL) 511 : 1115 FORMAT (/,' LISTE DES OBJETS ACCESSIBLES',/,(10I8)) 512 : C 513 : NPM = ICDOUR 514 : SEGINI ITRAV 515 : C BOUCLE SUR LES CHAMPS DE POINTS DE LA PILE ITLACC 516 : DO 550 I=1,ITL 517 : MCHPOI=ITLAC(I) 518 : IF (MCHPOI.EQ.0) goto 550 519 : SEGACT MCHPOI 520 : NSOUPO=IPCHP(/1) 521 : C 522 : C BOUCLE SUR LES SOUS CHAMP DE POINTS 523 : DO 520 J=1,NSOUPO 524 : MSOUPO=IPCHP(J) 525 : SEGACT MSOUPO 526 : MELEME=IGEOC 527 : SEGACT MELEME 528 : IF ( LISOUS(/1) .NE. 0 ) GOTO 515 529 : C BOUCLE SUR LES POINTS DU SOUS CHAMP 530 : DO 510 I1=1,NUM(/1) 531 : DO 510 I2=1,NUM(/2) 532 : ITRAV(NUM(I1,I2))=ITRAV(NUM(I1,I2))+1 533 : C ITRAV CONTIENT LE NBRE D'OCCURENCE DE CHAQUE POINT 534 : 510 CONTINUE 535 : 515 CONTINUE 536 : 520 CONTINUE 537 : C 538 : C Y A T-IL UN NOEUD DOUBLE ? 539 : C 540 : FLAG = .FALSE. 541 : DO 521 J=1,NSOUPO 542 : MSOUPO=IPCHP(J) 543 : SEGACT MSOUPO 544 : MELEME=IGEOC 545 : SEGACT MELEME 546 : IF ( LISOUS(/1) .NE. 0 ) GOTO 516 547 : C BOUCLE SUR LES POINTS DU SOUS CHAMP 548 : DO 511 I1=1,NUM(/1) 549 : DO 511 I2=1,NUM(/2) 550 : * 551 : IF (ITRAV(num(i1,i2)) .GT. 1 ) THEN 552 : ICHPOI = MCHPOI 553 : iratt=0 553 : CALL ELCHPO(ICHPOI,iratt) 554 : segact meleme 555 : ITLAC(I)=ICHPOI 556 : IF (Iratt .NE. 0 ) THEN 557 : ISGTR = ICOLA(2) 558 : C le chpoint a t-il un nom 559 : MOTERR =' ' 560 : DO 530 JJ=1,ISGTRC(/1) 561 : IF ( ISGTRI(JJ) .EQ. I ) MOTERR = ISGTRC(I) 562 : 530 CONTINUE 563 : C 564 : INTERR(1)= num(i1,i2) 565 : INTERR(2)= MCHPOI 566 : INTERR(3)= ITRAV(num(i1,i2)) 566 : CALL ERREUR(622) 567 : c remise a zero de ierr por pouvoir afficher les erreurs suivantes 568 : IERR = 0 569 : ENDIF 570 : ENDIF 571 : ITRAV(num(i1,i2)) = 0 572 : * 573 : 511 continue 574 : SEGDES MELEME 575 : 516 continue 576 : SEGDES MSOUPO 577 : 521 CONTINUE 578 : c 579 : c 580 : c 581 : SEGACT ITLAC1*MOD 582 : MCHPO1=mCHPOI 583 : SEGACT MCHPO1 584 : ILISSE=ILISSG 585 : SEGACT ILISSE*MOD 586 : DO 566 IOU=1,MCHPO1.IPCHP(/1) 587 : MSOUP1=MCHPO1.IPCHP(IOU) 588 : SEGACT MSOUP1 589 : IGE=MSOUP1.IGEOC 589 : CALL AJOUN(ITLAC1,IGE,ILISSE,1) 590 : SEGDES MSOUP1 591 : 566 CONTINUE 592 : * SEGDES ILISSE 593 : SEGDES MCHPO1 594 : C 595 : SEGDES MCHPOI 596 : 550 CONTINUE 597 : C 598 : SEGsup ITRAV 599 : 570 CONTINUE 600 : segact icolac*mod 601 : 601 : call chleha(2,0,0,0) 602 : 603 : *------------------------------------------------------------------ 604 : * ON APPELLE MAINTENANT MENAG5 POUR FAIRE LE NETTOYAGE DE LA MEMOIRE 604 : * CALL MENAG5(ICOLAC,ITLAC1) 605 : * ON NOTE QUE ITLAC1 N'A PAS ETE DETRUIT (DANS MENAG5) 606 : RETURN 607 : END 608 : 609 : 610 : 611 : 612 : 613 : 614 : 615 : 616 : 617 : 618 : 619 : 620 : 621 : 622 : 623 : 624 : 625 :
© Cast3M 2003 - All rights reserved.
Disclaimer