Télécharger kdom4a.eso

Retour à la liste

Numérotation des lignes :

  1. C KDOM4A SOURCE PV 13/04/16 21:15:17 7765
  2. SUBROUTINE KDOM4A(MTAB,MELEMQ)
  3. C
  4. C************************************************************************
  5. C
  6. C PROJET : CASTEM 2000
  7. C
  8. C NOM : KDOM4A
  9. C
  10. C DESCRIPTION : Subroutine called by KDOM2A
  11. C Axial-symmetric case, TRI7 and QUA8
  12. C We compute
  13. C MTAB . 'MAILLAGE'
  14. C MTAB . 'CENTRE'
  15. C MTAB . 'XCEN2D'
  16. C MTAB . 'YCEN2D'
  17. C MTAB . 'XXVOLUM'
  18. C MTAB . 'XXSURF2D'
  19. C and we change the position for the central points
  20. C of MELEMQ
  21. C
  22. C LANGAGE : FORTRAN 77 + ESOPE 2000 (avec estensions CISI)
  23. C
  24. C AUTEUR : A. BECCANTINI, DRN/DMT/SEMT/LTMF
  25. C
  26. C************************************************************************
  27. C
  28. C INPUT/OUTPUT : MTAB : domaine table
  29. C MELEMQ : QUAF mesh
  30. C************************************************************************
  31. C
  32. C Created the 24/02/04
  33. C
  34. C
  35. C**** Variables de COOPTIO
  36. C
  37. C INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR
  38. C & ,IOTER, IOLEC, IOIMP, IOCAR, IOACQ
  39. C & ,IOPER, IOSGB, IOGRA, IOSAU, IORES
  40. C & ,IECHO, IIMPI, IOSPI
  41. C & ,IDIM, IFICLE, IPREFI
  42. CC & ,MCOORD
  43. C & ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE
  44. C & ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU
  45. C & ,NORINC,NORVAL,NORIND,NORVAD
  46. C & ,NUCROU, IPSAUV, IREFOR, ISAFOR
  47. CC
  48. C
  49. IMPLICIT INTEGER(I-N)
  50. -INC CCOPTIO
  51. -INC SMCOORD
  52. -INC SMELEME
  53. -INC SMLMOTS
  54. -INC SMCHPOI
  55. -INC SMLENTI
  56. INTEGER MTAB, MELEMQ
  57. & ,MCHPSU,MCHPNO,MCHPMR,MCHX2D,MCHY2D
  58. & , NBS, NBREF, ITSOUS, NBNN, NBELEM, NBSOUS,NBE0
  59. & , JGM, JGN, IGEOM, ISOUS, IELEM
  60. & , NN1, NN2, NN3, NNC, NN4
  61. & , NFAC, NSOM, NTP, JG, LAST, LASTS
  62. & , LISFAC(4), LISSOM(4), NNS, NNOEU
  63. & , INOE
  64. & , LIFAC(3,4), MCHDIA
  65. REAL*8 X1,Y1,X2,Y2,X3,Y3,XCEN,YCEN, SURF, VOLU
  66. & ,X4,Y4,SURF0,VOLU0,XCEN0,YCEN0,XC2D,YC2D,XC20,YC20
  67. CHARACTER*8 TYPI
  68. POINTEUR MELMAI.MELEME, MELCEN.MELEME, MELTFA.MELEME
  69. & , MELSOM.MELEME, MELFAC.MELEME, MELFAL.MELEME, MELFAP.MELEME
  70. POINTEUR MCHVOL.MCHPOI, MPOVOL.MPOVAL
  71. & , MCHS2D.MCHPOI, MPOSUR.MPOVAL, MPOX2D.MPOVAL, MPOY2D.MPOVAL
  72. POINTEUR MLRES.MLENTI, MLRESS.MLENTI, MLEFAC.MLENTI, MLETOF.MLENTI
  73. C
  74. C**** 'MAILLAGE'
  75. C
  76. MELEME=MELEMQ
  77. SEGACT MELEME
  78. SEGINI, MELMAI=MELEME
  79. NBS=MELEME.LISOUS(/1)
  80. IF(NBS.EQ.0)NBS=1
  81. NBREF=0
  82. IF(NBS .EQ. 1)THEN
  83. ITSOUS=MELEME.ITYPEL
  84. IF(ITSOUS .EQ. 7)THEN
  85. C TRI7 -> TRI3
  86. MELMAI.ITYPEL=4
  87. NBNN=3
  88. ELSEIF(ITSOUS .EQ. 11)THEN
  89. C QUA9 -> QUA4
  90. MELMAI.ITYPEL=8
  91. NBNN=4
  92. ENDIF
  93. NBELEM=MELEME.NUM(/2)
  94. NBSOUS=0
  95. SEGADJ MELMAI
  96. NBE0=NBELEM
  97. ELSE
  98. NBE0=0
  99. DO ISOUS=1,NBS,1
  100. IPT1=MELEME.LISOUS(ISOUS)
  101. SEGACT IPT1
  102. ITSOUS=IPT1.ITYPEL
  103. NBELEM=IPT1.NUM(/2)
  104. IF(ITSOUS .EQ. 7)THEN
  105. C TRI7 -> TRI3
  106. NBNN=3
  107. MELMAI.ITYPEL=4
  108. ELSEIF(ITSOUS .EQ. 11)THEN
  109. C QUA9 -> QUA4
  110. MELMAI.ITYPEL=8
  111. NBNN=4
  112. ENDIF
  113. NBSOUS=0
  114. SEGINI IPT2
  115. MELMAI.LISOUS(ISOUS)=IPT2
  116. IPT2.ITYPEL=MELMAI.ITYPEL
  117. MELMAI.ITYPEL=0
  118. NBE0=NBE0+NBELEM
  119. IPT1=MELEME.LISOUS(ISOUS)
  120. ENDDO
  121. ENDIF
  122. CALL ECMO(MTAB,'MAILLAGE','MAILLAGE',MELMAI)
  123. C
  124. C**** 'CENTRE'
  125. C
  126. NBELEM=NBE0
  127. NBNN=1
  128. NBSOUS=0
  129. NBREF=0
  130. SEGINI MELCEN
  131. MELCEN.ITYPEL=1
  132. CALL ECMO(MTAB,'CENTRE','MAILLAGE',MELCEN)
  133. C
  134. C**** 'XXVOLUM', 'XXSURF2D', 'XCEN2D', 'YCEN2D'
  135. C
  136. TYPI='CENTRE '
  137. JGN=4
  138. JGM=1
  139. SEGINI MLMOTS
  140. MLMOTS.MOTS(1)='SCAL'
  141. CALL KRCHP1(TYPI,MELCEN,MCHVOL,MLMOTS)
  142. IF(IERR.NE.0) GOTO 9999
  143. CALL ECMO(MTAB,'XXVOLUM','CHPOINT',MCHVOL)
  144. IF(IERR.NE.0) GOTO 9999
  145. CALL LICHT(MCHVOL,MPOVOL,TYPI,IGEOM)
  146. IF(IERR.NE.0) GOTO 9999
  147. C SEGACT MPOVOL
  148. C
  149. CALL KRCHP1(TYPI,MELCEN,MCHS2D,MLMOTS)
  150. IF(IERR.NE.0) GOTO 9999
  151. CALL ECMO(MTAB,'XXSUR2D','CHPOINT',MCHS2D)
  152. IF(IERR.NE.0) GOTO 9999
  153. CALL LICHT(MCHS2D,MPOSUR,TYPI,IGEOM)
  154. IF(IERR.NE.0) GOTO 9999
  155. C SEGACT MPOSUR
  156. C
  157. CALL KRCHP1(TYPI,MELCEN,MCHX2D,MLMOTS)
  158. IF(IERR.NE.0) GOTO 9999
  159. CALL ECMO(MTAB,'XCEN2D','CHPOINT',MCHX2D)
  160. IF(IERR.NE.0) GOTO 9999
  161. CALL LICHT(MCHX2D,MPOX2D,TYPI,IGEOM)
  162. IF(IERR.NE.0) GOTO 9999
  163. C SEGACT MPOX2D
  164. C
  165. CALL KRCHP1(TYPI,MELCEN,MCHY2D,MLMOTS)
  166. IF(IERR.NE.0) GOTO 9999
  167. CALL ECMO(MTAB,'YCEN2D','CHPOINT',MCHY2D)
  168. IF(IERR.NE.0) GOTO 9999
  169. CALL LICHT(MCHY2D,MPOY2D,TYPI,IGEOM)
  170. IF(IERR.NE.0) GOTO 9999
  171. C SEGACT MPOY2D
  172. SEGSUP MLMOTS
  173. C
  174. C In KRIPAD
  175. C SEGDES MELCEN
  176. SEGACT MELCEN*MOD
  177. C
  178. C**** Filling
  179. C
  180. NBE0=0
  181. DO ISOUS=1,NBS,1
  182. IF(NBS.EQ.1)THEN
  183. IPT1=MELEME
  184. IPT2=MELMAI
  185. ELSE
  186. IPT1=MELEME.LISOUS(ISOUS)
  187. IPT2=MELMAI.LISOUS(ISOUS)
  188. ENDIF
  189. NBELEM=IPT1.NUM(/2)
  190. ITSOUS=IPT1.ITYPEL
  191. IF(ITSOUS .EQ. 7)THEN
  192. C TRI
  193. DO IELEM=1,NBELEM,1
  194. NBE0=NBE0+1
  195. NN1=IPT1.NUM(1,IELEM)
  196. NN2=IPT1.NUM(3,IELEM)
  197. NN3=IPT1.NUM(5,IELEM)
  198. NNC=IPT1.NUM(7,IELEM)
  199. C
  200. IPT2.NUM(1,IELEM)=NN1
  201. IPT2.NUM(2,IELEM)=NN2
  202. IPT2.NUM(3,IELEM)=NN3
  203. IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM)
  204. MELCEN.NUM(1,NBE0)=NNC
  205. MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM)
  206. C
  207. C************* We compute the position of the center
  208. C the 'XXVOLUM'
  209. C the 'XXSUR2D'
  210. C
  211. X1=XCOOR((NN1-1)*(IDIM+1)+1)
  212. Y1=XCOOR((NN1-1)*(IDIM+1)+2)
  213. X2=XCOOR((NN2-1)*(IDIM+1)+1)
  214. Y2=XCOOR((NN2-1)*(IDIM+1)+2)
  215. X3=XCOOR((NN3-1)*(IDIM+1)+1)
  216. Y3=XCOOR((NN3-1)*(IDIM+1)+2)
  217. CALL KDOM4B(X1,Y1,X2,Y2,X3,Y3,VOLU,SURF
  218. & ,XCEN,YCEN,XC2D,YC2D)
  219. C
  220. MPOVOL.VPOCHA(NBE0,1)=VOLU
  221. MPOSUR.VPOCHA(NBE0,1)=SURF
  222. MPOX2D.VPOCHA(NBE0,1)=XC2D
  223. MPOY2D.VPOCHA(NBE0,1)=YC2D
  224. XCOOR((NNC-1)*(IDIM+1)+1)=XCEN
  225. XCOOR((NNC-1)*(IDIM+1)+2)=YCEN
  226. ENDDO
  227. ELSEIF(ITSOUS .EQ. 11)THEN
  228. C QUA
  229. DO IELEM=1,NBELEM,1
  230. NBE0=NBE0+1
  231. NN1=IPT1.NUM(1,IELEM)
  232. NN2=IPT1.NUM(3,IELEM)
  233. NN3=IPT1.NUM(5,IELEM)
  234. NN4=IPT1.NUM(7,IELEM)
  235. NNC=IPT1.NUM(9,IELEM)
  236. C
  237. IPT2.NUM(1,IELEM)=NN1
  238. IPT2.NUM(2,IELEM)=NN2
  239. IPT2.NUM(3,IELEM)=NN3
  240. IPT2.NUM(4,IELEM)=NN4
  241. IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM)
  242. MELCEN.NUM(1,NBE0)=NNC
  243. MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM)
  244. C
  245. C************* We compute the position of the center
  246. C the 'XXVOLUM'
  247. C the 'XXSUR2D'
  248. C
  249. X1=XCOOR((NN1-1)*(IDIM+1)+1)
  250. Y1=XCOOR((NN1-1)*(IDIM+1)+2)
  251. X2=XCOOR((NN2-1)*(IDIM+1)+1)
  252. Y2=XCOOR((NN2-1)*(IDIM+1)+2)
  253. X3=XCOOR((NN3-1)*(IDIM+1)+1)
  254. Y3=XCOOR((NN3-1)*(IDIM+1)+2)
  255. X4=XCOOR((NN4-1)*(IDIM+1)+1)
  256. Y4=XCOOR((NN4-1)*(IDIM+1)+2)
  257. CALL KDOM4B(X1,Y1,X2,Y2,X4,Y4,VOLU0,SURF0,XCEN0,YCEN0
  258. $ ,XC20,YC20)
  259. CALL KDOM4B(X2,Y2,X3,Y3,X4,Y4,VOLU,SURF,XCEN,YCEN
  260. $ ,XC2D,YC2D)
  261. C
  262. MPOVOL.VPOCHA(NBE0,1)=VOLU+VOLU0
  263. MPOSUR.VPOCHA(NBE0,1)=SURF+SURF0
  264. MPOX2D.VPOCHA(NBE0,1)=((XC20*SURF0)+(XC2D*SURF))
  265. $ /(SURF+SURF0)
  266. MPOY2D.VPOCHA(NBE0,1)=((YC20*SURF0)+(YC2D*SURF))
  267. $ /(SURF+SURF0)
  268. XCOOR((NNC-1)*(IDIM+1)+1)=((XCEN0*VOLU0)+(XCEN*VOLU))
  269. $ /(VOLU+VOLU0)
  270. XCOOR((NNC-1)*(IDIM+1)+2)=((YCEN0*VOLU0)+(YCEN*VOLU))
  271. $ /(VOLU+VOLU0)
  272. ENDDO
  273. ENDIF
  274. SEGDES IPT2
  275. ENDDO
  276. C
  277. IF(NBS.NE.1)THEN
  278. SEGDES MELMAI
  279. ENDIF
  280. C
  281. SEGDES MPOSUR
  282. SEGDES MPOVOL
  283. SEGDES MELCEN
  284. C
  285. C MELEME et ses "fils" sont toujours actifs
  286. C
  287. C**** We create ELTFA, FACE and SOMMET
  288. C N.B. The position of the noeud belonging to the FACE
  289. C is not correct
  290. C
  291. SEGINI, MELTFA=MELEME
  292. NBREF=0
  293. IF(NBS .EQ. 1)THEN
  294. ITSOUS=MELEME.ITYPEL
  295. IF(ITSOUS .EQ. 7)THEN
  296. C TRI3
  297. NBNN=3
  298. MELTFA.ITYPEL=4
  299. C ELTFA TRI3
  300. ELSEIF(ITSOUS .EQ. 11)THEN
  301. C QUA4
  302. NBNN=4
  303. MELTFA.ITYPEL=8
  304. C ELTFA QUA4
  305. ENDIF
  306. NBELEM=MELEME.NUM(/2)
  307. NBSOUS=0
  308. SEGADJ MELTFA
  309. ELSE
  310. DO ISOUS=1,NBS,1
  311. IPT1=MELEME.LISOUS(ISOUS)
  312. NBELEM=IPT1.NUM(/2)
  313. ITSOUS=IPT1.ITYPEL
  314. IF(ITSOUS .EQ. 7)THEN
  315. C TRI3
  316. NBNN=3
  317. MELTFA.ITYPEL=4
  318. ELSEIF(ITSOUS .EQ. 11)THEN
  319. C QUA4
  320. NBNN=4
  321. MELTFA.ITYPEL=8
  322. C ELTFA QUA4
  323. ENDIF
  324. NBSOUS=0
  325. SEGINI IPT2
  326. MELTFA.LISOUS(ISOUS)=IPT2
  327. C
  328. IPT2.ITYPEL=MELTFA.ITYPEL
  329. MELTFA.ITYPEL=0
  330. ENDDO
  331. ENDIF
  332. C
  333. C**** We fill ELTFA
  334. C We also count:
  335. C NFAC = number of non-triangular faces
  336. C NSOM = number of SOMMET
  337. C
  338. NTP=MCOORD.XCOOR(/1)/(IDIM+1)
  339. JG=NTP
  340. NFAC=0
  341. NSOM=0
  342.  
  343. LAST=-1
  344. SEGINI MLRES
  345. LASTS=-1
  346. SEGINI MLRESS
  347. C LAST+MLRES = chaining list to find the faces
  348. C LASTS+MLRESS = chaining list to find the sommet
  349.  
  350. DO ISOUS=1,NBS,1
  351. IF(NBS.EQ.1) THEN
  352. IPT1=MELEME
  353. IPT2=MELTFA
  354. ELSE
  355. IPT1=MELEME.LISOUS(ISOUS)
  356. IPT2=MELTFA.LISOUS(ISOUS)
  357. ENDIF
  358. C
  359. NBELEM=IPT1.NUM(/2)
  360. ITSOUS=IPT1.ITYPEL
  361. IF(ITSOUS .EQ. 7)THEN
  362. C TRI (2D)
  363. LISFAC(1)=2
  364. LISFAC(2)=4
  365. LISFAC(3)=6
  366. LISSOM(1)=1
  367. LISSOM(2)=3
  368. LISSOM(3)=5
  369. NNS=3
  370. NNOEU=3
  371. ELSEIF(ITSOUS .EQ. 11)THEN
  372. C QUA (2D)
  373. LISFAC(1)=2
  374. LISFAC(2)=4
  375. LISFAC(3)=6
  376. LISFAC(4)=8
  377. LISSOM(1)=1
  378. LISSOM(2)=3
  379. LISSOM(3)=5
  380. LISSOM(4)=7
  381. NNS=4
  382. NNOEU=4
  383. ENDIF
  384. C
  385. DO IELEM=1,NBELEM,1
  386. DO INOE=1,NNOEU,1
  387. NN1=IPT1.NUM(LISFAC(INOE),IELEM)
  388. IPT2.NUM(INOE,IELEM)=NN1
  389. IF(MLRES.LECT(NN1) .EQ. 0)THEN
  390. NFAC=NFAC+1
  391. MLRES.LECT(NN1)=LAST
  392. LAST=NN1
  393. ENDIF
  394. ENDDO
  395. DO INOE=1,NNS,1
  396. NN1=IPT1.NUM(LISSOM(INOE),IELEM)
  397. IF(MLRESS.LECT(NN1) .EQ. 0)THEN
  398. NSOM=NSOM+1
  399. MLRESS.LECT(NN1)=LASTS
  400. LASTS=NN1
  401. ENDIF
  402. ENDDO
  403. ENDDO
  404. C
  405. SEGDES IPT2
  406. C
  407. ENDDO
  408. IF(NBS. NE. 1) SEGDES MELTFA
  409. CALL ECMO(MTAB,'ELTFA','MAILLAGE',MELTFA)
  410. IF(IERR .NE. 0) GOTO 9999
  411. C
  412. C******** Creation of SOMMET
  413. C
  414. NBELEM=NSOM
  415. NBNN=1
  416. NBSOUS=0
  417. NBREF=0
  418. SEGINI MELSOM
  419. MELSOM.ITYPEL=1
  420. DO IELEM=1,NSOM,1
  421. MELSOM.NUM(1,IELEM)=LASTS
  422. LASTS=MLRESS.LECT(LASTS)
  423. ENDDO
  424. IF(LASTS .NE. -1)THEN
  425. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  426. CALL ERREUR(5)
  427. ENDIF
  428. call crech1(melsom,1)
  429. SEGDES MELSOM
  430. CALL ECMO(MTAB,'SOMMET','MAILLAGE',MELSOM)
  431. SEGSUP MLRESS
  432. C
  433. C**** Creation of FACE
  434. C
  435. NBELEM=NFAC
  436. NBNN=1
  437. NBSOUS=0
  438. NBREF=0
  439. SEGINI MELFAC
  440. MELFAC.ITYPEL=1
  441. DO IELEM=1,NFAC,1
  442. MELFAC.NUM(1,IELEM)=LAST
  443. LAST=MLRES.LECT(LAST)
  444. ENDDO
  445. IF(LAST .NE. -1)THEN
  446. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  447. CALL ERREUR(5)
  448. ENDIF
  449. SEGDES MELFAC
  450. SEGSUP MLRES
  451. CALL ECMO(MTAB,'FACE','MAILLAGE',MELFAC)
  452. C
  453. C******* Creation of FACEL and FACEP
  454. C
  455. CALL KRIPAD(MELFAC,MLEFAC)
  456. C SEGINI MLEFAC
  457. JG=NFAC
  458. SEGINI MLETOF
  459. C
  460. C MLETOF.LECT(I1) = how many times has the i-th face of MELFAP
  461. C already been touched?
  462. C
  463. NBELEM=NFAC
  464. NBNN=3
  465. NBSOUS=0
  466. NBREF=0
  467. SEGINI MELFAL
  468. MELFAL.ITYPEL=3
  469. C
  470. C FACEP is a SEG3
  471. C
  472. NBELEM=NFAC
  473. NBNN=3
  474. NBSOUS=0
  475. NBREF=0
  476. SEGINI MELFAP
  477. MELFAP.ITYPEL=3
  478. C
  479. DO ISOUS=1,NBS,1
  480. C
  481. C********** Loop on the elementary mesh of the QUAF
  482. C
  483. IF(NBS.EQ.1) THEN
  484. IPT1=MELEME
  485. ELSE
  486. IPT1=MELEME.LISOUS(ISOUS)
  487. ENDIF
  488. C
  489. ITSOUS=IPT1.ITYPEL
  490. IF(ITSOUS .EQ. 7)THEN
  491. C TRI (2D)
  492. LIFAC(1,1)=2
  493. LIFAC(2,1)=1
  494. LIFAC(3,1)=3
  495. LIFAC(1,2)=4
  496. LIFAC(2,2)=3
  497. LIFAC(3,2)=5
  498. LIFAC(1,3)=6
  499. LIFAC(2,3)=5
  500. LIFAC(3,3)=1
  501. C Here we put the center point in LISSOM
  502. LISSOM(1)=7
  503. NNOEU=3
  504. C
  505. ELSEIF(ITSOUS .EQ. 11)THEN
  506. C QUA (2D)
  507. LIFAC(1,1)=2
  508. LIFAC(2,1)=1
  509. LIFAC(3,1)=3
  510. LIFAC(1,2)=4
  511. LIFAC(2,2)=3
  512. LIFAC(3,2)=5
  513. LIFAC(1,3)=6
  514. LIFAC(2,3)=5
  515. LIFAC(3,3)=7
  516. LIFAC(1,4)=8
  517. LIFAC(2,4)=7
  518. LIFAC(3,4)=1
  519. LISSOM(1)=9
  520. NNOEU=4
  521. ENDIF
  522. C
  523. NBELEM=IPT1.NUM(/2)
  524. DO IELEM=1,NBELEM,1
  525. C NNOEU = number of quagrangular elements
  526. DO INOE=1,NNOEU,1
  527. C NN1 is the global number of the face
  528. C NN2 is the local number of the face in the MELEME
  529. C 'FACE'
  530. C
  531. NN1=IPT1.NUM(LIFAC(1,INOE),IELEM)
  532. NN2=MLEFAC.LECT(NN1)
  533. IF(MLETOF.LECT(NN2).EQ.0)THEN
  534. C
  535. C MLETOF.LECT(NN2) = how many times the face NN2 has
  536. C been touched?
  537. C
  538. MLETOF.LECT(NN2)=1
  539. MELFAL.NUM(2,NN2)=NN1
  540. MELFAL.NUM(1,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  541. MELFAL.NUM(3,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  542. MELFAP.NUM(1,NN2)=IPT1.NUM(LIFAC(2,INOE),IELEM)
  543. MELFAP.NUM(2,NN2)=IPT1.NUM(LIFAC(3,INOE),IELEM)
  544. MELFAP.NUM(3,NN2)=NN1
  545. ELSEIF(MLETOF.LECT(NN2).EQ.1)THEN
  546. MLETOF.LECT(NN2)=2
  547. MELFAL.NUM(3,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  548. ELSE
  549. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  550. CALL ERREUR(5)
  551. ENDIF
  552. ENDDO
  553. ENDDO
  554. ENDDO
  555. SEGDES MELFAL
  556. SEGDES MELFAP
  557. SEGSUP MLETOF
  558. SEGSUP MLEFAC
  559. CALL ECMO(MTAB,'FACEL','MAILLAGE',MELFAL)
  560. IF(IERR .NE. 0) GOTO 9999
  561. CALL ECMO(MTAB,'FACEP','MAILLAGE',MELFAP)
  562. IF(IERR .NE. 0) GOTO 9999
  563. IF(NBS.NE.1)THEN
  564. SEGDES MELEME
  565. ENDIF
  566. C
  567. C**** We have to create
  568. C 'XXSURFAC'
  569. C 'XXNORMAF'
  570. C 'MATROT'
  571. C and to put the face centre in the right position!
  572. C
  573. CALL KDOM4C(MELFAC,MELFAL,MELFAP,MCHPSU,MCHPNO,MCHPMR)
  574. IF(IERR.NE.0)GOTO 9999
  575. C
  576. CALL ECMO(MTAB,'XXSURFAC','CHPOINT',MCHPSU)
  577. IF(IERR.NE.0) GOTO 9999
  578. CALL ECMO(MTAB,'XXNORMAF','CHPOINT',MCHPNO)
  579. IF(IERR.NE.0) GOTO 9999
  580. CALL ECMO(MTAB,'MATROT','CHPOINT',MCHPMR)
  581. IF(IERR.NE.0) GOTO 9999
  582. C
  583. C**** Finally, we compute XXDIEMIN
  584. C
  585. CALL KDOM12(MELTFA,MELCEN,MELFAC,MCHPNO,MCHDIA)
  586. IF(IERR.NE.0) GOTO 9999
  587. CALL ECMO(MTAB,'XXDIEMIN','CHPOINT',MCHDIA)
  588. IF(IERR.NE.0) GOTO 9999
  589. C
  590. 9999 RETURN
  591. END
  592.  
  593.  
  594.  
  595.  
  596.  

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