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

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