Télécharger kcha2.eso

Retour à la liste

Numérotation des lignes :

  1. C KCHA2 SOURCE PV 09/03/12 21:26:00 6325
  2. C
  3. SUBROUTINE KCHA2(IPCHE,IPGEOM,IPCENT,IRET)
  4. C-----------------------------------------------------------------------
  5. C Transforme un MCHAML constant par élément en un CHPO de support CENTRE
  6. C-----------------------------------------------------------------------
  7. C
  8. C--------------------
  9. C Paramètres Entrée :
  10. C--------------------
  11. C
  12. C IPCHE : pointeur sur le champ par élément
  13. C Le champ n'a qu'une composante reelle
  14. C
  15. C IPGEOM : pointeur sur le maillage quaf ou de base (issu de la table domaine).
  16. C IPCENT : pointeur sur le maillage des points centres
  17. C (issu de la table domaine).
  18. C
  19. C-------------------
  20. C Paramètre Sortie :
  21. C-------------------
  22. C
  23. C IRET : pointeur sur le CHPO de support centre
  24. C
  25. C-----------------------------------------------------------------------
  26. C
  27. C Subroutine appelée par KCHA.
  28. C
  29. C-----------------------------------------------------------------------
  30.  
  31. IMPLICIT INTEGER(I-N)
  32. IMPLICIT REAL*8 (A-H,O-Z)
  33. C
  34. C
  35. -INC CCOPTIO
  36. -INC SMCHAML
  37. -INC SMCHPOI
  38. -INC SMELEME
  39.  
  40. SEGMENT ITRA
  41. * LTAB(IE,IP) : indice dans le chpocentre du point IE de la partition IP
  42. INTEGER LTAB(NBELM,NPAR)
  43. ENDSEGMENT
  44. SEGMENT JTRA
  45. * JTAB(IZ) : indice dans le chpocentre de départ des points pour le sous-maillage IZ
  46. * ZTAB(IP) : nb de noeuds de la partition IP
  47. * ITAB(IP) : pointeur sur sous-zone identifiée à la partition IP
  48. * KTAB(IP) : nb d'éléments de cette sous-zone
  49. * OTAB(IP) : numéro d'ordre de cette sous-zone dans IPGEOM
  50. INTEGER JTAB(NBS),ZTAB(NPAR)
  51. INTEGER ITAB(NPAR),KTAB(NPAR),OTAB(NPAR)
  52. ENDSEGMENT
  53. SEGMENT KTRA
  54. * MTAB(IC) : nom de la composante IC du chamelem
  55. * NTAB(IC,IP) : numéro, dans chaque partition IP, de la
  56. * sous-partition ayant pour composante la composante
  57. * IC de la première partition
  58. CHARACTER*8 MTAB(MCOM)
  59. INTEGER NTAB(NC,NPAR)
  60. ENDSEGMENT
  61. SEGMENT KSIPP
  62. INTEGER ISPT(NBEL3)
  63. ENDSEGMENT
  64. *
  65. * NBS : nombre de sous-zones du maillage
  66. *
  67. IPT1 = IPGEOM
  68. SEGACT IPT1
  69. NBO = IPT1.LISOUS(/1)
  70. IF(NBO.EQ.0) THEN
  71. NBS = 1
  72. ELSE
  73. NBS = NBO
  74. ENDIF
  75. *
  76. * NPAR : nombre de partitions du chamelem
  77. *
  78. MCHELM = IPCHE
  79. SEGACT MCHELM
  80. NPAR = IMACHE(/1)
  81. *
  82. * NBELM : nombre maximal d'éléments parmi toutes les partitions
  83. *
  84. NBELM = 0
  85. DO IP =1,NPAR
  86. IPT2 = IMACHE(IP)
  87. SEGACT IPT2
  88. NBEL = IPT2.NUM(/2)
  89. NP = IPT2.NUM(/1)
  90. NBELM = MAX(NBEL,NBELM)
  91. * IF(NBEL.GT.NBELM) THEN
  92. * NBELM = NBEL
  93. * ENDIF
  94. SEGDES IPT2
  95. ENDDO
  96. *
  97. * Initialisation des segments de travail
  98. *
  99. SEGINI ITRA
  100. SEGINI JTRA
  101.  
  102. IF(NBO.EQ.0) THEN
  103. JTAB(1)=0
  104. ENDIF
  105.  
  106. DO IO=2,NBS
  107. IPT3 = IPT1.LISOUS(IO-1)
  108. SEGACT IPT3
  109. NB = IPT3.NUM(/2)
  110. JTAB(IO)= JTAB(IO-1) + NB
  111. SEGDES IPT3
  112. ENDDO
  113. *
  114. * Correspondance des maillages des partitions du chamelem
  115. * avec les sous-maillages du maillage
  116. *
  117.  
  118. * Test des nombres de noeuds par éléments
  119. DO IP=1,NPAR
  120. * pour chaque partition IP
  121. IPT2 = IMACHE(IP)
  122. SEGACT IPT2
  123. NP = IPT2.NUM(/1)
  124. ZTAB(IP)= IPT2.NUM(/2)
  125. DO IZ=1,NBS
  126. * pour chaque sous-maillage IZ
  127. IF(NBO.EQ.0)THEN
  128. IPT3 = IPT1
  129. ELSE
  130. IPT3 = IPT1.LISOUS(IZ)
  131. SEGACT IPT3
  132. ENDIF
  133. NP3 = IPT3.NUM(/1)
  134. IF(NP.EQ.NP3) THEN
  135. C On a trouve 2 sous-maillages ayant le meme nbre de noeuds
  136. C pour qu'ils puissent correspondre, ils doivent avoir 1
  137. C element commun
  138. NBEL3=IPT3.NUM(/2)
  139. ITEST=0
  140. DO 30 I0=1,NP
  141. I1=IPT2.NUM(I0,1)
  142. DO 20 I2=1,NBEL3
  143. DO 15 I3=1,NP3
  144. IF(IPT3.NUM(I3,I2).EQ.I1)THEN
  145. ITEST=ITEST+1
  146. GO TO 25
  147. ENDIF
  148. 15 CONTINUE
  149. 20 CONTINUE
  150. 25 CONTINUE
  151. 30 CONTINUE
  152. IF(ITEST.EQ.NP)THEN
  153. ITAB(IP)=IPT3
  154. KTAB(IP)=IPT3.NUM(/2)
  155. OTAB(IP)=IZ
  156. IF(NBO.GT.0)THEN
  157. SEGDES IPT3
  158. ENDIF
  159. GO TO 3
  160. ENDIF
  161. ENDIF
  162. ENDDO
  163. C On n'a pas trouvé, dans un CHAMELEM, de zone géométrique ou de
  164. C constituant correspondant à l'objet MODELE
  165. CALL ERREUR(472)
  166. RETURN
  167. 3 CONTINUE
  168. SEGDES IPT2
  169. ENDDO
  170.  
  171. * Test des numéros de noeud
  172. C les tests qui suivent sont extremement long pour un gros maillage
  173. C on va affecter a chaque element un poids egal a la somme des numeros
  174. C de ses noeuds et on ne comparera les numeros de noeuds que pour les
  175. C elements qui auront le meme poids.
  176. DO IP =1,NPAR
  177. IPT2 = IMACHE(IP)
  178. SEGACT IPT2
  179. IPT4 = ITAB(IP)
  180. SEGACT IPT4
  181. NBEL2 = ZTAB(IP)
  182. NBEL3 = KTAB(IP)
  183. NP = IPT2.NUM(/1)
  184. C
  185. SEGINI KSIPP
  186. DO JE=1,NBEL3
  187. ISP2=0
  188. DO JP=1,NP
  189. ISP2=ISP2+IPT4.NUM(JP,JE)
  190. ENDDO
  191. ISPT(JE)=ISP2
  192. ENDDO
  193.  
  194. C
  195. DO IE = 1,NBEL2
  196. IP1 = IPT2.NUM(1,IE)
  197. ISP1=0
  198. DO II=1,NP
  199. ISP1= ISP1+IPT2.NUM(II,IE)
  200. ENDDO
  201. DO JE = 1,NBEL3
  202. IF(ISPT(JE).EQ.ISP1) THEN
  203. DO JP=1,NP
  204. IP2=IPT4.NUM(JP,JE)
  205. IF(IP2.EQ.IP1) THEN
  206. ITEST = 1
  207. DO KP=1,NP-1
  208. JEE = JP+KP
  209. JEP = JEE / NP
  210. JEE = JEE - JEP * NP
  211. IF(JEE.EQ.0)THEN
  212. JEE = NP
  213. ENDIF
  214. KJ = IPT4.NUM(JEE,JE)
  215. KI = IPT2.NUM(KP+1,IE)
  216. IF(KJ.EQ.KI) THEN
  217. ITEST=ITEST+1
  218. ELSE
  219. GO TO 4
  220. ENDIF
  221. ENDDO
  222. IF(ITEST.EQ.NP) THEN
  223. LTAB(IE,IP)=JE+JTAB(OTAB(IP))
  224. GO TO 5
  225. ENDIF
  226. 4 CONTINUE
  227. ENDIF
  228. ENDDO
  229. ENDIF
  230. ENDDO
  231. C On n'a pas trouvé, dans un CHAMELEM, de zone géométrique ou de
  232. C constituant correspondant à l'objet MODELE
  233. CALL ERREUR(472)
  234. RETURN
  235. 5 CONTINUE
  236. ENDDO
  237. SEGDES IPT2, IPT4
  238. SEGSUP KSIPP
  239. ENDDO
  240. *
  241. * NOMBRE DE COMPOSANTES MAXI PAR PARTITION
  242. *
  243. NC = 0
  244. DO IP =1,NPAR
  245. MCHAML = ICHAML(IP)
  246. SEGACT MCHAML
  247. DO IT = 1,TYPCHE(/2)
  248. IF(TYPCHE(IT)(1:8).EQ.'POINTEUR') THEN
  249. c Problème non prévu dans le s.p. %m1:8 contactez votre assistance
  250. MOTERR(1:8) = 'KCHA2 '
  251. CALL ERREUR(349)
  252. RETURN
  253. ENDIF
  254. ENDDO
  255. IC = MCHAML.IELVAL(/1)
  256. NC = MAX(IC,NC)
  257. * IF(IC.GT.NC) THEN
  258. * NC = IC
  259. * ENDIF
  260. SEGDES MCHAML
  261. ENDDO
  262. MCOM = NC
  263.  
  264. * Préparation du champ-point à plusieurs composantes
  265. SEGINI KTRA
  266. MCHAML = ICHAML(1)
  267. SEGACT MCHAML
  268. MC = MCHAML.IELVAL(/1)
  269. DO IC =1,MC
  270. MTAB(IC)=NOMCHE(IC)
  271. NTAB(IC,1)=IC
  272. ENDDO
  273. SEGDES MCHAML
  274.  
  275. K=MC
  276. DO IP=2,NPAR
  277. MCHAML = ICHAML(IP)
  278. SEGACT MCHAML
  279. MC = MCHAML.IELVAL(/1)
  280. DO IC=1,MC
  281. DO JC=1,K
  282. IF(NOMCHE(IC).EQ.MTAB(JC))THEN
  283. NTAB(IC,IP)=JC
  284. GO TO 10
  285. ENDIF
  286. ENDDO
  287. K = K+1
  288. IF(MCOM.LT.K) THEN
  289. MCOM = K
  290. SEGADJ KTRA
  291. ENDIF
  292. MTAB(K)=NOMCHE(IC)
  293. NTAB(IC,IP)=K
  294. 10 CONTINUE
  295. ENDDO
  296. SEGDES MCHAML
  297. ENDDO
  298. *
  299. * Construction du champ-point
  300. *
  301. NSOUPO = 1
  302. NAT = 2
  303. SEGINI MCHPOI
  304. MTYPOI = ' '
  305. MOCHDE = 'KCHA FECIT'
  306. JATTRI(1) = 2
  307. NC = MCOM
  308. SEGINI MSOUPO
  309. IPCHP(1) = MSOUPO
  310. IPT5 = IPCENT
  311. SEGACT IPT5
  312. N = IPT5.NUM(/2)
  313. SEGDES IPT5
  314. SEGINI MPOVAL
  315. IPOVAL = MPOVAL
  316. IGEOC = IPCENT
  317. IFOPOI = IFOCHE
  318.  
  319. DO IC=1,MCOM
  320. NOCOMP(IC) = MTAB(IC)(1:4)
  321. *** NOHARN(IC)=INTAB(IC)
  322. *** REVOIR NHARM
  323. ENDDO
  324.  
  325. DO IP=1,NPAR
  326. MCHAML= ICHAML(IP)
  327. SEGACT MCHAML
  328. N2 = MCHAML.IELVAL(/1)
  329. IPT4 = ITAB(IP)
  330. SEGACT IPT4
  331. MEL = ZTAB(IP)
  332. DO II=1,N2
  333. IC = NTAB(II,IP)
  334. MELVAL = MCHAML.IELVAL(II)
  335. SEGACT MELVAL
  336. NPT = VELCHE(/1)
  337. NEL = VELCHE(/2)
  338. IF(NPT.EQ.1 .AND. NEL.EQ.1) THEN
  339. * constance sur la sous-zone
  340. DO IE = 1,MEL
  341. JP = LTAB(IE,IP)
  342. VPOCHA(JP,IC) = VELCHE(1,1)
  343. ENDDO
  344. ENDIF
  345. IF(NPT.EQ.1 .AND. NEL.NE.1) THEN
  346. * cas classique
  347. DO IE = 1,MEL
  348. JP = LTAB(IE,IP)
  349. VPOCHA(JP,IC) = VELCHE(1,IE)
  350. ENDDO
  351. ENDIF
  352. IF(NPT.NE.1 .AND. NEL.NE.1) THEN
  353. * on n'a pas un chamelem aux centres
  354. * on fait la moyenne sur les valeurs aux différents points
  355. DO IE = 1,MEL
  356. JP = LTAB(IE,IP)
  357. VAL = 0.D0
  358. DO KP=1,NPT
  359. VAL = VAL + VELCHE(KP,IE)
  360. ENDDO
  361. VAL = VAL / NPT
  362. VPOCHA(JP,IC) = VAL
  363. ENDDO
  364. ENDIF
  365. SEGDES MELVAL
  366. ENDDO
  367. SEGDES MCHAML, IPT4
  368. ENDDO
  369. *
  370. * Fermeture des segments
  371. *
  372. SEGDES MPOVAL
  373. SEGDES MSOUPO
  374. SEGDES MCHPOI
  375. SEGDES IPT1
  376. SEGDES MCHELM
  377. SEGSUP ITRA,JTRA,KTRA
  378.  
  379. IRET = MCHPOI
  380. RETURN
  381. END
  382.  
  383.  
  384.  
  385.  
  386.  
  387.  
  388.  
  389.  
  390.  
  391.  
  392.  

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