Télécharger facge2.eso

Retour à la liste

Numérotation des lignes :

  1. C FACGE2 SOURCE CB215821 16/04/21 21:16:45 8920
  2. SUBROUTINE FACGE2 (MYMOD,INFOEL,LRES,XDEC,IAXE,INOR,ICHFAC
  3. & ,EXTINC)
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. *----------------------------------------------------------------------
  7. * Calcul des facteurs de forme OPTION CACHE 2D-plan
  8. * SP APPELE PAR FFORME
  9. * entrée
  10. * MYMOD : objet modèle
  11. * INFOEL : segment décrivant la nature des éléments des maillages
  12. * LRES : parametre de resolution
  13. * XDEC : parametre de decoupage
  14. * IAXE : pointeur sur le chamtrio decrivant le plan de sym‚trie
  15. * INOR : paramŠtre de normalisation et impression
  16. * EXTINC : coefficient d'extinction si cavite absorbante
  17. * sortie
  18. * ICHFAC : chamelem facteur de forme
  19. *----------------------------------------------------------------------
  20. -INC CCOPTIO
  21. -INC SMCOORD
  22. -INC SMELEME
  23. C
  24. C----------------------------------------------------------------------
  25. C segment qui va contenir les coordonnées du plan de symétrie
  26. SEGMENT ,LISTEN
  27. INTEGER LECT(NBE)
  28. ENDSEGMENT
  29. POINTEUR IAXE.LISTEN
  30.  
  31. C-----------------------------------------------------------------------
  32. SEGMENT SKRESO
  33. INTEGER KFC,NRES,KES,KIMP
  34. ENDSEGMENT
  35. C KFC : NOMBRE DE FACES H.C
  36. C NRES: RESOLUTION
  37. C KES : DIM ESPACE
  38. C KIMP: IMPRESSION
  39. C-----------------------------------------------------------------------
  40. SEGMENT SKFAC2
  41. INTEGER NUK(MS,MFACE),KPATCH(MFACE)
  42. INTEGER NCELL(MFACE)
  43. REAL*8 U(3,MFACE),S(MFACE)
  44. REAL*8 FF1(MFACE)
  45. ENDSEGMENT
  46. SEGMENT IPATCH
  47. REAL*8 GP(MSP,NPATCH),SP(NPATCH)
  48. ENDSEGMENT
  49. C
  50. C DESCRIPTION DES ELEMENTS
  51. C ------------------------
  52. C MFACE : NOMBRE DE FACES
  53. C NUK : CONNECTIVITES
  54. C U : NORMALE UNITAIRE ET EQUATION DU PLAN DE L'ELEMENT
  55. C S : SURFACE
  56. C KVU : VISIBILITE A PRIORI
  57. C FF : FACTEURS DE FORME
  58. C FF1 : TRAVAIL
  59. C NCELL : NOMBRE TOTAL DE CELLULES VUES PAR UN POINT
  60. C KPATCH: POINTEUR SUR IPATCH
  61. C NPATCH: NOMBRE DE POINTS SUR L'ELEMENT (REDECOUPAGE)
  62. C GP : COORDONNEES DES POINTS
  63. C SP : ET SURFACES
  64. C-----------------------------------------------------------------------
  65. SEGMENT SHC2D
  66. INTEGER IR(NR),KA(NFC),IM(NFC,NFC)
  67. INTEGER KRO(NFC,NES),KSI(NFC,NES)
  68. REAL*8 V(NES,NR),G(NR)
  69. ENDSEGMENT
  70.  
  71. C DESCRIPTION DU H.C DE PROJECTION
  72. C --------------------------------
  73. C V : DIRECTION UNITAIRE DES CELLULES
  74. C G : FACTEUR DE FORME ASSOCIE
  75. C IR: CORRESPONDANCE
  76. C KRO , KSI : POUR LE CHANGEMENT DE REPERE
  77. C IM : REFERENCE
  78. C NR : RESOLUTION
  79. C NFC : NOMBRE DE FACES
  80. C-----------------------------------------------------------------------
  81. SEGMENT SKBUF2
  82. INTEGER NUMF(NFC,NOC,NR),NTYP(NFC,NR)
  83. REAL*8 ZB(NFC,NR),PSC(NFC,NR)
  84. ENDSEGMENT
  85. C
  86. C BUFFER ASSOCIE AU H.C
  87. C ---------------------
  88. C NUMF : INDICE DE LE DERNIERE FACE RENCONTREE
  89. C NTYP : TYPES ASSOCIES
  90. C ZB : PROFONDEUR
  91. C PSC : PRODUIT SCALAIRE (NORMALE.DIRECTION CELLULE)
  92. C-----------------------------------------------------------------------
  93. C FACTEURS DE FORME
  94. C NNBEL1 = NOMBRE DE LIGNES + 1
  95. C NBEL2 = NOMBRE DE COLONNES
  96. C LFACT(NNBEL1) POINTE SUR LE TABLEAU DES SURFACES
  97. C
  98. SEGMENT IFACFO
  99. INTEGER LFACT(NNBEL1)
  100. ENDSEGMENT
  101. SEGMENT LFAC
  102. REAL*8 FACT(NBEL2)
  103. ENDSEGMENT
  104. POINTEUR PSUR.LFAC, PLIG.LFAC
  105. POINTEUR PCOL.LFAC
  106. C----------------------------------------------------------------------
  107. SEGMENT STRAV
  108. REAL*8 U1(3),U2(3),O1(2)
  109. REAL*8 A1(2,2),A2(2,2)
  110. REAL*8 AA2(2,2),UU2(3),UA(2),UN(2)
  111. ENDSEGMENT
  112. C----------------------------------------------------------------------
  113. *//////
  114. * Mise à jour de variables SKRESO
  115. SEGINI SKRESO
  116. KES = IDIM
  117. KIMP = IIMPI
  118. NRES = LRES
  119. KFC=4
  120. *//////
  121. SEGINI STRAV
  122. C
  123. C
  124. CNN-----AXE DE SYMETRIE--------------------------------------------------
  125. IF (IAXE.NE.0) THEN
  126. SEGACT IAXE
  127. IF(IIMPI.GE.1) THEN
  128. WRITE(6,*) ' CALCUL AVEC AXE DE SYMETRIE '
  129. ENDIF
  130. C Numéro des 2 points définissant l'axe
  131. IREF1 = (IDIM+1)*(IAXE.LECT(1)-1)
  132. IREF2 = (IDIM+1)*(IAXE.LECT(2)-1)
  133. C On garde un point ( UA ) et la normale ( UN )
  134. UA(1) = XCOOR(IREF1+1)
  135. UA(2) = XCOOR(IREF1+2)
  136. UN(1) = UA(2) - XCOOR(IREF2+2)
  137. UN(2) = XCOOR(IREF2+1) - UA(1)
  138. DUN=SQRT(UN(1)*UN(1)+UN(2)*UN(2))
  139. IF (DUN.LT.1.E-5) THEN
  140. WRITE(6,*) ' LES POINTS DE L AXE SONT CONFONDUS '
  141. CALL ARRET(0)
  142. RETURN
  143. ENDIF
  144. UN(1) = UN(1)/DUN
  145. UN(2) = UN(2)/DUN
  146. SEGDES IAXE
  147. ENDIF
  148. CNN------------------------------------------------------------------
  149. NSOM = 2
  150. EPS = 1E-5
  151.  
  152. C
  153. C>>> PREPARATION
  154. C
  155. CALL KALPR2(MYMOD,INFOEL,SKFAC2,SHC2D,XDEC,NELD,SKRESO)
  156. C
  157. C>>> INITIALISATION OBJET FACFOR
  158. C
  159. NBEL1 = NELD
  160. NNBEL1 = NELD+1
  161. NBEL2 = NELD
  162. SEGINI IFACFO
  163.  
  164. DO 900 LS=1,NNBEL1
  165. SEGINI PLIG
  166. LFACT(LS) = PLIG
  167. SEGDES PLIG
  168. 900 CONTINUE
  169.  
  170. PSUR = LFACT(NNBEL1)
  171. SEGACT PSUR*MOD
  172. SEGACT SKFAC2
  173. MFACE = NUK(/2)
  174. DO 910 K1 = 1,MFACE
  175. PSUR.FACT(K1) = PSUR.FACT(K1) + S(K1)
  176. 910 CONTINUE
  177.  
  178. C -------------------------------------------------------------
  179. C>>> CALCUL
  180. C
  181. SEGACT SHC2D,SKFAC2*MOD
  182. MFACE = NUK(/2)
  183.  
  184.  
  185. NR = IR(/1)
  186. NFC = KRO(/1)
  187. NOC = 4
  188. SEGINI SKBUF2
  189.  
  190. CALL KFALIM(MFACE,K1D,K1F)
  191. DO 300 K1 = K1D,K1F
  192.  
  193. PLIG = LFACT(K1)
  194. SEGACT PLIG*MOD
  195.  
  196. DO 312 K=1,IDIM+1
  197. U1(K) = U(K,K1)
  198. 312 CONTINUE
  199.  
  200. DO 201 ISS = 1,NSOM
  201. IREF = (IDIM+1)*(NUK(ISS,K1)-1)
  202. DO 202 K = 1,IDIM
  203. A1(K,ISS) = XCOOR(IREF+K)
  204. 202 CONTINUE
  205. 201 CONTINUE
  206.  
  207. CALL KINPR2(U1,SHC2D,SKBUF2,SKRESO)
  208. CALL KVERI2(SHC2D,SKBUF2,SKRESO)
  209.  
  210. IPATCH = KPATCH(K1)
  211. SEGACT IPATCH
  212. NPATCH = GP(/2)
  213.  
  214. CALL KTYPKS(NPATCH,KS1D,KS1F)
  215.  
  216. DO 310 KS1 = KS1D,KS1F
  217.  
  218. DO 311 K=1,IDIM
  219. O1(K) = GP(K,KS1)
  220. 311 CONTINUE
  221. IF (IIMPI.GE.4) THEN
  222. WRITE(6,*) K1,KS1,' O1 ',(O1(I1),I1=1,IDIM)
  223. ENDIF
  224. CALL KINBU2(SKBUF2,SKRESO)
  225. C
  226. C FACES
  227. C -----
  228. DO 400 K2 = 1,MFACE
  229.  
  230. DO 412 K=1,IDIM+1
  231. U2(K) = U(K,K2)
  232. 412 CONTINUE
  233.  
  234. DO 211 ISS = 1,NSOM
  235. IREF = (IDIM+1)*(NUK(ISS,K2)-1)
  236. DO 212 K = 1,IDIM
  237. A2(K,ISS) = XCOOR(IREF+K)
  238. 212 CONTINUE
  239. 211 CONTINUE
  240.  
  241. CNNN-------SEQUENCE POUR LA FACE K2 DU MAILLAGE--------------
  242.  
  243. CALL KPRIOR(IDIM,NSOM,NSOM,A1,A2,U1,U2,KVU)
  244.  
  245. IF (KVU.NE.0) THEN
  246.  
  247. C = U2(IDIM+1)
  248. DO 401 IES = 1,IDIM
  249. C = C + U2(IES)*O1(IES)
  250. 401 CONTINUE
  251. IF (IIMPI.GE.4) WRITE(6,*) 'FACES ',K1,' ',K2,' KVU ',KVU
  252.  
  253. IF ((KVU.NE.2).OR.(KSIG(C,EPS).EQ.1)) THEN
  254. CALL KREMP2(K1,K2,O1,A2,C,U2,SHC2D,SKBUF2,SKRESO)
  255. ENDIF
  256. ENDIF
  257. CNNN-------------------------------------------------------------
  258.  
  259. IF(IAXE.NE.0) THEN
  260.  
  261. CNNN-------SEQUENCE POUR LA FACE SYMETRIQUE DE K2--------------------
  262. C L'AXE DE SYMETRIE EST DEFINI PAR UN POINT UA
  263. C UNE NORMALE UNITAIRE
  264. C CALCUL DES SYMETRIQUES DE U2(NORMALE) ET A2(SOMMETS)
  265. C
  266. KES1 = IDIM + 1
  267. CALL KSYM(IDIM,KES1,A2,U2,AA2,UU2,UA,UN)
  268.  
  269. CALL KPRIOR(IDIM,NSOM,NSOM,A1,AA2,U1,UU2,KVU)
  270.  
  271. IF (KVU.NE.0) THEN
  272.  
  273. C = UU2(IDIM+1)
  274. DO 403 IES = 1,IDIM
  275. C = C + UU2(IES)*O1(IES)
  276. 403 CONTINUE
  277. IF (IIMPI.GE.4) WRITE(6,*) 'FACES ',K1,' ',K2,' KVU ',KVU
  278.  
  279. IF ((KVU.NE.2).OR.(KSIG(C,EPS).EQ.1)) THEN
  280. CALL KREMP2(K1,K2,O1,AA2,C,UU2,SHC2D,SKBUF2,SKRESO)
  281. ENDIF
  282. ENDIF
  283. CNNN-------------------------------------------------------------
  284. ENDIF
  285.  
  286. 400 CONTINUE
  287. C
  288. C>>> RECOMBINAISON
  289. C
  290. SSP1 = SP(KS1)
  291.  
  292. C<<
  293. IF(EXTINC.LE.1D-3) THEN
  294. CALL KRCOM2(K1,SSP1,SHC2D,SKFAC2,SKBUF2,SKRESO)
  295. ELSE
  296. CALL KRCOA2(K1,SSP1,SHC2D,SKFAC2,SKBUF2,SKRESO,EXTINC)
  297. ENDIF
  298. C<<
  299. DO 920 K2 = 1,MFACE
  300. PLIG.FACT(K2) = PLIG.FACT(K2) + FF1(K2)
  301. 920 CONTINUE
  302.  
  303. 310 CONTINUE
  304. SEGDES IPATCH
  305. SEGDES PLIG
  306.  
  307. 300 CONTINUE
  308.  
  309. C -------------------------------------------------------------
  310.  
  311. DO 500 K2=1,MFACE
  312. IPATCH=KPATCH(K2)
  313. SEGSUP IPATCH
  314. 500 CONTINUE
  315. SEGSUP SKFAC2
  316.  
  317. SEGSUP SHC2D,SKBUF2
  318. C
  319. C>>> CALCUL DES BILANS, IMPRESSION, NORMALISATION
  320. C --------------------------------------------
  321.  
  322. LIMP=KIMP
  323. C<<
  324. IF(EXTINC.GT.1D-3) THEN
  325. INOR = 0
  326. ENDIF
  327. C<<
  328. CALL KFN(IFACFO,INOR,LIMP)
  329. C
  330. *//////
  331. IF(KIMP.GE.3) THEN
  332. CALL PRFACF(IFACFO)
  333. ENDIF
  334. *//////
  335. LTITR=1
  336. CALL FFMCHA(MYMOD,INFOEL,IFACFO,ICHFAC,LTITR)
  337.  
  338. C Destruction de IFACFO après traduction
  339. SEGACT IFACFO
  340. NNBEL1 = LFACT(/1)
  341. DO 950 NN = 1,NNBEL1
  342. PLIG = LFACT(NN)
  343. SEGSUP PLIG
  344. 950 CONTINUE
  345. SEGSUP IFACFO
  346.  
  347. SEGSUP STRAV, SKRESO
  348.  
  349. RETURN
  350. END
  351.  
  352.  
  353.  
  354.  
  355.  
  356.  

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