Télécharger kcha2.eso

Retour à la liste

Numérotation des lignes :

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

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