Télécharger faccvx.eso

Retour à la liste

Numérotation des lignes :

  1. C FACCVX SOURCE CHAT 11/03/16 21:21:59 6902
  2. SUBROUTINE FACCVX(MYMOD,INFOEL,NGAUSS,ICHFAC)
  3. C_______________________________________________________________________
  4. C Calcul des facteurs de forme en 2D-plan et 3D pour une geometrie
  5. C convexe
  6. C Pas de coques avec l'option convexe
  7. C Traitement des quadratiques en se ramenant a des elements
  8. C lineaires 'enveloppe'
  9. C_______________________________________________________________________
  10. C Arguments :
  11. C in : MYMOD : objet MMODEL contenant la geometrie
  12. C in : NGAUSS : nombre de points de Gauss en 3D (INTEGER )
  13. C out: ICHFAC : objet MCHAML contenant les facteurs de forme
  14. C_______________________________________________________________________
  15. C
  16. IMPLICIT INTEGER(I-N)
  17. IMPLICIT REAL*8 (A-H,O-Z)
  18. -INC CCOPTIO
  19. -INC SMMODEL
  20. -INC SMELEME
  21. -INC SMCOORD
  22. POINTEUR MYMOD.MMODEL
  23. POINTEUR ISSMA.MELEME , ISSMB.MELEME
  24. C_______________________________________________________________________
  25. C FACTEURS DE FORME
  26. C NNBEL1 = NOMBRE DE LIGNES + 1
  27. C NBEL2 = NOMBRE DE COLONNES
  28. C LFACT(NNBEL1) POINTE SUR LE TABLEAU DES SURFACES
  29. C
  30. SEGMENT IFACFO
  31. INTEGER LFACT(NNBEL1)
  32. ENDSEGMENT
  33. SEGMENT LFAC
  34. REAL*8 FACT(NBEL2)
  35. ENDSEGMENT
  36. POINTEUR PSUR.LFAC, PLIG.LFAC
  37. POINTEUR PCOL.LFAC
  38. C_______________________________________________________________________
  39. SEGMENT,INFOEL
  40. LOGICAL KCOQ(N1), KQUAD(N1)
  41. ENDSEGMENT
  42. C_______________________________________________________________________
  43. C structures nécessaires aux arguments de sous-programmes
  44. SEGMENT PMATG
  45. REAL*8 G(11,10)
  46. ENDSEGMENT
  47. SEGMENT PTRA23
  48. INTEGER NYA(5),NYB(5)
  49. REAL*8 AM(IDIM,5),BM(IDIM,5),UA(IDIM+1),UB(IDIM+1)
  50. ENDSEGMENT
  51. LOGICAL MALEUR
  52. LOGICAL ICOQ
  53. C_______________________________________________________________________
  54. C
  55. KIMP=IIMPI
  56. MALEUR = .FALSE.
  57. EDIS = 0.00001
  58. C... elements quadratiques
  59. NSPA1=1
  60. NSPA2=1
  61.  
  62. IF (INFOEL.EQ.0) THEN
  63. ICOQ= .FALSE.
  64. ELSE
  65. ICOQ= .TRUE.
  66. SEGACT INFOEL
  67. ENDIF
  68.  
  69. SEGACT MYMOD
  70. C
  71. C Calcul du nombre de faces NFACE et activation de maillages
  72. C
  73. SEGACT MYMOD
  74. N1 = MYMOD.KMODEL(/1)
  75. NFACE = 0
  76. DO 10 ITYP=1,N1
  77. IMODEL = MYMOD.KMODEL(ITYP)
  78. SEGACT IMODEL
  79. IPT1 = IMAMOD
  80. SEGACT IPT1
  81. NEL = IPT1.NUM(/2)
  82. NFACE = NFACE + NEL
  83. 10 CONTINUE
  84. C
  85. C>>> INITIALISATION OBJET FACFOR
  86. C ---------------------------
  87. C
  88. NNBEL1=NFACE+1
  89. NBEL2=NFACE
  90. SEGINI IFACFO
  91. DO 900 LS=1,NNBEL1
  92. SEGINI PLIG
  93. LFACT(LS)=PLIG
  94. SEGACT PLIG*MOD
  95. 900 CONTINUE
  96. PSUR = LFACT(NNBEL1)
  97. SEGACT PSUR*MOD
  98.  
  99. C -------------------------------------------------------------
  100. C
  101. IF (IDIM.EQ.3) THEN
  102. SEGINI ,PMATG
  103. CALL MATG(G)
  104. ENDIF
  105. SEGINI ,PTRA23
  106. C
  107. C
  108. NELTA=0
  109. DO NSMA=1,N1
  110. C ----------------------------------------------------------
  111. C On boucle sur les sous-objets MAILLAGE -> NSMA
  112. C
  113. NSPA1=1
  114. IF (ICOQ.AND.KQUAD(NSMA)) NSPA1=2
  115.  
  116. IMODE1 = MYMOD.KMODEL(NSMA)
  117. ISSMA = IMODE1.IMAMOD
  118.  
  119. NSGEO1= ISSMA.NUM(/1)
  120. C** NAM = ISSMA.NUM(/1)
  121. IF (IDIM.EQ.2) THEN
  122. NAM=2
  123. ELSE
  124. NAM=NSGEO1
  125. IF (ICOQ.AND.KQUAD(NSMA)) NAM=NSGEO1/2
  126. ENDIF
  127.  
  128. NNELMA = ISSMA.NUM(/2)
  129. C
  130. DO NELMA=1,NNELMA
  131. C ------------------------------------------------------
  132. KA = NELMA + NELTA
  133. PLIG = LFACT(KA)
  134.  
  135. C On boucle sur les éléments de NSMA -> NELMA
  136. C
  137. C Remplissage du tableau AM
  138. DO I=1, NSGEO1, NSPA1
  139. LS=I
  140. IF (ICOQ.AND.KQUAD(NSMA)) LS=(I+1)/2
  141. C On boucle sur les noeuds de NELMA
  142. IG = ISSMA.NUM(I,NELMA)
  143. C** NYA(I) = IG
  144. NYA(LS) = IG
  145. IREF = (IDIM+1)*(IG-1)
  146. IF(IIMPI.GE.4) WRITE(3,*) ' NELMA I ',NELMA,I
  147. DO K=1,IDIM
  148. C** AM(K,I)=XCOOR(IREF+K)
  149. AM(K,LS)=XCOOR(IREF+K)
  150. ENDDO
  151. IF(IIMPI.GE.4) WRITE(3,*) ' AM ',(AM(K,LS),K=1,IDIM)
  152. ENDDO
  153. C
  154. C
  155. C Calcul de la normale->UA et de la surface->SA
  156. C ( SS ne sert pas )
  157. IF (IDIM.EQ.3) THEN
  158. CALL KNORM(IDIM,AM,NAM,UA,SA)
  159. ELSE
  160. CALL KNORM2(IDIM,AM,NAM,UA,SA)
  161. ENDIF
  162. C
  163. PSUR.FACT(KA) = SA
  164. C
  165. IF (IIMPI.GE.4) THEN
  166. WRITE (6,*) 'SURFACE DE L ELEMENT',NELMA,' : ',SA
  167. WRITE (6,*) 'normale ',(UA(K),K=1,IDIM)
  168. ENDIF
  169. C
  170. NELTB=0
  171. DO NSMB=1,N1
  172. C ----------------------------------------------------
  173. C On boucle sur les sous-objets MAILLAGE -> NSMB
  174.  
  175. NSPA2=1
  176. IF (ICOQ.AND.KQUAD(NSMB)) NSPA2=2
  177.  
  178. IMODE2 = MYMOD.KMODEL(NSMB)
  179. ISSMB = IMODE2.IMAMOD
  180.  
  181. NSGEO2 = ISSMB.NUM(/1)
  182. C** NBM = ISSMB.NUM(/1)
  183. IF (IDIM.EQ.2) THEN
  184. NBM=2
  185. ELSE
  186. NBM=NSGEO2
  187. IF (ICOQ.AND.KQUAD(NSMB)) NBM=NSGEO2/2
  188. ENDIF
  189. NNELMB = ISSMB.NUM(/2)
  190. C
  191. DO NELMB=1,NNELMB
  192. C -------------------------------------------------
  193. KB = NELMB + NELTB
  194.  
  195.  
  196. C On boucle sur les éléments de NSMB -> NELMB
  197. C
  198. C ****On regarde si l'on ne traite pas le même élément
  199. IF ((NSMA.EQ.NSMB).AND.(NELMA.EQ.NELMB)) THEN
  200. FF = 0.D0
  201. ELSE
  202. DO I=1, NSGEO2, NSPA2
  203. LS=I
  204. IF (ICOQ.AND.KQUAD(NSMB)) LS=(I+1)/2
  205. C On boucle sur les noeuds de NELMB
  206. C
  207. IG = ISSMB.NUM(I,NELMB)
  208. C** NYB(I) = IG
  209. NYB(LS) = IG
  210. IREF = (IDIM+1)*(IG-1)
  211. IF(IIMPI.GE.4) WRITE(6,*) ' NELMB I ',NELMB,I
  212. DO K=1,IDIM
  213. C** BM(K,I)=XCOOR(IREF+K)
  214. BM(K,LS)=XCOOR(IREF+K)
  215. ENDDO
  216. IF(IIMPI.GE.4) WRITE(6,*) ' BM ',(BM(K,LS),K=1,IDIM)
  217. C
  218. ENDDO
  219. C
  220. C *****Calcul de la normale à NELMB -> UB
  221. IF (IDIM.EQ.3) THEN
  222. CALL KNORM(IDIM,BM,NBM,UB,SS)
  223. ELSE
  224. CALL KNORM2(IDIM,BM,NBM,UB,SS)
  225. ENDIF
  226. C
  227. C
  228. PS = 0.D0
  229. DO K=1,IDIM
  230. PS = PS + UA(K)*UB(K)
  231. ENDDO
  232. C
  233. IF (PS.LT.(0.995)) THEN
  234. IF (IDIM.EQ.3) THEN
  235. CALL CAL2S3(G,NAM,AM,NBM,BM,NGAUSS,FF,NYA,NYB,EDIS)
  236. ELSE
  237. CALL CAL2S2(NAM,AM,NBM,BM,FF)
  238. ENDIF
  239. C
  240. IF (FF.LT.1.D-6) THEN
  241. MALEUR = .TRUE.
  242. C** GOTO 60
  243. ENDIF
  244. C
  245. FF = FF/SA
  246. ELSE
  247. FF = 0.D0
  248. ENDIF
  249. PLIG.FACT(KB) = FF
  250. C
  251. ENDIF
  252. C
  253. ENDDO
  254. C fin NELMB ----------------------------------------
  255. NELTB=NELTB+NNELMB
  256. C
  257. ENDDO
  258. C fin NSMB --------------------------------------------
  259. C
  260. ENDDO
  261. C fin NELMA ---------------------------------------------
  262. NELTA=NELTA+NNELMA
  263. C
  264. ENDDO
  265. C fin NSMA -------------------------------------------------
  266. C
  267. C
  268. SEGSUP PTRA23
  269. IF (IDIM.EQ.3) THEN
  270. SEGSUP PMATG
  271. ENDIF
  272. C
  273.  
  274. 60 CONTINUE
  275. IF (MALEUR.EQV..TRUE.) THEN
  276. WRITE (6,*) 'verifiez l orientation des elements'
  277. ENDIF
  278.  
  279. C
  280. C>>> CACUL DES BILANS ET IMPRESSION (pas de normalisation en convexe)
  281. C ------------------------------
  282. INOR=0
  283. CALL KFN(IFACFO,INOR,KIMP)
  284.  
  285. C Traduction puis suppression de IFACFO
  286.  
  287. IF (KIMP.GE.3) THEN
  288. CALL PRFACF(IFACFO)
  289. ENDIF
  290.  
  291. DO 920 ITYP = 1,N1
  292. IMODEL = MYMOD.KMODEL(ITYP)
  293. SEGACT IMODEL
  294. IPT1 = IMAMOD
  295. SEGDES IPT1
  296. SEGDES IMODEL
  297. 920 CONTINUE
  298. SEGDES MYMOD
  299.  
  300. LTITR=1
  301. INFOEL=0
  302. CALL FFMCHA(MYMOD,INFOEL,IFACFO,ICHFAC,LTITR)
  303.  
  304. SEGACT IFACFO
  305. DO 930 LS=1,NNBEL1
  306. PLIG=LFACT(LS)
  307. SEGSUP PLIG
  308. 930 CONTINUE
  309. PSUR = LFACT(NNBEL1)
  310. SEGSUP IFACFO
  311.  
  312. RETURN
  313. END
  314.  
  315.  
  316.  
  317.  
  318.  
  319.  
  320.  
  321.  
  322.  
  323.  

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