Télécharger kdom10.eso

Retour à la liste

Numérotation des lignes :

  1. C KDOM10 SOURCE KK2000 14/04/10 21:15:09 8032
  2. SUBROUTINE KDOM10(MTAB)
  3. C
  4. C************************************************************************
  5. C
  6. C PROJET : CASTEM 2000
  7. C
  8. C NOM : KDOM10
  9. C
  10. C DESCRIPTION : Subroutine called by KDOM1 in the case of EULER
  11. C model
  12. C We fill the domain table MTAB
  13. C
  14. C LANGAGE : FORTRAN 77 + ESOPE 2000 (avec estensions CISI)
  15. C
  16. C AUTEUR : A. BECCANTINI, DRN/DMT/SEMT/LTMF
  17. C
  18. C************************************************************************
  19. C
  20. C
  21. IMPLICIT INTEGER(I-N)
  22. IMPLICIT REAL*8(A-H,O-Z)
  23. C
  24. INTEGER MTAB, JG, IELEM, ISOUS, NBELEM, NBNN, NBREF, NBSOUS, NBS
  25. & ,NBE0, IGEOM, JGM, JGN, NN1, NN2, NN3, NN4, NN5, NN6, NTP
  26. & ,LAST, LISFAC(6), INOE, NNOEU, NFAC, NNOEUT, LISFAT(4), NFACT
  27. & ,LASTT,IFAC, NSOM, LASTS, NNS, LISSOM(8),LIFAC(5,6)
  28. & ,LIFACT(4,4), NBSFP, MCHPSU, MCHPNO, MCHPMR, MCHDIA
  29. REAl*8 VOL, CEL(3), VOL1
  30. LOGICAL LOGCOM
  31. CHARACTER*8 TYPI
  32. -INC CCOPTIO
  33. -INC SMELEME
  34. -INC SMLENTI
  35. -INC SMCHPOI
  36. -INC SMLMOTS
  37. -INC SMCOORD
  38. POINTEUR MELCEN.MELEME, MELMAI.MELEME, MLREST.MLENTI
  39. & , MLRES.MLENTI, MELTFA.MELEME, MLRESS.MLENTI
  40. & , MELSOM.MELEME, MELFAC.MELEME, MELFAL.MELEME, MLEFAC.MLENTI
  41. & , MLETOF.MLENTI, IPTT.MELEME, IPTQ.MELEME, MELFAP.MELEME
  42. C
  43. C Elements allowed are 'SEG3' 'TRI7' 'QUA9' 'TE15' 'PY19' 'PR21' 'CU27'
  44. C ITYPEL 3 7 11 35 36 34 33
  45. C
  46. TYPI='MAILLAGE'
  47. CALL ACMO(MTAB,'QUAF',TYPI,MELEME)
  48. IF(IERR.NE.0)GOTO 9999
  49. C
  50. C 2D 3D
  51. C**** 'MAILLAGE' complex 1D/2D elts 2D/3D elts
  52. C 'CENTRE' 'POI1' (ITYPEL = 1) 1D/2D elts 2D/3D elts
  53. C 'SOMMET' 'POI1' (ITYPEL = 1) 2D elts 3D elts
  54. C 'FACE' 'POI1' (ITYPEL = 1) 2D elts 3D elts
  55. C 'FACEL' 'SEG3' (ITYPEL = 3) 2D elts 3D elts
  56. C 'FACEP' 'SEG3' (ITYPEL = 3) in 2D 2D elts 3D elts
  57. C complex in 3D
  58. C
  59. C 'ELTFA' complex 2D elts 3D elts
  60. C
  61. SEGACT MELEME
  62. NBS=MELEME.LISOUS(/1)
  63. IF(NBS .EQ. 0) NBS=1
  64. JG=NBS
  65. C MLENTI contains ITYPEL
  66. C MLENT1 contains NBELEM
  67. SEGINI MLENTI
  68. SEGINI MLENT1
  69. DO ISOUS=1,NBS,1
  70. IF(NBS .NE. 1)THEN
  71. IPT1=MELEME.LISOUS(ISOUS)
  72. SEGACT IPT1
  73. ELSE
  74. IPT1=MELEME
  75. ENDIF
  76. C We have already checked the elements available in KDOM2
  77. C We have already checked that they are referred just ONCE
  78. C (each MELEME.LISOUS(ISOUS) has different ITYPEL)
  79. C
  80. MLENTI.LECT(ISOUS)=IPT1.ITYPEL
  81. MLENT1.LECT(ISOUS)=IPT1.NUM(/2)
  82. ENDDO
  83. C
  84. C**** Compatibility check
  85. C
  86. C We do not allow 1D/2D meshes and 2D/3D meshes
  87. C
  88. IF(IDIM.EQ.2)THEN
  89. IF(MLENTI.LECT(1) .EQ. 3)THEN
  90. LOGCOM=.FALSE.
  91. IF(NBS .NE. 1)THEN
  92. WRITE(IOIMP,*) 'Euler model'
  93. CALL ERREUR(21)
  94. GOTO 9999
  95. ENDIF
  96. ELSE
  97. LOGCOM=.TRUE.
  98. DO ISOUS=2,NBS,1
  99. IF(MLENTI.LECT(ISOUS) .EQ. 3)THEN
  100. WRITE(IOIMP,*) 'Euler model'
  101. WRITE(IOIMP,*) 'No mixing between 1D and 2D'
  102. CALL ERREUR(21)
  103. GOTO 9999
  104. ENDIF
  105. ENDDO
  106. ENDIF
  107. ELSE
  108. C
  109. C****** 3D.
  110. C No 1D possibility
  111. C
  112. DO ISOUS=1,NBS,1
  113. IF(MLENTI.LECT(ISOUS) .EQ. 3)THEN
  114. WRITE(IOIMP,*) 'Euler model'
  115. WRITE(IOIMP,*) 'No 1D meshes in 3D'
  116. CALL ERREUR(21)
  117. GOTO 9999
  118. ENDIF
  119. ENDDO
  120. C
  121. IF((MLENTI.LECT(1) .EQ. 7) .OR. (MLENTI.LECT(1) .EQ. 11))THEN
  122. LOGCOM=.FALSE.
  123. DO ISOUS=1,NBS,1
  124. IF((MLENTI.LECT(ISOUS) .NE. 7) .AND.
  125. & (MLENTI.LECT(ISOUS) .NE. 11))THEN
  126. WRITE(IOIMP,*) 'Euler model'
  127. WRITE(IOIMP,*) 'No mixing between 2D and 3D'
  128. CALL ERREUR(21)
  129. GOTO 9999
  130. ENDIF
  131. ENDDO
  132. ELSE
  133. LOGCOM=.TRUE.
  134. DO ISOUS=2,NBS,1
  135. IF((MLENTI.LECT(NBS) .EQ. 7) .OR.
  136. & (MLENTI.LECT(NBS) .EQ. 11))THEN
  137. WRITE(IOIMP,*) 'Euler model'
  138. WRITE(IOIMP,*) 'No mixing between 2D and 3D'
  139. CALL ERREUR(21)
  140. GOTO 9999
  141. ENDIF
  142. ENDDO
  143. ENDIF
  144. ENDIF
  145. C
  146. C**** 'MAILLAGE'
  147. C 'CENTRE'
  148. C
  149. C Initialisation
  150. C
  151. SEGINI, MELMAI=MELEME
  152. NBREF=0
  153. IF(NBS .EQ. 1)THEN
  154. ISOUS=1
  155. IF(MLENTI.LECT(ISOUS) .EQ. 3)THEN
  156. C SEG3 -> SEG2
  157. MELMAI.ITYPEL=2
  158. NBNN=2
  159. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  160. C TRI7 -> TRI3
  161. MELMAI.ITYPEL=4
  162. NBNN=3
  163. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  164. C QUA9 -> QUA4
  165. MELMAI.ITYPEL=8
  166. NBNN=4
  167. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  168. C TE15 -> TET4
  169. MELMAI.ITYPEL=23
  170. NBNN=4
  171. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  172. C PY19 -> PYR5
  173. MELMAI.ITYPEL=25
  174. NBNN=5
  175. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  176. C PR21 -> PRI6
  177. MELMAI.ITYPEL=16
  178. NBNN=6
  179. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  180. C CU27 -> CUB8
  181. MELMAI.ITYPEL=14
  182. NBNN=8
  183. ENDIF
  184. NBELEM=MLENT1.LECT(ISOUS)
  185. NBSOUS=0
  186. SEGADJ MELMAI
  187. NBE0=NBELEM
  188. ELSE
  189. NBE0=0
  190. DO ISOUS=1,NBS,1
  191. NBELEM=MLENT1.LECT(ISOUS)
  192. IF(MLENTI.LECT(ISOUS) .EQ. 3)THEN
  193. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  194. CALL ERREUR(5)
  195. GOTO 9999
  196. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  197. C TRI7 -> TRI3
  198. NBNN=3
  199. MELMAI.ITYPEL=4
  200. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  201. C QUA9 -> QUA4
  202. MELMAI.ITYPEL=8
  203. NBNN=4
  204. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  205. C TE15 -> TET4
  206. MELMAI.ITYPEL=23
  207. NBNN=4
  208. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  209. C PY19 -> PYR5
  210. MELMAI.ITYPEL=25
  211. NBNN=5
  212. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  213. C PR21 -> PRI6
  214. MELMAI.ITYPEL=16
  215. NBNN=6
  216. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  217. C CU27 -> CUB8
  218. MELMAI.ITYPEL=14
  219. NBNN=8
  220. ENDIF
  221. NBSOUS=0
  222. SEGINI IPT2
  223. MELMAI.LISOUS(ISOUS)=IPT2
  224. IPT2.ITYPEL=MELMAI.ITYPEL
  225. MELMAI.ITYPEL=0
  226. NBE0=NBE0+NBELEM
  227. IPT1=MELEME.LISOUS(ISOUS)
  228. ENDDO
  229. ENDIF
  230. C
  231. NBELEM=NBE0
  232. NBNN=1
  233. NBSOUS=0
  234. NBREF=0
  235. SEGINI MELCEN
  236. MELCEN.ITYPEL=1
  237. NBE0=0
  238. C
  239. C**** Filling
  240. C
  241. DO ISOUS=1,NBS,1
  242. IF(NBS.EQ.1)THEN
  243. IPT1=MELEME
  244. IPT2=MELMAI
  245. ELSE
  246. IPT1=MELEME.LISOUS(ISOUS)
  247. IPT2=MELMAI.LISOUS(ISOUS)
  248. ENDIF
  249. NBELEM=MLENT1.LECT(ISOUS)
  250. IF(MLENTI.LECT(ISOUS) .EQ. 3)THEN
  251. C SEG
  252. DO IELEM=1,NBELEM,1
  253. NBE0=NBE0+1
  254. IPT2.NUM(1,IELEM)=IPT1.NUM(1,IELEM)
  255. IPT2.NUM(2,IELEM)=IPT1.NUM(3,IELEM)
  256. IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM)
  257. MELCEN.NUM(1,NBE0)=IPT1.NUM(2,IELEM)
  258. MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM)
  259. ENDDO
  260. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  261. C TRI
  262. DO IELEM=1,NBELEM,1
  263. NBE0=NBE0+1
  264. IPT2.NUM(1,IELEM)=IPT1.NUM(1,IELEM)
  265. IPT2.NUM(2,IELEM)=IPT1.NUM(3,IELEM)
  266. IPT2.NUM(3,IELEM)=IPT1.NUM(5,IELEM)
  267. IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM)
  268. MELCEN.NUM(1,NBE0)=IPT1.NUM(7,IELEM)
  269. MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM)
  270. ENDDO
  271. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  272. C QUA
  273. DO IELEM=1,NBELEM,1
  274. NBE0=NBE0+1
  275. IPT2.NUM(1,IELEM)=IPT1.NUM(1,IELEM)
  276. IPT2.NUM(2,IELEM)=IPT1.NUM(3,IELEM)
  277. IPT2.NUM(3,IELEM)=IPT1.NUM(5,IELEM)
  278. IPT2.NUM(4,IELEM)=IPT1.NUM(7,IELEM)
  279. IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM)
  280. MELCEN.NUM(1,NBE0)=IPT1.NUM(9,IELEM)
  281. MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM)
  282. ENDDO
  283. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  284. C TET
  285. DO IELEM=1,NBELEM,1
  286. NBE0=NBE0+1
  287. IPT2.NUM(1,IELEM)=IPT1.NUM(1,IELEM)
  288. IPT2.NUM(2,IELEM)=IPT1.NUM(3,IELEM)
  289. IPT2.NUM(3,IELEM)=IPT1.NUM(5,IELEM)
  290. IPT2.NUM(4,IELEM)=IPT1.NUM(10,IELEM)
  291. IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM)
  292. MELCEN.NUM(1,NBE0)=IPT1.NUM(15,IELEM)
  293. MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM)
  294. ENDDO
  295. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  296. C PYR
  297. DO IELEM=1,NBELEM,1
  298. NBE0=NBE0+1
  299. IPT2.NUM(1,IELEM)=IPT1.NUM(1,IELEM)
  300. IPT2.NUM(2,IELEM)=IPT1.NUM(3,IELEM)
  301. IPT2.NUM(3,IELEM)=IPT1.NUM(5,IELEM)
  302. IPT2.NUM(4,IELEM)=IPT1.NUM(7,IELEM)
  303. IPT2.NUM(5,IELEM)=IPT1.NUM(13,IELEM)
  304. IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM)
  305. MELCEN.NUM(1,NBE0)=IPT1.NUM(19,IELEM)
  306. MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM)
  307. ENDDO
  308. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  309. C PRI
  310. DO IELEM=1,NBELEM,1
  311. NBE0=NBE0+1
  312. IPT2.NUM(1,IELEM)=IPT1.NUM(1,IELEM)
  313. IPT2.NUM(2,IELEM)=IPT1.NUM(3,IELEM)
  314. IPT2.NUM(3,IELEM)=IPT1.NUM(5,IELEM)
  315. IPT2.NUM(4,IELEM)=IPT1.NUM(10,IELEM)
  316. IPT2.NUM(5,IELEM)=IPT1.NUM(12,IELEM)
  317. IPT2.NUM(6,IELEM)=IPT1.NUM(14,IELEM)
  318. IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM)
  319. MELCEN.NUM(1,NBE0)=IPT1.NUM(21,IELEM)
  320. MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM)
  321. ENDDO
  322. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  323. C CUB
  324. DO IELEM=1,NBELEM,1
  325. NBE0=NBE0+1
  326. IPT2.NUM(1,IELEM)=IPT1.NUM(1,IELEM)
  327. IPT2.NUM(2,IELEM)=IPT1.NUM(3,IELEM)
  328. IPT2.NUM(3,IELEM)=IPT1.NUM(5,IELEM)
  329. IPT2.NUM(4,IELEM)=IPT1.NUM(7,IELEM)
  330. IPT2.NUM(5,IELEM)=IPT1.NUM(13,IELEM)
  331. IPT2.NUM(6,IELEM)=IPT1.NUM(15,IELEM)
  332. IPT2.NUM(7,IELEM)=IPT1.NUM(17,IELEM)
  333. IPT2.NUM(8,IELEM)=IPT1.NUM(19,IELEM)
  334. IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM)
  335. MELCEN.NUM(1,NBE0)=IPT1.NUM(27,IELEM)
  336. MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM)
  337. ENDDO
  338. ELSE
  339. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  340. CALL ERREUR(5)
  341. ENDIF
  342. IF(NBS .NE. 1)THEN
  343. SEGDES IPT2
  344. ENDIF
  345. ENDDO
  346. CALL ECMO(MTAB,'MAILLAGE','MAILLAGE',MELMAI)
  347. CALL ECMO(MTAB,'CENTRE','MAILLAGE',MELCEN)
  348. SEGDES MELCEN
  349. SEGDES MELMAI
  350. C
  351. C**** Volume
  352. C
  353. TYPI='CENTRE '
  354. JGN=4
  355. JGM=1
  356. SEGINI MLMOTS
  357. MLMOTS.MOTS(1)='SCAL'
  358. CALL KRCHP1(TYPI,MELCEN,MCHPOI,MLMOTS)
  359. CALL LICHT(MCHPOI,MPOVAL,TYPI,IGEOM)
  360. C SEGACT MPOVAL
  361. C
  362. SEGSUP MLMOTS
  363. NBE0=0
  364. DO ISOUS=1,NBS,1
  365. IF(NBS.EQ.1) THEN
  366. IPT1=MELEME
  367. ELSE
  368. IPT1=MELEME.LISOUS(ISOUS)
  369. ENDIF
  370. C
  371. NBELEM=MLENT1.LECT(ISOUS)
  372. IF(MLENTI.LECT(ISOUS) .EQ. 3)THEN
  373. C SEG3
  374. DO IELEM=1,NBELEM,1
  375. NBE0=NBE0+1
  376. NN1=IPT1.NUM(1,IELEM)
  377. NN2=IPT1.NUM(2,IELEM)
  378. NN3=IPT1.NUM(3,IELEM)
  379. CALL KDOM5(NN1,NN2,NN3,VOL)
  380. MPOVAL.VPOCHA(NBE0,1)=VOL
  381. ENDDO
  382. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  383. C TRI
  384. DO IELEM=1,NBELEM,1
  385. NBE0=NBE0+1
  386. NN1=IPT1.NUM(1,IELEM)
  387. NN2=IPT1.NUM(3,IELEM)
  388. NN3=IPT1.NUM(5,IELEM)
  389. NN4=IPT1.NUM(7,IELEM)
  390. C Vol TRI7 as a vol of a degenerate QUA9
  391. CALL KDOM6(NN1,NN2,NN3,NN3,NN4,VOL)
  392. MPOVAL.VPOCHA(NBE0,1)=VOL
  393. ENDDO
  394. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  395. C QUA
  396. DO IELEM=1,NBELEM,1
  397. NBE0=NBE0+1
  398. NN1=IPT1.NUM(1,IELEM)
  399. NN2=IPT1.NUM(3,IELEM)
  400. NN3=IPT1.NUM(5,IELEM)
  401. NN4=IPT1.NUM(7,IELEM)
  402. NN5=IPT1.NUM(9,IELEM)
  403. CALL KDOM6(NN1,NN2,NN3,NN4,NN5,VOL)
  404. MPOVAL.VPOCHA(NBE0,1)=VOL
  405. ENDDO
  406. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  407. C TET
  408. DO IELEM=1,NBELEM,1
  409. NBE0=NBE0+1
  410. NN1=IPT1.NUM(1,IELEM)
  411. NN2=IPT1.NUM(3,IELEM)
  412. NN3=IPT1.NUM(5,IELEM)
  413. NN4=IPT1.NUM(10,IELEM)
  414. CALL KDOM4(NN1,NN2,NN3,NN4,CEL,VOL)
  415. MPOVAL.VPOCHA(NBE0,1)=ABS(VOL)
  416. ENDDO
  417. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  418. C PYR
  419. DO IELEM=1,NBELEM,1
  420. NBE0=NBE0+1
  421. NN1=IPT1.NUM(1,IELEM)
  422. NN2=IPT1.NUM(3,IELEM)
  423. NN3=IPT1.NUM(5,IELEM)
  424. NN4=IPT1.NUM(7,IELEM)
  425. NN5=IPT1.NUM(14,IELEM)
  426. NN6=IPT1.NUM(13,IELEM)
  427. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL)
  428. MPOVAL.VPOCHA(NBE0,1)=ABS(VOL)
  429. ENDDO
  430. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  431. C PRI
  432. C To compute the volume, we divide it into 2
  433. C TET et 3 PYR
  434. C
  435. DO IELEM=1,NBELEM,1
  436. VOL=0.0D0
  437. NBE0=NBE0+1
  438. NN1=IPT1.NUM(1,IELEM)
  439. NN2=IPT1.NUM(3,IELEM)
  440. NN3=IPT1.NUM(5,IELEM)
  441. NN4=IPT1.NUM(21,IELEM)
  442. CALL KDOM4(NN1,NN2,NN3,NN4,CEL,VOL1)
  443. VOL=VOL+VOL1
  444. NN1=IPT1.NUM(14,IELEM)
  445. NN2=IPT1.NUM(12,IELEM)
  446. NN3=IPT1.NUM(10,IELEM)
  447. NN4=IPT1.NUM(21,IELEM)
  448. CALL KDOM4(NN1,NN2,NN3,NN4,CEL,VOL1)
  449. VOL=VOL+VOL1
  450. NN1=IPT1.NUM(1,IELEM)
  451. NN2=IPT1.NUM(10,IELEM)
  452. NN3=IPT1.NUM(12,IELEM)
  453. NN4=IPT1.NUM(3,IELEM)
  454. NN5=IPT1.NUM(16,IELEM)
  455. NN6=IPT1.NUM(21,IELEM)
  456. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  457. VOL=VOL+VOL1
  458. NN1=IPT1.NUM(3,IELEM)
  459. NN2=IPT1.NUM(12,IELEM)
  460. NN3=IPT1.NUM(14,IELEM)
  461. NN4=IPT1.NUM(5,IELEM)
  462. NN5=IPT1.NUM(17,IELEM)
  463. NN6=IPT1.NUM(21,IELEM)
  464. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  465. VOL=VOL+VOL1
  466. NN1=IPT1.NUM(10,IELEM)
  467. NN2=IPT1.NUM(1,IELEM)
  468. NN3=IPT1.NUM(5,IELEM)
  469. NN4=IPT1.NUM(14,IELEM)
  470. NN5=IPT1.NUM(18,IELEM)
  471. NN6=IPT1.NUM(21,IELEM)
  472. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  473. VOL=VOL+VOL1
  474. MPOVAL.VPOCHA(NBE0,1)=ABS(VOL)
  475. ENDDO
  476. C
  477. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  478. C CUB
  479. C To compute the volume, we divide it into 6 PYR
  480. C
  481. DO IELEM=1,NBELEM,1
  482. VOL=0.0D0
  483. NBE0=NBE0+1
  484. NN1=IPT1.NUM(1,IELEM)
  485. NN2=IPT1.NUM(3,IELEM)
  486. NN3=IPT1.NUM(5,IELEM)
  487. NN4=IPT1.NUM(7,IELEM)
  488. NN5=IPT1.NUM(25,IELEM)
  489. NN6=IPT1.NUM(27,IELEM)
  490. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  491. VOL=VOL+VOL1
  492. NN1=IPT1.NUM(19,IELEM)
  493. NN2=IPT1.NUM(17,IELEM)
  494. NN3=IPT1.NUM(15,IELEM)
  495. NN4=IPT1.NUM(13,IELEM)
  496. NN5=IPT1.NUM(26,IELEM)
  497. NN6=IPT1.NUM(27,IELEM)
  498. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  499. VOL=VOL+VOL1
  500. NN1=IPT1.NUM(1,IELEM)
  501. NN2=IPT1.NUM(13,IELEM)
  502. NN3=IPT1.NUM(15,IELEM)
  503. NN4=IPT1.NUM(3,IELEM)
  504. NN5=IPT1.NUM(21,IELEM)
  505. NN6=IPT1.NUM(27,IELEM)
  506. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  507. VOL=VOL+VOL1
  508. NN1=IPT1.NUM(3,IELEM)
  509. NN2=IPT1.NUM(15,IELEM)
  510. NN3=IPT1.NUM(17,IELEM)
  511. NN4=IPT1.NUM(5,IELEM)
  512. NN5=IPT1.NUM(22,IELEM)
  513. NN6=IPT1.NUM(27,IELEM)
  514. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  515. VOL=VOL+VOL1
  516. NN1=IPT1.NUM(7,IELEM)
  517. NN2=IPT1.NUM(5,IELEM)
  518. NN3=IPT1.NUM(17,IELEM)
  519. NN4=IPT1.NUM(19,IELEM)
  520. NN5=IPT1.NUM(23,IELEM)
  521. NN6=IPT1.NUM(27,IELEM)
  522. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  523. VOL=VOL+VOL1
  524. NN1=IPT1.NUM(19,IELEM)
  525. NN2=IPT1.NUM(13,IELEM)
  526. NN3=IPT1.NUM(1,IELEM)
  527. NN4=IPT1.NUM(7,IELEM)
  528. NN5=IPT1.NUM(24,IELEM)
  529. NN6=IPT1.NUM(27,IELEM)
  530. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  531. VOL=VOL+VOL1
  532. MPOVAL.VPOCHA(NBE0,1)=ABS(VOL)
  533. ENDDO
  534. ELSE
  535. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  536. CALL ERREUR(5)
  537. ENDIF
  538. ENDDO
  539. C
  540. SEGDES MPOVAL
  541. CALL ECMO(MTAB,'XXVOLUM','CHPOINT',MCHPOI)
  542. C
  543. C
  544. C**** For the moment we have:
  545. C 'QUAF'
  546. C 'MAILLAGE'
  547. C 'CENTRE'
  548. C 'XXVOLUM'
  549. C
  550. C In the complete case (2D mesh in 2D and 3D mesh in 3D):
  551. C
  552. IF(LOGCOM)THEN
  553. C
  554. C******* We create ELTFA
  555. C
  556. SEGINI, MELTFA=MELEME
  557. NBREF=0
  558. IF(NBS .EQ. 1)THEN
  559. ISOUS=1
  560. IF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  561. C TRI3
  562. NBNN=3
  563. MELTFA.ITYPEL=4
  564. C ELTFA TRI3
  565. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  566. C QUA4
  567. NBNN=4
  568. MELTFA.ITYPEL=8
  569. C ELTFA QUA4
  570. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  571. C TET4
  572. NBNN=4
  573. MELTFA.ITYPEL=23
  574. C ELTFA TET4
  575. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  576. C PYR5
  577. NBNN=5
  578. MELTFA.ITYPEL=9
  579. C ELTFA QUA5
  580. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  581. C PRI6
  582. NBNN=5
  583. MELTFA.ITYPEL=25
  584. C ELTFA PYR5
  585. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  586. C CUB8
  587. NBNN=6
  588. MELTFA.ITYPEL=16
  589. C ELTFA PRI6
  590. ELSE
  591. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  592. CALL ERREUR(5)
  593. GOTO 9999
  594. ENDIF
  595. NBELEM=MLENT1.LECT(ISOUS)
  596. NBSOUS=0
  597. SEGADJ MELTFA
  598. ELSE
  599. DO ISOUS=1,NBS,1
  600. NBELEM=MLENT1.LECT(ISOUS)
  601. IF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  602. C TRI3
  603. NBNN=3
  604. MELTFA.ITYPEL=4
  605. C ELTFA TRI3
  606. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  607. C QUA4
  608. NBNN=4
  609. MELTFA.ITYPEL=8
  610. C ELTFA QUA4
  611. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  612. C TET4
  613. NBNN=4
  614. MELTFA.ITYPEL=23
  615. C ELTFA TET4
  616. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  617. C PYR5
  618. NBNN=5
  619. MELTFA.ITYPEL=9
  620. C ELTFA QUA5
  621. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  622. C PRI6
  623. NBNN=5
  624. MELTFA.ITYPEL=25
  625. C ELTFA PYR5
  626. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  627. C CUB8
  628. NBNN=6
  629. MELTFA.ITYPEL=16
  630. C ELTFA PRI6
  631. ELSE
  632. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  633. CALL ERREUR(5)
  634. GOTO 9999
  635. ENDIF
  636. NBSOUS=0
  637. SEGINI IPT2
  638. MELTFA.LISOUS(ISOUS)=IPT2
  639. C
  640. IPT2.ITYPEL=MELTFA.ITYPEL
  641. MELTFA.ITYPEL=0
  642. ENDDO
  643. ENDIF
  644. C
  645. C******* We fill ELTFA
  646. C We also count:
  647. C NFACT = number of triangular faces
  648. C NFAC = number of non-triangular faces
  649. C NSOM = number of SOMMET
  650. C
  651. NTP=MCOORD.XCOOR(/1)/(IDIM+1)
  652. JG=NTP
  653. NFAC=0
  654. NFACT=0
  655. NSOM=0
  656.  
  657. LAST=-1
  658. SEGINI MLRES
  659. LASTT=-1
  660. SEGINI MLREST
  661. LASTS=-1
  662. SEGINI MLRESS
  663. C LAST+MLRES = chaining list to find the (non-triangular faces)
  664. DO ISOUS=1,NBS,1
  665. IF(NBS.EQ.1) THEN
  666. IPT1=MELEME
  667. IPT2=MELTFA
  668. ELSE
  669. IPT1=MELEME.LISOUS(ISOUS)
  670. IPT2=MELTFA.LISOUS(ISOUS)
  671. ENDIF
  672. C
  673. NBELEM=MLENT1.LECT(ISOUS)
  674. IF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  675. C TRI (2D)
  676. LISFAC(1)=2
  677. LISFAC(2)=4
  678. LISFAC(3)=6
  679. LISSOM(1)=1
  680. LISSOM(2)=3
  681. LISSOM(3)=5
  682. NNS=3
  683. NNOEU=3
  684. NNOEUT=0
  685. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  686. C QUA (2D)
  687. LISFAC(1)=2
  688. LISFAC(2)=4
  689. LISFAC(3)=6
  690. LISFAC(4)=8
  691. LISSOM(1)=1
  692. LISSOM(2)=3
  693. LISSOM(3)=5
  694. LISSOM(4)=7
  695. NNS=4
  696. NNOEU=4
  697. NNOEUT=0
  698. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  699. C TET
  700. LISFAT(1)=11
  701. LISFAT(2)=12
  702. LISFAT(3)=13
  703. LISFAT(4)=14
  704. LISSOM(1)=1
  705. LISSOM(2)=3
  706. LISSOM(3)=5
  707. LISSOM(4)=10
  708. NNS=4
  709. NNOEU=0
  710. NNOEUT=4
  711. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  712. C PYR
  713. LISFAC(1)=14
  714. LISFAT(1)=15
  715. LISFAT(2)=16
  716. LISFAT(3)=17
  717. LISFAT(4)=18
  718. LISSOM(1)=1
  719. LISSOM(2)=3
  720. LISSOM(3)=5
  721. LISSOM(4)=7
  722. LISSOM(5)=13
  723. NNS=5
  724. NNOEU=1
  725. NNOEUT=4
  726. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  727. C PRI
  728. LISFAC(1)=16
  729. LISFAC(2)=17
  730. LISFAC(3)=18
  731. LISFAT(1)=19
  732. LISFAT(2)=20
  733. LISSOM(1)=1
  734. LISSOM(2)=3
  735. LISSOM(3)=5
  736. LISSOM(4)=10
  737. LISSOM(5)=12
  738. LISSOM(6)=14
  739. NNS=6
  740. NNOEU=3
  741. NNOEUT=2
  742. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  743. C CUB
  744. LISFAC(1)=25
  745. LISFAC(2)=26
  746. LISFAC(3)=21
  747. LISFAC(4)=22
  748. LISFAC(5)=23
  749. LISFAC(6)=24
  750. LISSOM(1)=1
  751. LISSOM(2)=3
  752. LISSOM(3)=5
  753. LISSOM(4)=7
  754. LISSOM(5)=13
  755. LISSOM(6)=15
  756. LISSOM(7)=17
  757. LISSOM(8)=19
  758. NNS=8
  759. NNOEU=6
  760. NNOEUT=0
  761. ELSE
  762. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  763. CALL ERREUR(5)
  764. ENDIF
  765. C
  766. DO IELEM=1,NBELEM,1
  767. IFAC=0
  768. DO INOE=1,NNOEU,1
  769. NN1=IPT1.NUM(LISFAC(INOE),IELEM)
  770. IFAC=IFAC+1
  771. IPT2.NUM(IFAC,IELEM)=NN1
  772. IF(MLRES.LECT(NN1) .EQ. 0)THEN
  773. NFAC=NFAC+1
  774. MLRES.LECT(NN1)=LAST
  775. LAST=NN1
  776. ENDIF
  777. ENDDO
  778. DO INOE=1,NNOEUT,1
  779. NN1=IPT1.NUM(LISFAT(INOE),IELEM)
  780. IFAC=IFAC+1
  781. IPT2.NUM(IFAC,IELEM)=NN1
  782. IF(MLREST.LECT(NN1) .EQ. 0)THEN
  783. NFACT=NFACT+1
  784. MLREST.LECT(NN1)=LASTT
  785. LASTT=NN1
  786. ENDIF
  787. ENDDO
  788. DO INOE=1,NNS,1
  789. NN1=IPT1.NUM(LISSOM(INOE),IELEM)
  790. IF(MLRESS.LECT(NN1) .EQ. 0)THEN
  791. NSOM=NSOM+1
  792. MLRESS.LECT(NN1)=LASTS
  793. LASTS=NN1
  794. ENDIF
  795. ENDDO
  796. C
  797. C************* Cas particulier: PRISME
  798. C
  799. IF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  800. NN1=IPT2.NUM(1,IELEM)
  801. NN2=IPT2.NUM(2,IELEM)
  802. NN3=IPT2.NUM(3,IELEM)
  803. DO INOE=1,2
  804. IPT2.NUM(INOE,IELEM)=IPT2.NUM(INOE+3,IELEM)
  805. ENDDO
  806. IPT2.NUM(3,IELEM)=NN1
  807. IPT2.NUM(4,IELEM)=NN2
  808. IPT2.NUM(5,IELEM)=NN3
  809. ENDIF
  810. ENDDO
  811. C
  812. IF(NBS.NE.1) THEN
  813. SEGDES IPT2
  814. ENDIF
  815. C
  816. ENDDO
  817. SEGDES MELTFA
  818. CALL ECMO(MTAB,'ELTFA','MAILLAGE',MELTFA)
  819.  
  820. CC
  821. CC******* Test
  822. CC
  823. C write(*,*) 'Triangular faces ', nfact
  824. C 10 if(lastt .ne. -1)then
  825. C write(*,*) lastt
  826. C lastt=mlrest.lect(lastt)
  827. C endif
  828. C if(lastt .ne. -1) goto 10
  829. C write(*,*) 'Non triangular faces ', nfac
  830. C 20 if(last .ne. -1)then
  831. C write(*,*) last
  832. C last=mlres.lect(last)
  833. C endif
  834. C if(last .ne. -1) goto 20
  835. C write(*,*) 'Sommets ', nsom
  836. C 30 if(lasts .ne. -1)then
  837. C write(*,*) lasts
  838. C lasts=mlress.lect(lasts)
  839. C endif
  840. C if(lasts .ne. -1) goto 30
  841. C
  842. CC
  843. CC******* Fin test
  844. CC
  845. C
  846. C******** Creation of SOMMET
  847. C
  848. NBELEM=NSOM
  849. NBNN=1
  850. NBSOUS=0
  851. NBREF=0
  852. SEGINI MELSOM
  853. MELSOM.ITYPEL=1
  854. DO IELEM=1,NSOM,1
  855. MELSOM.NUM(1,IELEM)=LASTS
  856. LASTS=MLRESS.LECT(LASTS)
  857. ENDDO
  858. IF(LASTS .NE. -1)THEN
  859. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  860. CALL ERREUR(5)
  861. ENDIF
  862. SEGDES MELSOM
  863. CALL ECMO(MTAB,'SOMMET','MAILLAGE',MELSOM)
  864. SEGSUP MLRESS
  865. C
  866. C******** Creation of FACE (in 3D, triangle first)
  867. C
  868. NBELEM=NFAC+NFACT
  869. NBNN=1
  870. NBSOUS=0
  871. NBREF=0
  872. SEGINI MELFAC
  873. MELFAC.ITYPEL=1
  874. DO IELEM=1,NFACT,1
  875. MELFAC.NUM(1,IELEM)=LASTT
  876. LASTT=MLREST.LECT(LASTT)
  877. ENDDO
  878. IF(LASTT .NE. -1)THEN
  879. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  880. CALL ERREUR(5)
  881. ENDIF
  882. DO IELEM=1,NFAC,1
  883. MELFAC.NUM(1,NFACT+IELEM)=LAST
  884. LAST=MLRES.LECT(LAST)
  885. ENDDO
  886. IF(LAST .NE. -1)THEN
  887. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  888. CALL ERREUR(5)
  889. ENDIF
  890. SEGDES MELFAC
  891. SEGSUP MLRES
  892. SEGSUP MLREST
  893. CALL ECMO(MTAB,'FACE','MAILLAGE',MELFAC)
  894. C
  895. C******* Creation of FACEL and FACEP
  896. C
  897. CALL KRIPAD(MELFAC,MLEFAC)
  898. C SEGINI MLEFAC
  899. JG=NFAC+NFACT
  900. SEGINI MLETOF
  901. C
  902. C MLETOF.LECT(I1) = how many times has the i-th face of MELFAP
  903. C already been touched?
  904. C
  905. NBELEM=NFAC+NFACT
  906. NBNN=3
  907. NBSOUS=0
  908. NBREF=0
  909. SEGINI MELFAL
  910. MELFAL.ITYPEL=3
  911. C
  912. IF(IDIM.EQ.2)THEN
  913. C FACEP is a SEG3
  914. NBELEM=NFAC
  915. NBNN=3
  916. NBSOUS=0
  917. NBREF=0
  918. SEGINI MELFAP
  919. MELFAP.ITYPEL=3
  920. IPTQ=MELFAP
  921. ELSEIF(NFAC.EQ.0)THEN
  922. C In 3D we have triangles only
  923. C TRI4
  924. NBELEM=NFACT
  925. NBSOUS=0
  926. NBREF=0
  927. NBNN=4
  928. SEGINI MELFAP
  929. IPTT=MELFAP
  930. MELFAP.ITYPEL=5
  931. ELSEIF(NFACT.EQ.0)THEN
  932. C In 3D we have quadrangles only
  933. C QUA5
  934. NBELEM=NFAC
  935. NBSOUS=0
  936. NBREF=0
  937. NBNN=5
  938. SEGINI MELFAP
  939. IPTQ=MELFAP
  940. MELFAP.ITYPEL=9
  941. ELSE
  942. C TRI4 5
  943. C QUA5 9
  944. NBELEM=0
  945. NBNN=0
  946. NBSOUS=2
  947. NBREF=0
  948. SEGINI MELFAP
  949. MELFAP.ITYPEL=0
  950. C
  951. NBELEM=NFACT
  952. NBSOUS=0
  953. NBREF=0
  954. NBNN=4
  955. SEGINI IPTT
  956. MELFAP.LISOUS(1)=IPTT
  957. IPTT.ITYPEL=5
  958. C
  959. NBELEM=NFAC
  960. NBSOUS=0
  961. NBREF=0
  962. NBNN=5
  963. SEGINI IPTQ
  964. MELFAP.LISOUS(2)=IPTQ
  965. IPTQ.ITYPEL=9
  966. ENDIF
  967. C NBSFP = NBSOUS for FACEP
  968. C
  969. NBSFP=NBSOUS
  970. C
  971. DO ISOUS=1,NBS,1
  972. C
  973. C********** Loop on the elementary mesh of the QUAF
  974. C
  975. C We recall that
  976. C MLENTI.LECT(ISOUS) contains the type of support of
  977. C MELEME.LISOUS
  978. C MLENT1.LECT(ISOUS) contains the number of elements of
  979. C MELEME.LISOUS
  980. C
  981. IF(NBS.EQ.1) THEN
  982. IPT1=MELEME
  983. ELSE
  984. IPT1=MELEME.LISOUS(ISOUS)
  985. ENDIF
  986. C
  987. IF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  988. C TRI (2D)
  989. LIFAC(1,1)=2
  990. LIFAC(2,1)=1
  991. LIFAC(3,1)=3
  992. LIFAC(1,2)=4
  993. LIFAC(2,2)=3
  994. LIFAC(3,2)=5
  995. LIFAC(1,3)=6
  996. LIFAC(2,3)=5
  997. LIFAC(3,3)=1
  998. C Here we put the center point in LISSOM
  999. LISSOM(1)=7
  1000. C Number of non-triangular and triangular faces
  1001. NNOEU=3
  1002. NNOEUT=0
  1003. C
  1004. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  1005. C QUA (2D)
  1006. LIFAC(1,1)=2
  1007. LIFAC(2,1)=1
  1008. LIFAC(3,1)=3
  1009. LIFAC(1,2)=4
  1010. LIFAC(2,2)=3
  1011. LIFAC(3,2)=5
  1012. LIFAC(1,3)=6
  1013. LIFAC(2,3)=5
  1014. LIFAC(3,3)=7
  1015. LIFAC(1,4)=8
  1016. LIFAC(2,4)=7
  1017. LIFAC(3,4)=1
  1018. LISSOM(1)=9
  1019. NNOEU=4
  1020. NNOEUT=0
  1021. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  1022. C TET
  1023. LIFACT(1,1)=11
  1024. LIFACT(2,1)=1
  1025. LIFACT(3,1)=3
  1026. LIFACT(4,1)=5
  1027. LIFACT(1,2)=12
  1028. LIFACT(2,2)=1
  1029. LIFACT(3,2)=10
  1030. LIFACT(4,2)=3
  1031. LIFACT(1,3)=13
  1032. LIFACT(2,3)=3
  1033. LIFACT(3,3)=10
  1034. LIFACT(4,3)=5
  1035. LIFACT(1,4)=14
  1036. LIFACT(2,4)=10
  1037. LIFACT(3,4)=1
  1038. LIFACT(4,4)=5
  1039. LISSOM(1)=15
  1040. NNOEU=0
  1041. NNOEUT=4
  1042. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  1043. C PYR
  1044. LIFAC(1,1)=14
  1045. LIFAC(2,1)=1
  1046. LIFAC(3,1)=3
  1047. LIFAC(4,1)=5
  1048. LIFAC(5,1)=7
  1049. LIFACT(1,1)=15
  1050. LIFACT(2,1)=1
  1051. LIFACT(3,1)=13
  1052. LIFACT(4,1)=3
  1053. LIFACT(1,2)=16
  1054. LIFACT(2,2)=3
  1055. LIFACT(3,2)=13
  1056. LIFACT(4,2)=5
  1057. LIFACT(1,3)=17
  1058. LIFACT(2,3)=5
  1059. LIFACT(3,3)=13
  1060. LIFACT(4,3)=7
  1061. LIFACT(1,4)=18
  1062. LIFACT(2,4)=13
  1063. LIFACT(3,4)=1
  1064. LIFACT(4,4)=7
  1065. LISSOM(1)=19
  1066. NNOEU=1
  1067. NNOEUT=4
  1068. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  1069. C PRI
  1070. LIFAC(1,1)=16
  1071. LIFAC(2,1)=1
  1072. LIFAC(3,1)=10
  1073. LIFAC(4,1)=12
  1074. LIFAC(5,1)=3
  1075. LIFAC(1,2)=17
  1076. LIFAC(2,2)=3
  1077. LIFAC(3,2)=12
  1078. LIFAC(4,2)=14
  1079. LIFAC(5,2)=5
  1080. LIFAC(1,3)=18
  1081. LIFAC(2,3)=1
  1082. LIFAC(3,3)=5
  1083. LIFAC(4,3)=14
  1084. LIFAC(5,3)=10
  1085. LIFACT(1,1)=19
  1086. LIFACT(2,1)=1
  1087. LIFACT(3,1)=3
  1088. LIFACT(4,1)=5
  1089. LIFACT(1,2)=20
  1090. LIFACT(2,2)=10
  1091. LIFACT(3,2)=14
  1092. LIFACT(4,2)=12
  1093. LISSOM(1)=21
  1094. NNOEU=3
  1095. NNOEUT=2
  1096. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  1097. C CUB
  1098. LIFAC(1,1)=21
  1099. LIFAC(2,1)=1
  1100. LIFAC(3,1)=13
  1101. LIFAC(4,1)=15
  1102. LIFAC(5,1)=3
  1103. LIFAC(1,2)=22
  1104. LIFAC(2,2)=3
  1105. LIFAC(3,2)=15
  1106. LIFAC(4,2)=17
  1107. LIFAC(5,2)=5
  1108. LIFAC(1,3)=23
  1109. LIFAC(2,3)=5
  1110. LIFAC(3,3)=17
  1111. LIFAC(4,3)=19
  1112. LIFAC(5,3)=7
  1113. LIFAC(1,4)=24
  1114. LIFAC(2,4)=1
  1115. LIFAC(3,4)=7
  1116. LIFAC(4,4)=19
  1117. LIFAC(5,4)=13
  1118. LIFAC(1,5)=25
  1119. LIFAC(2,5)=1
  1120. LIFAC(3,5)=3
  1121. LIFAC(4,5)=5
  1122. LIFAC(5,5)=7
  1123. LIFAC(1,6)=26
  1124. LIFAC(2,6)=13
  1125. LIFAC(3,6)=19
  1126. LIFAC(4,6)=17
  1127. LIFAC(5,6)=15
  1128. LISSOM(1)=27
  1129. NNOEU=6
  1130. NNOEUT=0
  1131. ELSE
  1132. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  1133. CALL ERREUR(5)
  1134. ENDIF
  1135. C
  1136. NBELEM=MLENT1.LECT(ISOUS)
  1137. DO IELEM=1,NBELEM,1
  1138. C NNOEU = number of quagrangular elements
  1139. DO INOE=1,NNOEU,1
  1140. C NN1 is the global number of the face
  1141. C NN2 is the local number of the face in the MELEME
  1142. C 'FACE'
  1143. C The MELEME 'FACE' contains : -triangular faces
  1144. C (MELEME IPTT)
  1145. C -non-triangular faces
  1146. C (MELEME IPTQ)
  1147. C Then NN3 = position of NN1 in IPTQ = NN2 - NFACT
  1148. C where NFACT is the total number of triangular faces
  1149. C
  1150. NN1=IPT1.NUM(LIFAC(1,INOE),IELEM)
  1151. NN2=MLEFAC.LECT(NN1)
  1152. NN3=NN2-NFACT
  1153. IF(MLETOF.LECT(NN2).EQ.0)THEN
  1154. C
  1155. C MLETOF.LECT(NN2) = how many times the face NN2 has
  1156. C been touched?
  1157. C
  1158. MLETOF.LECT(NN2)=1
  1159. MELFAL.NUM(2,NN2)=NN1
  1160. MELFAL.NUM(1,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  1161. MELFAL.NUM(3,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  1162. IF(IDIM .EQ.2)THEN
  1163. IPTQ.NUM(1,NN3)=IPT1.NUM(LIFAC(2,INOE),IELEM)
  1164. IPTQ.NUM(2,NN3)=IPT1.NUM(LIFAC(3,INOE),IELEM)
  1165. IPTQ.NUM(3,NN3)=NN1
  1166. ELSE
  1167. IPTQ.NUM(1,NN3)=IPT1.NUM(LIFAC(2,INOE),IELEM)
  1168. IPTQ.NUM(2,NN3)=IPT1.NUM(LIFAC(3,INOE),IELEM)
  1169. IPTQ.NUM(3,NN3)=IPT1.NUM(LIFAC(4,INOE),IELEM)
  1170. IPTQ.NUM(4,NN3)=IPT1.NUM(LIFAC(5,INOE),IELEM)
  1171. IPTQ.NUM(5,NN3)=NN1
  1172. ENDIF
  1173. ELSEIF(MLETOF.LECT(NN2).EQ.1)THEN
  1174. MLETOF.LECT(NN2)=2
  1175. MELFAL.NUM(3,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  1176. ELSE
  1177. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  1178. CALL ERREUR(5)
  1179. ENDIF
  1180. ENDDO
  1181. DO INOE=1,NNOEUT,1
  1182. C NN1 is the global number of the face
  1183. C NN2 is the local number of the face in the MELEME
  1184. C 'FACE' and is also the position of NN1 in IPTT
  1185. C
  1186. NN1=IPT1.NUM(LIFACT(1,INOE),IELEM)
  1187. NN2=MLEFAC.LECT(NN1)
  1188. IF(MLETOF.LECT(NN2).EQ.0)THEN
  1189. MLETOF.LECT(NN2)=1
  1190. MELFAL.NUM(2,NN2)=NN1
  1191. MELFAL.NUM(1,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  1192. MELFAL.NUM(3,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  1193. IPTT.NUM(1,NN2)=IPT1.NUM(LIFACT(2,INOE),IELEM)
  1194. IPTT.NUM(2,NN2)=IPT1.NUM(LIFACT(3,INOE),IELEM)
  1195. IPTT.NUM(3,NN2)=IPT1.NUM(LIFACT(4,INOE),IELEM)
  1196. IPTT.NUM(4,NN2)=NN1
  1197. ELSEIF(MLETOF.LECT(NN2).EQ.1)THEN
  1198. MLETOF.LECT(NN2)=2
  1199. MELFAL.NUM(3,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  1200. ELSE
  1201. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  1202. CALL ERREUR(5)
  1203. ENDIF
  1204. ENDDO
  1205. ENDDO
  1206. ENDDO
  1207. IF(NBSFP .NE. 0)THEN
  1208. SEGDES IPTQ
  1209. SEGDES IPTT
  1210. ENDIF
  1211. SEGDES MELFAL
  1212. SEGDES MELFAP
  1213. C SEGDES MELFAP
  1214. C SEGDES MELFAP
  1215. C SEGDES MELFAP
  1216. SEGSUP MLETOF
  1217. SEGSUP MLEFAC
  1218. CALL ECMO(MTAB,'FACEL','MAILLAGE',MELFAL)
  1219. CALL ECMO(MTAB,'FACEP','MAILLAGE',MELFAP)
  1220. C
  1221. C******** Creation of 'XXSURFAC', 'XXNORMAF', 'MATROT'
  1222. C
  1223. CALL KDOM11(MELFAC,MELFAL,MELFAP,MCHPSU,MCHPNO,MCHPMR)
  1224. IF(IERR.NE.0)GOTO 9999
  1225. CALL ECMO(MTAB,'XXSURFAC','CHPOINT',MCHPSU)
  1226. CALL ECMO(MTAB,'XXNORMAF','CHPOINT',MCHPNO)
  1227. CALL ECMO(MTAB,'MATROT','CHPOINT',MCHPMR)
  1228. C
  1229. C******** Creation of 'XXDIEMIN'
  1230. C
  1231. CALL KDOM12(MELTFA,MELCEN,MELFAC,MCHPNO,MCHDIA)
  1232. IF(IERR.NE.0)GOTO 9999
  1233. CALL ECMO(MTAB,'XXDIEMIN','CHPOINT',MCHDIA)
  1234. C
  1235. ENDIF
  1236. C
  1237. C
  1238. C***** Fin qui
  1239. C
  1240. IF(NBS .NE. 1)THEN
  1241. DO ISOUS=1,NBS,1
  1242. IPT1=MELEME.LISOUS(ISOUS)
  1243. SEGDES IPT1
  1244. ENDDO
  1245. ENDIF
  1246. C
  1247. SEGSUP MLENTI
  1248. SEGSUP MLENT1
  1249. SEGDES MELEME
  1250. C
  1251. 9999 RETURN
  1252. C
  1253. END
  1254.  
  1255.  
  1256.  
  1257.  

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