Télécharger kkdom2.eso

Retour à la liste

Numérotation des lignes :

  1. C KKDOM2 SOURCE CHAT 05/01/13 00:56:44 5004
  2. C KKDOM SOURCE MAGN 02/10/07 21:15:19 4439
  3. SUBROUTINE KKDOM2(MELEME,TOLER,NOMDOM,MTABI,MTABD,INEFMD)
  4. C************************************************************************
  5. C
  6. C OBJET : Cree une table de soustype DOMAINE
  7. C Appele par KDOM
  8. C
  9. C************************************************************************
  10. IMPLICIT INTEGER(I-N)
  11. IMPLICIT REAL*8 (A-H,O-Z)
  12. CHARACTER*8 NOMDOM,NOMC
  13. CHARACTER*8 NOM,TYPE,TYPI
  14. PARAMETER (NMEL=8)
  15. DIMENSION SGA(NMEL),SEPS(NMEL),SEPSD(NMEL)
  16. C***
  17. -INC CCOPTIO
  18. -INC SMELEME
  19. POINTEUR MELEMS.MELEME,MELEMC.MELEME,MELEF1.MELEME,MELEMP.MELEME
  20. POINTEUR MFF2.MELEME
  21. -INC SMLENTI
  22. DATA SGA/1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0/
  23. DATA SEPS/0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0/
  24. DATA SEPSD/8*0.D0/
  25. C***
  26.  
  27. C On verifie que si la directive INCL est présente les SPG
  28. C des points sommets sont bien inclus
  29.  
  30. MELEP0=0
  31. C write(6,*)' DEBUT KKDOM ========================'
  32. IF(MTABI.NE.0)THEN
  33. TYPI='MAILLAGE'
  34. CALL ACMO(MTABI,'SOMMET',TYPI,MSI)
  35. CALL KRIPAD(MSI,MLENTI)
  36. CALL VERPAD(MLENTI,MELEME,IRET)
  37. IF(IRET.NE.0)THEN
  38. WRITE(6,*)' Opérateur DOMA '
  39. WRITE(6,*)' Le maillage n''est pas contenu dans celui de'
  40. & ,' la table donnée pour la directive INCL '
  41. RETURN
  42. ENDIF
  43. SEGSUP MLENTI
  44. ENDIF
  45.  
  46. C??? call CQF2LN(MELEME,MLINE)
  47. CALL KQCEST(MELEME,IKR)
  48.  
  49. IF(IKR.EQ.1341)IKR=1
  50. IF(IKR.EQ.13)IKR=1
  51.  
  52. IF(IKR.EQ.2)THEN
  53. C au depart des LINEs -> LINE
  54. C write(6,*)'au depart des LINEs -> LINE'
  55.  
  56. CALL ECROBJ('MAILLAGE',MELEME)
  57. CALL CHANQU
  58. CALL C20227
  59. IF (IERR.NE.0) RETURN
  60. CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  61. MAIL=MELEME
  62. CALL CQF2LN(MELEME,MLINE)
  63. C write(6,*)' AVT TQ2CF'
  64. NOMC=' '
  65. CALL TQ2CF(MAIL,MELEMQ,MELEMC,
  66. & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR)
  67. MELEME=MLINE
  68. ELSEIF(IKR.EQ.1.AND.INEFMD.EQ.1)THEN
  69. C au depart des QUAFs -> LINE
  70. C write(6,*)'au depart des QUAFs -> LINE '
  71.  
  72. MAIL=MELEME
  73. C write(6,*)' KKDOM QUAFs -> LINE'
  74. NOMC=' '
  75. CALL TQ2CF(MAIL,MELEMQ,MELEMC,
  76. & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR)
  77. CALL CQF2LN(MELEME,MLINE)
  78. MELEME=MLINE
  79. C? MELEME=MAIL
  80. ENDIF
  81.  
  82. C write(6,*)' APR MTABI=',mtabi
  83. CALL CRTABL(MTABD)
  84. CALL ECMM(MTABD,'SOUSTYPE','DOMAINE')
  85. CALL ECME(MTABD,'PRECONDI',1)
  86. C write(6,*)' QUAF MELEMQ=',MELEMQ
  87. C? call ecrobj('MAILLAGE',MELEMQ)
  88. C? call prlist
  89. CALL ECMO(MTABD,'QUAF','MAILLAGE',MELEMQ)
  90. IF(MTABI.NE.0) CALL ECMO(MTABD,'PERE','TABLE',MTABI)
  91. CALL ECMM(MTABD,'NOMDOM',NOMDOM)
  92. CALL ECMO(MTABD,'MAILLAGE','MAILLAGE',MELEME)
  93. CALL ECME(MTABD,'INEFMD',INEFMD)
  94.  
  95. C write(6,*)' MELEF1,MELEMF,MELEMP,MELEMC,MELAF=',
  96. C &MELEF1,MELEMF,MELEMP,MELEMC,MELAF
  97. CALL ECMO(MTABD,'FACE','MAILLAGE',MELEF1)
  98. CALL ECMO(MTABD,'FACEL','MAILLAGE',MELEMF)
  99. CALL ECMO(MTABD,'FACEP','MAILLAGE',MELEMP)
  100. CALL ECMO(MTABD,'CENTRE','MAILLAGE',MELEMC)
  101. CALL ECMO(MTABD,'ELTFA','MAILLAGE',MELAF)
  102. CALL ECMO(MTABD,'FACEL2','MAILLAGE',MELEF2)
  103. CALL ECMO(MTABD,'MAILFACE','MAILLAGE',MFF2)
  104. CALL ECMF(MTABD,'TOLER',TOLER)
  105.  
  106. C? CALL ECRCHA('POI1')
  107. C? CALL ECROBJ('MAILLAGE',MELEME)
  108. C? CALL ECROBJ('MAILLAGE',MAIL )
  109. C? CALL PRCHAN
  110. C? CALL LIROBJ('MAILLAGE',MELEMS,1,IRET)
  111. C? IF(IRET.EQ.0)RETURN
  112. CALL CM2PO1(MELEME,MELEMS)
  113. CALL ECMO(MTABD,'SOMMET','MAILLAGE',MELEMS)
  114. C???? IF(MELEMS.EQ.0)RETURN
  115.  
  116. C write(6,*)' MTABI=',mtabi,' retour si 0 '
  117. IF(MTABI.NE.0)THEN
  118.  
  119. C In CRTABL -> SEGINI MTBT0
  120. CALL CRTABL(MTBT0)
  121. CALL ECME(MTBT0,'PRECONDI',1)
  122. CALL NOMOBJ('TABLE','tabl0tmp',MTBT0)
  123.  
  124. CALL ECMO(MTBT0,'QUAF','MAILLAGE',MELEMQ)
  125. CALL ECMO(MTBT0,'SOMMET','MAILLAGE',MELEMS)
  126. CALL ECMO(MTBT0,'FACE ','MAILLAGE',MELEF1)
  127. CALL ECMO(MTBT0,'FACEL','MAILLAGE',MELEMF)
  128. CALL ECMO(MTBT0,'FACEP','MAILLAGE',MELEMP)
  129. CALL ECMO(MTBT0,'CENTRE','MAILLAGE',MELEMC)
  130. CALL ECMO(MTBT0,'ELTFA','MAILLAGE',MELAF)
  131. CALL ECMO(MTBT0,'FACEL2','MAILLAGE',MELEF2)
  132. CALL ECMO(MTBT0,'MAILFACE','MAILLAGE',MFF2)
  133. CALL ECMO(MTBT0,'MAILLAGE','MAILLAGE',MELEME)
  134.  
  135. C write(6,*)' On vérifie l inclusion des points sommets '
  136. C On vérifie l'inclusion des points sommets (on peut avoir créé des pts centre)
  137. TYPI='MAILLAGE'
  138. CALL ACMO(MTABI,'SOMMET',TYPI,MSI)
  139. CALL ACMO(MTABI,'FACE',TYPI,MFI)
  140. CALL ACMO(MTABI,'CENTRE',TYPI,MCI)
  141. CALL ECROBJ('MAILLAGE',MFI)
  142. CALL ECROBJ('MAILLAGE',MCI)
  143. CALL PRFUSE
  144. CALL ECROBJ('MAILLAGE',MSI)
  145. CALL PRFUSE
  146. CALL ECROBJ('MAILLAGE',MELEMS)
  147. CALL PRFUSE
  148. CALL ECROBJ('MAILLAGE',MELEF1)
  149. CALL PRFUSE
  150. CALL ECROBJ('MAILLAGE',MELEMC)
  151. CALL PRFUSE
  152. CALL ECRREE(TOLER)
  153. CALL PRELIM(0)
  154. CALL LIROBJ('MAILLAGE',MMMMM,1,IRET)
  155. ENDIF
  156. C write(6,*)' APRES verification '
  157.  
  158. SEGACT MELEF1
  159. NBFD=MELEF1.NUM(/2)
  160. SEGDES MELEF1
  161. SEGACT MELEMC
  162. NELD=MELEMC.NUM(/2)
  163. SEGDES MELEMC
  164. SEGACT MELEMS
  165. NPTD=MELEMS.NUM(/2)
  166. SEGDES MELEMS
  167.  
  168. CALL ECME(MTABD,'NPTD',NPTD)
  169. CALL ECME(MTABD,'NELD',NELD)
  170. CALL ECME(MTABD,'NBFD',NBFD)
  171.  
  172. C write(6,*)' Appel a REFE'
  173. CALL ECROBJ('MAILLAGE',MELEME)
  174. CALL REFE
  175. CALL LIROBJ('LISTMOTS',ITABOG,0,IRET)
  176. CALL ECMO(MTABD,'OBJINCLU','LISTMOTS',ITABOG)
  177. C write(6,*)' FIN KKDOM ********************** '
  178.  
  179. RETURN
  180. END
  181.  
  182.  
  183.  
  184.  
  185.  

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