Télécharger prot.eso

Retour à la liste

Numérotation des lignes :

  1. C PROT SOURCE CB215821 19/07/31 21:16:53 10277
  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. ELSEIF (NOMCHE(I)(1:4).EQ.'EXCE') THEN
  123. MELVAL = IELVAL(I)
  124. SEGACT, MELVAL
  125. XEXCE1 = VELCHE(1,1)
  126. ENDIF
  127. 20 CONTINUE
  128. *
  129. * recherche du numero de caracteristique associe
  130. * a l'epaisseur et l'excentricitee
  131. *
  132. NUCAR = 0
  133. DO 22, I = 1, NBCAR
  134. IF (ICARAC.XEPAI(I).EQ.XEPAI1.AND.
  135. C ICARAC.XEXCE(I).EQ.XEXCE1) NUCAR = I
  136. 22 CONTINUE
  137. *
  138. IF (NUCAR.EQ.0) THEN
  139. NUCAR = NBCAR+1
  140. ICARAC.XEPAI(NUCAR)=XEPAI1
  141. ICARAC.XEXCE(NUCAR)=XEXCE1
  142. NBCAR = NUCAR
  143. ENDIF
  144. NCARAC(NUCHA)=NUCAR
  145. *
  146. MELEME = IMAMOD
  147. SEGACT MELEME
  148. *
  149. * recherche du nombre de noeuds
  150. *
  151. DO 25 I=1, NUM(/1)
  152. DO 25 J=1, NUM(/2)
  153. ITH= NUM(I,J)
  154. IF (ICPR(ITH,NUCAR).EQ.0) THEN
  155. IKOUR=IKOUR+1
  156. ICPR(ITH,NUCAR)=IKOUR
  157. ENDIF
  158. 25 CONTINUE
  159.  
  160. ENDIF
  161. ENDIF
  162. *
  163. if (numo.eq.1) then
  164. mots(1) = conmod(17:24)
  165. else
  166. do ipl = 1,jgm
  167. if (mots(ipl).eq.conmod(17:24)) goto 27
  168. enddo
  169. jgm = jgm + 1
  170. mots(jgm) = conmod(17:24)
  171. 27 continue
  172. endif
  173. C
  174. 30 CONTINUE
  175. *
  176. segadj mlmots
  177. * Augmentation du tableau de coordonnées
  178. *
  179. NBPTS = NBNOE+3*IKOUR
  180. SEGADJ MCOORD
  181. *
  182. NNNO = IKOUR
  183. SEGINI NKON
  184. SEGINI NUIN
  185. *
  186. DO 40, I = 1, NNNO
  187. NKON(I)=0
  188. DO 40, K = 1, IDIM
  189. XCOOR((NBNOE+I-1)*(IDIM+1)+K) = 0.
  190. XCOOR((NBNOE+I-1+IKOUR)*(IDIM+1)+K) = 0.
  191. XCOOR((NBNOE+I-1+2*IKOUR)*(IDIM+1)+K) = 0.
  192. 40 CONTINUE
  193. *
  194. * Boucle sur l'ensemble des sous zones du modeles
  195. *
  196. DO 100, NUMO = 1, NMOD
  197. IMODEL = KMODEL(NUMO)
  198. *
  199. * Test si le modele est une coque
  200. *
  201. NUFOR = NUMMFR(NEFMOD)
  202. IF (NUFOR.EQ.3 .OR. NUFOR.EQ.5 .OR. NUFOR.EQ.9) THEN
  203. *
  204. * Recherche du chamemlem de caracteristique assossiée
  205. *
  206. NUCHA = 0
  207. DO 50, NUCH = 1, NCHAM
  208. *
  209. IF ( CONCHE(NUCH).EQ.CONMOD.AND.
  210. C IMACHE(NUCH).EQ.IMAMOD) NUCHA = NUCH
  211. *
  212. 50 CONTINUE
  213. *
  214. IF (NUCHA.NE.0) THEN
  215. *
  216. NUCAR = NCARAC(NUCHA)
  217. MELEME = IMAMOD
  218. *
  219. * création du nouveau maillage
  220. *
  221. NBSOUS = 0
  222. NBREF = 0
  223. NBELE1 = NUM(/2)
  224. NBELEM = 3* NBELE1
  225. NBNN = NUM(/1)
  226.  
  227. SEGINI IPT1
  228. IPT1.ITYPEL = ITYPEL
  229. *
  230. DO 95 J=1, NBELE1
  231. IPT1.ICOLOR(J) = ICOLOR(J)
  232. IPT1.ICOLOR(J+NBELE1) = ICOLOR(J)
  233. IPT1.ICOLOR(J+2*NBELE1) = ICOLOR(J)
  234. *
  235. * Recherche d'une normale a l'element courant
  236. *
  237. XNORM = 0.
  238. DO 55, K = 1, IDIM
  239. VECN(K) = 0.
  240. 55 CONTINUE
  241. IF (IDIM.EQ.2) THEN
  242. ICO1 = NUM(NBNN,J)
  243. ICO2 = NUM(1,J)
  244. DO 57, K = 1, IDIM
  245. VEC1(K) = XCOOR((ICO1-1)*(IDIM+1)+K)-
  246. C XCOOR((ICO2-1)*(IDIM+1)+K)
  247. K1 = K+1
  248. IF (K1.GT.IDIM) K1 = 1
  249. VECN(K) = VEC1(K1)*(-1)**K
  250. XNORM = XNORM +VECN(K)*VECN(K)
  251. 57 CONTINUE
  252. ENDIF
  253. IF (IDIM.EQ.3) THEN
  254. ICO1 = NUM(NBNN-1,J)
  255. ICO2 = NUM(NBNN,J)
  256. *
  257. DO 65 I=1, NBNN
  258. ICO3 = NUM(I,J)
  259. DO 60, K = 1, IDIM
  260. VEC1(K) = XCOOR((ICO1-1)*(IDIM+1)+K)-
  261. C XCOOR((ICO2-1)*(IDIM+1)+K)
  262. VEC2(K) = XCOOR((ICO2-1)*(IDIM+1)+K)-
  263. C XCOOR((ICO3-1)*(IDIM+1)+K)
  264. 60 CONTINUE
  265. *
  266. ICO1 = ICO2
  267. ICO2 = ICO3
  268. DO 65, K = 1, IDIM
  269. K1 = K+1
  270. K2 = K+2
  271. IF (K1.GT.IDIM) K1 = K1 - IDIM
  272. IF (K2.GT.IDIM) K2 = K2 - IDIM
  273. VECN(K) = VEC1(K1)*VEC2(K2) -VEC2(K1)*VEC1(K2)
  274. C + VECN(K)
  275. IF (I.EQ.NBNN) XNORM = XNORM + VECN(K)*VECN(K)
  276. 65 CONTINUE
  277. ENDIF
  278. XNORM = SQRT(XNORM)
  279. *
  280. DO 70, K = 1, IDIM
  281. VECN(K) = VECN(K)/XNORM
  282. 70 CONTINUE
  283.  
  284. DO 95 I=1, NBNN
  285. *
  286. ICOU = NUM(I,J)
  287. IKOUR = ICPR(ICOU,NUCAR)
  288. NKON(IKOUR) = NKON(IKOUR)+1
  289. NUIN(IKOUR) = ICOU
  290. IPT1.NUM(I,J)= NBNOE+IKOUR
  291. IPT1.NUM(I,J+NBELE1)= NBNOE+IKOUR+NNNO
  292. IPT1.NUM(I,J+2*NBELE1)= NBNOE+IKOUR+2*NNNO
  293. *
  294. * Calcul des coordonées des nouveaux points
  295. *
  296. DO 90, K = 1, IDIM
  297. XCOOR((IPT1.NUM(I,J)-1)*(IDIM+1)+K) =
  298. C XCOOR((IPT1.NUM(I,J)-1)*(IDIM+1)+K) +
  299. C VECN(K)*ICARAC.XEXCE(NUCAR)
  300. XCOOR((IPT1.NUM(I,J)+NNNO-1)*(IDIM+1)+K) =
  301. C XCOOR((IPT1.NUM(I,J)+NNNO-1)*(IDIM+1)+K) +
  302. C VECN(K)*(ICARAC.XEXCE(NUCAR)+ICARAC.XEPAI(NUCAR)/2)
  303. XCOOR((IPT1.NUM(I,J)+2*NNNO-1)*(IDIM+1)+K) =
  304. C XCOOR((IPT1.NUM(I,J)+2*NNNO-1)*(IDIM+1)+K) +
  305. C VECN(K)*(ICARAC.XEXCE(NUCAR)-ICARAC.XEPAI(NUCAR)/2)
  306.  
  307. 90 CONTINUE
  308.  
  309. 95 CONTINUE
  310. *
  311. * Ajustement du pointeur maillage principal
  312. *
  313. NBSOUS = IPT2.LISOUS(/1)+1
  314. NBNN = 0
  315. NBREF = 0
  316. NBELEM = 0
  317. SEGADJ IPT2
  318. IPT2.LISOUS(NBSOUS) = IPT1
  319. ENDIF
  320. ENDIF
  321. *
  322. 100 CONTINUE
  323. *
  324. DO 110 I=1, NNNO
  325. DO 110, K=1, IDIM
  326. XCOOR((NBNOE+I-1)*(IDIM+1)+K) =
  327. C XCOOR((NBNOE+I-1)*(IDIM+1)+K)/NKON(I) +
  328. C XCOOR((NUIN(I)-1)*(IDIM+1)+K)
  329. XCOOR((NBNOE+I+NNNO-1)*(IDIM+1)+K) =
  330. C XCOOR((NBNOE+I+NNNO-1)*(IDIM+1)+K)/NKON(I) +
  331. C XCOOR((NUIN(I)-1)*(IDIM+1)+K)
  332. XCOOR((NBNOE+I+2*NNNO-1)*(IDIM+1)+K) =
  333. C XCOOR((NBNOE+I+2*NNNO-1)*(IDIM+1)+K)/NKON(I) +
  334. C XCOOR((NUIN(I)-1)*(IDIM+1)+K)
  335. 110 CONTINUE
  336. *
  337. SEGSUP ICARAC
  338. SEGSUP NKON
  339. SEGSUP NUIN
  340. SEGSUP VECT
  341.  
  342. NMAILL = IPT2.LISOUS(/1)
  343. IF (NMAILL.GE.1) THEN
  344. IF (NMAILL.EQ.1) THEN
  345. IPT3 = IPT2.LISOUS(1)
  346. SEGSUP IPT2
  347. IPT2 = IPT3
  348. ENDIF
  349. *
  350. * appel a PRO2 pour projeter les temperature sur le maillage
  351. * cree.
  352. isort= 1
  353. *
  354. CALL PRO2(IPT2,IPCHT,isort,IPOUT,ilphmo)
  355. if (ierr.ne.0) return
  356. *
  357. * Recopie des valeurs du champoint dans un Chamelem image
  358. * de la geometrie initiale de la coque
  359. *
  360. mlchpo = ipout
  361. segact mlchpo
  362. * kich : pour la projection du champ de temperature on n attend qu une phase
  363. if (ichpoi(/1).ne.1) call erreur(5)
  364. MCHPOI = ICHPOI(1)
  365. SEGACT MCHPOI
  366. *
  367. * Creation du Chamelem
  368. *
  369. N1 = NMAILL
  370. N3 = 6
  371. L1 = 12
  372. SEGINI MCHEL1
  373. MCHEL1.TITCHE='SCALAIRE'
  374. MCHEL1.IFOCHE=IFOUR
  375. NUCHAM = 0
  376. *
  377. * Boucle sur l'ensemble des sous zones du modeles
  378. *
  379. DO 200, NUMO = 1, NMOD
  380. *
  381. IMODEL = KMODEL(NUMO)
  382. SEGACT IMODEL
  383. *
  384. * Test si le modele est une coque
  385. *
  386. NUFOR = NUMMFR(NEFMOD)
  387. IF (NUFOR.EQ.3 .OR. NUFOR.EQ.5 .OR. NUFOR.EQ.9) THEN
  388. *
  389. * Recherche du chamemlem de caracteristique assossiée
  390. *
  391. NUCHA = 0
  392. DO 120, NUCH = 1, NCHAM
  393. *
  394. IF ( CONCHE(NUCH).EQ.CONMOD.AND.
  395. C IMACHE(NUCH).EQ.IMAMOD) NUCHA = NUCH
  396. *
  397. 120 CONTINUE
  398. *
  399. IF (NUCHA.NE.0) THEN
  400. *
  401. NUCAR = NCARAC(NUCHA)
  402. MELEME = IMAMOD
  403. SEGACT MELEME
  404. *
  405. * création du nouveau segment MCHAML
  406. *
  407. N2 = 3
  408. SEGINI MCHAML
  409. NUCHAM = NUCHAM+1
  410. MCHEL1.IMACHE(NUCHAM)=MELEME
  411. MCHEL1.ICHAML(NUCHAM)=MCHAML
  412. MCHEL1.CONCHE(NUCHAM)=CONMOD
  413. MCHEL1.INFCHE(NUCHAM,1)=0
  414. MCHEL1.INFCHE(NUCHAM,2)=0
  415. MCHEL1.INFCHE(NUCHAM,3)=0
  416. MCHEL1.INFCHE(NUCHAM,4)=0
  417. MCHEL1.INFCHE(NUCHAM,5)=0
  418. MCHEL1.INFCHE(NUCHAM,6)=1
  419. *
  420. N1PTEL = NUM(/1)
  421. N1EL = NUM(/2)
  422. N2PTEL = 0
  423. N2EL = 0
  424. *
  425. DO 170, IPOS = 1, N2
  426. *
  427. SEGINI MELVAL
  428. IF (IPOS.EQ.1) THEN
  429. NOMCHE(IPOS) = 'T '
  430. IMUL = 0
  431. ELSEIF (IPOS.EQ.2) THEN
  432. NOMCHE(IPOS) = 'TSUP'
  433. IMUL = 1
  434. ELSEIF (IPOS.EQ.3) THEN
  435. NOMCHE(IPOS) = 'TINF'
  436. IMUL = 2
  437. ENDIF
  438. IELVAL(IPOS) = MELVAL
  439. TYPCHE(IPOS) = 'REAL*8'
  440. *
  441. DO 160 NUEL=1, N1EL
  442. *
  443. DO 160 NUPT=1, N1PTEL
  444. *
  445. ICO3 = NUM(NUPT,NUEL)
  446. IKOUR = ICPR(ICO3,NUCAR)
  447. *
  448. *
  449. * Boucle sur les sous-zones du champoint
  450. *
  451. DO 150, I = 1, IPCHP(/1)
  452. *
  453. MSOUPO = IPCHP(I)
  454. SEGACT MSOUPO
  455. MPOVAL = IPOVAL
  456. SEGACT MPOVAL
  457. IPT1 = IGEOC
  458. SEGACT IPT1
  459. *
  460. * Boucle sur les composantes du champoint
  461. *
  462. DO 140, J = 1, NOCOMP(/1)
  463. *
  464. IF (NOCOMP(J).EQ.'T ') THEN
  465. *
  466. * Boucle sur les points
  467. *
  468. DO 130, K = 1, IPT1.NUM(/2)
  469. *
  470. * Comparaison des numeros de points
  471. * entre le champoint et la geometrie creee
  472. *
  473. IF (IPT1.NUM(1,K).EQ.IKOUR+NBNOE+IMUL*NNNO)
  474. C THEN
  475. VELCHE(NUPT,NUEL) = VPOCHA(K,J)
  476. GOTO 160
  477. ENDIF
  478. *
  479. 130 CONTINUE
  480. ENDIF
  481. 140 CONTINUE
  482. 150 CONTINUE
  483. 160 CONTINUE
  484. 170 CONTINUE
  485. ENDIF
  486. ENDIF
  487. *
  488. 200 CONTINUE
  489. *
  490. * Suppression du champoint
  491. *
  492. DO 220, I = 1, IPCHP(/1)
  493. *
  494. MSOUPO = IPCHP(I)
  495. MPOVAL = IPOVAL
  496. IPT1 = IGEOC
  497. ***** SEGSUP IPT1
  498. SEGSUP MPOVAL
  499. SEGSUP MSOUPO
  500. *
  501. 220 CONTINUE
  502. SEGSUP MCHPOI
  503. *
  504. * Suppression du maillage intermediaire
  505. *
  506. SEGACT IPT2
  507. *
  508. DO 240, IOB =1, IPT2.LISOUS(/1)
  509. *
  510. IPT1 = IPT2.LISOUS(IOB)
  511. SEGSUP IPT1
  512. *
  513. 240 CONTINUE
  514. ***** SEGSUP IPT2
  515.  
  516. *
  517. * Reajustement du tableau de coordonées
  518. *
  519. NBPTS = NBNOE
  520. SEGADJ MCOORD
  521. *
  522. * RESTITUTION DU CHAMP DE SORTIE
  523. *
  524. ITPR= MCHEL1
  525. *
  526. ELSE
  527. CALL ERREUR(704)
  528. ENDIF
  529. *
  530. SEGSUP ICPR
  531. SEGSUP NCARAC
  532. END
  533.  
  534.  
  535.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales