Télécharger kkdom.eso

Retour à la liste

Numérotation des lignes :

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

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