1 : C BARSOU SOURCE CHAT 11/04/14 21:15:10 6942 2 : SUBROUTINE BARSOU 3 : *------------------------------------------------------------------------* 4 : * Operateur BARSOU : Déplacement des noeuds milieu au quart * 5 : * * 6 : * MELEME (e/s) : Pointeur sur un MELEME (TRI6 ou QUA 8) * 7 : * IPOIN (e) : Pointe de fissure * 8 : * ou IPT3 (e) : Ligne de fissure dans le cas 3D massif * 9 : *------------------------------------------------------------------------* 10 : 11 : IMPLICIT INTEGER(I-N) 12 : IMPLICIT REAL*8 (A-H,O-Z) 13 : * 14 : -INC CCOPTIO 15 : -INC SMELEME 16 : -INC SMCOORD 17 : * 18 : *------------------------------------------------------------------------* 19 : * Déclaration des segments temporaires nécessaires au traitement * 20 : *------------------------------------------------------------------------* 21 : * Segment des noeuds à déplacer * 22 : SEGMENT, PTDEP 23 : INTEGER TPOIM(N), TPFIS(N), TPOIE(N) 24 : ENDSEGMENT 25 : POINTEUR IPTDP.PTDEP 26 : * Segment des noeuds milieu de la ligne de fissures * 27 : SEGMENT, PTMIL 28 : INTEGER TLFMI(N) 29 : ENDSEGMENT 30 : * Segment des pointes de fissure (pas de noeuds milieu) * 31 : SEGMENT, PTFIS 32 : INTEGER TLFPT(N) 33 : ENDSEGMENT 34 : * Segment des élements contenant des noeuds à déplacer * 35 : SEGMENT, ELMDP 36 : INTEGER TSOUS(N), TELMM(N), TPFIM(N), TTYPL(N), TNUPF(N) 37 : ENDSEGMENT 38 : * 39 : *------------------------------------------------------------------------* 40 : * Autres déclarations * 41 : *------------------------------------------------------------------------* 42 : REAL*8 V1(3), V2(3), V3(3), TDIST(20) 43 : INTEGER TMRAN(4), TERAN(4) 44 : INTEGER TMP15(14,3), TEP15(14,3), TMC20(19,3), TEC20(19,3) 45 : INTEGER TMP13(13,4), TEP13(13,4), TMT10(10,3), TET10(14,3) 46 : INTEGER TMQU8(7,2), TEQU8(7,2), TMTR6(5,2), TETR6(5,2) 47 : DATA TMP15(1,1), TMP15(1,2), TMP15(1,3), TMP15(3,1), TMP15(3,2), 48 : # TMP15(3,3), TMP15(5,1), TMP15(5,2), TMP15(5,3), TMP15(10,1), 49 : # TMP15(10,2), TMP15(10,3), TMP15(12,1), TMP15(12,2), TMP15(12,3), 50 : # TMP15(14,1), TMP15(14,2), TMP15(14,3) 51 : # /2,6,7,2,4,8,4,6,9,7,11,15,8,11,13,9,13,15/ 52 : DATA TEP15(1,1), TEP15(1,2), TEP15(1,3), TEP15(3,1), TEP15(3,2), 53 : # TEP15(3,3), TEP15(5,1), TEP15(5,2), TEP15(5,3), TEP15(10,1), 54 : # TEP15(10,2), TEP15(10,3), TEP15(12,1), TEP15(12,2), TEP15(12,3), 55 : # TEP15(14,1), TEP15(14,2), TEP15(14,3) 56 : # /3,5,10,1,5,12,3,1,14,1,12,14,3,10,14,5,12,10/ 57 : DATA TMC20(1,1), TMC20(1,2), TMC20(1,3), TMC20(3,1), TMC20(3,2), 58 : # TMC20(3,3), TMC20(5,1), TMC20(5,2), TMC20(5,3), TMC20(7,1), 59 : # TMC20(7,2), TMC20(7,3), TMC20(13,1), TMC20(13,2), TMC20(13,3), 60 : # TMC20(15,1), TMC20(15,2), TMC20(15,3), TMC20(17,1), TMC20(17,2), 61 : # TMC20(17,3), TMC20(19,1), TMC20(19,2), TMC20(19,3) 62 : # /2,8,9,2,4,10,4,6,11,6,8,12,9,14,20,14,16,10,11,16,18,12,18,20/ 63 : DATA TEC20(1,1), TEC20(1,2), TEC20(1,3), TEC20(3,1), TEC20(3,2), 64 : # TEC20(3,3), TEC20(5,1), TEC20(5,2), TEC20(5,3), TEC20(7,1), 65 : # TEC20(7,2), TEC20(7,3), TEC20(13,1), TEC20(13,2), TEC20(13,3), 66 : # TEC20(15,1), TEC20(15,2), TEC20(15,3), TEC20(17,1), TEC20(17,2), 67 : # TEC20(17,3), TEC20(19,1), TEC20(19,2), TEC20(19,3) 68 : # /3,7,13,1,5,15,3,7,17,5,1,19,1,15,19,13,17,3,5,15,19,7,17,13/ 69 : DATA TMP13(1,1), TMP13(1,2), TMP13(1,3), TMP13(3,1), TMP13(3,2), 70 : # TMP13(3,3), TMP13(5,1), TMP13(5,2), TMP13(5,3), TMP13(7,1), 71 : # TMP13(7,2), TMP13(7,3), TMP13(13,1), TMP13(13,2), TMP13(13,3), 72 : # TMP13(13,4) 73 : # /2,8,9,2,4,10,4,6,11,6,8,12,9,10,11,12/ 74 : DATA TEP13(1,1), TEP13(1,2), TEP13(1,3), TEP13(3,1), TEP13(3,2), 75 : # TEP13(3,3), TEP13(5,1), TEP13(5,2), TEP13(5,3), TEP13(7,1), 76 : # TEP13(7,2), TEP13(7,3), TEP13(13,1), TEP13(13,2), TEP13(13,3), 77 : # TEP13(13,4) 78 : # /3,7,10,1,5,13,3,7,13,5,1,13,1,3,5,7/ 79 : DATA TMT10(1,1), TMT10(1,2), TMT10(1,3), TMT10(3,1), TMT10(3,2), 80 : # TMT10(3,3), TMT10(5,1), TMT10(5,2), TMT10(5,3), TMT10(10,1), 81 : # TMT10(10,2), TMT10(10,3) 82 : # /2,6,7,2,4,8,4,6,9,7,8,9/ 83 : DATA TET10(1,1), TET10(1,2), TET10(1,3), TET10(3,1), TET10(3,2), 84 : # TET10(3,3), TET10(5,1), TET10(5,2), TET10(5,3), TET10(10,1), 85 : # TET10(10,2), TET10(10,3) 86 : # /3,5,10,1,5,10,3,1,10,1,3,5/ 87 : DATA TMQU8(1,1), TMQU8(1,2), TMQU8(3,1), TMQU8(3,2), TMQU8(5,1), 88 : # TMQU8(5,2), TMQU8(7,1), TMQU8(7,2) 89 : # /2,8,2,4,4,6,6,8/ 90 : DATA TEQU8(1,1), TEQU8(1,2), TEQU8(3,1), TEQU8(3,2), TEQU8(5,1), 91 : # TEQU8(5,2), TEQU8(7,1), TEQU8(7,2) 92 : # /3,7,1,5,3,7,5,1/ 93 : DATA TMTR6(1,1), TMTR6(1,2), TMTR6(3,1), TMTR6(3,2), TMTR6(5,1), 94 : # TMTR6(5,2) 95 : # /2,6,2,4,4,6/ 96 : DATA TETR6(1,1), TETR6(1,2), TETR6(3,1), TETR6(3,2), TETR6(5,1), 97 : # TETR6(5,2) 98 : # /3,5,1,5,3,1/ 99 : * 100 : *------------------------------------------------------------------------* 101 : * Récupération du maillage et de la pointe * 102 : * ou de la ligne de fissure * 103 : *------------------------------------------------------------------------* 103 : CALL LIROBJ('MAILLAGE', MELEME, 1, IRETOU) 104 : IF (IERR .NE. 0) RETURN 105 : IF (IRETOU .EQ. 0) RETURN 105 : CALL LIRREE(ALPHA, 0, IRETOU) 106 : IF (IERR .NE. 0) RETURN 107 : IF (IRETOU .EQ. 0) THEN 108 : ALPHA = 0.495 109 : ELSE 110 : IF (IIMPI.EQ.1) WRITE (*,*) 'REEL LU...' 111 : ENDIF 112 : IF (IIMPI.EQ.1) WRITE (*,*) 'OBJET MAILLAGE LU...' 112 : CALL LIROBJ('MAILLAGE', IPT3, 0, IRETOU) 113 : IF (IERR .NE. 0) RETURN 114 : SEGACT, MCOORD*MOD 115 : IF (IRETOU .EQ. 0) THEN 115 : CALL LIROBJ('POINT', IPOIN, 1, IRETOU) 116 : IF (IERR .NE. 0) RETURN 117 : IF (IRETOU .EQ. 0) RETURN 118 : IF (IIMPI.EQ.1) WRITE (*,*) 'OBJET POINT LU...' 119 : N = 1 120 : SEGINI, PTFIS 121 : TLFPT(1) = IPOIN 122 : IF (IIMPI.EQ.1) THEN 123 : WRITE (*,*) ' Noeud de fissure : ', IPOIN 124 : ENDIF 125 : SEGDES, PTFIS 126 : N = 0 127 : SEGINI, PTMIL 128 : SEGDES, PTMIL 129 : ELSE 130 : IF (IIMPI.EQ.1) WRITE (*,*) 'OBJET MAILLAGE LU...' 131 : N = 0 132 : SEGINI, PTFIS 133 : SEGDES, PTFIS 134 : N = 0 135 : SEGINI, PTMIL 136 : SEGDES, PTMIL 137 : SEGACT, IPT3 138 : IPT2 = IPT3 139 : IP = 0 140 : IF (IIMPI.EQ.1) WRITE (*,*) 'BOUCLE SUR LE MAILLAGE...' 141 : *----------POUR CHAQUE SOUS-ENSEMBLE 142 : DO 13 IS = 1, MAX(1, IPT3.LISOUS(/1)) 143 : IF (IPT3.LISOUS(/1) .NE. 0) THEN 144 : IPT2 = IPT3.LISOUS(IS) 145 : SEGACT, IPT2 146 : ENDIF 147 : IF (IIMPI.EQ.1) THEN 148 : WRITE (*,*) 'OBJET MAILLAGE DE TYPE ', IPT2.ITYPEL 149 : ENDIF 150 : DO 12 IE = 1, IPT2.NUM(/2) 151 : SEGACT, PTMIL 152 : N = TLFMI(/1) + 1 153 : SEGADJ, PTMIL 154 : TLFMI(N) = IPT2.NUM(2, IE) 155 : IF (IIMPI .EQ. 1) THEN 156 : WRITE (*,*) ' Point milieu-fissure ',TLFMI(N) 157 : ENDIF 158 : SEGDES, PTMIL 159 : SEGACT, PTFIS 160 : IF (IP .EQ. 0) THEN 161 : IP = 1 162 : N = 1 163 : SEGADJ, PTFIS 164 : TLFPT(1) = IPT2.NUM(1, IE) 165 : IF (IIMPI .EQ. 1) THEN 166 : WRITE (*,*) ' Point fissure ',TLFPT(N) 167 : ENDIF 168 : ENDIF 169 : N = TLFPT(/1) + 1 170 : SEGADJ, PTFIS 171 : TLFPT(N) = IPT2.NUM(3, IE) 172 : IF (IIMPI .EQ. 1) THEN 173 : WRITE (*,*) ' Point fissure ',TLFPT(N) 174 : ENDIF 175 : SEGDES, PTFIS 176 : 12 CONTINUE 177 : IF (IPT3.LISOUS(/1).NE.0) SEGDES, IPT2 178 : 13 CONTINUE 179 : SEGDES, IPT3 180 : ENDIF 181 : *------------------------------------------------------------------------* 182 : * Récupération des éléments contenant des noeuds à déplacer * 183 : *------------------------------------------------------------------------* 184 : IF (IIMPI.EQ.1) WRITE (*,*) 'RECUPERATION DES ELEMENTS' 185 : IK = 0 186 : N = 0 187 : SEGINI, ELMDP 188 : SEGDES, ELMDP 189 : SEGACT, PTFIS 190 : INP = TLFPT(/1) 191 : DO 5 IP = 1, INP 192 : IPOIN = TLFPT(IP) 193 : *----------ON CHERCHE LES ELEMENTS CONTENANT LA POINTE DE FISSURE 194 : SEGACT, MELEME 195 : IPT1 = MELEME 196 : DO 2 IS=1, MAX(1, MELEME.LISOUS(/1)) 197 : IF (MELEME.LISOUS(/1).NE.0) THEN 198 : IPT1 = MELEME.LISOUS(IS) 199 : SEGACT IPT1 200 : ENDIF 201 : DO 3 IE = 1, IPT1.NUM(/2) 202 : DO 4 IN = 1, IPT1.NUM(/1) 203 : IF (IPT1.NUM(IN, IE) .EQ. IPOIN) THEN 204 : *----------------------ON A TROUVE UN ELEMENT QUI CONTIENT LA POINTE 205 : SEGACT, ELMDP 206 : IF (TELMM(/1) .EQ. 0) THEN 207 : IK = IK + 1 208 : N = TELMM(/1) + 1 209 : SEGADJ, ELMDP 210 : TELMM(N) = IE 211 : TTYPL(N) = IPT1.ITYPEL 212 : TPFIM(N) = TLFPT(IP) 213 : TNUPF(N) = IN 214 : IF (MELEME.LISOUS(/1).NE.0) THEN 215 : TSOUS(N) = IS 216 : ELSE 217 : TSOUS(N) = 0 218 : ENDIF 219 : IF (IIMPI.EQ.1) THEN 220 : WRITE (*,*) ' Element : ',IE,' dans ',TSOUS(N) 221 : WRITE (*,*) ' fissure : ',TPFIM(N) 222 : ENDIF 223 : ELSE 224 : II = 1 225 : 6 IF(TELMM(II).NE.IE.OR.TSOUS(II).NE.IS.OR.TPFIM(II).NE.IPOIN) THEN 226 : II = II + 1 227 : IF (II .LE. TELMM(/1)) GOTO 6 228 : IK = IK + 1 229 : N = TELMM(/1) + 1 230 : SEGADJ, ELMDP 231 : TELMM(N) = IE 232 : TTYPL(N) = IPT1.ITYPEL 233 : TPFIM(N) = TLFPT(IP) 234 : TNUPF(N) = IN 235 : IF (MELEME.LISOUS(/1).NE.0) THEN 236 : TSOUS(N) = IS 237 : ELSE 238 : TSOUS(N) = 0 239 : ENDIF 240 : IF (IIMPI.EQ.1) THEN 241 : WRITE (*,*) ' Element : ',IE,' dans ',TSOUS(N) 242 : WRITE (*,*) ' fissure : ',TPFIM(N) 243 : ENDIF 244 : ENDIF 245 : ENDIF 246 : SEGDES, ELMDP 247 : ENDIF 248 : 4 CONTINUE 249 : 3 CONTINUE 250 : IF (LISOUS(/1).NE.0) SEGDES, IPT1 251 : 2 CONTINUE 252 : SEGDES, MELEME 253 : 5 CONTINUE 254 : SEGDES, PTFIS 255 : *------------------------------------------------------------------------* 256 : * Récupération des noeuds à déplacer * 257 : *------------------------------------------------------------------------* 258 : N = 0 259 : IF (IIMPI.EQ.1) WRITE (*,*) 'RECUPERATION DES NOEUDS' 260 : SEGINI, PTDEP 261 : SEGDES, PTDEP 262 : SEGACT, MELEME 263 : IPT1 = MELEME 264 : SEGACT, ELMDP 265 : SEGACT, PTDEP 266 : IK = 0 267 : *-------POUR CHAQUE ELEMENT SELECTIONNE PRECEDEMMENT 268 : IF (IIMPI.EQ.1) WRITE (*,*) ' ',TELMM(/1),' Elements à étudier' 269 : DO 20 IE = 1, ELMDP.TELMM(/1) 270 : IEFI = ELMDP.TNUPF(IE) 271 : IF (ELMDP.TTYPL(IE).EQ.6) THEN 272 : IF (IIMPI.EQ.1) WRITE (*,*) ' Element TRI6 # ', IE 273 : INBNO = 6 274 : GOTO 21 275 : ENDIF 276 : IF (ELMDP.TTYPL(IE).EQ.10) THEN 277 : IF (IIMPI.EQ.1) WRITE (*,*) ' Element QUA8 # ', IE 278 : INBNO = 8 279 : GOTO 22 280 : ENDIF 281 : IF (ELMDP.TTYPL(IE).EQ.15) THEN 282 : IF (IIMPI.EQ.1) WRITE (*,*) ' Element CU20 # ', IE 283 : INBNO = 20 284 : GOTO 23 285 : ENDIF 286 : IF (ELMDP.TTYPL(IE).EQ.17) THEN 287 : IF (IIMPI.EQ.1) WRITE (*,*) ' Element PR15 # ', IE 288 : INBNO = 15 289 : GOTO 24 290 : ENDIF 291 : IF (ELMDP.TTYPL(IE).EQ.24) THEN 292 : IF (IIMPI.EQ.1) WRITE (*,*) ' Element TE10 # ', IE 293 : INBNO = 10 294 : GOTO 25 295 : ENDIF 296 : IF (ELMDP.TTYPL(IE).EQ.26) THEN 297 : IF (IIMPI.EQ.1) WRITE (*,*) ' Element PY13 # ', IE 298 : INBNO = 13 299 : GOTO 26 300 : ENDIF 301 : GOTO 20 302 : 21 CONTINUE 303 : ***--------CAS DES ELEMENTS TRI6 304 : IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE)) 305 : SEGACT, IPT1 306 : NPMI = 2 307 : DO 211 IM = 1, NPMI 308 : TMRAN(IM) = TMTR6(IEFI, IM) 309 : TERAN(IM) = TETR6(IEFI, IM) 310 : 211 CONTINUE 311 : GOTO 200 312 : 22 CONTINUE 313 : ***--------CAS DES ELEMENTS QUA8 314 : IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE)) 315 : SEGACT, IPT1 316 : NPMI = 2 317 : DO 212 IM = 1, NPMI 318 : TMRAN(IM) = TMQU8(IEFI, IM) 319 : TERAN(IM) = TEQU8(IEFI, IM) 320 : 212 CONTINUE 321 : GOTO 200 322 : 23 CONTINUE 323 : ***--------CAS DES ELEMENTS CU20 324 : IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE)) 325 : SEGACT, IPT1 326 : NPMI = 3 327 : DO 213 IM = 1, NPMI 328 : TMRAN(IM) = TMC20(IEFI, IM) 329 : TERAN(IM) = TEC20(IEFI, IM) 330 : 213 CONTINUE 331 : GOTO 200 332 : 24 CONTINUE 333 : ***--------CAS DES ELEMENTS PR15 334 : IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE)) 335 : SEGACT, IPT1 336 : NPMI = 3 337 : DO 214 IM = 1, NPMI 338 : TMRAN(IM) = TMP15(IEFI, IM) 339 : TERAN(IM) = TEP15(IEFI, IM) 340 : 214 CONTINUE 341 : GOTO 200 342 : 25 CONTINUE 343 : ***--------CAS DES ELEMENTS TE10 344 : IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE)) 345 : SEGACT, IPT1 346 : NPMI = 3 347 : DO 215 IM = 1, NPMI 348 : TMRAN(IM) = TMT10(IEFI, IM) 349 : TERAN(IM) = TET10(IEFI, IM) 350 : 215 CONTINUE 351 : GOTO 200 352 : 26 CONTINUE 353 : ***--------CAS DES ELEMENTS PY13 354 : IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE)) 355 : SEGACT, IPT1 356 : IF (IEFI .EQ. 13) THEN 357 : NPMI = 4 358 : ELSE 359 : NPMI = 3 360 : ENDIF 361 : DO 216 IM = 1, NPMI 362 : TMRAN(IM) = TMP13(IEFI, IM) 363 : TERAN(IM) = TEP13(IEFI, IM) 364 : 216 CONTINUE 365 : ***--------RANGEMENT DES POINTS MILIEUX ET DES POINTS EXTREMITES 366 : 200 CONTINUE 367 : IF (IK .EQ. 0) THEN 368 : DO 220 IM = 1, NPMI 369 : IK = IK + 1 370 : N = IK 371 : SEGADJ, PTDEP 372 : PTDEP.TPOIM(N) = IPT1.NUM(TMRAN(IM), TELMM(IE)) 373 : PTDEP.TPOIE(N) = IPT1.NUM(TERAN(IM), TELMM(IE)) 374 : PTDEP.TPFIS(N) = ELMDP.TPFIM(IE) 375 : IF (IIMPI .EQ. 1) THEN 376 : WRITE (*,*) 'POINT MILIEU : ', PTDEP.TPOIM(N) 377 : WRITE (*,*) ' Point extremite : ', PTDEP.TPOIE(N) 378 : WRITE (*,*) ' Point fissure : ', PTDEP.TPFIS(N) 379 : ENDIF 380 : 220 CONTINUE 381 : ELSE 382 : DO 230 IM = 1, NPMI 383 : II = 1 384 : 240 IF (PTDEP.TPOIM(II).NE.IPT1.NUM(TMRAN(IM),TELMM(IE))) THEN 385 : IF (II .LE. IK) THEN 386 : II = II + 1 387 : GOTO 240 388 : ELSE 389 : IK = IK + 1 390 : N = PTDEP.TPOIM(/1) + 1 391 : SEGADJ, PTDEP 392 : PTDEP.TPOIM(N) = IPT1.NUM(TMRAN(IM), TELMM(IE)) 393 : PTDEP.TPOIE(N) = IPT1.NUM(TERAN(IM), TELMM(IE)) 394 : PTDEP.TPFIS(N) = ELMDP.TPFIM(IE) 395 : IF (IIMPI .EQ. 1) THEN 396 : WRITE (*,*) 'POINT MILIEU : ', PTDEP.TPOIM(N) 397 : WRITE (*,*) ' Point extremite : ', PTDEP.TPOIE(N) 398 : WRITE (*,*) ' Point fissure : ', PTDEP.TPFIS(N) 399 : ENDIF 400 : ENDIF 401 : ENDIF 402 : 230 CONTINUE 403 : ENDIF 404 : SEGDES, IPT1 405 : 20 CONTINUE 406 : SEGDES, PTDEP 407 : SEGDES, ELMDP 408 : SEGDES, MELEME 409 : * 410 : *------------------------------------------------------------------------* 411 : * Epuration du tableau contenant les noeuds milieu * 412 : *------------------------------------------------------------------------* 413 : SEGACT, PTDEP 414 : N = 1 415 : SEGINI, IPTDP 416 : IPTDP.TPOIM(1) = PTDEP.TPOIM(1) 417 : IPTDP.TPFIS(1) = PTDEP.TPFIS(1) 418 : IPTDP.TPOIE(1) = PTDEP.TPOIE(1) 419 : DO 50, IP = 2, PTDEP.TPOIM(/1) 420 : II = 1 421 : 51 IF (IPTDP.TPOIM(II) .NE. PTDEP.TPFIS(IP)) THEN 422 : II = II + 1 423 : IF (II .LE. IPTDP.TPOIM(/1)) GOTO 51 424 : N = IPTDP.TPOIM(/1) + 1 425 : SEGADJ, IPTDP 426 : IPTDP.TPOIM(N) = PTDEP.TPOIM(IP) 427 : IPTDP.TPFIS(N) = PTDEP.TPFIS(IP) 428 : IPTDP.TPOIE(N) = PTDEP.TPOIE(IP) 429 : ENDIF 430 : 50 CONTINUE 431 : SEGDES, IPTDP 432 : SEGDES, PTDEP 433 : *------------------------------------------------------------------------* 434 : * Déplacement des noeuds milieu * 435 : *------------------------------------------------------------------------* 436 : * 437 : SEGACT, IPTDP 438 : SEGACT, PTMIL 439 : DO 40, IP = 1, IPTDP.TPOIM(/1) 440 : IF (PTMIL.TLFMI(/1) .EQ. 0) GOTO 42 441 : II = 1 442 : 41 IF (TLFMI(II) .NE. IPTDP.TPOIM(IP)) THEN 443 : II = II + 1 444 : IF (II .LE. TLFMI(/1)) GOTO 41 445 : GOTO 42 446 : ELSE 447 : GOTO 40 448 : ENDIF 449 : 42 IF (IIMPI.EQ.1) THEN 450 : WRITE (*,*) 'Point milieu : ', IPTDP.TPOIM(IP) 451 : WRITE (*,*) ' Point fissure : ', IPTDP.TPFIS(IP) 452 : WRITE (*,*) ' Point extreme : ', IPTDP.TPOIE(IP) 453 : ENDIF 454 : ALPE = 0.5*(ALPHA - 1.)*ALPHA 455 : ALPM = (1. - ALPHA)*(ALPHA + 1) 456 : ALPF = 0.5*ALPHA*(ALPHA + 1.) 457 : IRPF = (IDIM + 1)*(IPTDP.TPFIS(IP) - 1) 458 : IRPM = (IDIM + 1)*(IPTDP.TPOIM(IP) - 1) 459 : IRPE = (IDIM + 1)*(IPTDP.TPOIE(IP) - 1) 460 : DO 43 IC = 1, IDIM 461 : XCOOR(IRPM + IC) = ALPF*XCOOR(IRPF + IC) + 462 : # ALPM*XCOOR(IRPM + IC) + ALPE*XCOOR(IRPE + IC) 463 : 43 CONTINUE 464 : 40 CONTINUE 465 : IF (IIMPI.EQ.1) THEN 466 : WRITE (*,*) IPTDP.TPOIM(/1), ' noeuds déplacés.' 467 : ENDIF 468 : SEGDES, IPTDP 469 : SEGDES, PTMIL 470 : *------------------------------------------------------------------------* 471 : * Suppression des segments temporaires * 472 : *------------------------------------------------------------------------* 473 : SEGSUP, IPTDP 474 : SEGSUP, PTDEP 475 : SEGSUP, PTMIL 476 : SEGSUP, PTFIS 477 : SEGSUP, ELMDP 478 : * 479 : RETURN 480 : END 481 : 482 : 483 : 484 : 485 : 486 :
© Cast3M 2003 - All rights reserved.
Disclaimer