Télécharger kdam.eso

Retour à la liste

Numérotation des lignes :

  1. C KDAM SOURCE BP208322 16/11/18 21:18:05 9177
  2. SUBROUTINE KDAM
  3. C************************************************************************
  4. C
  5. C OBJET : Cree une table de soustype DOMAINE
  6. C SYNTAXE : A = KDOM OBJ1 <IMPR>
  7. C
  8. C OBJ1 objet 'MAILLAGE'
  9. C IMPR impressions de controle
  10. C La table cree contient les informations suivantes:
  11. C
  12. C Indice Objet
  13. C Type Valeur Type Valeur
  14. C MOT SOUSTYPE MOT DOMAINE
  15. C MOT MAILLAGE MAILLAGE
  16. C MOT SOMMET MAILLAGE
  17. C MOT CENTRE MAILLAGE
  18. C MOT FACE MAILLAGE
  19. C MOT FACEL MAILLAGE
  20. C MOT NPTD ENTIER
  21. C MOT NELD ENTIER
  22. C MOT NBFD ENTIER
  23. C MOT OBJINCLU LISTMOTS
  24. C************************************************************************
  25. IMPLICIT INTEGER(I-N)
  26. IMPLICIT REAL*8 (A-H,O-Z)
  27. PARAMETER (NMO1=4)
  28. CHARACTER*8 MO1(NMO1)
  29. CHARACTER*8 NOM,TYPEL(20),NEM,TYPE,NOMI,MTYP,TYPI
  30. PARAMETER (LM1=9)
  31. CHARACTER*8 LIST1(LM1),LIST2(LM1)
  32. PARAMETER (NMEL=8)
  33. CHARACTER*4 MOEL(NMEL)
  34. DIMENSION SGA(NMEL),SEPS(NMEL),SEPSD(NMEL)
  35. C***
  36.  
  37. -INC PPARAM
  38. -INC CCOPTIO
  39. -INC CCGEOME
  40. -INC SMLMOTS
  41. POINTEUR TABOG.MLMOTS
  42. -INC SMELEME
  43. POINTEUR MELEMS.MELEME,MELEMC.MELEME,MELEF1.MELEME
  44. POINTEUR MELEMP.MELEME
  45. -INC SMCOORD
  46. -INC SMLENTI
  47. -INC SMTABLE
  48. POINTEUR MTABD.MTABLE
  49. POINTEUR MTABI.MTABLE,MTBT0.MTABLE
  50. DATA MO1/'IMPR ','INCL ','MACRO ',' '/
  51. DATA LIST1/'VOLUME ','COTE ','DIAMAX ','DIAMIN ',
  52. & 'NORMALE ','SURFACE ','ORIENTAT','DSOMMET ','DCENTRE '/
  53. DATA LIST2/'XXVOLUM ','XXCOTE ','XXDIAME ','XXDIEMIN',
  54. & 'XXNORMAF','XXSURFAC','XXNORMAE','XXDIAGSI','XXVOLUM '/
  55. DATA SGA/1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0/
  56. DATA SEPS/0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0/
  57. DATA SEPSD/8*0.D0/
  58. DATA MOEL/'TRI6','QUA8','SEG3','CU20','PR15','TE10','PY13','CHAH'/
  59. C***
  60.  
  61. COEF=0.D0
  62. KCHAHU=0
  63. MTABI=0
  64. MACRO=0
  65. CALL LIROBJ('MAILLAGE',MELEME,0,IRET)
  66. IF(IRET.EQ.0)THEN
  67. CALL LIROBJ('TABLE',MTABLE,1,IRET)
  68. IF(IRET.EQ.0)THEN
  69. WRITE(6,*)' On attend un objet MAILLAGE ou un objet TABLE'
  70. RETURN
  71. ENDIF
  72. CALL LIRCHA(NOM,1,LCHAR)
  73. IF(LCHAR.EQ.0)THEN
  74. WRITE(6,*)' On attend une CHAINE'
  75. RETURN
  76. ENDIF
  77. CALL OPTLI(IP,LIST1,NOM,LM1)
  78. IF(IP.NE.0)THEN
  79. NOMI=LIST2(IP)
  80. ELSE
  81. NOMI=NOM
  82. ENDIF
  83. CALL LEKTAB(MTABLE,NOMI,IPOINT)
  84. IF(IPOINT.EQ.0)RETURN
  85. TYPE=' '
  86. C -> In ACCTAB : SEGACT MTABLE
  87. CALL ACMO(MTABLE,NOMI,TYPE,IPOINT)
  88. SEGDES MTABLE
  89. CALL ECROBJ(TYPE,IPOINT)
  90. RETURN
  91. ENDIF
  92.  
  93.  
  94. CALL XDIAMM(MELEME,DIAM)
  95. DIAM=DIAM*0.0003D0
  96. CALL LIRREE(TOLER,0,IRET)
  97. IF(IRET.EQ.0)TOLER=DIAM
  98.  
  99. CALL QUENOM(NOM)
  100.  
  101. IMPR=0
  102. 1 CONTINUE
  103.  
  104. 21 CONTINUE
  105. CALL QUETYP(MTYP,0,IRET)
  106. IP=0
  107. IF(MTYP.EQ.'MOT')THEN
  108. CALL LIRCHA(NOM,1,LCHAR)
  109. IF(NOM.EQ.' ')GO TO 21
  110. CALL OPTLI(IP,MO1,NOM,NMO1)
  111. IF(IP.EQ.4)IP=0
  112. ENDIF
  113.  
  114. IF(IP.EQ.1)THEN
  115.  
  116. IMPR=1
  117. GO TO 1
  118.  
  119. ELSEIF(IP.EQ.2)THEN
  120.  
  121. CALL LIROBJ('TABLE',MTABI,1,IRET)
  122. IF(IRET.EQ.0)RETURN
  123. CALL LIRREE(TOLER,0,IRET)
  124. IF(IRET.EQ.0)TOLER=DIAM
  125. GO TO 1
  126.  
  127. ELSEIF(IP.EQ.3)THEN
  128.  
  129. MACRO=1
  130. 11 CONTINUE
  131. CALL LIRMOT(MOEL,NMEL,IPE,0)
  132. IF(IPE.EQ.0)GO TO 1
  133. IF(IPE.EQ.8)THEN
  134.  
  135. CALL LIRREE(XVALC,0,IRET)
  136. IF(IRET.EQ.1)THEN
  137. KCHAHU=1
  138. COEF=XVALC
  139. ENDIF
  140. GO TO 11
  141.  
  142. ENDIF
  143.  
  144. CALL LIRREE(XVAL1,1,IRET)
  145. IF(IRET.EQ.0)RETURN
  146. CALL LIRREE(XVAL2,1,IRET)
  147. IF(IRET.EQ.0)RETURN
  148. CALL LIRREE(XVAL3,1,IRET)
  149. IF(IRET.EQ.0)RETURN
  150. SGA(IPE)=XVAL1
  151. SEPS(IPE)=XVAL2
  152. SEPSD(IPE)=XVAL3
  153. GO TO 11
  154.  
  155. ELSE
  156. GO TO 2
  157. ENDIF
  158.  
  159. 2 CONTINUE
  160.  
  161. C On verifie que si la directive INCL est présente les SPG
  162. C des points sommets sont bien inclus
  163.  
  164. IF(MTABI.NE.0)THEN
  165. TYPI='MAILLAGE'
  166. CALL ACMO(MTABI,'SOMMET',TYPI,MSI)
  167. CALL KRIPAD(MSI,MLENTI)
  168. CALL VERPAD(MLENTI,MELEME,IRET)
  169. IF(IRET.NE.0)THEN
  170. WRITE(6,*)' Opérateur DOMA '
  171. WRITE(6,*)' Le maillage n''est pas contenu dans celui de'
  172. & ,' la table donnée pour la directive INCL '
  173. RETURN
  174. ENDIF
  175. SEGSUP MLENTI
  176. ENDIF
  177.  
  178. IF(MACRO.NE.0)THEN
  179.  
  180. MACRO=MELEME
  181. C In CRTABL -> SEGINI MTBT0
  182. CALL CRTABL(MTBT0)
  183. CALL NOMOBJ('TABLE','tabl0tmp',MTBT0)
  184. IF(IDIM.EQ.2)THEN
  185.  
  186. C write(6,*)' KCHAHU,coef=',KCHAHU,coef
  187. IF(KCHAHU.EQ.1)CALL CHAHUT(MACRO,COEF)
  188. CALL KTRSF(MACRO,MELEME,MTBT0,IRET,SGA,SEPS,SEPSD,COEF)
  189.  
  190. ELSE
  191. CALL KTRS3(MACRO,MELEME,MTBT0,IRET,SGA,SEPS,SEPSD,COEF)
  192. CALL ECROBJ('MAILLAGE',MELEME)
  193. CALL ECRREE(TOLER)
  194. CALL PRELIM(0)
  195. CALL LIROBJ('MAILLAGE',MMMMM,1,IRET)
  196. ENDIF
  197. IF(IRET.EQ.0)RETURN
  198.  
  199. IF(MTABI.NE.0)THEN
  200. TYPI='MAILLAGE'
  201. CALL ACMO(MTABI,'SOMMET',TYPI,MSI)
  202. CALL ECROBJ('MAILLAGE',MSI)
  203. CALL ECROBJ('MAILLAGE',MELEME)
  204. CALL PRFUSE
  205. CALL ECRREE(TOLER)
  206. CALL PRELIM(0)
  207. CALL LIROBJ('MAILLAGE',MMMMM,1,IRET)
  208. ENDIF
  209.  
  210. ENDIF
  211.  
  212. C Fin MACRO
  213.  
  214. C Debut KFCE
  215.  
  216. IF(MTABI.NE.0)THEN
  217. CALL ECRREE(TOLER)
  218. CALL ECROBJ('TABLE',MTABI)
  219. CALL ECRCHA('INCL')
  220. ENDIF
  221. CALL ECROBJ('MAILLAGE',MELEME)
  222. CALL ECRREE(TOLER)
  223.  
  224. MELEMQ=0
  225. CALL KFCE(IQUAD,MELEMQ)
  226. CALL LIROBJ('MAILLAGE',MELAF,1,IRET)
  227. CALL LIROBJ('MAILLAGE',MELEMC,1,IRET)
  228. CALL LIROBJ('MAILLAGE',MELEMP,1,IRET)
  229. CALL LIROBJ('MAILLAGE',MELEMF,1,IRET)
  230. CALL LIROBJ('MAILLAGE',MELEF1,1,IRET)
  231. IF(IRET.EQ.0)RETURN
  232.  
  233. CALL CRTABL(MTABD)
  234. CALL ECMM(MTABD,'SOUSTYPE','DOMAINE')
  235. IF(MTABI.NE.0) CALL ECMO(MTABD,'PERE','TABLE',MTABI)
  236. CALL ECMM(MTABD,'NOMDOM',NOM)
  237. CALL ECMO(MTABD,'MAILLAGE','MAILLAGE',MELEME)
  238. IF(MACRO.NE.0)THEN
  239. CALL ECMO(MTABD,'MACRO','MAILLAGE',MACRO)
  240. ELSEIF(IQUAD.EQ.1)THEN
  241. CALL ECMO(MTABD,'QUADRATIQUE','MAILLAGE',MELEME)
  242. CALL ECMO(MTABD,'MAILLAGE','MAILLAGE',MELEMQ)
  243. MQ=MELEMQ
  244. MELEMQ=MELEME
  245. MELEME=MQ
  246. ENDIF
  247.  
  248. CALL ECMO(MTABD,'FACE','MAILLAGE',MELEF1)
  249. CALL ECMO(MTABD,'FACEL','MAILLAGE',MELEMF)
  250. CALL ECMO(MTABD,'FACEP','MAILLAGE',MELEMP)
  251. CALL ECMO(MTABD,'CENTRE','MAILLAGE',MELEMC)
  252. CALL ECMO(MTABD,'ELTFA','MAILLAGE',MELAF)
  253. CALL ECMF(MTABD,'TOLER',TOLER)
  254.  
  255. CG TYPE=' '
  256. CG write(6,*)' avt MTBT0 MFICEL ',MTBT0
  257. CG CALL ACMO(MTBT0,'MFICEL',TYPE,MFICEL)
  258. CG IF(TYPE.NE.'MAILLAGE')MFICEL=0
  259. CG IF(MACRO.NE.0.AND.MFICEL.NE.0)THEN
  260.  
  261. IF(MACRO.NE.0)THEN
  262. C write(6,*)' OK ds MACRO ',toler
  263. TYPI='MAILLAGE'
  264. CALL ACMO(MTBT0,'MCTREI',TYPI,MCTREI)
  265. CALL ECMO(MTABD,'MCTREI','MAILLAGE',MCTREI)
  266. CALL ECROBJ('MAILLAGE',MELEMC)
  267. CALL ECROBJ('MAILLAGE',MCTREI)
  268. CALL PRFUSE
  269. CALL ECRREE(TOLER)
  270. CALL PRELIM(0)
  271. C? CALL PRTRAC
  272. C write(6,*)' premier PRELIM '
  273. CALL ECROBJ('MAILLAGE',MELEF1)
  274. CALL PRFUSE
  275. CALL ECRREE(TOLER)
  276. CALL PRELIM(0)
  277. C write(6,*)' second PRELIM '
  278. CALL LIROBJ('MAILLAGE',MMMMM,1,IRET)
  279. TYPE=' '
  280. CALL ACMO(MTBT0,'MCHPOC',TYPE,MCHPOC)
  281. IF(TYPE.EQ.'CHPOINT ')THEN
  282. CALL ECMO(MTABD,'MCHPOC','CHPOINT ',MCHPOC)
  283. TYPI='MAILLAGE'
  284. CALL ACMO(MTBT0,'MELSTB',TYPI,MELSTB)
  285. CALL ECMO(MTABD,'MELSTB','MAILLAGE',MELSTB)
  286. CG si utilise, remplacer MAILLAGE par TYPI
  287. TYPI='MAILLAGE'
  288. C CALL ACMO(MTBT0,'MFACEI',TYPI,MFACEI)
  289. C CALL ACMO(MTBT0,'MELTFI',TYPI,MELTFI)
  290. C CALL ACMO(MTBT0,'MELELI',TYPI,MELELI)
  291. C CALL ACMO(MTBT0,'MCTREI',TYPI,MCTREI)
  292. C CALL ACMO(MTBT0,'MCHPOF','CHPOINT ',MCHPOF)
  293. C CALL ECMO(MTABD,'FACEI','MAILLAGE',MFACEI)
  294. C CALL ECMO(MTABD,'ELTFAI','MAILLAGE',MELTFI)
  295. C CALL ECMO(MTABD,'FACELI','MAILLAGE',MFICEL)
  296. C CALL ECMO(MTABD,'MELELI','MAILLAGE',MELELI)
  297. C CALL ECMO(MTABD,'MCHPOF','CHPOINT ',MCHPOF)
  298. ENDIF
  299.  
  300. ENDIF
  301.  
  302. CALL ECRCHA('POI1')
  303. CALL ECROBJ('MAILLAGE',MELEME)
  304. CALL PRCHAN
  305. CALL LIROBJ('MAILLAGE',MELEMS,1,IRET)
  306. IF(IRET.EQ.0)RETURN
  307. CALL ECMO(MTABD,'SOMMET','MAILLAGE',MELEMS)
  308. IF(MELEMS.EQ.0)RETURN
  309.  
  310. SEGACT MELEF1
  311. NBFD=MELEF1.NUM(/2)
  312. SEGDES MELEF1
  313. SEGACT MELEMC
  314. NELD=MELEMC.NUM(/2)
  315. SEGDES MELEMC
  316. SEGACT MELEMS
  317. NPTD=MELEMS.NUM(/2)
  318. SEGDES MELEMS
  319.  
  320. CALL ECME(MTABD,'NPTD',NPTD)
  321. CALL ECME(MTABD,'NELD',NELD)
  322. CALL ECME(MTABD,'NBFD',NBFD)
  323.  
  324. CALL ECROBJ('MAILLAGE',MELEME)
  325. CALL REFE
  326. CALL LIROBJ('LISTMOTS',TABOG,0,IRET)
  327. CALL ECMO(MTABD,'OBJINCLU','LISTMOTS',TABOG)
  328.  
  329. NBTYP=0
  330. SEGACT MELEME
  331. NBSOUS=LISOUS(/1)
  332. IF(NBSOUS.EQ.0)NBSOUS=1
  333. DO 3 L=1,NBSOUS
  334. IF(NBSOUS.NE.1)THEN
  335. IPT1=LISOUS(L)
  336. SEGACT IPT1
  337. ELSE
  338. IPT1=MELEME
  339. ENDIF
  340. NBTYP=NBTYP+1
  341. NEM=NOMS(IPT1.ITYPEL)//' '
  342. C CALL KALPBG(NEM,'FONFORM0',IZFFM)
  343. C CALL ECMO(MTABD,'FONFORM0','FONFORM0',IZFFM)
  344. C CALL KALPBG(NEM,'FONFORM ',IZFFM)
  345. C CALL ECMO(MTABD,'FONFORM','FONFORM',IZFFM)
  346. TYPEL(NBTYP)=NEM
  347. IF(NBSOUS.NE.1)SEGDES IPT1
  348. 3 CONTINUE
  349. SEGDES MELEME
  350.  
  351. IF(IMPR.NE.0)THEN
  352. WRITE(6,1909)NOM,IDIM,NPTD,NELD
  353. 1909 FORMAT(/1X,9(8H********)/5X,'DOMAINE ',A8,' CREE DIM ESPACE:',
  354. & I2,' NB DE NOEUDS :',I6,/42X,
  355. & ' NB D ELEMENTS :',I6,/)
  356. WRITE(6,1919)
  357. DO M=1,NBTYP
  358. WRITE(6,1920) TYPEL(M)
  359. ENDDO
  360. 1919 FORMAT(5X,'TYPE DES ELEMENTS CONSTITUANT LE DOMAINE',/)
  361. 1920 FORMAT(5X,A8/)
  362. IF(TABOG.NE.0) THEN
  363. WRITE(6,1983)
  364. 1983 FORMAT(10X,' LISTE DES OBJETS INCLUS DANS LE DOMAINE ',/)
  365. SEGACT TABOG
  366. NBO=TABOG.MOTS(/2)
  367. WRITE(6,1982)(TABOG.MOTS(MM),MM=1,NBO)
  368. 1982 FORMAT(7(2X,A8))
  369. SEGDES TABOG
  370. WRITE(6,1928)
  371. 1928 FORMAT(//1X,9('********')/)
  372. ENDIF
  373. ENDIF
  374. SEGDES MTABD
  375. CALL ECROBJ('TABLE ',MTABD)
  376. RETURN
  377. END
  378.  
  379.  
  380.  
  381.  
  382.  
  383.  
  384.  
  385.  
  386.  
  387.  

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