Télécharger kkdom.eso

Retour à la liste

Numérotation des lignes :

  1. C KKDOM SOURCE MAGN 07/06/02 21:15:11 5749
  2. SUBROUTINE KKDOM(MELEME,MACRO,TOLER,NOMDOM,MTABI,MTABD,INEFMD)
  3. C************************************************************************
  4. C
  5. C OBJET : Cree une table de soustype DOMAINE
  6. C Appele par KDOM
  7. C
  8. C************************************************************************
  9. IMPLICIT INTEGER(I-N)
  10. IMPLICIT REAL*8 (A-H,O-Z)
  11. CHARACTER*8 NOMDOM,NOMC
  12. CHARACTER*8 NOM,TYPE,TYPI
  13. PARAMETER (NMEL=8)
  14. DIMENSION SGA(NMEL),SEPS(NMEL),SEPSD(NMEL)
  15. C***
  16. -INC CCOPTIO
  17. -INC SMELEME
  18. POINTEUR MELEMS.MELEME,MELEMC.MELEME,MELEF1.MELEME,MELEMP.MELEME
  19. POINTEUR MFF2.MELEME
  20. -INC SMLENTI
  21. DATA SGA/1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0/
  22. DATA SEPS/0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0/
  23. DATA SEPSD/8*0.D0/
  24. C***
  25.  
  26. C On verifie que si la directive INCL est présente les SPG
  27. C des points sommets sont bien inclus
  28.  
  29. MELEP0=0
  30. C write(6,*)' DEBUT KKDOM ========================'
  31. IF(MTABI.NE.0)THEN
  32. TYPI='MAILLAGE'
  33. CALL ACMO(MTABI,'SOMMET',TYPI,MSI)
  34. CALL KRIPAD(MSI,MLENTI)
  35. CALL VERPAD(MLENTI,MELEME,IRET)
  36. IF(IRET.NE.0)THEN
  37. WRITE(6,*)' Opérateur DOMA '
  38. WRITE(6,*)' Le maillage n''est pas contenu dans celui de'
  39. & ,' la table donnée pour la directive INCL '
  40. RETURN
  41. ENDIF
  42. SEGSUP MLENTI
  43. ENDIF
  44.  
  45. C??? call CQF2LN(MELEME,MLINE)
  46. CALL KQCEST(MELEME,IKR)
  47. C write(6,*)' IKR=',IKR,' MACRO=',MACRO,' INEFMD=',INEFMD
  48.  
  49. C? IF(IKR.EQ.13.AND.MACRO.NE.0)IKR=1
  50. C? IF(IKR.EQ.134.AND.MACRO.NE.0)IKR=1
  51. IF(IKR.EQ.13.AND.MACRO.NE.0)IKR=4
  52. IF(IKR.EQ.134.AND.MACRO.NE.0)IKR=4
  53. IF(IKR.EQ.34.AND.MACRO.NE.0)IKR=3
  54. IF(IKR.EQ.1341.AND.MACRO.EQ.0)IKR=1
  55. IF(IKR.EQ.13.AND.MACRO.EQ.0)IKR=1
  56.  
  57. IF(IKR.EQ.1341.AND.MACRO.NE.0)THEN
  58. C au depart des SEG3 -> LINE -> MACRO
  59. C write(6,*)'au depart des SEG3 -> LINE -> MACRO'
  60.  
  61. MACRO =MELEME
  62. MACRO1=MELEME
  63. CALL ECROBJ('MAILLAGE',MELEME)
  64. CALL CQ2L
  65. CALL LIROBJ('MAILLAGE',MLINE,1,IRET)
  66. MELEME=MLINE
  67. MAIL=MLINE
  68. NOMC=' '
  69. CALL TQ2CF(MAIL,MELEMQ,MELEMC,
  70. & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR)
  71. IQUAD=0
  72.  
  73. ELSEIF(IKR.EQ.1.AND.MACRO.EQ.0.AND.INEFMD.EQ.4)THEN
  74. C au depart des QUAFs -> LINB
  75. C write(6,*)'au depart des QUAFs -> LINB'
  76.  
  77. MAIL=MELEME
  78. CALL ECROBJ('MAILLAGE',MELEME)
  79. CALL CLINB
  80. IF (IERR.NE.0) RETURN
  81. CALL LIROBJ('MAILLAGE',MLINB,1,IRET)
  82. C write(6,*)' AVT TQ2CF'
  83. NOMC=' '
  84. CALL TQ2CF(MAIL,MELEMQ,MELEMC,
  85. & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR)
  86. MELEME=MLINB
  87. IQUAD=0
  88.  
  89. ELSEIF(IKR.NE.2.AND.MACRO.EQ.0.AND.INEFMD.NE.1)THEN
  90. C au depart des QUADs ou QUAF -> QUAF
  91. C write(6,*)'au depart des QUADs ou QUAF -> QUAF'
  92.  
  93. CALL ECROBJ('MAILLAGE',MELEME)
  94. CALL C20227
  95. IF (IERR.NE.0) RETURN
  96. CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  97. MAIL=MELEME
  98. NOMC=' '
  99. CALL TQ2CF(MAIL,MELEMQ,MELEMC,
  100. & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR)
  101. IQUAD=1
  102.  
  103. ELSEIF(IKR.EQ.2.AND.MACRO.EQ.0)THEN
  104. C au depart des LINEs -> LINE
  105. C write(6,*)'au depart des LINEs -> LINE'
  106.  
  107. CALL ECROBJ('MAILLAGE',MELEME)
  108. CALL CHANQU
  109. CALL C20227
  110. IF (IERR.NE.0) RETURN
  111. CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  112. MAIL=MELEME
  113. CALL CQF2LN(MELEME,MLINE)
  114. C write(6,*)' AVT TQ2CF'
  115. NOMC=' '
  116. CALL TQ2CF(MAIL,MELEMQ,MELEMC,
  117. & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR)
  118. MELEME=MLINE
  119. IQUAD=0
  120.  
  121. ELSEIF((IKR.EQ.3.OR.IKR.EQ.4).AND.MACRO.NE.0)THEN
  122. C au depart des QUADs -> MACRO
  123. C write(6,*)'au depart des QUADs -> MACRO '
  124.  
  125. MACRO=MELEME
  126. CALL ECROBJ('MAILLAGE',MELEME)
  127. CALL CMACRO
  128. IF (IERR.NE.0) RETURN
  129. CALL LIROBJ('MAILLAGE',MACRO1,1,IRET)
  130. CALL ECROBJ('MAILLAGE',MACRO1)
  131. CALL CQ2L
  132. IF (IERR.NE.0) RETURN
  133. CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  134. MAIL=MELEME
  135. NOMC=' '
  136. CALL TQ2CF(MAIL,MELEMQ,MELEMC,
  137. & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR)
  138. IQUAD=0
  139.  
  140. ELSEIF(IKR.EQ.1.AND.MACRO.NE.0)THEN
  141. C au depart des QUAFs -> MACRO
  142. C write(6,*)'au depart des QUAFs -> MACRO '
  143.  
  144. MAIL=MELEME
  145. MACRO=MELEME
  146. CALL CQF2MC(MELEME,MACRO1)
  147. IF (IERR.NE.0) RETURN
  148. CALL ECROBJ('MAILLAGE',MACRO1)
  149. CALL CQ2L
  150. IF (IERR.NE.0) RETURN
  151. CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  152. NOMC=' '
  153. CALL TQ2CF(MAIL,MELEMQ,MELEP0,
  154. & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR)
  155.  
  156. CALL TQ2CF(MELEME,MQ,MELEMC,
  157. & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR)
  158.  
  159. C? CALL KRECTR(MELEME,MELEMC)
  160. IQUAD=0
  161.  
  162. ELSEIF(IKR.EQ.1.AND.INEFMD.EQ.1)THEN
  163. C au depart des QUAFs -> LINE
  164. C write(6,*)'au depart des QUAFs -> LINE '
  165.  
  166. MAIL=MELEME
  167. C write(6,*)' KKDOM QUAFs -> LINE'
  168. NOMC=' '
  169. CALL TQ2CF(MAIL,MELEMQ,MELEMC,
  170. & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR)
  171. CALL CQF2LN(MELEME,MLINE)
  172. MELEME=MLINE
  173. C? MELEME=MAIL
  174. IQUAD=0
  175.  
  176. ENDIF
  177.  
  178. C write(6,*)' APR MTABI=',mtabi
  179. CALL CRTABL(MTABD)
  180. CALL ECMM(MTABD,'SOUSTYPE','DOMAINE')
  181. CALL ECME(MTABD,'PRECONDI',0)
  182. C write(6,*)' QUAF MELEMQ=',MELEMQ
  183. C? call ecrobj('MAILLAGE',MELEMQ)
  184. C? call prlist
  185. CALL ECMO(MTABD,'QUAF','MAILLAGE',MELEMQ)
  186. IF(MTABI.NE.0) CALL ECMO(MTABD,'PERE','TABLE',MTABI)
  187. CALL ECMM(MTABD,'NOMDOM',NOMDOM)
  188. CALL ECMO(MTABD,'MAILLAGE','MAILLAGE',MELEME)
  189. CALL ECME(MTABD,'INEFMD',INEFMD)
  190. IF(MACRO.NE.0)THEN
  191. CALL ECMO(MTABD,'MACRO','MAILLAGE',MACRO)
  192. CALL ECMO(MTABD,'QUAF ','MAILLAGE',MACRO)
  193. CALL ECMO(MTABD,'MACRO1','MAILLAGE',MACRO1)
  194. ELSEIF(IQUAD.EQ.1)THEN
  195. CALL ECMO(MTABD,'QUADRATIQUE','MAILLAGE',MELEME)
  196. CALL ECMO(MTABD,'MAILLAGE','MAILLAGE',MELEMQ)
  197. MQ=MELEMQ
  198. MELEMQ=MELEME
  199. MELEME=MQ
  200. ENDIF
  201.  
  202. C write(6,*)' MELEF1,MELEMF,MELEMP,MELEMC,MELAF=',
  203. C &MELEF1,MELEMF,MELEMP,MELEMC,MELAF
  204. CALL ECMO(MTABD,'FACE','MAILLAGE',MELEF1)
  205. CALL ECMO(MTABD,'FACEL','MAILLAGE',MELEMF)
  206. CALL ECMO(MTABD,'FACEP','MAILLAGE',MELEMP)
  207. CALL ECMO(MTABD,'CENTRE','MAILLAGE',MELEMC)
  208. CALL ECMO(MTABD,'ELTFA','MAILLAGE',MELAF)
  209. CALL ECMO(MTABD,'FACEL2','MAILLAGE',MELEF2)
  210. CALL ECMO(MTABD,'MAILFACE','MAILLAGE',MFF2)
  211. CALL ECMF(MTABD,'TOLER',TOLER)
  212.  
  213. IF(MACRO.NE.0)THEN
  214. IF(MELEP0.NE.0)
  215. &CALL ECMO(MTABD,'CENTREP0','MAILLAGE',MELEP0)
  216. C CALL KRECTR(MELEME,MELEMC)
  217. CALL ECMO(MTABD,'CENTRE','MAILLAGE',MELEMC)
  218. COEF=0.D0
  219. C write(6,*)' APPEL a KMLSTB MACRO1=',MACRO1
  220. CALL KMLSTB(MACRO1,MELEME,MELEMC,MELSTB,MCHPOC,
  221. & IRETM,SGA,SEPS,SEPSD,COEF)
  222. C write(6,*)' RETOUR de KMLSTB '
  223. IF(IRETM.EQ.1)THEN
  224. CALL ECMO(MTABD,'MELSTB','MAILLAGE',MELSTB)
  225. CALL ECMO(MTABD,'MCHPOC','CHPOINT ',MCHPOC)
  226. ENDIF
  227. ENDIF
  228.  
  229. C? CALL ECRCHA('POI1')
  230. C? CALL ECROBJ('MAILLAGE',MELEME)
  231. C? CALL ECROBJ('MAILLAGE',MAIL )
  232. C? CALL PRCHAN
  233. C? CALL LIROBJ('MAILLAGE',MELEMS,1,IRET)
  234. C? IF(IRET.EQ.0)RETURN
  235. CALL CM2PO1(MELEME,MELEMS)
  236. CALL ECMO(MTABD,'SOMMET','MAILLAGE',MELEMS)
  237. C???? IF(MELEMS.EQ.0)RETURN
  238.  
  239. C write(6,*)' MTABI=',mtabi,' retour si 0 '
  240. IF(MTABI.NE.0)THEN
  241.  
  242. C In CRTABL -> SEGINI MTBT0
  243. CALL CRTABL(MTBT0)
  244. CALL ECME(MTBT0,'PRECONDI',0)
  245. CALL NOMOBJ('TABLE','tabl0tmp',MTBT0)
  246.  
  247. CALL ECMO(MTBT0,'QUAF','MAILLAGE',MELEMQ)
  248. CALL ECMO(MTBT0,'SOMMET','MAILLAGE',MELEMS)
  249. CALL ECMO(MTBT0,'FACE ','MAILLAGE',MELEF1)
  250. CALL ECMO(MTBT0,'FACEL','MAILLAGE',MELEMF)
  251. CALL ECMO(MTBT0,'FACEP','MAILLAGE',MELEMP)
  252. CALL ECMO(MTBT0,'CENTRE','MAILLAGE',MELEMC)
  253. CALL ECMO(MTBT0,'ELTFA','MAILLAGE',MELAF)
  254. CALL ECMO(MTBT0,'FACEL2','MAILLAGE',MELEF2)
  255. CALL ECMO(MTBT0,'MAILFACE','MAILLAGE',MFF2)
  256. CALL ECMO(MTBT0,'MAILLAGE','MAILLAGE',MELEME)
  257.  
  258. IF(MACRO.NE.0)THEN
  259. CALL ECMO(MTBT0,'MACRO','MAILLAGE',MACRO)
  260. CALL ECMO(MTBT0,'MACRO1','MAILLAGE',MACRO1)
  261. IF(IRETM.EQ.1)THEN
  262. CALL ECMO(MTBT0,'MELSTB','MAILLAGE',MELSTB)
  263. CALL ECMO(MTBT0,'MCHPOC','CHPOINT ',MCHPOC)
  264. ENDIF
  265. ELSEIF(IQUAD.EQ.1)THEN
  266. CALL ECMO(MTBT0,'MELEMQ','MAILLAGE',MELEMQ)
  267. ENDIF
  268.  
  269. C write(6,*)' On vérifie l inclusion des points sommets '
  270. C On vérifie l'inclusion des points sommets (on peut avoir créé des pts centre)
  271. TYPI='MAILLAGE'
  272. CALL ACMO(MTABI,'SOMMET',TYPI,MSI)
  273. CALL ACMO(MTABI,'FACE',TYPI,MFI)
  274. CALL ACMO(MTABI,'CENTRE',TYPI,MCI)
  275. CALL ECROBJ('MAILLAGE',MFI)
  276. CALL ECROBJ('MAILLAGE',MCI)
  277. CALL PRFUSE
  278. CALL ECROBJ('MAILLAGE',MSI)
  279. CALL PRFUSE
  280. CALL ECROBJ('MAILLAGE',MELEMS)
  281. CALL PRFUSE
  282. CALL ECROBJ('MAILLAGE',MELEF1)
  283. CALL PRFUSE
  284. CALL ECROBJ('MAILLAGE',MELEMC)
  285. CALL PRFUSE
  286. CALL ECRREE(TOLER)
  287. CALL PRELIM(0)
  288. CALL LIROBJ('MAILLAGE',MMMMM,1,IRET)
  289. ENDIF
  290. C write(6,*)' APRES verification '
  291.  
  292. SEGACT MELEF1
  293. NBFD=MELEF1.NUM(/2)
  294. SEGDES MELEF1
  295. SEGACT MELEMC
  296. NELD=MELEMC.NUM(/2)
  297. SEGDES MELEMC
  298. SEGACT MELEMS
  299. NPTD=MELEMS.NUM(/2)
  300. SEGDES MELEMS
  301.  
  302. CALL ECME(MTABD,'NPTD',NPTD)
  303. CALL ECME(MTABD,'NELD',NELD)
  304. CALL ECME(MTABD,'NBFD',NBFD)
  305.  
  306. C write(6,*)' FIN KKDOM ********************** '
  307.  
  308. RETURN
  309. END
  310.  
  311.  
  312.  
  313.  
  314.  
  315.  
  316.  
  317.  
  318.  
  319.  

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