1 : C CHANG2 SOURCE CHAT 07/10/30 21:15:10 5942 2 : SUBROUTINE CHANG2(IPT1,ITY) 3 : IMPLICIT REAL*8 (A-H,O-Z) 4 : IMPLICIT INTEGER (I-N) 5 : C*********************************************************************** 6 : C NOM : CHANG2 7 : C DESCRIPTION : Change un maillage (éventuellement composite) 8 : C de QUAF en 'TRI3','TET4','QUA4','CUB8','PYR5' 9 : C 10 : C 11 : C LANGAGE : ESOPE 12 : C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF) 13 : C mél : gounand@semt2.smts.cea.fr 14 : C*********************************************************************** 15 : C APPELES : 16 : C APPELES (E/S) : 17 : C APPELES (BLAS) : 18 : C APPELES (CALCUL) : 19 : C APPELE PAR : 20 : C*********************************************************************** 21 : C SYNTAXE GIBIANE : 22 : C ENTREES : 23 : C ENTREES/SORTIES : 24 : C SORTIES : 25 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé 26 : C*********************************************************************** 27 : C VERSION : v1, 04/01/2007, version initiale 28 : C HISTORIQUE : v1, 04/01/2007, création 29 : C HISTORIQUE : 30 : C HISTORIQUE : 31 : C*********************************************************************** 32 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 33 : C en cas de modification de ce sous-programme afin de faciliter 34 : C la maintenance ! 35 : C*********************************************************************** 36 : -INC CCOPTIO 37 : -INC CCGEOME 38 : -INC SMELEME 39 : * 40 : LOGICAL LCOMP,ltelq 41 : PARAMETER(NTYP2=5) 42 : CHARACTER*4 LTYP2(NTYP2),LTYPD2(NTYP2),LTYPD3(NTYP2),MTYP,MTYP2 43 : INTEGER S3S2(2,2),T7T3(3,4),T7Q4(4,3),Q9T3(3,8),Q9Q4(4,4) 44 : INTEGER T15T4(4,4),T15O6(6),O6T4(4,4),T15C8(8,4),T15T7(7,4) 45 : INTEGER P19H6(6,4),P19O6(6),H6T4(4,3),P19T7(7,4),P19Q9(9) 46 : INTEGER P21P6A(6,4),P21P6B(6,4),P6AT4(4,3),P6BT4(4,3) 47 : INTEGER P21C8(8,6),P21T7(7,2),P21Q9(9,3) 48 : INTEGER C27C8(8,8),C8T4(4,5),C27Q9(9,6) 49 : * 50 : DATA LTYP2 /'TRI3','TET4','QUA4','CUB8','PYR5'/ 51 : DATA LTYPD2/'TRI3','TRI3','QUA4','QUA4','QUA4'/ 52 : DATA LTYPD3/'TET4','TET4','CUB8','CUB8','PYR5'/ 53 : * SEG3 -> 2 SEG2 54 : DATA S3S2/1,2 , 2,3/ 55 : * TRI7 -> 4 TRI3 56 : DATA T7T3/1,2,6 , 2,3,4 , 6,4,5 , 2,4,6/ 57 : * TRI7 -> 3 QUA4 58 : DATA T7Q4/1,2,7,6 , 2,3,4,7 , 7,4,5,6/ 59 : * QUA9 -> 8 TRI3 60 : DATA Q9T3/1,2,9 , 2,3,9 , 3,4,9 , 4,5,9 , 61 : $ 5,6,9 , 6,7,9 , 7,8,9 , 8,1,9/ 62 : * QUA9 -> 4 QUA4 63 : DATA Q9Q4/1,2,9,8 , 2,3,4,9 , 9,4,5,6 , 8,9,6,7/ 64 : * TE15 -> 4 TET4 + 1 OCT6 65 : DATA T15T4/1,2,6,7 , 2,3,4,8 , 4,5,6,9 , 7,8,9,10/ 66 : DATA T15O6/7,2,4,9,8,6/ 67 : * OCT6 -> 4 TET4 68 : DATA O6T4/1,2,6,5 , 2,3,6,5 , 3,4,6,5 , 4,1,6,5/ 69 : * TE15 -> 4 CUB8 70 : DATA T15C8/1,2,11,6,7,12,15,14 , 2,3,4,11,12,8,13,15 , 71 : $ 4,5,6,11,13,9,14,15 , 8,13,15,12,10,9,14,7/ 72 : * TE15 -> 4 TRI7 (Les faces) 73 : DATA T15T7/1,7,10,8,3,2,12 , 3,8,10,9,5,4,13 , 74 : $ 5,9,10,7,1,6,14 , 1,2,3,4,5,6,11/ 75 : * PY19 -> 4 HEX6 + 1 OCT6 76 : DATA P19H6/1,2,3,14,9,10 , 3,4,5,14,10,11 , 77 : $ 5,6,7,14,11,12 , 7,8,1,14,12,9/ 78 : DATA P19O6/9,10,11,12,13,14/ 79 : * HEX6 -> 3 TET4 80 : DATA H6T4/1,2,4,5 , 5,2,4,6 , 2,3,4,6/ 81 : * PY19 -> 4 TRI7 (Les faces triangulaires) 82 : DATA P19T7/1,9,13,10,3,2,15 , 3,10,13,11,5,4,16 , 83 : $ 5,11,13,12,7,6,17 , 7,12,13,9,1,8,18/ 84 : * PY19 -> QUA9 (La face carrée) 85 : DATA P19Q9/1,2,3,4,5,6,7,8,14/ 86 : * PR21 -> 4 PRI6 de type A 87 : DATA P21P6A/7,16,18,10,11,15 , 9,18,17,14,15,13 , 88 : $ 7,18,16,1,6,2 , 9,17,18,5,4,6/ 89 : * PR21 -> 4 PRI6 de type B 90 : DATA P21P6B/ 8,17,16,12,13,11 , 16,17,18,11,13,15 , 91 : $ 8,16,17,3,2,4 , 2,4,6,16,17,18/ 92 : Cbuggé $ 8,16,17,3,2,4 , 16,18,17,2,6,4/ 93 : * PRI6 de type A -> 3 TET4 94 : DATA P6AT4/1,2,3,4 , 5,3,4,6 , 5,2,4,3/ 95 : * PRI6 de type B -> 3 TET4 96 : DATA P6BT4/1,2,3,4 , 3,6,4,2 , 5,2,4,6/ 97 : * PR21 -> 6 CUB8 98 : DATA P21C8/7,16,21,18,10,11,20,15 , 16,8,17,21,11,12,13,20 , 99 : $ 21,17,9,18,20,13,14,15 , 1,2,19,6,7,16,21,18 , 100 : $ 2,3,4,19,16,8,17,21 , 19,4,5,6,21,17,9,18/ 101 : * PR21 -> 2 TRI7 (Les faces triangulaires) 102 : DATA P21T7/1,2,3,4,5,6,19 , 10,15,14,13,12,11,20/ 103 : * PR21 -> 3 QUA9 (Les faces carrées) 104 : DATA P21Q9/10,11,12,8,3,2,1,7,16 , 12,13,14,9,5,4,3,8,17 , 105 : $ 14,15,10,7,1,6,5,9,18/ 106 : * CU27 -> 8 CUB8 107 : DATA C27C8/1,2,25,8,9,21,27,24 , 3,4,25,2,10,22,27,21 , 108 : $ 5,6,25,4,11,23,27,22 , 7,8,25,6,12,24,27,23 , 109 : $ 13,20,26,14,9,24,27,21 , 15,14,26,16,10,21,27,22 , 110 : $ 17,16,26,18,11,22,27,23 , 19,18,26,20,12,23,27,24/ 111 : * CUB8 -> 5 TET4 112 : DATA C8T4/1,2,3,6 , 3,4,1,8 , 1,6,8,5 , 6,3,8,7 , 8,6,1,3/ 113 : * CU27 -> 6 QUA9 (Les faces carrées) 114 : DATA C27Q9/1,9,13,14,15,10,3,2,21 , 3,10,15,16,17,11,5,4,22 , 115 : $ 5,11,17,18,19,12,7,6,23 , 7,12,19,20,13,9,1,8,24 , 116 : $ 1,2,3,4,5,6,7,8,25 , 13,20,19,18,17,16,15,14,26/ 117 : * 118 : * Executable statements 119 : * 120 : IMPR=0 121 : IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans chang2.eso' 122 : * Numéro de l'élément à créer dans la numérotation de LTYP2 122 : CALL FIMOT2(NOMS(ITY),LTYP2,NTYP2,JTY,IMPR,IRET) 123 : IF (IRET.NE.0) GOTO 9999 124 : SEGACT IPT1 125 : NBSOUS=IPT1.LISOUS(/1) 126 : LCOMP=(NBSOUS.GE.1) 127 : IPT3=0 128 : * 129 : IF (NBSOUS.EQ.0) NBSOUS=1 130 : DO ISOUS=1,NBSOUS 131 : IF (LCOMP) THEN 132 : IPT2=IPT1.LISOUS(ISOUS) 133 : SEGACT IPT2 134 : ELSE 135 : IPT2=IPT1 136 : ENDIF 137 : ITYP=IPT2.ITYPEL 138 : MTYP=NOMS(ITYP) 139 : NBL=IPT2.NUM(/2) 140 : * NBN=IPT2.NUM(/1) 141 : IF (MTYP.EQ.'SEG3') THEN 142 : * Passage SEG3 -> 2 SEG2 143 : NBNN=2 144 : NBELEM=NBL*2 145 : NBSOUS=0 146 : NBREF=0 147 : SEGINI IPT4 148 : IPT4.ITYPEL=2 149 : IEL4=0 150 : DO IBL=1,NBL 151 : DO IL=1,2 152 : IEL4=IEL4+1 153 : DO IN=1,2 154 : IPT4.NUM(IN,IEL4)=IPT2.NUM(S3S2(IN,IL),IBL) 155 : ENDDO 156 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 157 : ENDDO 158 : ENDDO 159 : SEGDES IPT4 160 : ELSEIF (MTYP.EQ.'TRI7') THEN 161 : MTYP2=LTYPD2(JTY) 162 : IF (MTYP2.EQ.'TRI3') THEN 163 : * Passage TRI7 -> 4 TRI3 164 : NBNN=3 165 : NBELEM=NBL*4 166 : NBSOUS=0 167 : NBREF=0 168 : SEGINI IPT4 169 : IPT4.ITYPEL=4 170 : IEL4=0 171 : DO IBL=1,NBL 172 : DO IL=1,4 173 : IEL4=IEL4+1 174 : DO IN=1,3 175 : IPT4.NUM(IN,IEL4)=IPT2.NUM(T7T3(IN,IL),IBL) 176 : ENDDO 177 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 178 : ENDDO 179 : ENDDO 180 : SEGDES IPT4 181 : ELSEIF (MTYP2.EQ.'QUA4') THEN 182 : * Passage TRI7 -> 3 QUA4 183 : NBNN=4 184 : NBELEM=NBL*3 185 : NBSOUS=0 186 : NBREF=0 187 : SEGINI IPT4 188 : IPT4.ITYPEL=8 189 : IEL4=0 190 : DO IBL=1,NBL 191 : DO IL=1,3 192 : IEL4=IEL4+1 193 : DO IN=1,4 194 : IPT4.NUM(IN,IEL4)=IPT2.NUM(T7Q4(IN,IL),IBL) 195 : ENDDO 196 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 197 : ENDDO 198 : ENDDO 199 : SEGDES IPT4 200 : ELSE 201 : GOTO 9998 202 : ENDIF 203 : ELSEIF (MTYP.EQ.'QUA9') THEN 204 : MTYP2=LTYPD2(JTY) 205 : IF (MTYP2.EQ.'TRI3') THEN 206 : * Passage QUA9 -> 8 TRI3 207 : NBNN=3 208 : NBELEM=NBL*8 209 : NBSOUS=0 210 : NBREF=0 211 : SEGINI IPT4 212 : IPT4.ITYPEL=4 213 : IEL4=0 214 : DO IBL=1,NBL 215 : DO IL=1,8 216 : IEL4=IEL4+1 217 : DO IN=1,3 218 : IPT4.NUM(IN,IEL4)=IPT2.NUM(Q9T3(IN,IL),IBL) 219 : ENDDO 220 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 221 : ENDDO 222 : ENDDO 223 : SEGDES IPT4 224 : ELSEIF (MTYP2.EQ.'QUA4') THEN 225 : * Passage QUA9 -> 4 QUA4 226 : NBNN=4 227 : NBELEM=NBL*4 228 : NBSOUS=0 229 : NBREF=0 230 : SEGINI IPT4 231 : IPT4.ITYPEL=8 232 : IEL4=0 233 : DO IBL=1,NBL 234 : DO IL=1,4 235 : IEL4=IEL4+1 236 : DO IN=1,4 237 : IPT4.NUM(IN,IEL4)=IPT2.NUM(Q9Q4(IN,IL),IBL) 238 : ENDDO 239 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 240 : ENDDO 241 : ENDDO 242 : SEGDES IPT4 243 : ELSE 244 : GOTO 9998 245 : ENDIF 246 : ELSEIF (MTYP.EQ.'TE15') THEN 247 : MTYP2=LTYPD3(JTY) 248 : IF (MTYP2.EQ.'TET4') THEN 249 : * Passage TE15 -> 8 TET4 250 : NBNN=4 251 : NBELEM=NBL*8 252 : NBSOUS=0 253 : NBREF=0 254 : SEGINI IPT4 254 : CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET) 255 : IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN 255 : CALL ERREUR(5) 256 : RETURN 257 : ENDIF 258 : IPT4.ITYPEL=ITYP2 259 : IEL4=0 260 : DO IBL=1,NBL 261 : * D'abord les 4TET4 des coins 262 : DO IL=1,4 263 : IEL4=IEL4+1 264 : DO IN=1,4 265 : IPT4.NUM(IN,IEL4)=IPT2.NUM(T15T4(IN,IL),IBL) 266 : ENDDO 267 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 268 : ENDDO 269 : * Puis l'octaèdre du milieu 270 : DO IL=1,4 271 : IEL4=IEL4+1 272 : DO IN=1,4 273 : IPT4.NUM(IN,IEL4)= 274 : $ IPT2.NUM(T15O6(O6T4(IN,IL)),IBL) 275 : ENDDO 276 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 277 : ENDDO 278 : ENDDO 279 : SEGDES IPT4 280 : ELSEIF (MTYP2.EQ.'CUB8') THEN 281 : * Passage TE15 -> 4 CUB8 282 : NBNN=8 283 : NBELEM=NBL*4 284 : NBSOUS=0 285 : NBREF=0 286 : SEGINI IPT4 286 : CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET) 287 : IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN 287 : CALL ERREUR(5) 288 : RETURN 289 : ENDIF 290 : IPT4.ITYPEL=ITYP2 291 : IEL4=0 292 : DO IBL=1,NBL 293 : DO IL=1,4 294 : IEL4=IEL4+1 295 : DO IN=1,8 296 : IPT4.NUM(IN,IEL4)=IPT2.NUM(T15C8(IN,IL),IBL) 297 : ENDDO 298 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 299 : ENDDO 300 : ENDDO 301 : SEGDES IPT4 302 : ELSEIF (MTYP2.EQ.'PYR5') THEN 303 : * Passage TE15 -> 12 PYR5 304 : NBNN=5 305 : NBELEM=NBL*12 306 : NBSOUS=0 307 : NBREF=0 308 : SEGINI IPT4 308 : CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET) 309 : IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN 309 : CALL ERREUR(5) 310 : RETURN 311 : ENDIF 312 : IPT4.ITYPEL=ITYP2 313 : IEL4=0 314 : DO IBL=1,NBL 315 : DO IL=1,4 316 : DO IL2=1,3 317 : IEL4=IEL4+1 318 : DO IN=1,4 319 : IPT4.NUM(IN,IEL4)= 320 : $ IPT2.NUM(T15T7(T7Q4(IN,IL2),IL),IBL) 321 : ENDDO 322 : IPT4.NUM(5,IEL4)=IPT2.NUM(15,IBL) 323 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 324 : ENDDO 325 : ENDDO 326 : ENDDO 327 : SEGDES IPT4 328 : ELSE 329 : GOTO 9998 330 : ENDIF 331 : ELSEIF (MTYP.EQ.'PY19') THEN 332 : MTYP2=LTYPD3(JTY) 333 : IF (MTYP2.EQ.'TET4') THEN 334 : * Passage PY19 -> 16 TET4 335 : NBNN=4 336 : NBELEM=NBL*16 337 : NBSOUS=0 338 : NBREF=0 339 : SEGINI IPT4 339 : CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET) 340 : IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN 340 : CALL ERREUR(5) 341 : RETURN 342 : ENDIF 343 : IPT4.ITYPEL=ITYP2 344 : IEL4=0 345 : DO IBL=1,NBL 346 : * D'abord les 4 HEX6 des coins 347 : DO IL=1,4 348 : DO IL2=1,3 349 : IEL4=IEL4+1 350 : DO IN=1,4 351 : IPT4.NUM(IN,IEL4)= 352 : $ IPT2.NUM(P19H6(H6T4(IN,IL2),IL),IBL) 353 : ENDDO 354 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 355 : ENDDO 356 : ENDDO 357 : * Puis l'octaèdre du milieu 358 : DO IL=1,4 359 : IEL4=IEL4+1 360 : DO IN=1,4 361 : IPT4.NUM(IN,IEL4)= 362 : $ IPT2.NUM(P19O6(O6T4(IN,IL)),IBL) 363 : ENDDO 364 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 365 : ENDDO 366 : ENDDO 367 : SEGDES IPT4 368 : ELSEIF (MTYP2.EQ.'PYR5') THEN 369 : * Passage PY19 -> 16 PYR5 370 : NBNN=5 371 : NBELEM=NBL*16 372 : NBSOUS=0 373 : NBREF=0 374 : SEGINI IPT4 374 : CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET) 375 : IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN 375 : CALL ERREUR(5) 376 : RETURN 377 : ENDIF 378 : IPT4.ITYPEL=ITYP2 379 : IEL4=0 380 : DO IBL=1,NBL 381 : * Les faces triangulaires 382 : DO IL=1,4 383 : DO IL2=1,3 384 : IEL4=IEL4+1 385 : DO IN=1,4 386 : IPT4.NUM(IN,IEL4)= 387 : $ IPT2.NUM(P19T7(T7Q4(IN,IL2),IL),IBL) 388 : ENDDO 389 : IPT4.NUM(5,IEL4)=IPT2.NUM(19,IBL) 390 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 391 : ENDDO 392 : ENDDO 393 : * La face carrée 394 : DO IL=1,4 395 : IEL4=IEL4+1 396 : DO IN=1,4 397 : IPT4.NUM(IN,IEL4)= 398 : $ IPT2.NUM(P19Q9(Q9Q4(IN,IL)),IBL) 399 : ENDDO 400 : IPT4.NUM(5,IEL4)=IPT2.NUM(19,IBL) 401 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 402 : ENDDO 403 : ENDDO 404 : SEGDES IPT4 405 : ELSE 406 : GOTO 9998 407 : ENDIF 408 : ELSEIF (MTYP.EQ.'PR21') THEN 409 : MTYP2=LTYPD3(JTY) 410 : IF (MTYP2.EQ.'TET4') THEN 411 : * Passage PR21 -> 24 TET4 412 : NBNN=4 413 : NBELEM=NBL*24 414 : NBSOUS=0 415 : NBREF=0 416 : SEGINI IPT4 416 : CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET) 417 : IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN 417 : CALL ERREUR(5) 418 : RETURN 419 : ENDIF 420 : IPT4.ITYPEL=ITYP2 421 : IEL4=0 422 : DO IBL=1,NBL 423 : * D'abord les 4 PRI6 de type A 424 : DO IL=1,4 425 : DO IL2=1,3 426 : IEL4=IEL4+1 427 : DO IN=1,4 428 : IPT4.NUM(IN,IEL4)= 429 : $ IPT2.NUM(P21P6A(P6AT4(IN,IL2),IL),IBL) 430 : ENDDO 431 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 432 : ENDDO 433 : ENDDO 434 : * Puis les 4 PRI6 de type B 435 : DO IL=1,4 436 : DO IL2=1,3 437 : IEL4=IEL4+1 438 : DO IN=1,4 439 : IPT4.NUM(IN,IEL4)= 440 : $ IPT2.NUM(P21P6B(P6BT4(IN,IL2),IL),IBL) 441 : ENDDO 442 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 443 : ENDDO 444 : ENDDO 445 : ENDDO 446 : SEGDES IPT4 447 : ELSEIF (MTYP2.EQ.'CUB8') THEN 448 : * Passage PR21 -> 6 CUB8 449 : NBNN=8 450 : NBELEM=NBL*6 451 : NBSOUS=0 452 : NBREF=0 453 : SEGINI IPT4 453 : CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET) 454 : IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN 454 : CALL ERREUR(5) 455 : RETURN 456 : ENDIF 457 : IPT4.ITYPEL=ITYP2 458 : IEL4=0 459 : DO IBL=1,NBL 460 : DO IL=1,6 461 : IEL4=IEL4+1 462 : DO IN=1,8 463 : IPT4.NUM(IN,IEL4)=IPT2.NUM(P21C8(IN,IL),IBL) 464 : ENDDO 465 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 466 : ENDDO 467 : ENDDO 468 : SEGDES IPT4 469 : ELSEIF (MTYP2.EQ.'PYR5') THEN 470 : * Passage PR21 -> 18 PYR5 471 : NBNN=5 472 : NBELEM=NBL*18 473 : NBSOUS=0 474 : NBREF=0 475 : SEGINI IPT4 475 : CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET) 476 : IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN 476 : CALL ERREUR(5) 477 : RETURN 478 : ENDIF 479 : IPT4.ITYPEL=ITYP2 480 : IEL4=0 481 : DO IBL=1,NBL 482 : * Les faces triangulaires 483 : DO IL=1,2 484 : DO IL2=1,3 485 : IEL4=IEL4+1 486 : DO IN=1,4 487 : IPT4.NUM(IN,IEL4)= 488 : $ IPT2.NUM(P21T7(T7Q4(IN,IL2),IL),IBL) 489 : ENDDO 490 : IPT4.NUM(5,IEL4)=IPT2.NUM(21,IBL) 491 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 492 : ENDDO 493 : ENDDO 494 : * Les faces carrées 495 : DO IL=1,3 496 : DO IL2=1,4 497 : IEL4=IEL4+1 498 : DO IN=1,4 499 : IPT4.NUM(IN,IEL4)= 500 : $ IPT2.NUM(P21Q9(Q9Q4(IN,IL2),IL),IBL) 501 : ENDDO 502 : IPT4.NUM(5,IEL4)=IPT2.NUM(21,IBL) 503 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 504 : ENDDO 505 : ENDDO 506 : ENDDO 507 : SEGDES IPT4 508 : ELSE 509 : GOTO 9998 510 : ENDIF 511 : ELSEIF (MTYP.EQ.'CU27') THEN 512 : MTYP2=LTYPD3(JTY) 513 : IF (MTYP2.EQ.'TET4') THEN 514 : * Passage CU27 -> 40 TET4 515 : NBNN=4 516 : NBELEM=NBL*40 517 : NBSOUS=0 518 : NBREF=0 519 : SEGINI IPT4 519 : CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET) 520 : IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN 520 : CALL ERREUR(5) 521 : RETURN 522 : ENDIF 523 : IPT4.ITYPEL=ITYP2 524 : IEL4=0 525 : DO IBL=1,NBL 526 : DO IL=1,8 527 : DO IL2=1,5 528 : IEL4=IEL4+1 529 : DO IN=1,4 530 : IPT4.NUM(IN,IEL4)= 531 : $ IPT2.NUM(C27C8(C8T4(IN,IL2),IL),IBL) 532 : ENDDO 533 : ENDDO 534 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 535 : ENDDO 536 : ENDDO 537 : SEGDES IPT4 538 : ELSEIF (MTYP2.EQ.'CUB8') THEN 539 : * Passage CU27 -> 8 CUB8 540 : NBNN=8 541 : NBELEM=NBL*8 542 : NBSOUS=0 543 : NBREF=0 544 : SEGINI IPT4 544 : CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET) 545 : IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN 545 : CALL ERREUR(5) 546 : RETURN 547 : ENDIF 548 : IPT4.ITYPEL=ITYP2 549 : IEL4=0 550 : DO IBL=1,NBL 551 : DO IL=1,8 552 : IEL4=IEL4+1 553 : DO IN=1,8 554 : IPT4.NUM(IN,IEL4)=IPT2.NUM(C27C8(IN,IL),IBL) 555 : ENDDO 556 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 557 : ENDDO 558 : ENDDO 559 : SEGDES IPT4 560 : ELSEIF (MTYP2.EQ.'PYR5') THEN 561 : * Passage CU27 -> 24 PYR5 562 : NBNN=5 563 : NBELEM=NBL*24 564 : NBSOUS=0 565 : NBREF=0 566 : SEGINI IPT4 566 : CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET) 567 : IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN 567 : CALL ERREUR(5) 568 : RETURN 569 : ENDIF 570 : IPT4.ITYPEL=ITYP2 571 : IEL4=0 572 : DO IBL=1,NBL 573 : DO IL=1,6 574 : DO IL2=1,4 575 : IEL4=IEL4+1 576 : DO IN=1,4 577 : IPT4.NUM(IN,IEL4)= 578 : $ IPT2.NUM(C27Q9(Q9Q4(IN,IL2),IL),IBL) 579 : ENDDO 580 : IPT4.NUM(5,IEL4)=IPT2.NUM(27,IBL) 581 : IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL) 582 : ENDDO 583 : ENDDO 584 : ENDDO 585 : SEGDES IPT4 586 : ELSE 587 : GOTO 9998 588 : ENDIF 589 : ELSE 590 : GOTO 9998 591 : ENDIF 592 : * 593 : IF (LCOMP) SEGDES IPT2 594 : IF (IPT3.EQ.0) THEN 595 : IPT3=IPT4 596 : ELSE 597 : ltelq=.false. 597 : CALL FUSE(IPT3,IPT4,IPT5,ltelq) 598 : IPT3=IPT5 599 : ENDIF 600 : * 601 : ENDDO 602 : SEGDES IPT1 603 : * 604 : 605 : IPT1=IPT3 606 : * 607 : * Normal termination 608 : * 609 : IRET=0 610 : RETURN 611 : * 612 : * Format handling 613 : * 614 : * 615 : * Error handling 616 : * 617 : * 995 2 618 : *On ne sait pas changer des éléments %m1:4 en élément %m5:8 619 : 9998 CONTINUE 620 : MOTERR(1:4)=MTYP 621 : MOTERR(5:8)=NOMS(ITY) 621 : CALL ERREUR(995) 622 : RETURN 623 : 9999 CONTINUE 624 : IRET=1 625 : WRITE(IOIMP,*) 'An error was detected in subroutine chang2' 626 : RETURN 627 : * 628 : * End of subroutine CHANG2 629 : * 630 : END 631 : 632 : 633 :
© Cast3M 2003 - All rights reserved.
Disclaimer