1 : C TAJPOT SOURCE CHAT 06/03/29 21:35:17 5360 2 : SUBROUTINE TAJPOT(IPT,ITD,ITRNOE,NBNMAX,ITRTRI,NBCMAX, 3 : > NOETRI,NBE,COORD,SPH,NBSMAX, 4 : > ITVL,IMAX,SZERO,NBTNEW,iarr) 5 : C ********************************************************************** 6 : C OBJET : AJOUT DU POINT IPT DANS UNE TRIANGULATION DE DELAUNAY 7 : C 8 : C EN ENTREE : 9 : C IPT : LE NUMERO (DANS COORD) DU POINT A AJOUTER 10 : C ITD : UN TRIANGLE PROCHE DE IPT (SI POSSIBLE) 11 : C 12 : C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI : LA TRIANGULATION 13 : C COORD : COORDONNEES DES NOEUDS DE LA TRIANGULATION 14 : C 15 : C SPH : TABLEAU DES SPHERES CIRCONSCRITES AUX TRIANGLES 16 : C (CF. SPHCERTRI) 17 : C NBSMAX : NOMBRE DE CHAMPS POUR LE CALCUL DES SPHERES (>=2) 18 : C 19 : C ITVL: TABLEAU DE TRAVAIL. ON Y EMPILE SIMULTANEMENT : 20 : C - LES ELEMENTS A DETRUIRE ET LEUR FRONTIERE 21 : C - LES ELEMENTS A CONSTRUIRE ET LES SOMMETS PERDUS 22 : C IMAX : TAILLE DU TABLEAU DE TRAVAIL (6*NBADET+10) 23 : C 24 : C SZERO : SURFACE MINIMUM DES TRIANGLES CREES 25 : C SI ELLE EST ATTEINTE LE POINT EST REJETE 26 : C 27 : C EN SORTIE : LA TRIANGULATION CONTENANT IPT (SI iarr=0) 28 : C NBTNEW : LE NOMBRE D'ELEMENTS CREES 29 : C LES ELEMENTS CREES SONT LES TRIANGLES DE NUMERO 1 A NBTNEW 30 : C iarr : CODE D'ERREUR 0 SI OK 31 : C -1 LE NOEUD N'A PAS PU ETRE AJOUTE (REJET) 32 : C LA TRIANGULATION RESTE VALIDE 33 : C -2 ITVL TROP PETIT 34 : C REMARQUE : 35 : C POUR UTILISER TAJPOT ET AJOUTER UN POINT A UNE TRIANGULATION 36 : C IL FAUT : 37 : C - CREER LA STRUCTURE DU MAILLAGE (CF. SMAOCR) 38 : C - INITIALISER SPH EN APPELANT SPHCERTRI POUR CHAQUE TRIANGLE 39 : C - AJOUTER LES COORDONNEES DU POINT A COORD. 40 : C ********************************************************************** 41 : IMPLICIT INTEGER(I-N) 42 : INTEGER IPT,ITD,NBSMAX,NBTNEW 43 : INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX 44 : INTEGER NOETRI(*),NBE,ITVL(*),IMAX,iarr 45 : REAL*8 SPH(*),COORD(*),SZERO 46 : C 47 : C --- POUR LE DEBUG --- 48 : C 49 : C COMMON /DEBUG/ ITRACE, ITEST, iarrOR, IMESS 50 : C INTEGER ITRACE, ITEST, iarrOR 51 : C CHARACTER*256 IMESS 52 : C 53 : C --- POUR LES STATS --- 54 : C 55 : C COMMON /STATS/ ICARD(100),TEMPSCPU(100) 56 : C INTEGER ICARD 57 : C REAL TEMPSCPU 58 : C --- VARIABLES INTERNES --- 59 : INTEGER IDE,NBC,IADETR,NADETR,NBCSTR,IACSTR,NTCMAX 60 : C INTEGER ITRAV,NBTRAV, 61 : INTEGER NBFNOE,ITRACE 62 : INTEGER I,J,K, IND, IFR,NIFMAX,NBIFR,ISOMP,NBSOMP 63 : INTEGER NBIFR1,IT,IF,IT1,IFR2,NBCOL,NP, NOEMAX 64 : INTEGER ISENS, IDIMC 65 : INTEGER GORIEN 66 : EXTERNAL GORIEN 67 : C 68 : C ---- POUR LE DEBUG ---- 69 : INTEGER ITERR, ITAMPO 70 : INTEGER ITERR2, IAERR, NT, IPTDSC, IPTDS2, IPOINT(3),IOR 71 : INTEGER SPPOIN, SPPOI2 72 : EXTERNAL SPPOIN, SPPOI2 73 : REAL*8 TAILLE, ZERO 74 : C REAL TIMED, TIMEF, TABTIME(2), ETIME 75 : C EXTERNAL ETIME 76 : C 77 : ITRACE = 0 78 : IDIMC = 2 79 : NBTNEW = 0 80 : ZERO = 1.D-30 81 : IDE = IDIMC 82 : NBC = IDIMC + 1 83 : NOEMAX = 1 84 : C 85 : C ---- 1. RECHERCHE DES ELEMENTS A DETRUIRE -------------------- 86 : C LES ELEMENTS DONT LE CERCLE CIRCONSCRIT CONTIENT LE POINT "IPT" 87 : C SONT MIS DANS LE TABLEAU ITVL DE "IADETR" JUSQU'A "NADETR" 88 : C -------------------------------------------------------------- 89 : C TIMED = ETIME(TABTIME) 90 : C 91 : IADETR = 1 92 : IF( ITD.GT.0 )THEN 93 : C ------------------------------------------------ 94 : C --- ON CONNAIT 1 TRIANGLE CONTENANT LE POINT : ITD --- 95 : C ------------------------------------------------ 96 : ITVL(IADETR) = ITD 97 : NADETR = 1 97 : CALL RTCONN(COORD((IPT-1)*IDIMC+1),IDIMC,ITRNOE,NBNMAX, 98 : > ITRTRI,NBCMAX,COORD,SPH, 99 : > ITVL(IADETR),NADETR,IMAX,ZERO,iarr) 100 : 101 : ELSE 102 : C ----------------------------------------------------- 103 : C --- ON RECHERCHE LES TRIANGLES CONTENANT LE POINT : ITD --- 104 : C ----------------------------------------------------- 105 : NADETR = 0 105 : CALL RTADET(COORD((IPT-1)*IDIMC+1),IDIMC,ITRNOE,NBNMAX, 106 : > ITRTRI,NBCMAX,NBE,COORD,SPH, 107 : > ITVL(IADETR),NADETR,IMAX,ZERO,iarr) 108 : ENDIF 109 : IF((NADETR.LT.1).OR.(iarr .NE. 0))THEN 110 : iarr = -1 110 : CALL DSERRE(1,iarr,'TAJPOT','DANS LA RECHERCHE') 111 : GOTO 999 112 : ELSE 113 : IF( ITRACE.NE. 0 )THEN 114 : C PRINT *,'A DETRUIRE :',NADETR 115 : C PRINT *,(ITVL(IADETR+I-1),I=1,NADETR) 116 : ENDIF 117 : ENDIF 118 : C 119 : NTCMAX = 2 120 : C 121 : C TIMEF = ETIME(TABTIME) 122 : C TEMPSCPU(1) = TEMPSCPU(1) + TIMEF - TIMED 123 : C 124 : C 125 : C ---- 2. CALCUL DE LA FRONTIERE ----------------------------- 126 : C 127 : C TIMED = TIMEF 128 : C 128 : CALL ENSTRI(ITVL(IADETR),NADETR) 129 : C 130 : DO 10 I=1,NTCMAX 131 : ITVL(IADETR+NADETR+I-1) = I + NBE 132 : DO 5 K=1,NBNMAX 133 : ITRNOE(((I+NBE)-1)*NBNMAX + K ) = 0 134 : 5 CONTINUE 135 : DO 6 K=1,NBCMAX 136 : ITRTRI(((I+NBE)-1)*NBCMAX + K ) = 0 137 : 6 CONTINUE 138 : 10 CONTINUE 139 : C PRINT *,'AVANT RENUMEROTATION' 139 : C CALL DEBTABIPR(ITRNOE,NBE,NBNMAX,1) 139 : C CALL DEBTABIPR(ITRTRI,NBE,NBCMAX,1) 139 : CALL NUCOMP(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, 140 : > NOEMAX,(NBE+NTCMAX),ITVL(IADETR), 141 : > (NADETR+NTCMAX),iarr) 142 : IF(iarr .NE. 0)THEN 142 : CALL DSERRE(1,iarr,'NUCOMP','COMPRESSION EL') 143 : GOTO 999 144 : ENDIF 145 : C ---- COMPACTAGE DES SPHERES -------------------------------- 145 : CALL SPCOMP(SPH, NBSMAX, (NBE+NTCMAX),ITVL(IADETR), 146 : > (NADETR+NTCMAX),iarr) 147 : IF(iarr .NE. 0)THEN 147 : CALL DSERRE(1,iarr,'SPCOMP','COMPRESSION SPH') 148 : GOTO 999 149 : ENDIF 150 : IND = 1 151 : IFR = IADETR + NADETR 152 : NBIFR = 0 153 : NIFMAX = IMAX - NADETR 153 : CALL TMAFRT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,IND,NADETR, 154 : > ITVL(IFR),NBIFR,NIFMAX,iarr) 155 : C ---- POUR LE DEBUG ---------- 156 : IF( iarr .NE. 0 )THEN 156 : CALL DSERRE(1,iarr,'TAJPOT','FRONTIERE T A DET.') 156 : C CALL DEBTABIPR(ITRNOE,NBE+NTCMAX,NBNMAX,1) 156 : C CALL DEBTABIPR(ITRTRI,NBE+NTCMAX,NBCMAX,1) 157 : GOTO 999 158 : ENDIF 159 : C IF( ITRACE.NE.0 )THEN 160 : C PRINT *,'FRONTIERE : ',(ITVL((I-1)*2+IFR), 161 : C > ITVL((I-1)*2+IFR+1),I=1,NBIFR) 162 : C ENDIF 163 : C 164 : C TIMEF = ETIME(TABTIME) 165 : C TEMPSCPU(2) = TEMPSCPU(2) + TIMEF - TIMED 166 : C 167 : C ---- 3. VERIFICATION DE L'ORIENTATION ---------------------- 168 : C 169 : IACSTR = IFR + ( NBIFR * 2 ) 170 : NBCSTR = NBIFR 171 : IF( NBCSTR .LT. (NADETR+2))THEN 172 : C --- POUR LE CAS 2D --- 173 : iarr = -1 173 : CALL DSERRE(1,iarr,'TAJPOT','SOMMET PERDU') 174 : C ICARD(4) = ICARD(4) + 1 175 : GOTO 100 176 : ENDIF 177 : C 178 : IF( NBCSTR .GT. (NADETR+2))THEN 179 : C --- POUR LE CAS 2D --- 180 : iarr = -1 180 : CALL DSERRE(1,iarr,'TAJPOT','TRI NON CONNEXES') 181 : C ICARD(5) = ICARD(5) + 1 182 : GOTO 100 183 : ENDIF 184 : C 185 : DO 20 I=1,NBIFR 186 : C ITVL((I-1)*NBC+IACSTR) = IPT 186 : C CALL TNOFRT(IDE,ITRNOE,NBNMAX,ITVL((I-1)*2+IFR), 187 : C > ITVL((I-1)*2+IFR+1),ITVL((I-1)*NBC+IACSTR+1)) 188 : C 189 : C 190 : ITVL((I-1)*NBC+IACSTR+2) = IPT 190 : CALL TNOFRT(IDE,ITRNOE,NBNMAX,ITVL((I-1)*2+IFR), 191 : > ITVL((I-1)*2+IFR+1),ITVL((I-1)*NBC+IACSTR)) 192 : IF( GORIEN(ITVL((I-1)*NBC+IACSTR),NBC,COORD,IDIMC,SZERO) 193 : > .NE.1 )THEN 194 : C ---- POUR LE DEBUG ---- 195 : IF( ITRACE.EQ. 1 ) THEN 196 : C PRINT *,'ERREUR A L AJOUT DU POINT ',IPT 197 : C PRINT *,(COORD((IPT-1)*IDIMC+J),J=1,IDIMC) 198 : C PRINT *,'-----> ELEMENT A CONSTRUIRE :' 199 : DO 13 J=1,NBC 200 : IPOINT(J) = ITVL((I-1)*NBC+IACSTR+J-1) 201 : 13 CONTINUE 202 : C PRINT *,'T = ',(IPOINT(J),J=1,NBC) 202 : CALL GTAILL(IPOINT,NBC,COORD,IDIMC,TAILLE,iarr) 203 : C PRINT *,'S = ',TAILLE 204 : IOR = GORIEN(ITVL((I-1)*NBC+IACSTR), 205 : > NBC,COORD,IDIMC,SZERO) 206 : C PRINT *,'ORIENTATION = ',IOR 207 : C 208 : C PRINT *,'-----> ELEMENT A DETRUIRE :' 209 : ITERR = ITVL((I-1)*2+IFR) 210 : IAERR = ITVL((I-1)*2+IFR+1) 211 : C PRINT *,'T = ',ITERR 212 : C PRINT *,'A = ',IAERR 213 : NT = ITRNOE((ITERR-1)*NBNMAX+1+IDIMC) 214 : IPTDSC = SPPOIN(IDIMC,COORD((NT-1)*IDIMC+1), 215 : > COORD((IPT-1)*IDIMC+1), 216 : > SPH((ITERR-1)*(IDIMC+1)+1),ZERO) 217 : IPTDS2 = SPPOI2(IDIMC,COORD((NT-1)*IDIMC+1), 218 : > COORD((IPT-1)*IDIMC+1), 219 : > SPH((ITERR-1)*(IDIMC+1)+1),ZERO) 220 : C IF( IPTDSC .NE. 1)PRINT *,'ON NE DOIT PAS DETRUIRE T',ITERR 221 : C PRINT *,'-----> ELEMENT VOISIN DE L ELEMENT :' 222 : ITERR2 = ITRTRI((ITERR-1)*NBCMAX+IAERR) 223 : C PRINT *,'T = ',ITERR2 224 : NT = ITRNOE((ITERR2-1)*NBNMAX+1+IDIMC) 225 : IPTDSC = SPPOIN(IDIMC,COORD((NT-1)*IDIMC+1), 226 : > COORD((IPT-1)*IDIMC+1), 227 : > SPH((ITERR2-1)*(IDIMC+1)+1),ZERO) 228 : IPTDS2 = SPPOI2(IDIMC,COORD((NT-1)*IDIMC+1), 229 : > COORD((IPT-1)*IDIMC+1), 230 : > SPH((ITERR2-1)*(IDIMC+1)+1),ZERO) 231 : C IF( IPTDSC .EQ. 1)PRINT *,'ON A OUBLIE DE DETRUIRE T',ITERR2 232 : ENDIF 233 : C 234 : C ---- REPRISE SUR ERREUR : RECOMPACTAGE ---- 235 : 236 : iarr = -1 236 : C CALL DSERRE(1,iarr,'TAJPOT','ORIENTATION ELEMENT') 237 : C ICARD(5) = ICARD(5) + 1 238 : C 239 : C --- ON PERTURBE LE CALCUL DES SPHERES --- 240 : C 241 : ITERR = ITVL((I-1)*2+IFR) 242 : IAERR = ITVL((I-1)*2+IFR+1) 243 : ITERR2 = ITRTRI((ITERR-1)*NBCMAX+IAERR) 244 : ITAMPO = ITRNOE(ITERR*NBNMAX) 245 : ITRNOE(ITERR*NBNMAX) = ITRNOE(ITERR*NBNMAX-1) 246 : ITRNOE(ITERR*NBNMAX-1) = ITRNOE(ITERR*NBNMAX-2) 247 : ITRNOE(ITERR*NBNMAX-2) = ITAMPO 248 : ITAMPO = ITRTRI(ITERR*NBCMAX) 249 : ITRTRI(ITERR*NBCMAX) = ITRTRI(ITERR*NBCMAX-1) 250 : ITRTRI(ITERR*NBCMAX-1) = ITRTRI(ITERR*NBCMAX-2) 251 : ITRTRI(ITERR*NBCMAX-2) = ITAMPO 252 : C 252 : CALL SPCREE(IDIMC,ITERR,ITRNOE((ITERR-1)*NBNMAX+1), 253 : > COORD,SPH,ZERO,iarr) 254 : C 255 : C --- ON PERTURBE AUSSI LE VOISIN --- 256 : C 257 : IF( ITERR2.LE.0 )GOTO 100 258 : ITERR = ITERR2 259 : ITAMPO = ITRNOE(ITERR*NBNMAX) 260 : ITRNOE(ITERR*NBNMAX) = ITRNOE(ITERR*NBNMAX-1) 261 : ITRNOE(ITERR*NBNMAX-1) = ITRNOE(ITERR*NBNMAX-2) 262 : ITRNOE(ITERR*NBNMAX-2) = ITAMPO 263 : ITAMPO = ITRTRI(ITERR*NBCMAX) 264 : ITRTRI(ITERR*NBCMAX) = ITRTRI(ITERR*NBCMAX-1) 265 : ITRTRI(ITERR*NBCMAX-1) = ITRTRI(ITERR*NBCMAX-2) 266 : ITRTRI(ITERR*NBCMAX-2) = ITAMPO 267 : C 267 : CALL SPCREE(IDIMC,ITERR,ITRNOE((ITERR-1)*NBNMAX+1), 268 : > COORD,SPH,ZERO,iarr) 269 : 270 : GOTO 100 271 : ENDIF 272 : 20 CONTINUE 273 : C 274 : C ---- 4. FRONTIERE EXTERIEUR DU TROU --------- 275 : C LES VOISINS SUR LA FRONTIERES DES ELEMENTS A DETRUIRE 276 : C 277 : NBIFR1 = 0 278 : DO 50 I=1,NBIFR 279 : IT = ITVL((I-1)*2+IFR) 280 : IF = ITVL((I-1)*2+IFR+1) 281 : C --- MULTI-MAT --- 282 : ISENS = 1 283 : IF( IF.LT.0 )ISENS = -1 284 : IT1 = ABS(ITRTRI((IT-1)*NBCMAX+(IF*ISENS))) 285 : IF( IT1.NE.0 )THEN 286 : DO 30 J=1,NBCMAX 287 : IF(ABS(ITRTRI((IT1-1)*NBCMAX+J)).EQ.IT)GO TO 40 288 : 30 CONTINUE 289 : iarr = -1 289 : CALL DSERRE(1,iarr,'TAJPOT','ERREUR TROU') 290 : GO TO 999 291 : 40 NBIFR1 = NBIFR1 + 1 292 : ITVL((NBIFR1-1)*2+IFR) = ABS(IT1) 293 : ITVL((NBIFR1-1)*2+IFR+1) = ISENS*J 294 : ENDIF 295 : 50 CONTINUE 296 : C 297 : C ---- 5. DESTRUCTION DES MAILLES ---------------------------- 298 : C 299 : C TIMED = ETIME(TABTIME) 300 : C 301 : NBFNOE = 0 302 : NBSOMP = 0 303 : ISOMP = IACSTR + (NBCSTR * NBC) 304 : DO 60 I=1,NADETR 304 : CALL SMADET(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NOETRI, 305 : > NBFNOE,I,NBC,ITVL(ISOMP+NBSOMP),NBSOMP,iarr) 306 : IF( iarr .NE. 0 )THEN 306 : CALL DSERRE(1,iarr,'TAJPOT','ERREUR DESTRUCTION') 307 : GOTO 999 308 : ENDIF 309 : 60 CONTINUE 310 : NBE = NBE - NADETR 311 : IF( NBSOMP.NE.0 )THEN 312 : iarr = -1 312 : CALL DSERRE(1,iarr,'TAJPOT','SOMMETS PERDUS') 313 : C PRINT *, (ITVL(ISOMP),I=1,NBSOMP) 314 : GO TO 999 315 : ENDIF 316 : C 317 : C TIMEF = ETIME(TABTIME) 318 : C TEMPSCPU(5) = TEMPSCPU(5) + TIMEF - TIMED 319 : C 320 : C ---- 6. CONSTRUCTION DES NOUVEAUX ELEMENTS ----------------- 321 : C 322 : C TIMED = TIMEF 323 : C 324 : NBFNOE = 0 325 : C ITRAV = ISOMP 326 : C NBTRAV = IMAX - ITRAV + 1 326 : C CALL STRCREE(IDE,ITVL(IACSTR),NBCSTR, 327 : C > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NBFNOE, 328 : C > ITVL(ITRAV),NBTRAV,iarr) 329 : C REMPLACE PAR : 330 : C ========================================================= 331 : DO 63 I=1,NBCSTR 332 : DO 61 J=1,NBC 333 : ITRNOE((I-1)*NBNMAX+J)=ITVL((I-1)*NBC+IACSTR-1+J) 334 : ITRTRI((I-1)*NBCMAX+J)=0 335 : 61 CONTINUE 336 : DO 62 J=1,(I-1) 337 : IF( ITRNOE((J-1)*NBNMAX+1).EQ.ITRNOE((I-1)*NBNMAX+2) )THEN 338 : ITRTRI((J-1)*NBCMAX+3) = I 339 : ITRTRI((I-1)*NBCMAX+2) = J 340 : ENDIF 341 : IF( ITRNOE((J-1)*NBCMAX+2).EQ.ITRNOE((I-1)*NBCMAX+1) )THEN 342 : ITRTRI((J-1)*NBCMAX+2) = I 343 : ITRTRI((I-1)*NBCMAX+3) = J 344 : ENDIF 345 : 62 CONTINUE 346 : 63 CONTINUE 347 : C DO 62 J=1,(I-1) 348 : C IF( ITRNOE((J-1)*NBNMAX+3).EQ.ITRNOE((I-1)*NBNMAX+2) )THEN 349 : C ITRTRI((J-1)*NBCMAX+3) = I 350 : C ITRTRI((I-1)*NBCMAX+1) = J 351 : C ENDIF 352 : C IF( ITRNOE((J-1)*NBCMAX+2).EQ.ITRNOE((I-1)*NBCMAX+3) )THEN 353 : C ITRTRI((J-1)*NBCMAX+1) = I 354 : C ITRTRI((I-1)*NBCMAX+3) = J 355 : C ENDIF 356 : C 62 CONTINUE 357 : C 63 CONTINUE 358 : C NOETRI(ITVL((I-1)*NBC+IACSTR)) = 1 359 : C BUG4 O.STAB 08.08.95 REMPLACER PAR : 360 : NOETRI(IPT) = 1 360 : C CALL DEBTABIPR(ITRNOE,NBCSTR,NBNMAX,1) 360 : C CALL DEBTABIPR(ITRTRI,NBCSTR,NBCMAX,1) 361 : C ========================================================== 362 : DO 70 I=1,NBCSTR 363 : C --- POUR LE DEBUG --- 364 : IF( ITRACE .GT. 0 )THEN 365 : IF( GORIEN(ITRNOE((I-1)*NBNMAX+1),NBC, COORD, IDIMC, SZERO ) 366 : > .NE.1 )THEN 367 : C PRINT *,'ERREUR D ORIENTATION A LA CREATION DE T',I 368 : C PRINT *,'P1 : ',ITRNOE((I-1)*NBNMAX+1) 369 : C PRINT *,'P2 : ',ITRNOE((I-1)*NBNMAX+2) 370 : C PRINT *,'P3 : ',ITRNOE((I-1)*NBNMAX+3) 371 : iarr = -1 372 : GO TO 999 373 : ENDIF 374 : ENDIF 375 : C --------------------- 375 : CALL SPCREE(IDIMC,I,ITRNOE((I-1)*NBNMAX+1),COORD,SPH, 376 : > ZERO,iarr) 377 : IF( iarr .NE. 0 )THEN 377 : CALL DSERRE(1,iarr,'TAJPOT','CALCUL SPHERES') 378 : GOTO 999 379 : ENDIF 380 : 70 CONTINUE 381 : C 382 : C TIMEF = ETIME(TABTIME) 383 : C TEMPSCPU(6) = TEMPSCPU(6) + TIMEF - TIMED 384 : C 385 : C --- 7. CONNECTION AVEC LES ANCIENS --- 386 : C 387 : C TIMED = TIMEF 388 : C 389 : IND = 1 390 : IFR2 = IACSTR 391 : NIFMAX = IMAX - IACSTR 391 : CALL TMAFRT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,IND,NBCSTR, 392 : > ITVL(IFR2),NBIFR,NIFMAX,iarr) 393 : IF( iarr .NE. 0 )THEN 393 : CALL DSERRE(1,iarr,'TAJPOT','FRONTIERE T CREES') 394 : GOTO 999 395 : ENDIF 396 : C 397 : C --- MISE A JOUR DE ITRTRI ----------------- 398 : C 398 : CALL S2GLAR(ITVL(IFR),NBIFR1,ITVL(IFR2),NBIFR, 399 : > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBCOL) 400 : C 401 : C --- MISE A JOUR DE NOETRI ----------------- 402 : C 403 : DO 90 I=1,NBCSTR 404 : DO 80 J=1,NBNMAX 405 : NP = ITRNOE((I-1)*NBNMAX+J) 406 : IF( NP .NE. 0 )NOETRI(NP)=I 407 : 80 CONTINUE 408 : 90 CONTINUE 409 : NBE = NBE + NBCSTR 410 : NBTNEW = NBCSTR 411 : C ICARD(6) = ICARD(6) + NBCSTR 412 : C ICARD(7) = ICARD(7) + NADETR 413 : C 414 : C TIMEF = ETIME(TABTIME) 415 : C TEMPSCPU(7) = TEMPSCPU(7) + TIMEF - TIMED 416 : GOTO 999 417 : C 418 : C ---- REPRISE SUR ERREUR : RECOMPACTAGE ---- 419 : C 420 : 100 iarr = 0 421 : IF( NADETR .EQ. NBE )GO TO 999 422 : DO 110 J=1,NADETR 423 : ITVL(J) = J 424 : 110 CONTINUE 425 : DO 120 J=1,NTCMAX 426 : ITVL(NADETR+J) = NBE + J 427 : 120 CONTINUE 428 : C DO 110 J=1, (NADETR+NTCMAX) 429 : C ITVL(IADETR+J-1) = NBE - NADETR + J 430 : C 110 CONTINUE 430 : CALL NUCOMP(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, 431 : > NOEMAX,(NBE+NTCMAX),ITVL(IADETR), 432 : > (NADETR+NTCMAX),iarr) 433 : IF(iarr .NE. 0)THEN 433 : CALL DSERRE(1,iarr,'NUCOMP','COMPRESS 2 EL') 434 : GOTO 999 435 : ENDIF 435 : CALL SPCOMP(SPH, NBSMAX, (NBE+NTCMAX),ITVL(IADETR), 436 : > (NADETR+NTCMAX),iarr) 437 : IF(iarr .NE. 0)THEN 437 : CALL DSERRE(1,iarr,'SPCOMP','COMPRESS 2 SPH') 438 : GOTO 999 439 : ENDIF 440 : IF( ITRACE.NE.0)THEN 441 : C PRINT *,'APRES REPRISE SUR ERREUR ' 441 : C CALL DEBTABIPR(ITRNOE,NBE,NBNMAX,1) 441 : C CALL DEBTABIPR(ITRTRI,NBE,NBCMAX,1) 442 : ENDIF 443 : iarr = -1 444 : C 445 : 999 END 446 : 447 : 448 : 449 :
© Cast3M 2003 - All rights reserved.
Disclaimer