1 : C HEXOS SOURCE CHAT 06/06/01 21:16:49 5450 2 : SUBROUTINE HEXOS(ITR1,NBE1,NBN1,ITR2,NBE2,NBN2,COORD,NBCOOR, 3 : > N1,N2,DEN1,DEN2,NBCOUC, 4 : > ITVL,NITMAX,NOSUPR, 5 : > ITR3,NBE3,NBEMAX,NBPMAX,NBNL,ICOIN,ITRACE, 6 : > IERCOD,iarr,RAISON) 7 : C ********************************************************************** 8 : C OBJET HEXOS : MAILLAGE H8 RACCORDANT 2 MAILLAGE GRILLES COMPATIBLES 9 : C 10 : C EN ENTREE : 11 : C 12 : C --------- MAILLAGES A RACCORDER -------------------------- 13 : C ITR1 : DEFINITION DE LA CONNECTIQUE DU MAILLAGE 14 : C ITR1((I-1)*4+J = JIEME NOEUD DU IIEME ELEMENT 15 : C LES ELEMENTS SONT DES QUADRANGLES A 4 NOEUDS 16 : C NBE1 : NOMBRE DE QUADRANGLES DANS LE MAILLAGE ITR1 17 : C NBN1 : NOMBRE DE NOEUDS DU MAILLAGE ITR1 18 : C 19 : C ITR2,NBE2,NBN2 : DEFINITION DU DEUXIEME MAILLAGE 20 : C 21 : C COORD : TABLEAU DES COORDONNEES DES POINTS 22 : C COORD((I-1)*3+J) = LA JIEME COORDONNE DU IEME NOEUD 23 : C NBCOOR : NOMBRE DE POINTS DANS LE TABLEAU COORD 24 : C 25 : C --------- PARAMETRES POUR LE RACCORD ----------------------- 26 : C N1 : NUMERO DU NOEUD DE ITR1 A CONNECTER A N2 DE ITR2 27 : C N2 : " " " " " ITR2 " " " A N1 DE ITR1 28 : C DEN1 : TAILLE SOUHAITEE POUR LES ELEMENTS S'APPUYANT SUR ITR1 29 : C DEN2 : " " " " " " " " " " " SUR ITR2 30 : C NBCOUC : NOMBRE DE COUCHES SUPPLEMENTAIRES(PAR DEFAUT 1 SEULE COUCHE) 31 : C 32 : C --------- LES TABLEAUX VIDES ------------------------------ 33 : C ITVL : TABLEAU D'ENTIERS POUR LES CALCULS 34 : C NITMAX : TAILLE DE ITVL, LA PLACE DEMANDEE EST DE : 35 : C T1 =(NBE2+NBE1)*4 +NBCOOR POUR LA STRUCTURE MAILLAGE (T2=3*NBCOOR) 36 : C T3 = NBN1 + NBN2 POUR LES GRILLES (T4 = MAX(NBN1,NBN2)) 37 : C T5 = 2*NBLIG1*NBCOL2 POUR LA GRILLE INTERMEDIAIRE (2 COUCHES) 38 : C T5 = 0 SI UNE COUCHE 39 : C T6 = 2*NBLIG1*NBCOL2*(NBRAN-1) + NBCOOR 40 : C NITMAX >= T1+T3+ MAX(T2,T4,T5+T6) 41 : C AVEC NBRAN = (3+NBCOUC+NBCOL2+NBLIG2-NBCOL1-NBLIG1) 42 : C AVEC NBN1 = NBNL(1)*NBNL(2) ; NBN1 <= 3 + 2*NBE1 43 : C NBN2 = NBNL(3)*NBNL(4) ; NBN2 <= 3 + 2*NBE2 44 : C AVEC NBLIG1 = MAX(NBNL(2),NBNL(4)) 45 : C NBCOL2 = MAX(NBNL(1),NBNL(3)) 46 : C 47 : C ITR3 : TABLEAU DES HEXAEDRES (A REMPLIR) 48 : C NBEMAX : NOMBRE MAXIMUM D'ELEMENTS (LIE A LA TAILLE DE ITR3) 49 : C = 0 SI L'ON SOUHAITE SEULEMENT UNE IDENTIFICATION DES 50 : C GRILLE : NBNL, ICOIN 51 : C NBPMAX : NOMBRE MAXIMUM DE NOEUDS (LIE A LA TAILLE DE COORD) 52 : C 53 : C NOSUPR : NOSUPR = 1 SUPPRESSION DES NOEUDS ISOLES 54 : C NOSUPR = 0 PAS DE SUPPRESSION DE NOEUD 55 : C (LA SUPPRESSION DES NOEUDS POSE UN PROBLEME 56 : C QUAND IL Y A DES NOEUDS MILIEU) 57 : C 58 : C EN SORTIE : 59 : C 60 : C ITR3 : DEFINITION DE LA CONNECTIQUE DU MAILLAGE 61 : C ITR3((I-1)*8+J = JIEME NOEUD DU IIEME ELEMENT 62 : C LES ELEMENTS SONT DES HEXAEDRES A 8 NOEUDS 63 : C NBE3 : NOMBRE D'HEXAEDRES DANS LE MAILLAGE ITR3 64 : C COORD : TABLEAU DES POINTS CONTENANT LES POINTS AJOUTES 65 : C NBCOOR : NOMBRE DE POINTS APRES AJOUT 66 : C 67 : C NBNL : NOMBRE DE LIGNES ET DE COLONNES DES MAILLAGES ITR1 ET ITR2 68 : C NBNL(1) = NOMBRE DE COLONNES DE ITR1 69 : C NBNL(2) = NOMBRE DE LIGNES DE ITR1 70 : C NBNL(3) = NOMBRE DE COLONNES DE ITR2 71 : C NBNL(4) = NOMBRE DE LIGNES DE ITR2 72 : C ICOIN : LES NUMEROS DES NOEUDS DES COINS DE ITR1 ET ITR2 73 : C ICOIN(1) = PREMIER COIN DE ITR1.... 74 : C ICOIN(4) = PREMIER COIN DE ITR2 .... 75 : C iarr : TYPE D'ERREUR -1 SI DONNEES INCORRECTES 76 : C -2 SI TABLEAUX INSUFFISANTS 77 : C IERCOD : CODE DETAILLE DE L'ERREUR 78 : C -100 : ERREUR NON REPERTORIEE 79 : C -101 : LES NUMEROS DES DEUX NOEUDS SONT INCORRECTS 80 : C -102 : LES DEUX NOEUDS SONT CONFONDUS 81 : C -103 : LES DENSITES SONT INCORRECTES 82 : C -104 : LE NOMBRE DE COUCHES DOIT ETRE POSITIF OU NUL 83 : C -105 : CONNECTIQUE NON VALIDE POUR LE PREMIER MAILLAGE 84 : C -106 : CONNECTIQUE NON VALIDE POUR LE DEUXIEME MAILLAGE 85 : C -107 : LES DEUX MAILLAGES PARTAGENT UN NOEUD 86 : C -108 : LE NOMBRE TOTAL DE LIGNES OU DE COLONNES EST IMPAIR 87 : C -109 : LA TAILLE SOUHAITEE EST SUPERIEURE A LA TAILLE DISPONIBLE 88 : C -110 : LE PREMIER MAILLAGE N'EST PAS UNE GRILLE 89 : C -111 : ORIENTATION DU PREMIER MAILLAGE IMPOSSIBLE 90 : C LES NOEUDS ET LE MAILLAGE SONT COPLANAIRES 91 : C -112 : LE DEUXIEME MAILLAGE N'EST PAS UNE GRILLE 92 : C -113 : ORIENTATION DU DEUXIEME MAILLAGE IMPOSSIBLE 93 : C LES NOEUDS ET LE MAILLAGE SONT COPLANAIRES 94 : C ********************************************************************** 95 : IMPLICIT INTEGER(I-N) 96 : -INC CCREEL 97 : INTEGER ITR1(*),NBE1,NBN1,ITR2(*),NBE2,NBN2 98 : REAL*8 COORD(*),DEN1,DEN2 99 : INTEGER NBCOOR,N1,N2,NBCOUC,ITVL(*),NITMAX,NOSUPR 100 : INTEGER ITR3(*),NBE3 101 : INTEGER NBNL(*),ICOIN(*) 102 : INTEGER NBEMAX,NBPMAX,ITRACE,IERCOD,iarr 103 : C 104 : INTEGER NCC1,NCC2,NBNMX1,NBNMX2,NBCMX1,NBCMX2 105 : INTEGER ITRTR1,ITRTR2,INOET1,INOET2,ITRAV,ITRVMX 106 : INTEGER IDE,IDIMC 107 : C 108 : INTEGER IGR1,NGRMX1,IGR2,NGRMX2,NBCOL3,NBLIG3,NBRAN3 109 : INTEGER ICOMPR,NBENUL,NBISOL,NBN3,I,IOP 110 : INTEGER NBEGEN,NBPGEN,NBCMAX,NBNMAX,ITRTRI,NOEMAX,NOETRI 111 : C 112 : REAL*8 DLONG,RAISON,VK(3) 113 : * SAVE RAISON 114 : C 115 : C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS 116 : C REAL*8 XYZHUG,XYZMIN,XYZEPS 117 : C 118 : IERCOD = -100 119 : ICOMPR = 0 120 : NBE3 = 0 121 : IF((N1.LE.0).OR.(N2.LE.0).OR.(N1.GT.NBCOOR).OR. 122 : > (N2.GT.NBCOOR))THEN 123 : iarr = -1 124 : IERCOD = -101 124 : CALL DSERRE(1,iarr,'HEXOS','IL FAUT DONNER LES COINS') 125 : GOTO 9999 126 : ENDIF 127 : C --------------------------- 128 : C --- CALCUL DE LA PROGRESSION --- 129 : C --------------------------- 130 : C 131 : IDIMC = 3 132 : DLONG = 0.0 133 : DO 5 I=1,IDIMC 134 : DLONG=(COORD((N1-1)*IDIMC+I)-COORD((N2-1)*IDIMC+I))**2 +DLONG 135 : 5 CONTINUE 136 : IF( DLONG.GT.XPETIT )DLONG = SQRT(DLONG) 137 : IF( DLONG.LE.XPETIT )THEN 138 : iarr = -1 139 : IERCOD = -102 139 : CALL DSERRE(1,iarr,'HEXOS',' COINS CONFONDUS') 140 : GOTO 9999 141 : ENDIF 142 : IF((DEN1.LT.0.0 ).OR.(DEN2.LT.0.0))THEN 143 : iarr = -1 144 : IERCOD = -103 144 : CALL DSERRE(1,iarr,'ESHEXO', 145 : > ' LA DENSITE DOIT ETRE POSITIVE OU NULLE') 146 : GOTO 9999 147 : ENDIF 148 : C IF((DEN1.GT.(DLONG+XPETIT) ).OR.(DEN2.GT.(DLONG+XPETIT)))THEN 149 : C iarr = -1 150 : C IERCOD = -109 150 : C CALL DSERRE(1,iarr,'ESHEXO', 151 : C > ' LA TAILLE SOUHAITEE EST SUPERIEURE A LA TAILLE DISPONIBLE') 152 : C GOTO 9999 153 : C ENDIF 154 : C IF(NBCOUC.LT.0)THEN 155 : C iarr = -1 156 : C IERCOD = -104 156 : C CALL DSERRE(1,iarr,'ESHEXO', 157 : C > ' LE NOMBRE DE COUCHES DOIT ETRE POSITIF OU NUL') 158 : C GOTO 9999 159 : C ENDIF 160 : C 160 : IF(NBEMAX.EQ.0)CALL SUGEGE(DEN1,DEN2,DLONG,RAISON,NBCOUC,iarr) 161 : C 162 : IF( iarr.NE.0 )THEN 163 : iarr = -1 164 : IERCOD = -103 164 : CALL DSERRE(1,iarr,'HEXOS',' APPEL SUGEGE') 165 : GOTO 9999 166 : ENDIF 167 : C 168 : C ------------------------- 169 : C --- CALCUL DE LA STRUCTURE --- 170 : C ------------------------- 171 : C 172 : IDE = 2 173 : NCC1 = 1 174 : NCC2 = 1 175 : NBNMX1 = 4 176 : NBNMX2 = 4 177 : NBCMX1 = 4 178 : NBCMX2 = 4 179 : C 180 : IF(NITMAX.LT.(((NBE1+NBE2)+ NBCOOR)*4))THEN 181 : iarr = -2 181 : CALL DSERRE(1,iarr,'HEXOS',' CREATION DES MAILLAGES') 182 : GOTO 9999 183 : ENDIF 184 : C 185 : ITRTR1 = 1 186 : INOET1 = (NBCMX1 * NBE1) + ITRTR1 187 : ITRAV = NBCOOR + INOET1 188 : ITRVMX = NITMAX - ITRAV 188 : CALL SMAOCR(IDE,ITR1,NBE1,COORD, 189 : > NBCOOR,IDIMC, 190 : > ITR1,NBNMX1,ITVL(ITRTR1), 191 : > NBCMX1,ITVL(INOET1),NBCOOR, 192 : > ITVL(ITRAV),ITRVMX,NCC1,iarr) 193 : IF(iarr.NE.0)THEN 194 : IERCOD = -105 194 : CALL DSERRE(1,iarr,'HEXOS',' APPEL SMAOCR') 195 : GOTO 9999 196 : ENDIF 197 : C 198 : C ------------------------- 199 : C 200 : ITRTR2 = ITRAV 201 : INOET2 = (NBE2 * NBCMX2) + ITRTR2 202 : ITRAV = NBCOOR + INOET2 203 : ITRVMX = NITMAX - ITRAV 203 : CALL SMAOCR(IDE,ITR2,NBE2,COORD, 204 : > NBCOOR,IDIMC, 205 : > ITR2,NBNMX2,ITVL(ITRTR2), 206 : > NBCMX2,ITVL(INOET2),NBCOOR, 207 : > ITVL(ITRAV),ITRVMX,NCC2,iarr) 208 : IF(iarr.NE.0)THEN 209 : IERCOD = -106 209 : CALL DSERRE(1,iarr,'HEXOS',' APPEL SMAOCR') 210 : GOTO 9999 211 : ENDIF 212 : C ----------- FUSION DE INOETRI ------ 212 : C CALL ESEINT(1,' ITR1 ',ITR1,NBE1*4) 212 : C CALL ESEINT(1,' ITR2 ',ITR2,NBE2*4) 212 : C CALL ESEINT(1,'INOET1 ',ITVL(INOET1),NBCOOR) 212 : C CALL ESEINT(1,'INOET2 ',ITVL(INOET2),NBCOOR) 213 : DO 10 I=1,NBCOOR 214 : IF(ITVL(I-1+INOET1).EQ.0)THEN 215 : ITVL(I-1+INOET1) = ITVL(I-1+INOET2) + NBE1 216 : ELSE 217 : IF( ITVL(I-1+INOET2).NE.0 )THEN 218 : iarr = -1 219 : IERCOD = -107 219 : CALL DSERRE(1,iarr,'HEXOS', 220 : > ' LES 2 MAILLAGES PARTANGENT 1 NOEUD') 220 : CALL ESEINT(1,'LE NOEUD ',I,1) 221 : GOTO 9999 222 : ENDIF 223 : ENDIF 224 : 10 CONTINUE 225 : C 226 : C =========================================== 227 : C ---- 2. CONSTRUCTION DES 2 GRILLES SURFACIQUES ---- 228 : C =========================================== 229 : IF(ITRACE.GT.0) 229 : > CALL ESECHA(1,'-> CONTRUCTION DES 2 GRILLES',' ') 230 : C 231 : IGR1 = ITRAV 232 : NGRMX1 = NBN1 233 : IGR2 = IGR1 + NGRMX1 234 : NGRMX2 = NBN2 235 : ITRAV = IGR2 + NGRMX2 236 : ITRVMX = NITMAX - ITRAV 237 : IF( ITRVMX.LT. 0)THEN 238 : iarr = -2 238 : CALL DSERRE(1,iarr,'HEXOS',' CREATION DES GRILLES') 239 : GOTO 9999 240 : ENDIF 241 : DO 20 I=1,4 242 : NBNL(I) = 0 243 : ICOIN(I) = 0 244 : ICOIN(I+4) = 0 245 : 20 CONTINUE 245 : CALL Q4ORG2(ITR1,NBNMX1,ITVL(ITRTR1),NBCMX1,NBE1, 246 : > ITR2,NBNMX2,ITVL(ITRTR2),NBCMX2,NBE2,N1,N2, 247 : > COORD,NBCOOR,IDIMC, 248 : > ITVL(ITRAV),ITRVMX, 249 : > ITVL(IGR1),NGRMX1,ITVL(IGR2),NGRMX2, 250 : > ICOIN,NBNL,0,iarr) 251 : C 252 : C 253 : C 254 : IF(iarr.EQ.-1)THEN 255 : C 256 : C ----- PREMIER MAILLAGE ---- 257 : C 258 : IF((NBNL(1).EQ.0).OR.(NBNL(2).EQ.0))THEN 259 : IERCOD = -110 259 : CALL DSERRE(1,iarr,'HEXOS',' APPEL Q4ORG2') 259 : CALL DSERRE(1,iarr,'HEXOS', 260 : > ' LE PREMIER MAILLAGE N EST PAS UNE GRILLE') 261 : GOTO 9999 262 : ENDIF 263 : IF((ICOIN(1).NE.N1).AND.(ICOIN(2).NE.N1).AND. 264 : > (ICOIN(3).NE.N1).AND.(ICOIN(4).NE.N1))THEN 265 : IERCOD = -118 265 : CALL DSERRE(1,iarr,'HEXOS',' APPEL Q4ORG2') 265 : CALL DSERRE(1,iarr,'HEXOS', 266 : > ' LE PREMIER NOEUD N EST PAS DANS LE PREMIER MAILLAGE') 267 : GOTO 9999 268 : ENDIF 269 : C ----- ORIENTATION DE IGR1 ---- 270 : C 271 : DO 25 I=1,IDIMC 272 : VK(I)=(COORD((N2-1)*IDIMC+I)-COORD((N1-1)*IDIMC+I)) 273 : 25 CONTINUE 273 : CALL G2ORIE(ITVL(IGR1),NBNL(1),NBNL(2),IDIMC,COORD,VK,IOP ) 274 : IF( IOP.EQ. 0)THEN 275 : IERCOD = -111 275 : CALL DSERRE(1,iarr,'HEXOS', 276 : > ' ORIENTATION DE LA PREMIERE GRILLE IMPOSSIBLE') 277 : GOTO 9999 278 : ENDIF 279 : C 280 : C ----- DEUXIEME MAILLAGE ---- 281 : C 282 : IF((NBNL(3).EQ.0).OR.(NBNL(4).EQ.0))THEN 283 : IERCOD = -112 283 : CALL DSERRE(1,iarr,'HEXOS',' APPEL Q4ORG2') 283 : CALL DSERRE(1,iarr,'HEXOS', 284 : > ' LE DEUXIEME MAILLAGE N EST PAS UNE GRILLE') 285 : GOTO 9999 286 : ENDIF 287 : IF((ICOIN(5).NE.N2).AND.(ICOIN(6).NE.N2).AND. 288 : > (ICOIN(7).NE.N2).AND.(ICOIN(8).NE.N2))THEN 289 : IERCOD = -122 289 : CALL DSERRE(1,iarr,'HEXOS',' APPEL Q4ORG2') 289 : CALL DSERRE(1,iarr,'HEXOS', 290 : > ' LE DEUXIEME NOEUD N EST PAS DANS LE DEUXIEME MAILLAGE') 291 : GOTO 9999 292 : ENDIF 293 : C 293 : CALL G2ORIE(ITVL(IGR2),NBNL(3),NBNL(4),IDIMC,COORD,VK,IOP ) 294 : IF( IOP.EQ. 0)THEN 295 : IERCOD = -113 295 : CALL DSERRE(1,iarr,'HEXOS', 296 : > ' ORIENTATION DE LA DEUXIEME GRILLE IMPOSSIBLE') 297 : GOTO 9999 298 : ENDIF 299 : C 300 : IF((NBNL(1).GT.NBNL(3)).AND.(NBNL(2).GT.NBNL(4)))THEN 301 : C 302 : C --- ON INVERSE IGR1 ET IGR2 --- 303 : C 303 : CALL ESECHA(1,'-> ON INVERSE L ORDRE DES GRILLES ',' ') 304 : iarr = 0 305 : NGRMX1 = NBN2 306 : IGR2 = IGR1 + NGRMX1 307 : NGRMX2 = NBN1 308 : ITRAV = IGR2 + NGRMX2 308 : CALL Q4ORG2(ITR2,NBNMX2,ITVL(ITRTR2),NBCMX2,NBE2, 309 : > ITR1,NBNMX1,ITVL(ITRTR1),NBCMX1,NBE1,N2,N1, 310 : > COORD,NBCOOR,IDIMC, 311 : > ITVL(ITRAV),ITRVMX, 312 : > ITVL(IGR1),NGRMX1,ITVL(IGR2),NGRMX2, 313 : > ICOIN,NBNL,0,iarr) 314 : ENDIF 315 : C 316 : ENDIF 317 : C 318 : IF(ITRACE.GT.0)THEN 318 : CALL ESECHA(1,'-> GRILLE 1 ',' ') 318 : CALL ESEINT(1,'COLONNES LIGNES : ',NBNL(1),2) 318 : CALL ESEINT(1,'LES COINS : ',ICOIN(1),4) 318 : CALL ESECHA(1,'-> GRILLE 2 ',' ') 318 : CALL ESEINT(1,'COLONNES LIGNES : ',NBNL(3),2) 318 : CALL ESEINT(1,'LES COINS : ',ICOIN(5),4) 319 : ENDIF 320 : C 321 : IF(iarr.NE.0)THEN 321 : CALL DSERRE(1,iarr,'HEXOS',' APPEL Q4ORG2') 322 : GOTO 9999 323 : ENDIF 324 : C 325 : IF( (MOD(NBNL(1)+NBNL(3),2).NE.0).OR. 326 : > (MOD(NBNL(2)+NBNL(4),2).NE.0))THEN 327 : IERCOD = -108 328 : iarr = -1 329 : GOTO 9999 330 : ENDIF 331 : C 332 : IF(NBEMAX.EQ.0)THEN 333 : NBE3 = 0 334 : GOTO 9999 335 : ENDIF 336 : C 337 : C =========================================== 338 : C ---- 3. MAILLAGE 3D RACCORDANT LES 2 GRILLES ---- 339 : C =========================================== 340 : IF(ITRACE.GT.0) 340 : > CALL ESECHA(1,'**** RACCORD 3D ****',' ') 341 : C ========================================== 342 : C --- RACCORD EN DEUX COUCHES 343 : C ========================================== 344 : IF((NBNL(3).GT.NBNL(1)).AND.(NBNL(4).GT.NBNL(2)))THEN 345 : IF(ITRACE.GT.0) 345 : > CALL ESECHA(1,' RACCORD EN 2 COUCHES : ', 346 : > ' MAILLAGE SURFACIQUE INTERMEDIAIRE ') 347 : C ----------------------------------- 348 : C --- EVALUATION DE LA PLACE NECESSAIRE --- 349 : C ----------------------------------- 350 : NBLIG3 = NBNL(1) 351 : NBCOL3 = (NBNL(4)-NBNL(2))/2 +2+NBCOUC-1 352 : NBRAN3 = NBNL(4) 353 : C 354 : NBEGEN = (NBLIG3-1)*(NBCOL3-1)*(NBRAN3-1) 355 : NBPGEN = NBLIG3*NBCOL3*NBRAN3 356 : C 357 : NBLIG3 = NBNL(3) 358 : NBCOL3 = (NBNL(3)-NBNL(1))/2 +2+NBCOUC-1 359 : NBRAN3 = NBNL(4) 360 : C 361 : NBEGEN = (NBLIG3-1)*(NBCOL3-1)*(NBRAN3-1) + NBEGEN 362 : NBPGEN = NBLIG3*NBCOL3*NBRAN3 + NBPGEN 363 : C 364 : C --- ON PEUT COMPRIMER EN SUPPRIMANT LES 2 MAILLAGES : ITRINO1... 365 : C 366 : C --- MAILLAGE EN H8 --- 367 : C 368 : NBNMAX = 8 369 : C 369 : CALL H8RCGG(ITVL(IGR1),NBNL(2),NBNL(1), 370 : > ITVL(IGR2),NBNL(4),NBNL(3), 371 : > COORD,NBCOOR,IDIMC,NBCOUC,RAISON, 372 : > ITVL(ITRAV),ITRVMX, 373 : > ITR3,NBNMAX,NBE3,NBN3, 374 : > NBEMAX,NBPMAX,ICOMPR,ITRACE,iarr) 375 : IF(iarr.NE.0)THEN 375 : CALL DSERRE(1,iarr,'HEXOS',' APPEL H8RCGG') 376 : GOTO 9999 377 : ENDIF 378 : C 379 : ELSE 380 : C ========================================== 381 : C --- RACCORD EN UNE COUCHE 382 : C ========================================== 383 : IF(ITRACE.GT.0) 383 : > CALL ESECHA(1,' RACCORD EN 1 COUCHES : ', 384 : > ' MAILLAGE HEXAEDRIQUE ') 385 : C 386 : C ----------------------------------- 387 : C --- EVALUATION DE LA PLACE NECESSAIRE --- 388 : C ----------------------------------- 389 : NBLIG3 = NBNL(3) 390 : NBCOL3 = (NBNL(3)-NBNL(1)+NBNL(2)-NBNL(4))/2 +2+NBCOUC-1 391 : NBRAN3 = NBNL(2) 392 : C 393 : NBEGEN = (NBLIG3-1)*(NBCOL3-1)*(NBRAN3-1) 394 : NBPGEN = NBLIG3*NBCOL3*NBRAN3 395 : C 396 : C --- ON PEUT COMPRIMER EN SUPPRIMANT LES 2 MAILLAGES : ITRINO1... 397 : C 398 : C --- MAILLAGE EN H8 --- 399 : C 400 : NBNMAX = 8 401 : C 401 : CALL H8RCG2(ITVL(IGR1),NBNL(2),NBNL(1), 402 : > ITVL(IGR2),NBNL(4),NBNL(3), 403 : > COORD,NBCOOR,IDIMC,NBCOUC,RAISON, 404 : > ITVL(ITRAV),ITRVMX, 405 : > ITR3,NBNMAX,NBE3,NBN3, 406 : > NBEMAX,NBPMAX,ICOMPR,ITRACE,iarr) 407 : ENDIF 408 : C 409 : IF(iarr.NE.0)THEN 409 : CALL DSERRE(1,iarr,'HEXOS',' APPEL H8RCG2') 410 : GOTO 9999 411 : ENDIF 412 : C 413 : C =================================================== 414 : C --- 3. COMPRESSION DU MAILLAGE --- 415 : C =================================================== 416 : C 417 : 30 CONTINUE 418 : C 419 : IF((NBNL(2).NE.NBNL(4)).OR.(NBNL(1).NE.NBNL(3)).OR. 420 : > (NOSUPR.EQ.1) )THEN 421 : C 422 : IF(ITRACE.GT.0)THEN 422 : CALL ESECHA(1,'**** POST-TRAITEMENT ****',' ') 422 : CALL ESECHA(1,'-> COMPRESSION DU MAILLAGE 3D',' ') 423 : ENDIF 424 : C 425 : C --- LA SUPPRESSION DES NOEUDS POSE UN PROBLEME 426 : C QUAND IL Y A DES NOEUDS MILIEU : IDIMC6 = 0 427 : C 428 : IDIMC6 = 0 429 : C 430 : IDE = 3 431 : NBCMAX = 0 432 : ITRTRI = 0 433 : NOEMAX = 0 434 : NOETRI = 0 435 : NBENUL = NBE3 436 : NBISOL = NBCOOR 436 : CALL NUGCNU(IDE,ITR3,NBNMAX,ITRTRI,NBCMAX, 437 : > NOETRI,NOEMAX,NBE3,COORD,IDIMC6,NBCOOR, 438 : > ITVL(ITRAV),ITRVMX,iarr) 439 : C 440 : IF(ITRACE.GT.0)THEN 440 : CALL ESEINT(1,'NOMBRE D ELEMENTS SUPPRIMES : ',NBENUL-NBE3,1) 440 : CALL ESEINT(1,'NOMBRE DE POINTS SUPPRIMES : ',NBISOL-NBCOOR,1) 441 : ENDIF 442 : ENDIF 443 : C 443 : C CALL ESEINT(1,' ITR3 ',ITR3,NBE3*8) 444 : C 445 : 9999 END 446 : 447 : 448 : 449 : 450 : 451 :
© Cast3M 2003 - All rights reserved.
Disclaimer