Télécharger facgen.eso

Retour à la liste

Numérotation des lignes :

  1. C FACGEN SOURCE CHAT 06/08/24 21:34:13 5529
  2. SUBROUTINE FACGEN (MYMOD,INFOEL,LRES,XDEC,IAXE,INOR,ICHFAC
  3. & ,EXTINC)
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. C----------------------------------------------------------------------
  7. C 03/96 l'hemicube est defini dans le repere local a la face "1"
  8. C
  9. C Calcul des facteurs de forme OPTION CACHE 3D
  10. C SP APPELE PAR FACFOR
  11. C entree:
  12. C MYMOD : objet modèle
  13. C INFOEL : segment décrivant la nature des éléments des maillages
  14. C LRES : parametre de resolution
  15. C XDEC : parametre de decoupage
  16. C IAXE : pointeur sur le LISTEN contenant les pointeurs des
  17. C points definissant le plan de symetrie
  18. C INOR : parametre de normalisation et impression
  19. C sortie:
  20. C ICHFAC : chamelem facteur de forme
  21. C----------------------------------------------------------------------
  22. -INC CCOPTIO
  23. -INC SMCOORD
  24. POINTEUR MYMOD.MMODEL
  25. -INC TFFOR3D
  26. C--------------------------------------------------------------
  27. C FACTEURS DE FORME
  28. C NNBEL1 = NOMBRE DE LIGNES + 1
  29. C NBEL2 = NOMBRE DE COLONNES
  30. C LFACT(NNBEL1) POINTE SUR LE TABLEAU DES SURFACES
  31. C
  32. SEGMENT IFACFO
  33. INTEGER LFACT(NNBEL1)
  34. ENDSEGMENT
  35. SEGMENT LFAC
  36. REAL*8 FACT(NBEL2)
  37. ENDSEGMENT
  38. POINTEUR PSUR.LFAC, PLIG.LFAC
  39. POINTEUR PCOL.LFAC
  40. C--------------------------------------------------------------
  41. SEGMENT SPROGP
  42. INTEGER MKF(MPT),MICOO(2,MPT)
  43. REAL*8 MXR(3,MPT)
  44. ENDSEGMENT
  45. C--------------------------------------------------------------
  46. SEGMENT SKCEL
  47. INTEGER KBCEL(NR,NR),IINT(2,NSTAC),IS(NSTAC),JS(NSTAC)
  48. REAL*8 RMAX
  49. ENDSEGMENT
  50. C--------------------------------------------------------------
  51. C segment qui va contenir les coordonnées du plan de symétrie
  52. SEGMENT ,LISTEN
  53. INTEGER LECT(NBE)
  54. ENDSEGMENT
  55. POINTEUR IAXE.LISTEN
  56. C--------------------------------------------------------------
  57. C
  58. DIMENSION U1(4),U2(4)
  59. DIMENSION O1(3)
  60. DIMENSION A1(3,3),A2(3,3)
  61. DIMENSION UA(3),UN(3),UU2(4),AA2(3,3)
  62. C** changement de repere
  63. DIMENSION HCM(3,3),OH(3),AH1(3,3),UH1(4)
  64. DIMENSION AH2(3,3),UH2(4),AAH2(3,3),UUH2(4)
  65. C**
  66. C
  67. C--------------------------------------------------------------
  68. C
  69. * Definition du common CKRESO
  70. KFC=6
  71. NRES = LRES
  72. KES = IDIM
  73. KIMP = IIMPI
  74. NSOM=3
  75.  
  76. C
  77. C-----PLAN DE SYMETRIE-----------------------------------------------
  78. IF (IAXE.NE.0) THEN
  79. C A partir des trois points definissant le plan , on va garder
  80. C une normale et le premier point
  81. SEGACT IAXE
  82. IF (IIMPI.GE.1) THEN
  83. WRITE(6,*) ' CALCUL AVEC PLAN DE SYMETRIE '
  84. ENDIF
  85. DO 100 IP= 1,NSOM
  86. C On boucle sur les points
  87. IREF = (IDIM+1)*(IAXE.LECT(IP)-1)
  88. DO 101 IIES= 1,IDIM
  89. C On boucle sur les coordonnées
  90. A1(IIES,IP) = XCOOR(IREF+IIES)
  91. C (boucle : pas de défaut de page pour un tableau 3*3 de réels)
  92. 101 CONTINUE
  93. 100 CONTINUE
  94. SEGDES IAXE
  95. CALL KNORM(IDIM,A1,IDIM,U1,SSS)
  96. DO 102 IIES = 1,IDIM
  97. UA(IIES) = A1(IIES,1)
  98. UN(IIES) = U1(IIES)
  99. 102 CONTINUE
  100. IF(KIMP.GE.2) THEN
  101. WRITE(6,*) ' plan de symetrie '
  102. WRITE(6,*) ' point ',(UA(I),I=1,IDIM)
  103. WRITE(6,*) ' normale ',(UN(I),I=1,IDIM)
  104. ENDIF
  105. ENDIF
  106.  
  107. C-----PLAN DE SYMETRIE-----------------------------------------------
  108.  
  109. EPS = 1D-5
  110. C
  111. C
  112. C>>> PREPARATION
  113. C
  114. CALL KALPRE(MYMOD,INFOEL,SKFACE,XDEC,NELD)
  115. C
  116. C>>> INITIALISATION DES OBJETS DE TRAVAIL
  117. C
  118.  
  119. NBEL1 = NELD
  120. NNBEL1 = NELD+1
  121. NBEL2 = NELD
  122. SEGINI IFACFO
  123.  
  124. DO 900 LS=1,NNBEL1
  125. SEGINI PLIG
  126. LFACT(LS) = PLIG
  127. SEGDES PLIG
  128. 900 CONTINUE
  129.  
  130. PSUR = LFACT(NNBEL1)
  131. SEGACT PSUR*MOD
  132.  
  133. SEGACT SKFACE*MOD
  134. MFACE = NUK(/2)
  135. DO 910 K1 = 1,MFACE
  136. I1 = KCORR(K1)
  137. PSUR.FACT(I1) = PSUR.FACT(I1) + S(K1)
  138. 910 CONTINUE
  139.  
  140. NR=NRES
  141. NES=KES
  142. NFC=KFC
  143. SEGINI SHC3D
  144. IF(KIMP.GE.2) THEN
  145. WRITE(6,*) ' SHC3D ',SHC3D
  146. ENDIF
  147. CALL KCACUB(NES,NR,G,V,NFC,KRO,KSI,IR)
  148. CALL KHCDAT(NR,KA,IM)
  149.  
  150. NSTAC = NR*NR
  151. SEGINI SKCEL
  152.  
  153. NFC = KRO(/1)
  154. NOC = 8
  155. RMAX = 0.9
  156. SEGINI SKBUFF
  157.  
  158. MPT = 3
  159. SEGINI SPROGP
  160.  
  161. NSE = 3
  162. NIMAX = 10*NR
  163. NSCEL = NIMAX
  164. SEGINI SPROJA
  165.  
  166. C CALCUL
  167. C ------
  168.  
  169. CALL KFALIM(MFACE,K1D,K1F)
  170. DO 300 K1 = K1D,K1F
  171.  
  172. I1 = KCORR(K1)
  173. IF (IIMPI.GE.4) WRITE(6,*) 'La facette',K1,
  174. # 'appartient à l élmt',I1
  175. PLIG = LFACT(I1)
  176. SEGACT PLIG*MOD
  177.  
  178. SREL = S(K1)/PSUR.FACT(I1)
  179.  
  180. DO 312 K=1,IDIM+1
  181. U1(K) = U(K,K1)
  182. 312 CONTINUE
  183.  
  184. DO 201 ISS = 1,NSOM
  185. IREF = (IDIM+1)*(NUK(ISS,K1)-1)
  186. DO 202 K = 1,IDIM
  187. A1(K,ISS) = XCOOR(IREF+K)
  188. 202 CONTINUE
  189. 201 CONTINUE
  190.  
  191. C** repere local a l'HC
  192.  
  193. CALL KREPER(IDIM,NSOM,U1,A1,HCM)
  194.  
  195. IPATCH = KPATCH(K1)
  196. SEGACT IPATCH
  197.  
  198. NPATCH = GP(/2)
  199.  
  200. CALL KTYPKS(NPATCH,KS1D,KS1F)
  201. DO 310 KS1 = KS1D,KS1F
  202. IF (IIMPI.GE.4) WRITE(6,*) ' K1 KS1 NPATCH ',K1,KS1,NPATCH
  203.  
  204. DO 311 K=1,IDIM
  205. O1(K) = GP(K,KS1)
  206. 311 CONTINUE
  207. IF (IIMPI.GE.4) WRITE(6,*) K1,
  208. # KS1,' O1 ',(O1(I1),I1=1,IDIM)
  209.  
  210. CALL KINBUF(SKBUFF)
  211. C
  212. C O1 est le point de vue sur la surface 1
  213.  
  214. C coordonnées dans le repere local
  215. OH(1)=0.D0
  216. OH(2)=0.D0
  217. OH(3)=0.D0
  218.  
  219. CALL KCHREP(IDIM,NSOM,O1,A1,U1,AH1,UH1,HCM)
  220.  
  221. CALL KINPRO(UH1,SHC3D,SKBUFF)
  222.  
  223. CALL KVERIF(SHC3D,SKBUFF)
  224.  
  225. C 2eme boucle sur les faces
  226. C -------------------------
  227. C RAPPEL:
  228. C CAS TRAITES KVU = 1 : TRAITEMENT COMMUN
  229. C KVU = 2 ET KSIG..=1 -----------------
  230. C
  231. DO 400 K2 = 1,MFACE
  232.  
  233. IF(KIMP.GE.4) THEN
  234. write(6,*)
  235. write(6,*) ' K1 K2 ',K1,K2
  236. ENDIF
  237. C
  238. DO 412 K=1,IDIM+1
  239. U2(K) = U(K,K2)
  240. 412 CONTINUE
  241.  
  242. DO 211 ISS = 1,NSOM
  243. IREF = (IDIM+1)*(NUK(ISS,K2)-1)
  244. DO 212 K = 1,IDIM
  245. A2(K,ISS) = XCOOR(IREF+K)
  246. 212 CONTINUE
  247. 211 CONTINUE
  248.  
  249. C coordonnées dans le repere local
  250. CALL KCHREP(IDIM,NSOM,O1,A2,U2,AH2,UH2,HCM)
  251.  
  252.  
  253. CNNN------SEQUENCE POUR LA FACE K2---------------------------------
  254. C
  255. C>>> VISIBILITE A PRIORI
  256. C
  257. C** CALL KPRIOR(IDIM,NSOM,NSOM,A1,A2,U1,U2,KVU)
  258. CALL KPRIOR(IDIM,NSOM,NSOM,AH1,AH2,UH1,UH2,KVU)
  259. C
  260. IF (KVU.NE.0) THEN
  261. C** C = U2(IDIM+1)
  262. C = UH2(IDIM+1)
  263. C DO 401 IIES = 1,IDIM
  264. C** C = C + U2(IIES)*O1(IIES)
  265. C inutile C = C + UH2(IIES)*OH(IIES)
  266. C401 CONTINUE
  267.  
  268. IF ((KVU.NE.2).OR.(KSIG(C,EPS).EQ.1)) THEN
  269. C** CALL KPROJF(O1,A2,K1,K2,C,U2,SHC3D,SKCEL,SKBUFF,SPROGA,SPROGP)
  270. CALL KPROJF(OH,AH2,K1,K2,C,UH2,SHC3D,SKCEL,SKBUFF,SPROJA,SPROGP)
  271.  
  272. ENDIF
  273.  
  274. ENDIF
  275.  
  276. CNNN--FIN SEQUENCE POUR LA FACE K2---------------------------------
  277. C
  278. IF (IAXE.NE.0) THEN
  279.  
  280. CNNN------SEQUENCE POUR LA FACE SYMETRIQUE DE K2 ------------------
  281. C LE PLAN SE SYMETRIE EST DEFINI PAR UN POINT UA
  282. C UNE NORMALE UNITAIRE UN
  283. C CALCUL DES SYMETRIQUES DE U2 ET A2(SOMMETS)
  284. C
  285. KES1 = IDIM + 1
  286. CALL KSYM(IDIM,KES1,A2,U2,AA2,UU2,UA,UN)
  287.  
  288. C coordonnées dans le repere local
  289. CALL KCHREP(IDIM,NSOM,O1,AA2,UU2,AAH2,UUH2,HCM)
  290.  
  291. C** CALL KPRIOR(IDIM,NSOM,NSOM,A1,AA2,U1,UU2,KVU)
  292. CALL KPRIOR(IDIM,NSOM,NSOM,AH1,AAH2,UH1,UUH2,KVU)
  293.  
  294. IF (KVU.NE.0) THEN
  295. C** C = UU2(IDIM+1)
  296. C = UUH2(IDIM+1)
  297. CC DO 402 IIES = 1,IDIM
  298. C** C = C + UU2(IIES)*O1(IIES)
  299. C inutile C = C + UUH2(IIES)*OH(IIES)
  300. C402 CONTINUE
  301.  
  302. IF ((KVU.NE.2).OR.(KSIG(C,EPS).EQ.1)) THEN
  303. C** CALL KPROJF(O1,AA2,K1,K2,C,UU2,SHC3D,SKCEL,SKBUFF,SPROJA,SPROGP)
  304. CALL KPROJF(OH,AAH2,K1,K2,C,UUH2
  305. & ,SHC3D,SKCEL,SKBUFF,SPROJA,SPROGP)
  306. ENDIF
  307.  
  308. ENDIF
  309.  
  310. CNNN--FIN SEQUENCE POUR LA FACE SYMETRIQUE DE K2-------------------
  311.  
  312. ENDIF
  313. 400 CONTINUE
  314. C
  315. C>>> RECOMBINAISON
  316. C
  317. SSP1 = SP(KS1)
  318. CALL KRCOMB(K1,SSP1,SHC3D,SKFACE,SKBUFF,EXTINC)
  319.  
  320. IF (K1F.NE.MFACE) THEN
  321. FFFT = 0.D0
  322. DO 420 K2=1,MFACE
  323. FFFT = FFFT + FF1(K2)
  324. 420 CONTINUE
  325. WRITE(6,*) ' '
  326. WRITE(6,*) ' FIJ RELATIF A LA FACE (TRI3) ',K1,' SOMME ',FFFT
  327. CALL UTPRIM(FF1,MFACE)
  328. ENDIF
  329.  
  330. DO 920 K2 = 1,MFACE
  331. I2 = KCORR(K2)
  332. PLIG.FACT(I2) = PLIG.FACT(I2) + FF1(K2)*SREL
  333. 920 CONTINUE
  334.  
  335. 310 CONTINUE
  336.  
  337. SEGDES PLIG
  338. SEGDES IPATCH
  339. 300 CONTINUE
  340. C
  341. C -------------------------------------------------------------
  342. C
  343. SEGDES IFACFO
  344. SEGDES PSUR
  345. C
  346. SEGSUP ,SHC3D,SKCEL,SKBUFF
  347. SEGSUP ,SPROGP,SPROJA
  348. SEGSUP SKFACE
  349. C
  350. IF (K1D.NE.1.AND.K1F.NE.MFACE) CALL ARRET(0)
  351. C
  352. C>>> NORMALISATION ET SYMETRISATION
  353. C ------------------------------
  354.  
  355. IF(EXTINC.GT.1D-3) THEN
  356. INOR=0
  357. ENDIF
  358.  
  359. CALL KFN(IFACFO,INOR,KIMP)
  360.  
  361. IF(KIMP.GE.3) THEN
  362. CALL PRFACF(IFACFO)
  363. ENDIF
  364. C
  365. C
  366. C>>> TRADUCTION
  367. C ----------
  368. LTITR=1
  369. CALL FFMCHA(MYMOD,INFOEL,IFACFO,ICHFAC,LTITR)
  370. C
  371. C Destruction de IFACFO après traduction
  372. SEGACT IFACFO
  373. NNBEL1 = LFACT(/1)
  374. DO 950 NN = 1,NNBEL1
  375. PLIG = LFACT(NN)
  376. SEGSUP PLIG
  377. 950 CONTINUE
  378. SEGSUP IFACFO
  379.  
  380. RETURN
  381. END
  382.  
  383.  
  384.  
  385.  
  386.  

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