Télécharger faccvx.eso

Retour à la liste

Numérotation des lignes :

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

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