Télécharger flucoq.eso

Retour à la liste

Numérotation des lignes :

  1. C FLUCOQ SOURCE CB215821 19/07/30 21:16:17 10273
  2.  
  3. C=======================================================================
  4. C= F L U C O Q =
  5. C= ----------- =
  6. C= =
  7. C= Fonction : =
  8. C= ---------- =
  9. C= Calcul des flux nodaux equivalents a une condition de FLUX IMPOSE =
  10. C= pour des elements de type COQUE =
  11. C= Sous-programme appele par FLUX2 (flux2.eso) =
  12. C= =
  13. C= Parametres : (E)=Entree (S)=Sortie =
  14. C= ------------ =
  15. C= IPMODE (E) Pointeur sur le segment MMODEL =
  16. C= IPGEOM (E) Objet MAILLAGE support de IPCHPO =
  17. C= IPCHPO (E) Pointeur sur le CHPOINT (ou le MCHAML) de flux =
  18. C= imposes aux noeuds de la structure =
  19. C= (champ variable ou constant) =
  20. C= NUMPOI (E) Vaut -1 si le flux impose est normal a la surface, =
  21. C= sinon pointeur sur un POINT correspondant a la =
  22. C= direction du flux (par rapport au repere global) =
  23. C= MOCOMP (E) Nom de la composante du champ de flux equivalents =
  24. C= MLMOTX (E) Pointeur MLMOTS de la liste des composantes de =
  25. C= IPCHPO associees aux 3 directions x,y,z. =
  26. C= IPFLUX (S) Pointeur sur le champ des flux nodaux equivalents =
  27. C= =
  28. C= Variables locales : =
  29. C= ------------------- =
  30. C= ITGEOM Pointeur sur un MAILLAGE elementaire COQUE =
  31. C= IPENVE Pointeur sur l'enveloppe d'un maillage COQUE =
  32. C= IPGEOM Pointeur sur un MAILLAGE elementaire du CHPOINT =
  33. C= IPOGEO Pointeur sur un MAILLAGE commun au CHPOINT et au COQUE =
  34. C= =
  35. C=======================================================================
  36.  
  37. SUBROUTINE FLUCOQ (IPMODE,IPGEOM,IPCHPO,NUMPOI,NOMCQ,MLMOTX,
  38. & IPFLUX)
  39.  
  40. IMPLICIT INTEGER(I-N)
  41. IMPLICIT REAL*8 (A-H,O-Z)
  42.  
  43. -INC CCOPTIO
  44. -INC CCHAMP
  45. -INC CCREEL
  46. -INC SMCHAML
  47. -INC SMCHPOI
  48. -INC SMMODEL
  49. -INC SMELEME
  50. -INC SMCOORD
  51. -INC SMLMOTS
  52.  
  53. CHARACTER*(*) NOMCQ
  54.  
  55. PARAMETER (XUn=1.)
  56.  
  57. DIMENSION IVAL(4)
  58. CHARACTER*4 IMOT1,IMOT2
  59.  
  60. C= Activation du MMODEL
  61. MMODEL=IPMODE
  62. NSOU=KMODEL(/1)
  63. C= Activation de MLMOTX si defini
  64. IF (MLMOTX.NE.0) THEN
  65. MLMOTS=MLMOTX
  66. SEGACT,MLMOTS
  67. NINC = MOTS(/2)
  68. ENDIF
  69.  
  70. C BOUCLE SUR LES ZONES ELEMENTAIRES DU MODELE
  71. C =============================================
  72. idimp1=IDIM+1
  73. IRRT=0
  74. IFOI=0
  75. DO ISOU=1,NSOU
  76.  
  77. IPCHEL=0
  78.  
  79. IMODEL=KMODEL(ISOU)
  80. ITGEOM=IMAMOD
  81. NEF=NEFMOD
  82.  
  83. IPENVE=ITGEOM
  84.  
  85. * ON RECUPERE LES MAILLAGES ELEMENTAIRES DE L'ENVELOPPE
  86. * APPUYES STRICTEMENT SUR LE CHPOINT DE FLUX
  87. CALL ECROBJ('MAILLAGE',IPGEOM)
  88. CALL ECRCHA('STRI')
  89. CALL ECRCHA('APPU')
  90. CALL ECROBJ('MAILLAGE',IPENVE)
  91. CALL EXTREL(IRR,0,i)
  92.  
  93. * IL Y A DES MAILLAGES COMMUNS AU CHPOINT ET A L'ENVELOPPE
  94. IF (IRR.EQ.0) THEN
  95. CALL LIROBJ('MAILLAGE',IPOGEO,1,IRET)
  96. IF (IERR.NE.0) GOTO 8
  97. * ON DESIRE CONNAITRE LES CARACTERISTIQUES DE CES MAILLAGES
  98. IPT3=IPOGEO
  99. SEGACT,IPT3
  100. NSOU3=IPT3.LISOUS(/1)
  101. IF (NSOU3.EQ.0) THEN
  102. NBN2=IPT3.NUM(/1)
  103. ENDIF
  104.  
  105. * BOUCLE SUR LES ZONES DE CET OBJET GEOMETRIQUE
  106. DO IMAIL=1,MAX(1,NSOU3)
  107. IF (NSOU3.NE.0) THEN
  108. IPT2=IPT3.LISOUS(IMAIL)
  109. SEGACT,IPT2
  110. IPOGEO=IPT2
  111. NBN2=IPT2.NUM(/1)
  112. ENDIF
  113. * RECHERCHE DE LA FORMULATION DES (SUR)FACES
  114. NEFACE=NUMGEO(NEF)
  115. * RECUPERATION DES CARACTERISTIQUES D'INTEGRATION
  116. CALL TSHAPE(NEFACE,'GAUSS',IPINTE)
  117. * ECHEC DANS L'ACQUISITION DES CARACTERISTIQUES D'INTEGRATION
  118. IF (IERR.NE.0) GOTO 8
  119.  
  120. * ON GENERE UN CHAMELEM ELEMENTAIRE DE FLUX
  121. * A PARTIR DU MAILLAGE ELEMENTAIRE DE POINTEUR IPOGEO
  122. * ET DU CHPOINT
  123. if (IPCHPO.gt.0) then
  124. CALL CHAME1(IPOGEO,0,IPCHPO,' ',ICHELF,6)
  125. else
  126. *ou ET DU MCHAML
  127. ICHE = -1*IPCHPO
  128. CALL REDUIC(ICHE,IPOGEO,ICHELF)
  129. endif
  130. MCHEL1=ICHELF
  131. IF (IERR.NE.0) GOTO 8
  132.  
  133. MCHAM1=MCHEL1.ICHAML(1)
  134. NBCOMP=MCHAM1.IELVAL(/1)
  135. IF (NBCOMP.EQ.1) THEN
  136. IPFLOD=MCHAM1.IELVAL(1)
  137. ELSE
  138. C POUR CHAQUE ELEMENT,
  139. C ON DETERMINE UN VECTEUR DIRIGE VERS L INTERIEUR DU MASSIF
  140. C A PARTIR D UN POINT DE LA FACE ET DU CENTRE DE GRAVITE DU MASSIF
  141. C ON COPIE LE CHAMP EN AJOUTANT UNE COMPOSANTE
  142. IF (MLMOTX.EQ.0) THEN
  143. MOTERR(1:8)='LISTMOTS'
  144. CALL ERREUR(37)
  145. RETURN
  146. ENDIF
  147. MLMOTS=MLMOTX
  148. SEGACT,MLMOTS
  149. NINC=MOTS(/2)
  150. IF (NINC.NE.IDIM) THEN
  151. CALL ERREUR(21)
  152. GOTO 8
  153. ENDIF
  154. MELVAL=MCHAM1.IELVAL(1)
  155. N1PTEL=VELCHE(/1)
  156. N1EL=VELCHE(/2)
  157. N2PTEL=0
  158. N2EL=0
  159. NBCOMP=IDIM
  160. N2=NBCOMP+IDIM
  161. SEGINI,MCHAML
  162. IPFLOD=MCHAML
  163. DO I=1,N2
  164. SEGINI,MELVAL
  165. IELVAL(I)=MELVAL
  166. ENDDO
  167. DO I=1,NINC
  168. IMOT1=MOTS(i)
  169. DO J=1,NINC
  170. IMOT2=MCHAM1.NOMCHE(J)
  171. IF (IMOT1.EQ.IMOT2) IVAL(I)=J
  172. ENDDO
  173. ENDDO
  174. SEGDES,MLMOTS
  175. DO I=1,NBCOMP
  176. MELVA1=MCHAM1.IELVAL(IVAL(I))
  177. MELVAL=IELVAL(I)
  178. DO j=1,N1EL
  179. DO k=1,N1PTEL
  180. VELCHE(k,j)=MELVA1.VELCHE(k,j)
  181. ENDDO
  182. ENDDO
  183. ENDDO
  184.  
  185. NBPTE1=N1PTEL
  186. NEL1=N1EL
  187. NUMPOI=1
  188. MELEME=IPOGEO
  189. IPT1=ITGEOM
  190. NBMA1=NUM(/1)
  191. DO IEF=1,NUM(/2)
  192. DO IEM=1,IPT1.NUM(/2)
  193. JNE=0
  194. DO INM=1,IPT1.NUM(/1)
  195. DO INF=1,NBMA1
  196. IF (IPT1.NUM(INM,IEM).EQ.NUM(INF,IEF)) JNE=JNE+1
  197. ENDDO
  198. ENDDO
  199. IF (JNE.EQ.NBMA1) GOTO 170
  200. ENDDO
  201. DO j=1,N2
  202. MELVAL=IELVAL(j)
  203. SEGSUP,MELVAL
  204. ENDDO
  205. SEGSUP,IPT3
  206. GOTO 8
  207. C CDG element de "volume"
  208. C CDG de la "face"
  209. C Calcul de la normale interieure (stocker dans MCHAML)
  210. 170 NBM=IPT1.NUM(/1)
  211. IF (IDIM.EQ.2) THEN
  212. XG=XZero
  213. YG=XZero
  214. DO INM=1,NBM
  215. IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1
  216. XG=XG+XCOOR(IREFM+1)
  217. YG=YG+XCOOR(IREFM+2)
  218. ENDDO
  219. XG=XG/NBM
  220. YG=YG/NBM
  221. XK=XZero
  222. YK=XZero
  223. DO INF=1,NBMA1
  224. IREFF=(NUM(INF,IEF)-1)*idimp1
  225. XK=XK+XCOOR(IREFF+1)
  226. YK=YK+XCOOR(IREFF+2)
  227. ENDDO
  228. XK=XK/NBMA1
  229. YK=YK/NBMA1
  230. V1=XG-XK
  231. V2=YG-YK
  232. VN=SQRT(V1*V1+V2*V2)
  233. V1=V1/VN
  234. V2=V2/VN
  235. DO INF=1,NBMA1
  236. MELVAL=IELVAL(NBCOMP+1)
  237. VELCHE(INF,IEF)=V1
  238. MELVAL=IELVAL(NBCOMP+2)
  239. VELCHE(INF,IEF)=V2
  240. ENDDO
  241. ELSE IF (IDIM.EQ.3) THEN
  242. XG=XZero
  243. YG=XZero
  244. ZG=XZero
  245. DO INM=1,NBM
  246. IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1
  247. XG=XG+XCOOR(IREFM+1)
  248. YG=YG+XCOOR(IREFM+2)
  249. ZG=ZG+XCOOR(IREFM+3)
  250. ENDDO
  251. XG=XG/NBM
  252. YG=YG/NBM
  253. ZG=ZG/NBM
  254. XK=XZero
  255. YK=XZero
  256. ZK=XZero
  257. DO INF=1,NBMA1
  258. IREFF=(NUM(INF,IEF)-1)*idimp1
  259. XK=XK+XCOOR(IREFF+1)
  260. YK=YK+XCOOR(IREFF+2)
  261. ZK=ZK+XCOOR(IREFF+3)
  262. ENDDO
  263. XK=XK/NBMA1
  264. YK=YK/NBMA1
  265. ZK=ZK/NBMA1
  266. V1=XG-XK
  267. V2=YG-YK
  268. V3=ZG-ZK
  269. VN=SQRT(V1*V1+V2*V2+V3*V3)
  270. V1=V1/VN
  271. V2=V2/VN
  272. V3=V3/VN
  273. DO INF=1,NBMA1
  274. MELVAL=IELVAL(NBCOMP+1)
  275. VELCHE(INF,IEF)=V1
  276. MELVAL=IELVAL(NBCOMP+2)
  277. VELCHE(INF,IEF)=V2
  278. MELVAL=IELVAL(NBCOMP+3)
  279. VELCHE(INF,IEF)=V3
  280. ENDDO
  281. ELSE IF (IDIM.EQ.1) THEN
  282. XG=XZero
  283. DO INM=1,NBM
  284. IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1
  285. XG=XG+XCOOR(IREFM+1)
  286. ENDDO
  287. XG=XG/NBM
  288. XK=XZero
  289. DO INF=1,NBMA1
  290. IREFF=(NUM(INF,IEF)-1)*idimp1
  291. XK=XK+XCOOR(IREFF+1)
  292. ENDDO
  293. XK=XK/NBMA1
  294. V1=XG-XK
  295. V1=V1/ABS(V1)
  296. DO INF=1,NBMA1
  297. MELVAL=IELVAL(NBCOMP+1)
  298. VELCHE(INF,IEF)=V1
  299. ENDDO
  300. ENDIF
  301. ENDDO
  302. ENDIF
  303. * CHAMELEM ELEMENTAIRE DES FLUX NODAUX EQUIVALENTS
  304. L1=7
  305. N1=1
  306. N3=1
  307. SEGINI,MCHELM
  308. IPCHEL=MCHELM
  309. TITCHE='CHALEUR'
  310. IFOCHE=IFOUR
  311. INFCHE(1,1)=0
  312. IMACHE(1)=IPOGEO
  313. N2=1
  314. SEGINI,MCHAML
  315. ICHAML(1)=MCHAML
  316. NOMCHE(1)='FLUX'
  317. TYPCHE(1)='REAL*8'
  318. * CALCUL DES FLUX NODAUX EQUIVALENTS
  319. * FACES ASSOCIEES SEG2 OU SEG3
  320. IF (NEFACE.EQ.2.OR.NEFACE.EQ.3) THEN
  321. CALL FLUMA2(IPFLOD,IPOGEO,IPINTE,NUMPOI,IPFLEQ)
  322. * FACES ASSOCIEES TRI3,TRI6,QUA4 OU QUA8
  323. ELSE IF (NEFACE.EQ. 4.OR.NEFACE.EQ.6.OR.NEFACE.EQ.8.OR.
  324. . NEFACE.EQ.10) THEN
  325. CALL FLUMA3(IPFLOD,IPOGEO,IPINTE,NUMPOI,IPFLEQ)
  326. * FACES ASSOCIEES POI1
  327. ELSE IF (NEFACE.EQ.45) THEN
  328. CALL FLUMA1(IPFLOD,IPOGEO,IPINTE,NUMPOI,IPFLEQ)
  329. ENDIF
  330. IF (NUMPOI.EQ.1) THEN
  331. MCHAM2=IPFLOD
  332. DO i=1,MCHAM2.IELVAL(/1)
  333. MELVAL=MCHAM2.IELVAL(i)
  334. SEGSUP,MELVAL
  335. ENDDO
  336. SEGSUP,MCHAM2
  337. ENDIF
  338.  
  339. IF (IERR.NE.0) THEN
  340. SEGSUP,MCHAML,MCHELM
  341. GOTO 8
  342. ENDIF
  343. IELVAL(1)=IPFLEQ
  344.  
  345. * ON TRANSFORME LE CHAMELEM EN CHPOINT
  346. CALL CHAMPO(IPCHEL,0,IPCH1,IDUM)
  347. MCHPOI=IPCH1
  348. DO i=1,IPCHP(/1)
  349. MSOUPO=IPCHP(i)
  350. NOCOMP(1)=nomcq
  351. ENDDO
  352.  
  353. CALL DTCHEL(IPCHEL)
  354. * ON REGROUPE,LE CAS ECHEANT,LES DIFFERENTS CHPOINTS
  355. IF ((ISOU-IRRT).GT.1.OR.IMAIL.GT.1) THEN
  356. CALL ADCHPO(IPCH1,IPFLUX,IRET,XUn,XUn)
  357. IF (IRET.EQ.0) GOTO 8
  358. C* CALL ECRCHA('GEOM')
  359. CALL DTCHPO(IPCH1)
  360. C* CALL ECRCHA('GEOM')
  361. CALL DTCHPO(IPFLUX)
  362. IPFLUX=IRET
  363. ELSE
  364. IPFLUX=IPCH1
  365. ENDIF
  366. ENDDO
  367. * ON N'A PAS TROUVE DE MAILLAGE COMMUN A CETTE PARTIE DE
  368. * L'ENVELOPPE ET DU CHPOINT
  369. ELSE IF (IRR.EQ.1) THEN
  370. IRRT=IRRT+1
  371. ENDIF
  372. ENDDO
  373.  
  374. * IL N'EXISTE PAS D'ELEMENTS COMMUNS AU CHPOINT DES FLUX NODAUX
  375. * ET A L'ENVELOPPE DU MASSIF
  376. IF (IRRT.EQ.NSOU) CALL ERREUR(408)
  377.  
  378. 8 CONTINUE
  379. END
  380.  
  381.  
  382.  

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