Télécharger kdom10.eso

Retour à la liste

Numérotation des lignes :

  1. C KDOM10 SOURCE CB215821 19/08/20 21:18:48 10287
  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. ENDDO
  343. CALL ECMO(MTAB,'MAILLAGE','MAILLAGE',MELMAI)
  344. CALL ECMO(MTAB,'CENTRE','MAILLAGE',MELCEN)
  345. SEGDES MELCEN
  346. SEGDES MELMAI
  347. C
  348. C**** Volume
  349. C
  350. TYPI='CENTRE '
  351. JGN=4
  352. JGM=1
  353. SEGINI MLMOTS
  354. MLMOTS.MOTS(1)='SCAL'
  355. CALL KRCHP1(TYPI,MELCEN,MCHPOI,MLMOTS)
  356. CALL LICHT(MCHPOI,MPOVAL,TYPI,IGEOM)
  357. C SEGACT MPOVAL
  358. C
  359. SEGSUP MLMOTS
  360. NBE0=0
  361. DO ISOUS=1,NBS,1
  362. IF(NBS.EQ.1) THEN
  363. IPT1=MELEME
  364. ELSE
  365. IPT1=MELEME.LISOUS(ISOUS)
  366. ENDIF
  367. C
  368. NBELEM=MLENT1.LECT(ISOUS)
  369. IF(MLENTI.LECT(ISOUS) .EQ. 3)THEN
  370. C SEG3
  371. DO IELEM=1,NBELEM,1
  372. NBE0=NBE0+1
  373. NN1=IPT1.NUM(1,IELEM)
  374. NN2=IPT1.NUM(2,IELEM)
  375. NN3=IPT1.NUM(3,IELEM)
  376. CALL KDOM5(NN1,NN2,NN3,VOL)
  377. MPOVAL.VPOCHA(NBE0,1)=VOL
  378. ENDDO
  379. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  380. C TRI
  381. DO IELEM=1,NBELEM,1
  382. NBE0=NBE0+1
  383. NN1=IPT1.NUM(1,IELEM)
  384. NN2=IPT1.NUM(3,IELEM)
  385. NN3=IPT1.NUM(5,IELEM)
  386. NN4=IPT1.NUM(7,IELEM)
  387. C Vol TRI7 as a vol of a degenerate QUA9
  388. CALL KDOM6(NN1,NN2,NN3,NN3,NN4,VOL)
  389. MPOVAL.VPOCHA(NBE0,1)=VOL
  390. ENDDO
  391. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  392. C QUA
  393. DO IELEM=1,NBELEM,1
  394. NBE0=NBE0+1
  395. NN1=IPT1.NUM(1,IELEM)
  396. NN2=IPT1.NUM(3,IELEM)
  397. NN3=IPT1.NUM(5,IELEM)
  398. NN4=IPT1.NUM(7,IELEM)
  399. NN5=IPT1.NUM(9,IELEM)
  400. CALL KDOM6(NN1,NN2,NN3,NN4,NN5,VOL)
  401. MPOVAL.VPOCHA(NBE0,1)=VOL
  402. ENDDO
  403. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  404. C TET
  405. DO IELEM=1,NBELEM,1
  406. NBE0=NBE0+1
  407. NN1=IPT1.NUM(1,IELEM)
  408. NN2=IPT1.NUM(3,IELEM)
  409. NN3=IPT1.NUM(5,IELEM)
  410. NN4=IPT1.NUM(10,IELEM)
  411. CALL KDOM4(NN1,NN2,NN3,NN4,CEL,VOL)
  412. MPOVAL.VPOCHA(NBE0,1)=ABS(VOL)
  413. ENDDO
  414. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  415. C PYR
  416. DO IELEM=1,NBELEM,1
  417. NBE0=NBE0+1
  418. NN1=IPT1.NUM(1,IELEM)
  419. NN2=IPT1.NUM(3,IELEM)
  420. NN3=IPT1.NUM(5,IELEM)
  421. NN4=IPT1.NUM(7,IELEM)
  422. NN5=IPT1.NUM(14,IELEM)
  423. NN6=IPT1.NUM(13,IELEM)
  424. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL)
  425. MPOVAL.VPOCHA(NBE0,1)=ABS(VOL)
  426. ENDDO
  427. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  428. C PRI
  429. C To compute the volume, we divide it into 2
  430. C TET et 3 PYR
  431. C
  432. DO IELEM=1,NBELEM,1
  433. VOL=0.0D0
  434. NBE0=NBE0+1
  435. NN1=IPT1.NUM(1,IELEM)
  436. NN2=IPT1.NUM(3,IELEM)
  437. NN3=IPT1.NUM(5,IELEM)
  438. NN4=IPT1.NUM(21,IELEM)
  439. CALL KDOM4(NN1,NN2,NN3,NN4,CEL,VOL1)
  440. VOL=VOL+VOL1
  441. NN1=IPT1.NUM(14,IELEM)
  442. NN2=IPT1.NUM(12,IELEM)
  443. NN3=IPT1.NUM(10,IELEM)
  444. NN4=IPT1.NUM(21,IELEM)
  445. CALL KDOM4(NN1,NN2,NN3,NN4,CEL,VOL1)
  446. VOL=VOL+VOL1
  447. NN1=IPT1.NUM(1,IELEM)
  448. NN2=IPT1.NUM(10,IELEM)
  449. NN3=IPT1.NUM(12,IELEM)
  450. NN4=IPT1.NUM(3,IELEM)
  451. NN5=IPT1.NUM(16,IELEM)
  452. NN6=IPT1.NUM(21,IELEM)
  453. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  454. VOL=VOL+VOL1
  455. NN1=IPT1.NUM(3,IELEM)
  456. NN2=IPT1.NUM(12,IELEM)
  457. NN3=IPT1.NUM(14,IELEM)
  458. NN4=IPT1.NUM(5,IELEM)
  459. NN5=IPT1.NUM(17,IELEM)
  460. NN6=IPT1.NUM(21,IELEM)
  461. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  462. VOL=VOL+VOL1
  463. NN1=IPT1.NUM(10,IELEM)
  464. NN2=IPT1.NUM(1,IELEM)
  465. NN3=IPT1.NUM(5,IELEM)
  466. NN4=IPT1.NUM(14,IELEM)
  467. NN5=IPT1.NUM(18,IELEM)
  468. NN6=IPT1.NUM(21,IELEM)
  469. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  470. VOL=VOL+VOL1
  471. MPOVAL.VPOCHA(NBE0,1)=ABS(VOL)
  472. ENDDO
  473. C
  474. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  475. C CUB
  476. C To compute the volume, we divide it into 6 PYR
  477. C
  478. DO IELEM=1,NBELEM,1
  479. VOL=0.0D0
  480. NBE0=NBE0+1
  481. NN1=IPT1.NUM(1,IELEM)
  482. NN2=IPT1.NUM(3,IELEM)
  483. NN3=IPT1.NUM(5,IELEM)
  484. NN4=IPT1.NUM(7,IELEM)
  485. NN5=IPT1.NUM(25,IELEM)
  486. NN6=IPT1.NUM(27,IELEM)
  487. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  488. VOL=VOL+VOL1
  489. NN1=IPT1.NUM(19,IELEM)
  490. NN2=IPT1.NUM(17,IELEM)
  491. NN3=IPT1.NUM(15,IELEM)
  492. NN4=IPT1.NUM(13,IELEM)
  493. NN5=IPT1.NUM(26,IELEM)
  494. NN6=IPT1.NUM(27,IELEM)
  495. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  496. VOL=VOL+VOL1
  497. NN1=IPT1.NUM(1,IELEM)
  498. NN2=IPT1.NUM(13,IELEM)
  499. NN3=IPT1.NUM(15,IELEM)
  500. NN4=IPT1.NUM(3,IELEM)
  501. NN5=IPT1.NUM(21,IELEM)
  502. NN6=IPT1.NUM(27,IELEM)
  503. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  504. VOL=VOL+VOL1
  505. NN1=IPT1.NUM(3,IELEM)
  506. NN2=IPT1.NUM(15,IELEM)
  507. NN3=IPT1.NUM(17,IELEM)
  508. NN4=IPT1.NUM(5,IELEM)
  509. NN5=IPT1.NUM(22,IELEM)
  510. NN6=IPT1.NUM(27,IELEM)
  511. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  512. VOL=VOL+VOL1
  513. NN1=IPT1.NUM(7,IELEM)
  514. NN2=IPT1.NUM(5,IELEM)
  515. NN3=IPT1.NUM(17,IELEM)
  516. NN4=IPT1.NUM(19,IELEM)
  517. NN5=IPT1.NUM(23,IELEM)
  518. NN6=IPT1.NUM(27,IELEM)
  519. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  520. VOL=VOL+VOL1
  521. NN1=IPT1.NUM(19,IELEM)
  522. NN2=IPT1.NUM(13,IELEM)
  523. NN3=IPT1.NUM(1,IELEM)
  524. NN4=IPT1.NUM(7,IELEM)
  525. NN5=IPT1.NUM(24,IELEM)
  526. NN6=IPT1.NUM(27,IELEM)
  527. CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  528. VOL=VOL+VOL1
  529. MPOVAL.VPOCHA(NBE0,1)=ABS(VOL)
  530. ENDDO
  531. ELSE
  532. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  533. CALL ERREUR(5)
  534. ENDIF
  535. ENDDO
  536. C
  537. CALL ECMO(MTAB,'XXVOLUM','CHPOINT',MCHPOI)
  538. C
  539. C
  540. C**** For the moment we have:
  541. C 'QUAF'
  542. C 'MAILLAGE'
  543. C 'CENTRE'
  544. C 'XXVOLUM'
  545. C
  546. C In the complete case (2D mesh in 2D and 3D mesh in 3D):
  547. C
  548. IF(LOGCOM)THEN
  549. C
  550. C******* We create ELTFA
  551. C
  552. SEGINI, MELTFA=MELEME
  553. NBREF=0
  554. IF(NBS .EQ. 1)THEN
  555. ISOUS=1
  556. IF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  557. C TRI3
  558. NBNN=3
  559. MELTFA.ITYPEL=4
  560. C ELTFA TRI3
  561. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  562. C QUA4
  563. NBNN=4
  564. MELTFA.ITYPEL=8
  565. C ELTFA QUA4
  566. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  567. C TET4
  568. NBNN=4
  569. MELTFA.ITYPEL=23
  570. C ELTFA TET4
  571. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  572. C PYR5
  573. NBNN=5
  574. MELTFA.ITYPEL=9
  575. C ELTFA QUA5
  576. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  577. C PRI6
  578. NBNN=5
  579. MELTFA.ITYPEL=25
  580. C ELTFA PYR5
  581. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  582. C CUB8
  583. NBNN=6
  584. MELTFA.ITYPEL=16
  585. C ELTFA PRI6
  586. ELSE
  587. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  588. CALL ERREUR(5)
  589. GOTO 9999
  590. ENDIF
  591. NBELEM=MLENT1.LECT(ISOUS)
  592. NBSOUS=0
  593. SEGADJ MELTFA
  594. ELSE
  595. DO ISOUS=1,NBS,1
  596. NBELEM=MLENT1.LECT(ISOUS)
  597. IF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  598. C TRI3
  599. NBNN=3
  600. MELTFA.ITYPEL=4
  601. C ELTFA TRI3
  602. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  603. C QUA4
  604. NBNN=4
  605. MELTFA.ITYPEL=8
  606. C ELTFA QUA4
  607. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  608. C TET4
  609. NBNN=4
  610. MELTFA.ITYPEL=23
  611. C ELTFA TET4
  612. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  613. C PYR5
  614. NBNN=5
  615. MELTFA.ITYPEL=9
  616. C ELTFA QUA5
  617. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  618. C PRI6
  619. NBNN=5
  620. MELTFA.ITYPEL=25
  621. C ELTFA PYR5
  622. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  623. C CUB8
  624. NBNN=6
  625. MELTFA.ITYPEL=16
  626. C ELTFA PRI6
  627. ELSE
  628. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  629. CALL ERREUR(5)
  630. GOTO 9999
  631. ENDIF
  632. NBSOUS=0
  633. SEGINI IPT2
  634. MELTFA.LISOUS(ISOUS)=IPT2
  635. C
  636. IPT2.ITYPEL=MELTFA.ITYPEL
  637. MELTFA.ITYPEL=0
  638. ENDDO
  639. ENDIF
  640. C
  641. C******* We fill ELTFA
  642. C We also count:
  643. C NFACT = number of triangular faces
  644. C NFAC = number of non-triangular faces
  645. C NSOM = number of SOMMET
  646. C
  647. NTP=MCOORD.XCOOR(/1)/(IDIM+1)
  648. JG=NTP
  649. NFAC=0
  650. NFACT=0
  651. NSOM=0
  652.  
  653. LAST=-1
  654. SEGINI MLRES
  655. LASTT=-1
  656. SEGINI MLREST
  657. LASTS=-1
  658. SEGINI MLRESS
  659. C LAST+MLRES = chaining list to find the (non-triangular faces)
  660. DO ISOUS=1,NBS,1
  661. IF(NBS.EQ.1) THEN
  662. IPT1=MELEME
  663. IPT2=MELTFA
  664. ELSE
  665. IPT1=MELEME.LISOUS(ISOUS)
  666. IPT2=MELTFA.LISOUS(ISOUS)
  667. ENDIF
  668. C
  669. NBELEM=MLENT1.LECT(ISOUS)
  670. IF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  671. C TRI (2D)
  672. LISFAC(1)=2
  673. LISFAC(2)=4
  674. LISFAC(3)=6
  675. LISSOM(1)=1
  676. LISSOM(2)=3
  677. LISSOM(3)=5
  678. NNS=3
  679. NNOEU=3
  680. NNOEUT=0
  681. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  682. C QUA (2D)
  683. LISFAC(1)=2
  684. LISFAC(2)=4
  685. LISFAC(3)=6
  686. LISFAC(4)=8
  687. LISSOM(1)=1
  688. LISSOM(2)=3
  689. LISSOM(3)=5
  690. LISSOM(4)=7
  691. NNS=4
  692. NNOEU=4
  693. NNOEUT=0
  694. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  695. C TET
  696. LISFAT(1)=11
  697. LISFAT(2)=12
  698. LISFAT(3)=13
  699. LISFAT(4)=14
  700. LISSOM(1)=1
  701. LISSOM(2)=3
  702. LISSOM(3)=5
  703. LISSOM(4)=10
  704. NNS=4
  705. NNOEU=0
  706. NNOEUT=4
  707. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  708. C PYR
  709. LISFAC(1)=14
  710. LISFAT(1)=15
  711. LISFAT(2)=16
  712. LISFAT(3)=17
  713. LISFAT(4)=18
  714. LISSOM(1)=1
  715. LISSOM(2)=3
  716. LISSOM(3)=5
  717. LISSOM(4)=7
  718. LISSOM(5)=13
  719. NNS=5
  720. NNOEU=1
  721. NNOEUT=4
  722. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  723. C PRI
  724. LISFAC(1)=16
  725. LISFAC(2)=17
  726. LISFAC(3)=18
  727. LISFAT(1)=19
  728. LISFAT(2)=20
  729. LISSOM(1)=1
  730. LISSOM(2)=3
  731. LISSOM(3)=5
  732. LISSOM(4)=10
  733. LISSOM(5)=12
  734. LISSOM(6)=14
  735. NNS=6
  736. NNOEU=3
  737. NNOEUT=2
  738. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  739. C CUB
  740. LISFAC(1)=25
  741. LISFAC(2)=26
  742. LISFAC(3)=21
  743. LISFAC(4)=22
  744. LISFAC(5)=23
  745. LISFAC(6)=24
  746. LISSOM(1)=1
  747. LISSOM(2)=3
  748. LISSOM(3)=5
  749. LISSOM(4)=7
  750. LISSOM(5)=13
  751. LISSOM(6)=15
  752. LISSOM(7)=17
  753. LISSOM(8)=19
  754. NNS=8
  755. NNOEU=6
  756. NNOEUT=0
  757. ELSE
  758. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  759. CALL ERREUR(5)
  760. ENDIF
  761. C
  762. DO IELEM=1,NBELEM,1
  763. IFAC=0
  764. DO INOE=1,NNOEU,1
  765. NN1=IPT1.NUM(LISFAC(INOE),IELEM)
  766. IFAC=IFAC+1
  767. IPT2.NUM(IFAC,IELEM)=NN1
  768. IF(MLRES.LECT(NN1) .EQ. 0)THEN
  769. NFAC=NFAC+1
  770. MLRES.LECT(NN1)=LAST
  771. LAST=NN1
  772. ENDIF
  773. ENDDO
  774. DO INOE=1,NNOEUT,1
  775. NN1=IPT1.NUM(LISFAT(INOE),IELEM)
  776. IFAC=IFAC+1
  777. IPT2.NUM(IFAC,IELEM)=NN1
  778. IF(MLREST.LECT(NN1) .EQ. 0)THEN
  779. NFACT=NFACT+1
  780. MLREST.LECT(NN1)=LASTT
  781. LASTT=NN1
  782. ENDIF
  783. ENDDO
  784. DO INOE=1,NNS,1
  785. NN1=IPT1.NUM(LISSOM(INOE),IELEM)
  786. IF(MLRESS.LECT(NN1) .EQ. 0)THEN
  787. NSOM=NSOM+1
  788. MLRESS.LECT(NN1)=LASTS
  789. LASTS=NN1
  790. ENDIF
  791. ENDDO
  792. C
  793. C************* Cas particulier: PRISME
  794. C
  795. IF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  796. NN1=IPT2.NUM(1,IELEM)
  797. NN2=IPT2.NUM(2,IELEM)
  798. NN3=IPT2.NUM(3,IELEM)
  799. DO INOE=1,2
  800. IPT2.NUM(INOE,IELEM)=IPT2.NUM(INOE+3,IELEM)
  801. ENDDO
  802. IPT2.NUM(3,IELEM)=NN1
  803. IPT2.NUM(4,IELEM)=NN2
  804. IPT2.NUM(5,IELEM)=NN3
  805. ENDIF
  806. ENDDO
  807. C
  808. C
  809. ENDDO
  810. SEGDES MELTFA
  811. CALL ECMO(MTAB,'ELTFA','MAILLAGE',MELTFA)
  812.  
  813. CC
  814. CC******* Test
  815. CC
  816. C write(*,*) 'Triangular faces ', nfact
  817. C 10 if(lastt .ne. -1)then
  818. C write(*,*) lastt
  819. C lastt=mlrest.lect(lastt)
  820. C endif
  821. C if(lastt .ne. -1) goto 10
  822. C write(*,*) 'Non triangular faces ', nfac
  823. C 20 if(last .ne. -1)then
  824. C write(*,*) last
  825. C last=mlres.lect(last)
  826. C endif
  827. C if(last .ne. -1) goto 20
  828. C write(*,*) 'Sommets ', nsom
  829. C 30 if(lasts .ne. -1)then
  830. C write(*,*) lasts
  831. C lasts=mlress.lect(lasts)
  832. C endif
  833. C if(lasts .ne. -1) goto 30
  834. C
  835. CC
  836. CC******* Fin test
  837. CC
  838. C
  839. C******** Creation of SOMMET
  840. C
  841. NBELEM=NSOM
  842. NBNN=1
  843. NBSOUS=0
  844. NBREF=0
  845. SEGINI MELSOM
  846. MELSOM.ITYPEL=1
  847. DO IELEM=1,NSOM,1
  848. MELSOM.NUM(1,IELEM)=LASTS
  849. LASTS=MLRESS.LECT(LASTS)
  850. ENDDO
  851. IF(LASTS .NE. -1)THEN
  852. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  853. CALL ERREUR(5)
  854. ENDIF
  855. SEGDES MELSOM
  856. CALL ECMO(MTAB,'SOMMET','MAILLAGE',MELSOM)
  857. SEGSUP MLRESS
  858. C
  859. C******** Creation of FACE (in 3D, triangle first)
  860. C
  861. NBELEM=NFAC+NFACT
  862. NBNN=1
  863. NBSOUS=0
  864. NBREF=0
  865. SEGINI MELFAC
  866. MELFAC.ITYPEL=1
  867. DO IELEM=1,NFACT,1
  868. MELFAC.NUM(1,IELEM)=LASTT
  869. LASTT=MLREST.LECT(LASTT)
  870. ENDDO
  871. IF(LASTT .NE. -1)THEN
  872. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  873. CALL ERREUR(5)
  874. ENDIF
  875. DO IELEM=1,NFAC,1
  876. MELFAC.NUM(1,NFACT+IELEM)=LAST
  877. LAST=MLRES.LECT(LAST)
  878. ENDDO
  879. IF(LAST .NE. -1)THEN
  880. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  881. CALL ERREUR(5)
  882. ENDIF
  883. SEGDES MELFAC
  884. SEGSUP MLRES
  885. SEGSUP MLREST
  886. CALL ECMO(MTAB,'FACE','MAILLAGE',MELFAC)
  887. C
  888. C******* Creation of FACEL and FACEP
  889. C
  890. CALL KRIPAD(MELFAC,MLEFAC)
  891. C SEGINI MLEFAC
  892. JG=NFAC+NFACT
  893. SEGINI MLETOF
  894. C
  895. C MLETOF.LECT(I1) = how many times has the i-th face of MELFAP
  896. C already been touched?
  897. C
  898. NBELEM=NFAC+NFACT
  899. NBNN=3
  900. NBSOUS=0
  901. NBREF=0
  902. SEGINI MELFAL
  903. MELFAL.ITYPEL=3
  904. C
  905. IF(IDIM.EQ.2)THEN
  906. C FACEP is a SEG3
  907. NBELEM=NFAC
  908. NBNN=3
  909. NBSOUS=0
  910. NBREF=0
  911. SEGINI MELFAP
  912. MELFAP.ITYPEL=3
  913. IPTQ=MELFAP
  914. ELSEIF(NFAC.EQ.0)THEN
  915. C In 3D we have triangles only
  916. C TRI4
  917. NBELEM=NFACT
  918. NBSOUS=0
  919. NBREF=0
  920. NBNN=4
  921. SEGINI MELFAP
  922. IPTT=MELFAP
  923. MELFAP.ITYPEL=5
  924. ELSEIF(NFACT.EQ.0)THEN
  925. C In 3D we have quadrangles only
  926. C QUA5
  927. NBELEM=NFAC
  928. NBSOUS=0
  929. NBREF=0
  930. NBNN=5
  931. SEGINI MELFAP
  932. IPTQ=MELFAP
  933. MELFAP.ITYPEL=9
  934. ELSE
  935. C TRI4 5
  936. C QUA5 9
  937. NBELEM=0
  938. NBNN=0
  939. NBSOUS=2
  940. NBREF=0
  941. SEGINI MELFAP
  942. MELFAP.ITYPEL=0
  943. C
  944. NBELEM=NFACT
  945. NBSOUS=0
  946. NBREF=0
  947. NBNN=4
  948. SEGINI IPTT
  949. MELFAP.LISOUS(1)=IPTT
  950. IPTT.ITYPEL=5
  951. C
  952. NBELEM=NFAC
  953. NBSOUS=0
  954. NBREF=0
  955. NBNN=5
  956. SEGINI IPTQ
  957. MELFAP.LISOUS(2)=IPTQ
  958. IPTQ.ITYPEL=9
  959. ENDIF
  960. C NBSFP = NBSOUS for FACEP
  961. C
  962. NBSFP=NBSOUS
  963. C
  964. DO ISOUS=1,NBS,1
  965. C
  966. C********** Loop on the elementary mesh of the QUAF
  967. C
  968. C We recall that
  969. C MLENTI.LECT(ISOUS) contains the type of support of
  970. C MELEME.LISOUS
  971. C MLENT1.LECT(ISOUS) contains the number of elements of
  972. C MELEME.LISOUS
  973. C
  974. IF(NBS.EQ.1) THEN
  975. IPT1=MELEME
  976. ELSE
  977. IPT1=MELEME.LISOUS(ISOUS)
  978. ENDIF
  979. C
  980. IF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  981. C TRI (2D)
  982. LIFAC(1,1)=2
  983. LIFAC(2,1)=1
  984. LIFAC(3,1)=3
  985. LIFAC(1,2)=4
  986. LIFAC(2,2)=3
  987. LIFAC(3,2)=5
  988. LIFAC(1,3)=6
  989. LIFAC(2,3)=5
  990. LIFAC(3,3)=1
  991. C Here we put the center point in LISSOM
  992. LISSOM(1)=7
  993. C Number of non-triangular and triangular faces
  994. NNOEU=3
  995. NNOEUT=0
  996. C
  997. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  998. C QUA (2D)
  999. LIFAC(1,1)=2
  1000. LIFAC(2,1)=1
  1001. LIFAC(3,1)=3
  1002. LIFAC(1,2)=4
  1003. LIFAC(2,2)=3
  1004. LIFAC(3,2)=5
  1005. LIFAC(1,3)=6
  1006. LIFAC(2,3)=5
  1007. LIFAC(3,3)=7
  1008. LIFAC(1,4)=8
  1009. LIFAC(2,4)=7
  1010. LIFAC(3,4)=1
  1011. LISSOM(1)=9
  1012. NNOEU=4
  1013. NNOEUT=0
  1014. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  1015. C TET
  1016. LIFACT(1,1)=11
  1017. LIFACT(2,1)=1
  1018. LIFACT(3,1)=3
  1019. LIFACT(4,1)=5
  1020. LIFACT(1,2)=12
  1021. LIFACT(2,2)=1
  1022. LIFACT(3,2)=10
  1023. LIFACT(4,2)=3
  1024. LIFACT(1,3)=13
  1025. LIFACT(2,3)=3
  1026. LIFACT(3,3)=10
  1027. LIFACT(4,3)=5
  1028. LIFACT(1,4)=14
  1029. LIFACT(2,4)=10
  1030. LIFACT(3,4)=1
  1031. LIFACT(4,4)=5
  1032. LISSOM(1)=15
  1033. NNOEU=0
  1034. NNOEUT=4
  1035. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  1036. C PYR
  1037. LIFAC(1,1)=14
  1038. LIFAC(2,1)=1
  1039. LIFAC(3,1)=3
  1040. LIFAC(4,1)=5
  1041. LIFAC(5,1)=7
  1042. LIFACT(1,1)=15
  1043. LIFACT(2,1)=1
  1044. LIFACT(3,1)=13
  1045. LIFACT(4,1)=3
  1046. LIFACT(1,2)=16
  1047. LIFACT(2,2)=3
  1048. LIFACT(3,2)=13
  1049. LIFACT(4,2)=5
  1050. LIFACT(1,3)=17
  1051. LIFACT(2,3)=5
  1052. LIFACT(3,3)=13
  1053. LIFACT(4,3)=7
  1054. LIFACT(1,4)=18
  1055. LIFACT(2,4)=13
  1056. LIFACT(3,4)=1
  1057. LIFACT(4,4)=7
  1058. LISSOM(1)=19
  1059. NNOEU=1
  1060. NNOEUT=4
  1061. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  1062. C PRI
  1063. LIFAC(1,1)=16
  1064. LIFAC(2,1)=1
  1065. LIFAC(3,1)=10
  1066. LIFAC(4,1)=12
  1067. LIFAC(5,1)=3
  1068. LIFAC(1,2)=17
  1069. LIFAC(2,2)=3
  1070. LIFAC(3,2)=12
  1071. LIFAC(4,2)=14
  1072. LIFAC(5,2)=5
  1073. LIFAC(1,3)=18
  1074. LIFAC(2,3)=1
  1075. LIFAC(3,3)=5
  1076. LIFAC(4,3)=14
  1077. LIFAC(5,3)=10
  1078. LIFACT(1,1)=19
  1079. LIFACT(2,1)=1
  1080. LIFACT(3,1)=3
  1081. LIFACT(4,1)=5
  1082. LIFACT(1,2)=20
  1083. LIFACT(2,2)=10
  1084. LIFACT(3,2)=14
  1085. LIFACT(4,2)=12
  1086. LISSOM(1)=21
  1087. NNOEU=3
  1088. NNOEUT=2
  1089. ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  1090. C CUB
  1091. LIFAC(1,1)=21
  1092. LIFAC(2,1)=1
  1093. LIFAC(3,1)=13
  1094. LIFAC(4,1)=15
  1095. LIFAC(5,1)=3
  1096. LIFAC(1,2)=22
  1097. LIFAC(2,2)=3
  1098. LIFAC(3,2)=15
  1099. LIFAC(4,2)=17
  1100. LIFAC(5,2)=5
  1101. LIFAC(1,3)=23
  1102. LIFAC(2,3)=5
  1103. LIFAC(3,3)=17
  1104. LIFAC(4,3)=19
  1105. LIFAC(5,3)=7
  1106. LIFAC(1,4)=24
  1107. LIFAC(2,4)=1
  1108. LIFAC(3,4)=7
  1109. LIFAC(4,4)=19
  1110. LIFAC(5,4)=13
  1111. LIFAC(1,5)=25
  1112. LIFAC(2,5)=1
  1113. LIFAC(3,5)=3
  1114. LIFAC(4,5)=5
  1115. LIFAC(5,5)=7
  1116. LIFAC(1,6)=26
  1117. LIFAC(2,6)=13
  1118. LIFAC(3,6)=19
  1119. LIFAC(4,6)=17
  1120. LIFAC(5,6)=15
  1121. LISSOM(1)=27
  1122. NNOEU=6
  1123. NNOEUT=0
  1124. ELSE
  1125. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  1126. CALL ERREUR(5)
  1127. ENDIF
  1128. C
  1129. NBELEM=MLENT1.LECT(ISOUS)
  1130. DO IELEM=1,NBELEM,1
  1131. C NNOEU = number of quagrangular elements
  1132. DO INOE=1,NNOEU,1
  1133. C NN1 is the global number of the face
  1134. C NN2 is the local number of the face in the MELEME
  1135. C 'FACE'
  1136. C The MELEME 'FACE' contains : -triangular faces
  1137. C (MELEME IPTT)
  1138. C -non-triangular faces
  1139. C (MELEME IPTQ)
  1140. C Then NN3 = position of NN1 in IPTQ = NN2 - NFACT
  1141. C where NFACT is the total number of triangular faces
  1142. C
  1143. NN1=IPT1.NUM(LIFAC(1,INOE),IELEM)
  1144. NN2=MLEFAC.LECT(NN1)
  1145. NN3=NN2-NFACT
  1146. IF(MLETOF.LECT(NN2).EQ.0)THEN
  1147. C
  1148. C MLETOF.LECT(NN2) = how many times the face NN2 has
  1149. C been touched?
  1150. C
  1151. MLETOF.LECT(NN2)=1
  1152. MELFAL.NUM(2,NN2)=NN1
  1153. MELFAL.NUM(1,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  1154. MELFAL.NUM(3,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  1155. IF(IDIM .EQ.2)THEN
  1156. IPTQ.NUM(1,NN3)=IPT1.NUM(LIFAC(2,INOE),IELEM)
  1157. IPTQ.NUM(2,NN3)=IPT1.NUM(LIFAC(3,INOE),IELEM)
  1158. IPTQ.NUM(3,NN3)=NN1
  1159. ELSE
  1160. IPTQ.NUM(1,NN3)=IPT1.NUM(LIFAC(2,INOE),IELEM)
  1161. IPTQ.NUM(2,NN3)=IPT1.NUM(LIFAC(3,INOE),IELEM)
  1162. IPTQ.NUM(3,NN3)=IPT1.NUM(LIFAC(4,INOE),IELEM)
  1163. IPTQ.NUM(4,NN3)=IPT1.NUM(LIFAC(5,INOE),IELEM)
  1164. IPTQ.NUM(5,NN3)=NN1
  1165. ENDIF
  1166. ELSEIF(MLETOF.LECT(NN2).EQ.1)THEN
  1167. MLETOF.LECT(NN2)=2
  1168. MELFAL.NUM(3,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  1169. ELSE
  1170. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  1171. CALL ERREUR(5)
  1172. ENDIF
  1173. ENDDO
  1174. DO INOE=1,NNOEUT,1
  1175. C NN1 is the global number of the face
  1176. C NN2 is the local number of the face in the MELEME
  1177. C 'FACE' and is also the position of NN1 in IPTT
  1178. C
  1179. NN1=IPT1.NUM(LIFACT(1,INOE),IELEM)
  1180. NN2=MLEFAC.LECT(NN1)
  1181. IF(MLETOF.LECT(NN2).EQ.0)THEN
  1182. MLETOF.LECT(NN2)=1
  1183. MELFAL.NUM(2,NN2)=NN1
  1184. MELFAL.NUM(1,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  1185. MELFAL.NUM(3,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  1186. IPTT.NUM(1,NN2)=IPT1.NUM(LIFACT(2,INOE),IELEM)
  1187. IPTT.NUM(2,NN2)=IPT1.NUM(LIFACT(3,INOE),IELEM)
  1188. IPTT.NUM(3,NN2)=IPT1.NUM(LIFACT(4,INOE),IELEM)
  1189. IPTT.NUM(4,NN2)=NN1
  1190. ELSEIF(MLETOF.LECT(NN2).EQ.1)THEN
  1191. MLETOF.LECT(NN2)=2
  1192. MELFAL.NUM(3,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  1193. ELSE
  1194. WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  1195. CALL ERREUR(5)
  1196. ENDIF
  1197. ENDDO
  1198. ENDDO
  1199. ENDDO
  1200. IF(NBSFP .NE. 0)THEN
  1201. SEGDES IPTQ
  1202. SEGDES IPTT
  1203. ENDIF
  1204. SEGDES MELFAL
  1205. SEGDES MELFAP
  1206. C SEGDES MELFAP
  1207. C SEGDES MELFAP
  1208. C SEGDES MELFAP
  1209. SEGSUP MLETOF
  1210. SEGSUP MLEFAC
  1211. CALL ECMO(MTAB,'FACEL','MAILLAGE',MELFAL)
  1212. CALL ECMO(MTAB,'FACEP','MAILLAGE',MELFAP)
  1213. C
  1214. C******** Creation of 'XXSURFAC', 'XXNORMAF', 'MATROT'
  1215. C
  1216. CALL KDOM11(MELFAC,MELFAL,MELFAP,MCHPSU,MCHPNO,MCHPMR)
  1217. IF(IERR.NE.0)GOTO 9999
  1218. CALL ECMO(MTAB,'XXSURFAC','CHPOINT',MCHPSU)
  1219. CALL ECMO(MTAB,'XXNORMAF','CHPOINT',MCHPNO)
  1220. CALL ECMO(MTAB,'MATROT','CHPOINT',MCHPMR)
  1221. C
  1222. C******** Creation of 'XXDIEMIN'
  1223. C
  1224. CALL KDOM12(MELTFA,MELCEN,MELFAC,MCHPNO,MCHDIA)
  1225. IF(IERR.NE.0)GOTO 9999
  1226. CALL ECMO(MTAB,'XXDIEMIN','CHPOINT',MCHDIA)
  1227. C
  1228. ENDIF
  1229. C
  1230. C
  1231. C***** Fin qui
  1232. C
  1233. C
  1234. SEGSUP MLENTI
  1235. SEGSUP MLENT1
  1236. C
  1237. 9999 RETURN
  1238. C
  1239. END
  1240.  
  1241.  
  1242.  

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