1 : C RAFT SOURCE CHAT 07/10/29 21:27:41 5940 2 : SUBROUTINE RAFT 3 : C ********************************************************************** 4 : C INTERFACE CASTEM 2000 5 : C 6 : C SURF2 = RAFT (CHPO1) SURF1 ; 7 : C 8 : C 9 : C OBJET : 10 : C _______ 11 : C 12 : C L'OPERATEUR RAFT RAFINE UN MAILLAGE TRIANGULAIRE (OBJET SURF1) 13 : C POUR RESPECTER UNE CARTE DE TAILLEW DONNEE (OBJET CHPO1). LES ELEM- 14 : C ENTS SONT DES TRIANGLES LINEAIRES QUELLES QUE SOIENT LES DIRECTIVES 15 : C D'OPTION. 16 : C 17 : C 18 : C DATE : 03.05.96 / 03.04.97 19 : C ______ 20 : C 21 : C AUTEURS : O. STAB 22 : C _________ 23 : C 24 : C 25 : C ********************************************************************** 26 : IMPLICIT INTEGER(I-N) 27 : IMPLICIT REAL*8 (A-H,O-Z) 28 : C 29 : -INC CCOPTIO 30 : -INC SMELEME 31 : -INC SMCOORD 32 : -INC CCGEOME 33 : -INC SMCHPOI 34 : SEGMENT ITRAVX 35 : INTEGER ITVL (ITOTAI) 36 : ENDSEGMENT 37 : SEGMENT RTRAV 38 : REAL*8 RTVL ( ITOTAR) 39 : ENDSEGMENT 40 : SEGMENT ICPR (XCOOR(/1)/(IDIM+1)) 41 : SEGMENT ICPP (XCOOR(/1)/(IDIM+1)) 42 : SEGMENT IRADEC 43 : REAL*8 RADEC (MRIADEC) 44 : ENDSEGMENT 45 : C elimination de l'external TC 46 : C INTEGER D2CHPO 47 : C EXTERNAL D2CHPO 48 : INTEGER NRIADC,NITMAX,NRTMAX,NPONEW,IERRDS 49 : C --- VARIABLES INTERNES --- 50 : INTEGER NBN,NBE,IDIMC,NBNMAX,NBCMAX,IDE,NPOMAX,NBEMAX,ITRNOE 51 : INTEGER ITRTRI,NOETRI,ITRAV,IRTRAV,NITMX2,NRTMX2,ICOORD 52 : INTEGER I,NCC,NOEMAX 53 : C 53 : CALL DSINIT 54 : IERRDS = 0 55 : C ======================= 56 : C --- 1.LECTURE DES DONNEES --- 57 : C ======================= 58 : C 59 : * LECTURE DES OBJETS COURANTS (ENTREES) 60 : * ===================================== 61 : IF(IDIM.NE.2) THEN 62 : INTERR(1)=IDIM 63 : C FONCTION INDISPONIBLE EN DIMENSION %I1 63 : CALL ERREUR(709) 64 : GOTO 999 65 : ENDIF 66 : C 66 : CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU) 67 : IF(IERR.NE.0) THEN 68 : C ON A PAS TROUVE LE MAILLAGE 68 : CALL ERREUR(503) 69 : GOTO 999 70 : ENDIF 71 : C 71 : CALL LIRENT ( IVAL,0,IRETOU) 72 : C 73 : SEGACT IPT1 74 : NBE = IPT1.NUM(/2) 75 : NBEINI = NBE 76 : NBNTOT = -1 77 : IF(IRETOU.NE.0) THEN 78 : IF( IVAL.LT.NBE )THEN 79 : C Le nombre de noeuds ne peut ètre inférieur à %i1 80 : C (nombre d'éléments) 81 : INTERR(1) = NBE 81 : CALL ERREUR(838) 82 : SEGDES IPT1 83 : GOTO 999 84 : ENDIF 85 : NBNTOT = IVAL 86 : ENDIF 87 : 88 : IF((IPT1.LISOUS(/1).NE.0).OR. 89 : > (IPT1.ITYPEL.NE.4))THEN 90 : C DONNEES INCOMPATIBLES 90 : CALL ERREUR(21) 91 : SEGDES IPT1 92 : GOTO 999 93 : ENDIF 94 : SEGDES IPT1 95 : * 96 : * LECTURE DU CHAMPS DE DENSITE 97 : * ============================ 98 : * 98 : CALL LIROBJ('CHPOINT',MCHPO1,0,IRETOU) 99 : IF(IRETOU.EQ.0)THEN 100 : C ON A PAS TROUVE LE CHAMPS DE POINTS 100 : IF(IIMPI.NE.0) CALL ERREUR(839) 101 : PCHPOI = 0 102 : ELSE 103 : PCHPOI = 1 104 : ENDIF 105 : C 106 : C ---- VERIFICATION DU CHPOINT ---- 107 : IF( PCHPOI.EQ.1)THEN 108 : SEGACT MCHPO1 109 : MSOUP1 = MCHPO1.IPCHP(1) 110 : SEGACT MSOUP1 111 : IF( MCHPO1.IPCHP(/1).GT.1)THEN 112 : C IL Y A PLUS D'UN CHAMP PAR POINT LEQUEL CHOISIR ? 112 : CALL ERREUR(840) 113 : SEGDES IPT1,MCHPO1,MSOUP1 114 : GOTO 999 115 : ENDIF 116 : C 117 : 8003 MPOVA1 = MSOUP1.IPOVAL 118 : SEGACT MPOVA1 119 : IF( MPOVA1.VPOCHA(/2).NE.1 )THEN 120 : C Il y a plus d'une valeur par point ?! 120 : CALL ERREUR(841) 121 : SEGDES IPT1,MCHPO1,MSOUP1,MPOVA1 122 : GOTO 999 123 : ENDIF 124 : SEGDES MCHPO1,MSOUP1,MPOVA1 125 : ENDIF 126 : C ---- FIN VERIFICATION DU CHPOINT ---- 127 : * 128 : * 129 : * ALLOCATION DE LA MEMOIRE 130 : * ===================================== 131 : * 132 : * 133 : * 134 : * ===================================== 135 : IDIMC = IDIM 136 : NBNMAX = 3 137 : NBCMAX = NBNMAX 138 : NBADET = 50 139 : C 140 : ICMEMO = 1 141 : NBNINI = 0 142 : C 143 : C --- POUR TESTER LES MESSAGE D'ERREUR ET LA REALLOCATION : 144 : NBNREL = (10 * NBEINI ) / 2 145 : NBNABS = 40000 146 : 5 CONTINUE 147 : NBNREL = 7 * (NBEINI / 2) 148 : IF( NBNINI.NE.0 )NBNREL = 7 * NBNINI 149 : IF(NBNTOT.NE.-1) THEN 150 : NPOMAX = NBNTOT*ICMEMO + NBADET 151 : ELSE 152 : NPOMAX = MAX(NBNREL,NBNABS)*ICMEMO + NBADET 153 : ENDIF 154 : NBEMAX = MAX((14*NBEINI),(2*NBNABS)) * ICMEMO 155 : C 156 : 6 CONTINUE 157 : C 158 : C NITMAX = 20 * NPOMAX + 288 + 310 159 : C NRTMAX = 12 * (NPOMAX + 12) 160 : C 161 : NITMAX = (NBNMAX+NBCMAX)*NBEMAX + 162 : > NPOMAX + 163 : > MAX(7*NPOMAX , 6*NBADET+10) + 288 164 : C 165 : C ITRNOE,ITRTRI, NOETRI,ITRAV (MAX SMAOCR,R2RAF) 166 : C 167 : C 168 : NRTMAX = (IDIMC*NPOMAX) + 169 : > NBEMAX + 170 : > 2*NBEMAX + 171 : > (IDIMC*NBEMAX) + 172 : > (IDIMC*NPOMAX) + 224 173 : C 174 : C ICOORD, RADEC, ? , ITRAV (SPHERES+COORD) 175 : C 176 : C 177 : * 178 : * TRANSFERT DANS LA STRUCTURE DE L'ALGO 179 : * ===================================== 180 : * 181 : ICOORD = 1 182 : ITRNOE = 1 183 : IDE = 2 184 : NCC = 1 185 : C --- INITIALISATION EN CAS DE REALLOCATION --- 186 : NBE = NBEINI 187 : * 188 : * REMPLISSAGE DU TABLEAU DE CONNEXION 189 : * =================================== 190 : SEGACT IPT1 191 : ITOTAI= NITMAX 192 : SEGINI ITRAVX 193 : NBANC = XCOOR(/1) /( IDIM+1) 194 : SEGINI,ICPR,ICPP 195 : ITOTAR = NRTMAX 196 : SEGINI RTRAV 197 : MRIADEC = NPOMAX 198 : SEGINI IRADEC 199 : INO = 0 200 : DO 7764 I=1,NBE 201 : DO 7764 J=1,NBNMAX 202 : IA = IPT1.NUM(J,I) 203 : IF( ICPR(IA).EQ.0 ) THEN 204 : INO = INO+1 205 : ICPR(IA) = INO 206 : ICPP(INO)= IA 207 : DO 7763 K=1,IDIMC 208 : RTVL((INO-1)*IDIMC+K+ICOORD-1)= 209 : > XCOOR((IA-1)*(IDIM+1)+K) 210 : 7763 CONTINUE 211 : C --- PAR DEFAUT : LA DENSITE PONCTUELLE --- 212 : RADEC(INO) = XCOOR(IA*(IDIM+1)) 213 : ENDIF 214 : ITVL((I-1)*NBNMAX +J+ITRNOE-1) = ICPR(IA) 215 : 7764 CONTINUE 216 : NBN = INO 217 : NBNINI = INO 218 : SEGDES IPT1 219 : C 220 : C ON A LE NOMBRE EXACT DE NOEUDS DANS LE MAILLAGE 221 : C 222 : NPONEW=NPOMAX-NBN 223 : IF( NPONEW.LE.0 )THEN 224 : IF( NBNTOT.NE.-1)THEN 225 : C Le nombre de noeuds ne peut ètre inférieur à %i1 226 : C (nombre de noeuds existants) 227 : INTERR(1) = NBN 227 : CALL ERREUR(844) 228 : SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP 229 : GOTO 999 230 : ENDIF 231 : NPOMAX = 5 * NBN 232 : SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP 233 : C Patience on reprend avec plus de mémoire... 233 : CALL ERREUR(850) 234 : GOTO 6 235 : ENDIF 236 : * 237 : IF(PCHPOI.EQ.1)THEN 238 : * 239 : * TRANSFERT DE LA DENSITE 240 : * ----------------------- 241 : SEGACT MCHPO1,MSOUP1,MPOVA1 242 : IF( MPOVA1.VPOCHA(/1).NE.NBN )THEN 243 : SEGDES MCHPO1,MSOUP1,MPOVA1 244 : SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP 245 : C La densité (CHPOINT) doit ètre définie sur LE maillage donné. 245 : CALL ERREUR(843) 246 : GOTO 999 247 : ENDIF 248 : * LECTURE DU MAILLAGE ASSOCIE AU CHPOINT 249 : IPT2 = MSOUP1.IGEOC 250 : SEGACT IPT2 251 : NBE2 = IPT2.NUM(/2) 252 : NBNN2 = IPT2.NUM(/1) 253 : C SEGINI IRADEC 254 : NRIADC = MPOVA1.VPOCHA(/1) 255 : * 256 : DO 8000 I=1,NRIADC 257 : * ------- LECTURE DE L'ANCIEN NUMERO --------- 258 : IA = IPT2.NUM(1,I) 259 : * ------- NOUVEAU NUMERO -------- 260 : INO = ICPR(IA) 261 : IF((INO.LT.1).OR.(INO.GT.NRIADC))THEN 262 : SEGDES MCHPO1,MSOUP1,MPOVA1,IPT2 263 : SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP 264 : C La densité (CHPOINT) doit ètre définie sur LE maillage donné. 264 : CALL ERREUR(843) 265 : GOTO 999 266 : ENDIF 267 : RADEC(INO) = MPOVA1.VPOCHA(I,1) 268 : 8000 CONTINUE 269 : SEGDES MCHPO1,MSOUP1,MPOVA1,IPT2 270 : ELSE 271 : * -------------------------------------------------- 272 : * PAS DE CHPOINT => ON VERIFIE QUE LA DENSITE DONNEE 273 : C PAR RADEC(INO) = XCOORD(IA,3) EST ACCEPTABLE 274 : * -------------------------------------------------- 275 : NRIADC = NBNINI 276 : DO 8001 INO=1,NBNINI 277 : IF( RADEC(INO).LE.0 )GOTO 8002 278 : 8001 CONTINUE 279 : GOTO 8004 280 : 8002 NRIADC = 0 281 : 8004 CONTINUE 282 : ENDIF 283 : * 284 : C ======================= 285 : C --- 1.1. ALLOCATION --- 286 : C ======================= 287 : C 288 : C 289 : ITRTRI = ITRNOE + (NBEMAX * NBNMAX) 290 : NOETRI = ITRTRI + (NBEMAX * NBCMAX) 291 : ITRAV = NOETRI + NPOMAX 292 : NITMX2 = NITMAX - ITRAV 293 : IRTRAV = NPOMAX * IDIMC + 1 294 : NRTMX2 = NRTMAX - IRTRAV 295 : NOEMAX = NPOMAX 296 : C 297 : C ========================================= 298 : C --- 2. CREATION DE LA STRUCTURE DE DONNEES --- 299 : C ========================================= 300 : C 301 : * 301 : CALL SMAOCR(IDE,ITVL(ITRNOE),NBE,RTVL(ICOORD), 302 : > NBN,IDIMC, 303 : > ITVL(ITRNOE),NBNMAX,ITVL(ITRTRI), 304 : > NBCMAX,ITVL(NOETRI),NOEMAX, 305 : > ITVL(ITRAV),NITMX2,NCC,IERRDS) 306 : C 307 : IF( IERRDS.NE.0 )THEN 308 : IF( IERRDS.EQ.-2 )THEN 309 : SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP 309 : CALL ERREUR(850) 310 : ICMEMO = ICMEMO + 1 311 : IERRDS = 0 312 : GOTO 5 313 : ENDIF 314 : C Maillage incorrect ?!!! 315 : SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP 315 : CALL ERREUR(844) 316 : GOTO 999 317 : ENDIF 318 : C 319 : C ================================== 320 : C --- 3. GENERATION DES NOEUDS ET 321 : C INSERTION DANS LA TRIANGULATION --- 322 : C ================================== 323 : C 324 : NITMX2 = NITMAX - ITRAV 325 : IRTRAV = NPOMAX * IDIMC + 1 326 : NRTMX2 = NRTMAX - IRTRAV 327 : NOEMAX = NPOMAX 328 : C 329 : IF( NRIADC.EQ. 0 )THEN 330 : C ======================== 331 : C --- RAFFINEMENT PAR DEFAUT --- 332 : C ======================== 333 : * 333 : CALL R2RAF(ITVL(ITRNOE),NBNMAX,ITVL(ITRTRI),NBCMAX, 334 : > ITVL(NOETRI),NOEMAX, 335 : > RTVL(ICOORD),NBN,NBE,NPOMAX,NBEMAX, 336 : > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2, 337 : > IERRDS) 338 : ELSE 339 : C ======================== 340 : C --- RAFFINEMENT ITERATIF --- 341 : C ======================== 342 : C 342 : CALL R2CPO(IADEC,RADEC, 342 : C CALL R2CPO(D2CHPO,IADEC,RADEC, modif TC 343 : > ITVL(ITRNOE),NBNMAX, 344 : > ITVL(ITRTRI),NBCMAX, 345 : > ITVL(NOETRI),NOEMAX, 346 : > RTVL(ICOORD),IDIMC,NBN,NBE,NPOMAX,NBEMAX, 347 : > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2, 348 : > NBENEW,IERRDS) 349 : ENDIF 350 : C 351 : C 352 : IF(IERRDS.NE.0)THEN 353 : IF(IERRDS.EQ.-2)THEN 354 : IF(NBNTOT.EQ.-1)THEN 355 : C PAS DE LIMITATION SUR LES NOEUDS, LA MEMOIRE EVALUEE 356 : C EST INSUFFISANTE 357 : SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP 358 : ICMEMO = ICMEMO + 1 359 : C Patience on reprend avec plus de mémoire... 359 : CALL ERREUR(850) 360 : IERRDS = 0 361 : GOTO 5 362 : ENDIF 363 : C LIMITATION SUR LES NOEUDS DONNE PAR L'UTILISATEUR 364 : IERRDS = 0 365 : GOTO 40 366 : ENDIF 367 : C IERRDS = -1 ... 367 : CALL ERREUR(848) 368 : C ERREUR GENERATION DE MAILLAGE. IL EST NEANMOINS CREE POUR CONTROLE 368 : C CALL ERREUR(27) 369 : IERRDS = 0 370 : GOTO 40 371 : ENDIF 372 : C 373 : * 374 : * REMPLISSAGE NOUVEL OBJET MAILLAGE ET TABLEAU DES COORDONNEES 375 : * ============================================================ 376 : 40 CONTINUE 377 : NBELEM=NBE 378 : NBNN=3 379 : NBREF=0 380 : NBSOUS=0 381 : SEGINI MELEME 382 : NBPTS = NBN-NBNINI+NBANC 383 : SEGADJ MCOORD 384 : DO 7781 I=1,NBN-NBNINI 385 : XCOOR((NBANC +I-1)*(IDIM+1) +1) = RTVL((NBNINI+I-1)*IDIMC+1) 386 : XCOOR((NBANC +I-1)*(IDIM+1) +2) = RTVL((NBNINI+I-1)*IDIMC+2) 387 : * ---- POUR LA DENSITE : DENSITE COURANTE ---- 388 : XCOOR((NBANC +I-1)*(IDIM+1) +3) = DENSIT 389 : 7781 CONTINUE 390 : * 391 : DO 7782 I=1,NBE 392 : DO 7783 J=1,3 393 : IA=ITVL((I-1)*NBNMAX +J-1+ITRNOE) 394 : C 395 : IF ( IA .LE.NBNINI) THEN 396 : IB = ICPP(IA) 397 : ELSE 398 : IB = IA -NBNINI +NBANC 399 : ENDIF 400 : NUM(J,I)=IB 401 : 7783 CONTINUE 402 : ICOLOR(I) = IDCOUL 403 : 7782 CONTINUE 404 : ITYPEL=4 405 : SEGDES MELEME 406 : SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP 406 : CALL ECROBJ('MAILLAGE',MELEME) 407 : C 408 : C 409 : 999 END 410 : 411 : 412 : 413 : 414 : 415 : 416 :
© Cast3M 2003 - All rights reserved.
Disclaimer