1 : C PROT SOURCE PV 13/04/12 21:15:48 7756 2 : SUBROUTINE PROT(IPMODE,IPCHT,IPCHE,ITPR) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : *--------------------------------------------------------------------* 6 : * * 7 : * Sous-programme associé à l'opérateur CALP * 8 : * ____________________________________________ * 9 : * * 10 : * Projection d'un chamelem de temperature sur une géometrie 11 : * constituée de coques * 12 : * * 13 : * * 14 : * Auteur, date de création: * 15 : * ------------------------- * 16 : * * 17 : * Bruno VIGAN, le 26 février 1997. * 18 : * * 19 : *--------------------------------------------------------------------* 20 : * 21 : -INC CCOPTIO 22 : -INC SMCOORD 23 : -INC SMMODEL 24 : -INC SMCHAML 25 : -INC SMELEME 26 : -INC SMCHPOI 27 : -INC SMLCHPO 28 : -INC SMLMOTS 29 : -INC TMTRAV 30 : 31 : SEGMENT VECT 32 : REAL*8 VEC1(IDIM) 33 : REAL*8 VEC2(IDIM) 34 : REAL*8 VECN(IDIM) 35 : ENDSEGMENT 36 : SEGINI VECT 37 : * 38 : SEGMENT ICPR(NBNOE,NCHAM) 39 : SEGMENT NKON(IKOUR) 40 : SEGMENT NUIN(IKOUR) 41 : * 42 : SEGMENT ICARAC 43 : REAL*8 XEPAI(NCHAM) 44 : REAL*8 XEXCE(NCHAM) 45 : ENDSEGMENT 46 : SEGMENT NCARAC(NCHAM) 47 : 48 : 49 : * 50 : MMODEL=IPMODE 51 : SEGACT,MMODEL 52 : NMOD=KMODEL(/1) 53 : * 54 : MCHELM=IPCHE 55 : SEGACT,MCHELM 56 : NCHAM=ICHAML(/1) 57 : * 58 : NBNOE = XCOOR(/1)/(IDIM+1) 59 : SEGINI ICPR 60 : SEGINI ICARAC 61 : SEGINI NCARAC 62 : * 63 : DO 10, I = 1, NCHAM 64 : ICARAC.XEPAI(I)= 0. 65 : ICARAC.XEXCE(I)= 0. 66 : DO 10, J=1, NBNOE 67 : ICPR(J,I)=0 68 : CONTINUE 69 : 10 CONTINUE 70 : NBCAR = 0 71 : * 72 : * Création du maillage principal 73 : * 74 : NBSOUS = 0 75 : NBREF = 0 76 : NBELEM = 0 77 : NBNN = 0 78 : SEGINI IPT2 79 : IKOUR=0 80 : c listmots des phases 81 : ilphmo = -1 82 : jgn = 8 83 : jgm = nmod 84 : segini mlmots 85 : ilphmo = mlmots 86 : jgm = 1 87 : * 88 : * Boucle sur l'ensemble des sous zones du modeles 89 : * 90 : DO 30, NUMO = 1, NMOD 91 : * 92 : IMODEL = KMODEL(NUMO) 93 : SEGACT,IMODEL 94 : * 95 : * Test si le modele est une coque 96 : * 97 : NUFOR = NUMMFR(NEFMOD) 98 : IF (NUFOR.EQ.3 .OR. NUFOR.EQ.5 .OR. NUFOR.EQ.9)THEN 99 : * 100 : * Recherche du chamemlem de caracteristique assossiée 101 : * 102 : NUCHA = 0 103 : DO 15, NUCH = 1, NCHAM 104 : * 105 : IF ( CONCHE(NUCH).EQ.CONMOD.AND. 106 : C IMACHE(NUCH).EQ.IMAMOD) NUCHA = NUCH 107 : * 108 : 15 CONTINUE 109 : * 110 : IF (NUCHA.NE.0) THEN 111 : MCHAML=ICHAML(NUCHA) 112 : SEGACT,MCHAML 113 : * 114 : XEXCE1 = 0. 115 : XEPAI1 = 0. 116 : NCOMP = IELVAL(/1) 117 : DO 20, I = 1, NCOMP 118 : IF (NOMCHE(I)(1:4).EQ.'EPAI') THEN 119 : MELVAL = IELVAL(I) 120 : SEGACT, MELVAL 121 : XEPAI1 = VELCHE(1,1) 122 : SEGDES, MELVAL 123 : ELSEIF (NOMCHE(I)(1:4).EQ.'EXCE') THEN 124 : MELVAL = IELVAL(I) 125 : SEGACT, MELVAL 126 : XEXCE1 = VELCHE(1,1) 127 : SEGDES, MELVAL 128 : ENDIF 129 : 20 CONTINUE 130 : SEGDES,MCHAML 131 : * 132 : * recherche du numero de caracteristique associe 133 : * a l'epaisseur et l'excentricitee 134 : * 135 : NUCAR = 0 136 : DO 22, I = 1, NBCAR 137 : IF (ICARAC.XEPAI(I).EQ.XEPAI1.AND. 138 : C ICARAC.XEXCE(I).EQ.XEXCE1) NUCAR = I 139 : 22 CONTINUE 140 : * 141 : IF (NUCAR.EQ.0) THEN 142 : NUCAR = NBCAR+1 143 : ICARAC.XEPAI(NUCAR)=XEPAI1 144 : ICARAC.XEXCE(NUCAR)=XEXCE1 145 : NBCAR = NUCAR 146 : ENDIF 147 : NCARAC(NUCHA)=NUCAR 148 : * 149 : MELEME = IMAMOD 150 : SEGACT MELEME 151 : * 152 : * recherche du nombre de noeuds 153 : * 154 : DO 25 I=1, NUM(/1) 155 : DO 25 J=1, NUM(/2) 156 : ITH= NUM(I,J) 157 : IF (ICPR(ITH,NUCAR).EQ.0) THEN 158 : IKOUR=IKOUR+1 159 : ICPR(ITH,NUCAR)=IKOUR 160 : ENDIF 161 : 25 CONTINUE 162 : 163 : ENDIF 164 : ENDIF 165 : * 166 : if (numo.eq.1) then 167 : mots(1) = conmod(17:24) 168 : else 169 : do ipl = 1,jgm 170 : if (mots(ipl).eq.conmod(17:24)) goto 27 171 : enddo 172 : jgm = jgm + 1 173 : mots(jgm) = conmod(17:24) 174 : 27 continue 175 : endif 176 : C 177 : 30 CONTINUE 178 : * 179 : segadj mlmots 180 : * Augmentation du tableau de coordonnées 181 : * 182 : NBPTS = NBNOE+3*IKOUR 183 : SEGADJ MCOORD 184 : * 185 : NNNO = IKOUR 186 : SEGINI NKON 187 : SEGINI NUIN 188 : * 189 : DO 40, I = 1, NNNO 190 : NKON(I)=0 191 : DO 40, K = 1, IDIM 192 : XCOOR((NBNOE+I-1)*(IDIM+1)+K) = 0. 193 : XCOOR((NBNOE+I-1+IKOUR)*(IDIM+1)+K) = 0. 194 : XCOOR((NBNOE+I-1+2*IKOUR)*(IDIM+1)+K) = 0. 195 : 40 CONTINUE 196 : * 197 : * Boucle sur l'ensemble des sous zones du modeles 198 : * 199 : DO 100, NUMO = 1, NMOD 200 : IMODEL = KMODEL(NUMO) 201 : * 202 : * Test si le modele est une coque 203 : * 204 : NUFOR = NUMMFR(NEFMOD) 205 : IF (NUFOR.EQ.3 .OR. NUFOR.EQ.5 .OR. NUFOR.EQ.9) THEN 206 : * 207 : * Recherche du chamemlem de caracteristique assossiée 208 : * 209 : NUCHA = 0 210 : DO 50, NUCH = 1, NCHAM 211 : * 212 : IF ( CONCHE(NUCH).EQ.CONMOD.AND. 213 : C IMACHE(NUCH).EQ.IMAMOD) NUCHA = NUCH 214 : * 215 : 50 CONTINUE 216 : * 217 : IF (NUCHA.NE.0) THEN 218 : * 219 : NUCAR = NCARAC(NUCHA) 220 : MELEME = IMAMOD 221 : * 222 : * création du nouveau maillage 223 : * 224 : NBSOUS = 0 225 : NBREF = 0 226 : NBELE1 = NUM(/2) 227 : NBELEM = 3* NBELE1 228 : NBNN = NUM(/1) 229 : 230 : SEGINI IPT1 231 : IPT1.ITYPEL = ITYPEL 232 : * 233 : DO 95 J=1, NBELE1 234 : IPT1.ICOLOR(J) = ICOLOR(J) 235 : IPT1.ICOLOR(J+NBELE1) = ICOLOR(J) 236 : IPT1.ICOLOR(J+2*NBELE1) = ICOLOR(J) 237 : * 238 : * Recherche d'une normale a l'element courant 239 : * 240 : XNORM = 0. 241 : DO 55, K = 1, IDIM 242 : VECN(K) = 0. 243 : 55 CONTINUE 244 : IF (IDIM.EQ.2) THEN 245 : ICO1 = NUM(NBNN,J) 246 : ICO2 = NUM(1,J) 247 : DO 57, K = 1, IDIM 248 : VEC1(K) = XCOOR((ICO1-1)*(IDIM+1)+K)- 249 : C XCOOR((ICO2-1)*(IDIM+1)+K) 250 : K1 = K+1 251 : IF (K1.GT.IDIM) K1 = 1 252 : VECN(K) = VEC1(K1)*(-1)**K 253 : XNORM = XNORM +VECN(K)*VECN(K) 254 : 57 CONTINUE 255 : ENDIF 256 : IF (IDIM.EQ.3) THEN 257 : ICO1 = NUM(NBNN-1,J) 258 : ICO2 = NUM(NBNN,J) 259 : * 260 : DO 65 I=1, NBNN 261 : ICO3 = NUM(I,J) 262 : DO 60, K = 1, IDIM 263 : VEC1(K) = XCOOR((ICO1-1)*(IDIM+1)+K)- 264 : C XCOOR((ICO2-1)*(IDIM+1)+K) 265 : VEC2(K) = XCOOR((ICO2-1)*(IDIM+1)+K)- 266 : C XCOOR((ICO3-1)*(IDIM+1)+K) 267 : 60 CONTINUE 268 : * 269 : ICO1 = ICO2 270 : ICO2 = ICO3 271 : DO 65, K = 1, IDIM 272 : K1 = K+1 273 : K2 = K+2 274 : IF (K1.GT.IDIM) K1 = K1 - IDIM 275 : IF (K2.GT.IDIM) K2 = K2 - IDIM 276 : VECN(K) = VEC1(K1)*VEC2(K2) -VEC2(K1)*VEC1(K2) 277 : C + VECN(K) 278 : IF (I.EQ.NBNN) XNORM = XNORM + VECN(K)*VECN(K) 279 : 65 CONTINUE 280 : ENDIF 281 : XNORM = SQRT(XNORM) 282 : * 283 : DO 70, K = 1, IDIM 284 : VECN(K) = VECN(K)/XNORM 285 : 70 CONTINUE 286 : 287 : DO 95 I=1, NBNN 288 : * 289 : ICOU = NUM(I,J) 290 : IKOUR = ICPR(ICOU,NUCAR) 291 : NKON(IKOUR) = NKON(IKOUR)+1 292 : NUIN(IKOUR) = ICOU 293 : IPT1.NUM(I,J)= NBNOE+IKOUR 294 : IPT1.NUM(I,J+NBELE1)= NBNOE+IKOUR+NNNO 295 : IPT1.NUM(I,J+2*NBELE1)= NBNOE+IKOUR+2*NNNO 296 : * 297 : * Calcul des coordonées des nouveaux points 298 : * 299 : DO 90, K = 1, IDIM 300 : XCOOR((IPT1.NUM(I,J)-1)*(IDIM+1)+K) = 301 : C XCOOR((IPT1.NUM(I,J)-1)*(IDIM+1)+K) + 302 : C VECN(K)*ICARAC.XEXCE(NUCAR) 303 : XCOOR((IPT1.NUM(I,J)+NNNO-1)*(IDIM+1)+K) = 304 : C XCOOR((IPT1.NUM(I,J)+NNNO-1)*(IDIM+1)+K) + 305 : C VECN(K)*(ICARAC.XEXCE(NUCAR)+ICARAC.XEPAI(NUCAR)/2) 306 : XCOOR((IPT1.NUM(I,J)+2*NNNO-1)*(IDIM+1)+K) = 307 : C XCOOR((IPT1.NUM(I,J)+2*NNNO-1)*(IDIM+1)+K) + 308 : C VECN(K)*(ICARAC.XEXCE(NUCAR)-ICARAC.XEPAI(NUCAR)/2) 309 : 310 : 90 CONTINUE 311 : 312 : 95 CONTINUE 313 : * 314 : * Ajustement du pointeur maillage principal 315 : * 316 : NBSOUS = IPT2.LISOUS(/1)+1 317 : NBNN = 0 318 : NBREF = 0 319 : NBELEM = 0 320 : SEGADJ IPT2 321 : IPT2.LISOUS(NBSOUS) = IPT1 322 : SEGDES IPT1 323 : ENDIF 324 : ENDIF 325 : * 326 : 100 CONTINUE 327 : * 328 : DO 110 I=1, NNNO 329 : DO 110, K=1, IDIM 330 : XCOOR((NBNOE+I-1)*(IDIM+1)+K) = 331 : C XCOOR((NBNOE+I-1)*(IDIM+1)+K)/NKON(I) + 332 : C XCOOR((NUIN(I)-1)*(IDIM+1)+K) 333 : XCOOR((NBNOE+I+NNNO-1)*(IDIM+1)+K) = 334 : C XCOOR((NBNOE+I+NNNO-1)*(IDIM+1)+K)/NKON(I) + 335 : C XCOOR((NUIN(I)-1)*(IDIM+1)+K) 336 : XCOOR((NBNOE+I+2*NNNO-1)*(IDIM+1)+K) = 337 : C XCOOR((NBNOE+I+2*NNNO-1)*(IDIM+1)+K)/NKON(I) + 338 : C XCOOR((NUIN(I)-1)*(IDIM+1)+K) 339 : 110 CONTINUE 340 : * 341 : SEGSUP ICARAC 342 : SEGSUP NKON 343 : SEGSUP NUIN 344 : SEGSUP VECT 345 : 346 : NMAILL = IPT2.LISOUS(/1) 347 : IF (NMAILL.GE.1) THEN 348 : IF (NMAILL.EQ.1) THEN 349 : IPT3 = IPT2.LISOUS(1) 350 : SEGSUP IPT2 351 : IPT2 = IPT3 352 : ENDIF 353 : * 354 : * appel a PRO2 pour projeter les temperature sur le maillage 355 : * cree. 356 : isort= 1 357 : * 357 : CALL PRO2(IPT2,IPCHT,isort,IPOUT,ilphmo) 358 : if (ierr.ne.0) return 359 : * 360 : * Recopie des valeurs du champoint dans un Chamelem image 361 : * de la geometrie initiale de la coque 362 : * 363 : mlchpo = ipout 364 : segact mlchpo 365 : * kich : pour la projection du champ de temperature on n attend qu une phase 365 : if (ichpoi(/1).ne.1) call erreur(5) 366 : MCHPOI = ICHPOI(1) 367 : SEGACT MCHPOI 368 : * 369 : * Creation du Chamelem 370 : * 371 : N1 = NMAILL 372 : N3 = 6 373 : L1 = 12 374 : SEGINI MCHEL1 375 : MCHEL1.TITCHE='SCALAIRE' 376 : MCHEL1.IFOCHE=IFOUR 377 : NUCHAM = 0 378 : * 379 : * Boucle sur l'ensemble des sous zones du modeles 380 : * 381 : DO 200, NUMO = 1, NMOD 382 : * 383 : IMODEL = KMODEL(NUMO) 384 : SEGACT IMODEL 385 : * 386 : * Test si le modele est une coque 387 : * 388 : NUFOR = NUMMFR(NEFMOD) 389 : IF (NUFOR.EQ.3 .OR. NUFOR.EQ.5 .OR. NUFOR.EQ.9) THEN 390 : * 391 : * Recherche du chamemlem de caracteristique assossiée 392 : * 393 : NUCHA = 0 394 : DO 120, NUCH = 1, NCHAM 395 : * 396 : IF ( CONCHE(NUCH).EQ.CONMOD.AND. 397 : C IMACHE(NUCH).EQ.IMAMOD) NUCHA = NUCH 398 : * 399 : 120 CONTINUE 400 : * 401 : IF (NUCHA.NE.0) THEN 402 : * 403 : NUCAR = NCARAC(NUCHA) 404 : MELEME = IMAMOD 405 : SEGACT MELEME 406 : * 407 : * création du nouveau segment MCHAML 408 : * 409 : N2 = 3 410 : SEGINI MCHAML 411 : NUCHAM = NUCHAM+1 412 : MCHEL1.IMACHE(NUCHAM)=MELEME 413 : MCHEL1.ICHAML(NUCHAM)=MCHAML 414 : MCHEL1.CONCHE(NUCHAM)=CONMOD 415 : MCHEL1.INFCHE(NUCHAM,1)=0 416 : MCHEL1.INFCHE(NUCHAM,2)=0 417 : MCHEL1.INFCHE(NUCHAM,3)=0 418 : MCHEL1.INFCHE(NUCHAM,4)=0 419 : MCHEL1.INFCHE(NUCHAM,5)=0 420 : MCHEL1.INFCHE(NUCHAM,6)=1 421 : * 422 : N1PTEL = NUM(/1) 423 : N1EL = NUM(/2) 424 : N2PTEL = 0 425 : N2EL = 0 426 : * 427 : DO 170, IPOS = 1, N2 428 : * 429 : SEGINI MELVAL 430 : IF (IPOS.EQ.1) THEN 431 : NOMCHE(IPOS) = 'T ' 432 : IMUL = 0 433 : ELSEIF (IPOS.EQ.2) THEN 434 : NOMCHE(IPOS) = 'TSUP' 435 : IMUL = 1 436 : ELSEIF (IPOS.EQ.3) THEN 437 : NOMCHE(IPOS) = 'TINF' 438 : IMUL = 2 439 : ENDIF 440 : IELVAL(IPOS) = MELVAL 441 : TYPCHE(IPOS) = 'REAL*8' 442 : * 443 : DO 160 NUEL=1, N1EL 444 : * 445 : DO 160 NUPT=1, N1PTEL 446 : * 447 : ICO3 = NUM(NUPT,NUEL) 448 : IKOUR = ICPR(ICO3,NUCAR) 449 : * 450 : * 451 : * Boucle sur les sous-zones du champoint 452 : * 453 : DO 150, I = 1, IPCHP(/1) 454 : * 455 : MSOUPO = IPCHP(I) 456 : SEGACT MSOUPO 457 : MPOVAL = IPOVAL 458 : SEGACT MPOVAL 459 : IPT1 = IGEOC 460 : SEGACT IPT1 461 : * 462 : * Boucle sur les composantes du champoint 463 : * 464 : DO 140, J = 1, NOCOMP(/1) 465 : * 466 : IF (NOCOMP(J).EQ.'T ') THEN 467 : * 468 : * Boucle sur les points 469 : * 470 : DO 130, K = 1, IPT1.NUM(/2) 471 : * 472 : * Comparaison des numeros de points 473 : * entre le champoint et la geometrie creee 474 : * 475 : IF (IPT1.NUM(1,K).EQ.IKOUR+NBNOE+IMUL*NNNO) 476 : C THEN 477 : VELCHE(NUPT,NUEL) = VPOCHA(K,J) 478 : GOTO 160 479 : ENDIF 480 : * 481 : 130 CONTINUE 482 : ENDIF 483 : 140 CONTINUE 484 : 150 CONTINUE 485 : 160 CONTINUE 486 : SEGDES MELVAL 487 : 170 CONTINUE 488 : SEGDES MELEME 489 : SEGDES MCHAML 490 : ENDIF 491 : ENDIF 492 : SEGDES IMODEL 493 : * 494 : 200 CONTINUE 495 : * 496 : * Suppression du champoint 497 : * 498 : DO 220, I = 1, IPCHP(/1) 499 : * 500 : MSOUPO = IPCHP(I) 501 : MPOVAL = IPOVAL 502 : IPT1 = IGEOC 503 : ***** SEGSUP IPT1 504 : SEGSUP MPOVAL 505 : SEGSUP MSOUPO 506 : * 507 : 220 CONTINUE 508 : SEGSUP MCHPOI 509 : * 510 : * Suppression du maillage intermediaire 511 : * 512 : SEGACT IPT2 513 : * 514 : DO 240, IOB =1, IPT2.LISOUS(/1) 515 : * 516 : IPT1 = IPT2.LISOUS(IOB) 517 : SEGSUP IPT1 518 : * 519 : 240 CONTINUE 520 : ***** SEGSUP IPT2 521 : 522 : * 523 : * Reajustement du tableau de coordonées 524 : * 525 : NBPTS = NBNOE 526 : SEGADJ MCOORD 527 : * 528 : * ECRITURE DU CHAMPS DE SORTIE 529 : * 529 : C CALL ECROBJ('MCHAML',MCHEL1) 530 : ITPR= MCHEL1 531 : SEGDES MCHEL1 532 : * 533 : ELSE 533 : CALL ERREUR(704) 534 : ENDIF 535 : * 536 : SEGSUP ICPR 537 : SEGSUP NCARAC 538 : END 539 : 540 : 541 : 542 : 543 : 544 : 545 : 546 : 547 : 548 : 549 : 550 : 551 : 552 : 553 :
© Cast3M 2003 - All rights reserved.
Disclaimer