Télécharger prot.eso

Retour à la liste

Numérotation des lignes :

  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. *
  358. CALL PRO2(IPT2,IPCHT,isort,IPOUT,ilphmo)
  359. if (ierr.ne.0) return
  360. *
  361. * Recopie des valeurs du champoint dans un Chamelem image
  362. * de la geometrie initiale de la coque
  363. *
  364. mlchpo = ipout
  365. segact mlchpo
  366. * kich : pour la projection du champ de temperature on n attend qu une phase
  367. if (ichpoi(/1).ne.1) call erreur(5)
  368. MCHPOI = ICHPOI(1)
  369. SEGACT MCHPOI
  370. *
  371. * Creation du Chamelem
  372. *
  373. N1 = NMAILL
  374. N3 = 6
  375. L1 = 12
  376. SEGINI MCHEL1
  377. MCHEL1.TITCHE='SCALAIRE'
  378. MCHEL1.IFOCHE=IFOUR
  379. NUCHAM = 0
  380. *
  381. * Boucle sur l'ensemble des sous zones du modeles
  382. *
  383. DO 200, NUMO = 1, NMOD
  384. *
  385. IMODEL = KMODEL(NUMO)
  386. SEGACT IMODEL
  387. *
  388. * Test si le modele est une coque
  389. *
  390. NUFOR = NUMMFR(NEFMOD)
  391. IF (NUFOR.EQ.3 .OR. NUFOR.EQ.5 .OR. NUFOR.EQ.9) THEN
  392. *
  393. * Recherche du chamemlem de caracteristique assossiée
  394. *
  395. NUCHA = 0
  396. DO 120, NUCH = 1, NCHAM
  397. *
  398. IF ( CONCHE(NUCH).EQ.CONMOD.AND.
  399. C IMACHE(NUCH).EQ.IMAMOD) NUCHA = NUCH
  400. *
  401. 120 CONTINUE
  402. *
  403. IF (NUCHA.NE.0) THEN
  404. *
  405. NUCAR = NCARAC(NUCHA)
  406. MELEME = IMAMOD
  407. SEGACT MELEME
  408. *
  409. * création du nouveau segment MCHAML
  410. *
  411. N2 = 3
  412. SEGINI MCHAML
  413. NUCHAM = NUCHAM+1
  414. MCHEL1.IMACHE(NUCHAM)=MELEME
  415. MCHEL1.ICHAML(NUCHAM)=MCHAML
  416. MCHEL1.CONCHE(NUCHAM)=CONMOD
  417. MCHEL1.INFCHE(NUCHAM,1)=0
  418. MCHEL1.INFCHE(NUCHAM,2)=0
  419. MCHEL1.INFCHE(NUCHAM,3)=0
  420. MCHEL1.INFCHE(NUCHAM,4)=0
  421. MCHEL1.INFCHE(NUCHAM,5)=0
  422. MCHEL1.INFCHE(NUCHAM,6)=1
  423. *
  424. N1PTEL = NUM(/1)
  425. N1EL = NUM(/2)
  426. N2PTEL = 0
  427. N2EL = 0
  428. *
  429. DO 170, IPOS = 1, N2
  430. *
  431. SEGINI MELVAL
  432. IF (IPOS.EQ.1) THEN
  433. NOMCHE(IPOS) = 'T '
  434. IMUL = 0
  435. ELSEIF (IPOS.EQ.2) THEN
  436. NOMCHE(IPOS) = 'TSUP'
  437. IMUL = 1
  438. ELSEIF (IPOS.EQ.3) THEN
  439. NOMCHE(IPOS) = 'TINF'
  440. IMUL = 2
  441. ENDIF
  442. IELVAL(IPOS) = MELVAL
  443. TYPCHE(IPOS) = 'REAL*8'
  444. *
  445. DO 160 NUEL=1, N1EL
  446. *
  447. DO 160 NUPT=1, N1PTEL
  448. *
  449. ICO3 = NUM(NUPT,NUEL)
  450. IKOUR = ICPR(ICO3,NUCAR)
  451. *
  452. *
  453. * Boucle sur les sous-zones du champoint
  454. *
  455. DO 150, I = 1, IPCHP(/1)
  456. *
  457. MSOUPO = IPCHP(I)
  458. SEGACT MSOUPO
  459. MPOVAL = IPOVAL
  460. SEGACT MPOVAL
  461. IPT1 = IGEOC
  462. SEGACT IPT1
  463. *
  464. * Boucle sur les composantes du champoint
  465. *
  466. DO 140, J = 1, NOCOMP(/1)
  467. *
  468. IF (NOCOMP(J).EQ.'T ') THEN
  469. *
  470. * Boucle sur les points
  471. *
  472. DO 130, K = 1, IPT1.NUM(/2)
  473. *
  474. * Comparaison des numeros de points
  475. * entre le champoint et la geometrie creee
  476. *
  477. IF (IPT1.NUM(1,K).EQ.IKOUR+NBNOE+IMUL*NNNO)
  478. C THEN
  479. VELCHE(NUPT,NUEL) = VPOCHA(K,J)
  480. GOTO 160
  481. ENDIF
  482. *
  483. 130 CONTINUE
  484. ENDIF
  485. 140 CONTINUE
  486. 150 CONTINUE
  487. 160 CONTINUE
  488. SEGDES MELVAL
  489. 170 CONTINUE
  490. SEGDES MELEME
  491. SEGDES MCHAML
  492. ENDIF
  493. ENDIF
  494. SEGDES IMODEL
  495. *
  496. 200 CONTINUE
  497. *
  498. * Suppression du champoint
  499. *
  500. DO 220, I = 1, IPCHP(/1)
  501. *
  502. MSOUPO = IPCHP(I)
  503. MPOVAL = IPOVAL
  504. IPT1 = IGEOC
  505. ***** SEGSUP IPT1
  506. SEGSUP MPOVAL
  507. SEGSUP MSOUPO
  508. *
  509. 220 CONTINUE
  510. SEGSUP MCHPOI
  511. *
  512. * Suppression du maillage intermediaire
  513. *
  514. SEGACT IPT2
  515. *
  516. DO 240, IOB =1, IPT2.LISOUS(/1)
  517. *
  518. IPT1 = IPT2.LISOUS(IOB)
  519. SEGSUP IPT1
  520. *
  521. 240 CONTINUE
  522. ***** SEGSUP IPT2
  523.  
  524. *
  525. * Reajustement du tableau de coordonées
  526. *
  527. NBPTS = NBNOE
  528. SEGADJ MCOORD
  529. *
  530. * ECRITURE DU CHAMPS DE SORTIE
  531. *
  532. C CALL ECROBJ('MCHAML',MCHEL1)
  533. ITPR= MCHEL1
  534. SEGDES MCHEL1
  535. *
  536. ELSE
  537. CALL ERREUR(704)
  538. ENDIF
  539. *
  540. SEGSUP ICPR
  541. SEGSUP NCARAC
  542. END
  543.  
  544.  
  545.  
  546.  
  547.  
  548.  
  549.  
  550.  
  551.  
  552.  
  553.  
  554.  
  555.  
  556.  
  557.  
  558.  

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