Télécharger kfce.eso

Retour à la liste

Numérotation des lignes :

  1. C KFCE SOURCE BP208322 16/11/18 21:18:09 9177
  2. SUBROUTINE KFCE(IQUAD,MELEMQ)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C*************************************************************************
  6. C
  7. C Objet : calcule les connectivites faces -> elements (SEG3)
  8. C (Ptc 1 Face Pc2)
  9. C les supports geometriques des faces (POI1)
  10. C
  11. C Syntaxe : A , B , C , D , E = 'KFCE' GEO GEO1 <'INCL' TABD> ;
  12. C
  13. C A : Connectivites elements -> faces (ELTFA) MELAF
  14. C B : Support geometrique des centres (CENTRE) MELEM1
  15. C C : Connectivites faces -> sommets (FACEP) MPFD
  16. C D : Connectivites faces -> elements (FACEL) MFD
  17. C E : Support geometrique des faces (FACE) MF1
  18. C
  19. C
  20. C GEO : objet maillage
  21. C GEO1 : support geometrique de l'objet maillage
  22. C
  23. C INCL : directive indiquant qu'on cherche a inclure les
  24. C points crees dans le domaine TABD
  25. C_________________________________________________________________________
  26. C
  27. C NPF = IKAS(5,I,NTYEL)= le nombre de point constituant une face pour
  28. C le type d'element NTYEL
  29. C
  30. C
  31. C*************************************************************************
  32. PARAMETER (NBTYEL=10)
  33. CHARACTER*8 LTYPEL(NBTYEL),NOM8,TYPE
  34. DIMENSION IKAS(5,6,NBTYEL),NPS(4),LTPL(4),MPS(4)
  35. DIMENSION LNBFAC(NBTYEL),NBTYF(NBTYEL),LNBSO(25)
  36. C
  37. C CORRESPONDANCE
  38. C maillage SEG2 TRI3 QUA4 CUB8 PRI6 PYR5 TET4 TRI6 SEG3 QUA9
  39. C | | | | | | | | | |
  40. C V V V V V V V V V V
  41. C faces SEG2 TRI3 QUA4 PRI6 PYR5 QUA5 TET4 TRI3 SEG2 QUA4
  42. C
  43. C
  44. C ALIAS seg2 tri3 qua4 pri6 pyr5 qua5 tet4 cub8 tri6 seg3 qua8
  45. C ALIAS numero 2 4 8 16 25 9 23 14 6 3 10
  46.  
  47. -INC CCOPTIO
  48. -INC SMCOORD
  49. -INC SMTABLE
  50. POINTEUR MTABD.MTABLE,MTBT.MTABLE
  51. -INC SMLENTI
  52. -INC SMELEME
  53. POINTEUR MFD.MELEME,MF1.MELEME,MELEM1.MELEME
  54. POINTEUR MPFD.MELEME,MELAF.MELEME
  55. POINTEUR MELEMC.MELEME,MELEF1.MELEME
  56. POINTEUR MELES1.MELEME,MELEMQ.MELEME
  57. POINTEUR MELEM0.MELEME
  58. -INC CCGEOME
  59.  
  60. SEGMENT TRAV
  61. INTEGER ITRAV(NBFA,4)
  62. ENDSEGMENT
  63.  
  64. CHARACTER*4 LISMO(1)
  65. PARAMETER (NTB=1)
  66. DIMENSION KTAB(NTB)
  67. CHARACTER*8 LTAB(NTB)
  68. DATA LTYPEL/'SEG2 ','TRI3 ','QUA4 ','CUB8 ',
  69. & 'PRI6 ','PYR5 ','TET4 ',
  70. & 'TRI6 ','SEG3 ','QUA8 '/
  71. DATA LNBFAC/ 2 , 3 , 4 , 6 , 5 , 5 , 4 ,
  72. & 3 , 2 , 4 /
  73. DATA NBTYF/ 2 , 4 , 8 , 16 , 25 , 9 , 23 ,
  74. & 4 , 2 , 8 /
  75. C LNBSO pointe sur la ligne de IKAS en fct du type d'element (position
  76. C dans LNBSO)
  77. DATA LNBSO /0 ,1 ,9 ,2 ,0 ,8 ,0 ,3 ,
  78. & 0 ,10,0 ,0 ,0 ,4 ,0 ,5 ,
  79. & 0 ,0 ,0 ,0 ,0 ,0 ,7 ,0 ,6/
  80. DATA IKAS/
  81. & 1,0,0,0,1,2,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  82. & 1,2,0,0,2,2,3,0,0,2,3,1,0,0,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  83. & 1,2,0,0,2,2,3,0,0,2,3,4,0,0,2,4,1,0,0,2,0,0,0,0,0,0,0,0,0,0,
  84. & 1,2,3,4,4,5,6,7,8,4,1,2,6,5,4,2,3,7,6,4,3,4,8,7,4,4,1,5,8,4,
  85. & 1,2,3,0,3,4,5,6,0,3,1,2,5,4,4,2,3,6,5,4,3,1,4,6,4,0,0,0,0,0,
  86. & 1,2,3,4,4,1,2,5,0,3,2,3,5,0,3,3,4,5,0,3,4,1,5,0,3,0,0,0,0,0,
  87. & 1,2,4,0,3,1,2,3,0,3,4,2,3,0,3,1,4,3,0,3,0,0,0,0,0,0,0,0,0,0,
  88. & 1,3,0,0,2,3,5,0,0,2,5,1,0,0,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  89. & 1,0,0,0,1,3,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  90. & 1,3,0,0,2,3,5,0,0,2,5,7,0,0,2,7,1,0,0,2,0,0,0,0,0,0,0,0,0,0/
  91. DATA LTPL /1,2,4,8/
  92. DATA LISMO /'INCL'/
  93. DATA LTAB /'DOMAINE '/
  94.  
  95. C***
  96. CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  97. MELEM0=MELEME
  98. IF(IRET.EQ.0)GO TO 90
  99. CALL LIRREE(XVAL,0,IXV)
  100. XVAL=ABS(XVAL)
  101.  
  102. MTABD=0
  103. KINC=0
  104. CALL LIRMOT(LISMO,1,IP,0)
  105. IF(IP.NE.0)THEN
  106. KINC=1
  107. NTO=1
  108. CALL LITABS(LTAB,KTAB,NTB,NTO,IRET)
  109. IF(IRET.EQ.0)RETURN
  110. CALL LIRREE(XVAL,1,IXV)
  111. IF(IRET.EQ.0)RETURN
  112. XVAL=ABS(XVAL)
  113. MTABD=KTAB(1)
  114. TYPE=' '
  115. CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC)
  116. IF(TYPE.NE.'MAILLAGE')RETURN
  117. TYPE=' '
  118. CALL ACMO(MTABD,'FACE',TYPE,MELEF1)
  119. IF(TYPE.NE.'MAILLAGE')RETURN
  120. TYPE=' '
  121. CALL ACMO(MTABD,'SOMMET',TYPE,MELES1)
  122. IF(TYPE.NE.'MAILLAGE')RETURN
  123. ENDIF
  124.  
  125.  
  126. SEGACT MELEME
  127. NBSOUS=LISOUS(/1)
  128.  
  129. IF(NBSOUS.NE.0)THEN
  130. NBNN=0
  131. NBELEM=0
  132. NBREF=0
  133. SEGINI MELAF
  134. ELSE
  135. NBSOUS=1
  136. ENDIF
  137.  
  138. NBFA=0
  139. IELIM=0
  140. NBS=NBSOUS
  141.  
  142. DO 1 L=1,NBS
  143. IF(NBS.NE.1)THEN
  144. IPT1=LISOUS(L)
  145. SEGACT IPT1
  146. ELSE
  147. IPT1=MELEME
  148. ENDIF
  149. NOM8=NOMS(IPT1.ITYPEL)//' '
  150. CALL OPTLI(IP,LTYPEL,NOM8,NBTYEL)
  151. C write(6,*)' NOM8,IP=',NOM8,IP
  152. IF(IP.EQ.0)THEN
  153. WRITE(6,*)' On ne sait rien faire pour cet element ',NOM8
  154. GO TO 90
  155. ENDIF
  156. IF((IDIM.EQ.2.AND.IP.EQ.1).OR.
  157. $ (IDIM.EQ.3.AND.IP.LE.3)) IELIM=1
  158.  
  159. NBNN=LNBFAC(IP)
  160. NBELEM=IPT1.NUM(/2)
  161. NBFA=NBFA+NBELEM*NBNN
  162. NBSOUS=0
  163. NBREF=0
  164. SEGINI IPT2
  165. IPT2.ITYPEL=NBTYF(IP)
  166. IF(NBS.NE.1) THEN
  167. MELAF.LISOUS(L)=IPT2
  168. CG Pas besoin de désactiver MELAF, MELEME, IPT1, IPT2
  169. CG SEGDES IPT2
  170. CG SEGDES IPT1
  171. ELSE
  172. MELAF=IPT2
  173. ENDIF
  174. 1 CONTINUE
  175. CG SEGDES MELEME
  176. CG SEGDES MELAF
  177. C write(6,*)' Nombre de face total =',NBFA
  178.  
  179. IDIM1=IDIM+1
  180. CG Pas besoin d'activer MELAF, MELEME, IPT1, IPT2
  181. CG SEGACT MELEME,MELAF*MOD
  182. DO 50 L=1,NBS
  183. IF(NBS.NE.1)THEN
  184. IPT1=LISOUS(L)
  185. IPT2=MELAF.LISOUS(L)
  186. CG SEGACT IPT1
  187. CG SEGACT IPT2*MOD
  188. ELSE
  189. IPT1=MELEME
  190. IPT2=MELAF
  191. ENDIF
  192. NOM8=NOMS(IPT1.ITYPEL)//' '
  193. CALL OPTLI(IP,LTYPEL,NOM8,NBTYEL)
  194. IF(IP.GE.8.AND.IP.LE.10)THEN
  195. IQUAD=1
  196. ELSE
  197. IQUAD=0
  198. ENDIF
  199.  
  200. NBFAC=LNBFAC(IP)
  201. NEL=IPT1.NUM(/2)
  202. NP=IPT1.NUM(/1)
  203.  
  204. C ici on reserve la place pour les faces (ne concerne pas les TRI6...)
  205. NELN=0
  206. IF(IQUAD.EQ.0)THEN
  207. NELN=NEL*NBFAC
  208. C write(6,*)' NBFAC=',NBFAC,' IP=',IP,' NP=',NP,' NF=',NF
  209. NBPTI=XCOOR(/1)/IDIM1
  210. KF=NBPTI
  211. NBPTS=NBPTI+NELN
  212. SEGADJ MCOORD
  213. ENDIF
  214.  
  215. DO 52 I=1,NBFAC
  216. NPF=IKAS(5,I,IP)
  217. I1=IKAS(1,I,IP)
  218. I2=IKAS(2,I,IP)
  219. I3=IKAS(3,I,IP)
  220. I4=IKAS(4,I,IP)
  221.  
  222. GO TO (631,632,633,634),NPF
  223.  
  224. 631 CONTINUE
  225.  
  226. IF(IDIM.EQ.2)THEN
  227. C write(6,*)' Cas Segment la face est un poi1 '
  228.  
  229. IF(IQUAD.EQ.0)THEN
  230. DO 851 K=1,NEL
  231. KF1=KF
  232. KF=KF+1
  233. IPT2.NUM(I,K)=KF
  234. N1=IPT1.NUM(I1,K)
  235. N11=N1-1
  236. MD1=N11*IDIM1+1
  237. MD2=N11*IDIM1+2
  238. MG1=KF1*IDIM1+1
  239. MG2=KF1*IDIM1+2
  240. XCOOR(MG1)=XCOOR(MD1)
  241. XCOOR(MG2)=XCOOR(MD2)
  242. XCOOR(KF*IDIM1)=XCOOR(N1*IDIM1)
  243. 851 CONTINUE
  244. ELSE
  245. DO 751 K=1,NEL
  246. IPT2.NUM(I,K)=IPT1.NUM(I1,K)
  247. 751 CONTINUE
  248. ENDIF
  249.  
  250. ELSE
  251.  
  252. DO 951 K=1,NEL
  253. KF1=KF
  254. KF=KF+1
  255. IPT2.NUM(I,K)=KF
  256. N1=IPT1.NUM(I1,K)
  257. N11=N1-1
  258. MD1=N11*IDIM1+1
  259. MD2=N11*IDIM1+2
  260. MD3=N11*IDIM1+3
  261. MG1=KF1*IDIM1+1
  262. MG2=KF1*IDIM1+2
  263. MG3=KF1*IDIM1+3
  264. XCOOR(MG1)=XCOOR(MD1)
  265. XCOOR(MG2)=XCOOR(MD2)
  266. XCOOR(MG3)=XCOOR(MD3)
  267. XCOOR(KF*IDIM1)=XCOOR(N1*IDIM1)
  268. 951 CONTINUE
  269. ENDIF
  270.  
  271. GO TO 640
  272.  
  273. 632 CONTINUE
  274.  
  275. IF(IDIM.EQ.2)THEN
  276. C write(6,*)' Cas Triangle ou quadrangle la face est un seg2 '
  277.  
  278. IF(IQUAD.EQ.0)THEN
  279. DO 852 K=1,NEL
  280. KF1=KF
  281. KF=KF+1
  282. IPT2.NUM(I,K)=KF
  283. N1=IPT1.NUM(I1,K)
  284. N2=IPT1.NUM(I2,K)
  285. MG1=KF1*IDIM1+1
  286. MG2=KF1*IDIM1+2
  287. XCOOR(MG1)=
  288. & (XCOOR((N1-1)*IDIM1+1)+XCOOR((N2-1)*IDIM1+1))
  289. $ /2.D0
  290. XCOOR(MG2)=
  291. & (XCOOR((N1-1)*IDIM1+2)+XCOOR((N2-1)*IDIM1+2))
  292. $ /2.D0
  293. XCOOR(KF*IDIM1)=(XCOOR(N1*IDIM1)+XCOOR(N2*IDIM1))/2
  294. $ .D0
  295. C write(6,*)' KF=',KF,XCOOR(MG1),XCOOR(MG2)
  296. 852 CONTINUE
  297. ELSE
  298. C write(6,*)' I1,I=',i1,i
  299. DO 752 K=1,NEL
  300. IPT2.NUM(I,K)=IPT1.NUM(I1+1,K)
  301. 752 CONTINUE
  302. ENDIF
  303.  
  304. ELSE
  305.  
  306. DO 952 K=1,NEL
  307. KF1=KF
  308. KF=KF+1
  309. IPT2.NUM(I,K)=KF
  310. N1=IPT1.NUM(I1,K)
  311. N2=IPT1.NUM(I2,K)
  312. MG1=KF1*IDIM1+1
  313. MG2=KF1*IDIM1+2
  314. MG3=KF1*IDIM1+3
  315. XCOOR(MG1)=
  316. & (XCOOR((N1-1)*IDIM1+1)+XCOOR((N2-1)*IDIM1+1))/2
  317. $ .D0
  318. XCOOR(MG2)=
  319. & (XCOOR((N1-1)*IDIM1+2)+XCOOR((N2-1)*IDIM1+2))/2
  320. $ .D0
  321. XCOOR(MG3)=
  322. & (XCOOR((N1-1)*IDIM1+3)+XCOOR((N2-1)*IDIM1+3))/2
  323. $ .D0
  324. XCOOR(KF*IDIM1)=(XCOOR(N1*IDIM1)+XCOOR(N2*IDIM1))/2.D0
  325. 952 CONTINUE
  326. ENDIF
  327.  
  328. GO TO 640
  329.  
  330. 633 CONTINUE
  331. DO 853 K=1,NEL
  332. KF1=KF
  333. KF=KF+1
  334. IPT2.NUM(I,K)=KF
  335. N1=IPT1.NUM(I1,K)
  336. N2=IPT1.NUM(I2,K)
  337. N3=IPT1.NUM(I3,K)
  338. MG1=KF1*IDIM1+1
  339. MG2=MG1+1
  340. MG3=MG1+2
  341. XCOOR(MG1)=
  342. & (XCOOR((N1-1)*IDIM1+1)+XCOOR((N2-1)*IDIM1+1)
  343. & +XCOOR((N3-1)*IDIM1+1))/3.D0
  344. XCOOR(MG2)=
  345. & (XCOOR((N1-1)*IDIM1+2)+XCOOR((N2-1)*IDIM1+2)
  346. & +XCOOR((N3-1)*IDIM1+2))/3.D0
  347. XCOOR(MG3)=
  348. & (XCOOR((N1-1)*IDIM1+3)+XCOOR((N2-1)*IDIM1+3)
  349. & +XCOOR((N3-1)*IDIM1+3))/3.D0
  350. XCOOR(KF*IDIM1)=(XCOOR(N1*IDIM1)+XCOOR(N2*IDIM1)
  351. & +XCOOR(N3*IDIM1))/3.D0
  352. 853 CONTINUE
  353.  
  354. GO TO 640
  355.  
  356. 634 CONTINUE
  357. DO 854 K=1,NEL
  358. KF1=KF
  359. KF=KF+1
  360. IPT2.NUM(I,K)=KF
  361. N1=IPT1.NUM(I1,K)
  362. N2=IPT1.NUM(I2,K)
  363. N3=IPT1.NUM(I3,K)
  364. N4=IPT1.NUM(I4,K)
  365. MG1=KF1*IDIM1+1
  366. MG2=MG1+1
  367. MG3=MG1+2
  368. XCOOR(MG1)=
  369. & (XCOOR((N1-1)*IDIM1+1)+XCOOR((N2-1)*IDIM1+1)
  370. & +XCOOR((N3-1)*IDIM1+1)+XCOOR((N4-1)*IDIM1+1))/4.D0
  371. XCOOR(MG2)=
  372. & (XCOOR((N1-1)*IDIM1+2)+XCOOR((N2-1)*IDIM1+2)
  373. & +XCOOR((N3-1)*IDIM1+2)+XCOOR((N4-1)*IDIM1+2))/4.D0
  374. XCOOR(MG3)=
  375. & (XCOOR((N1-1)*IDIM1+3)+XCOOR((N2-1)*IDIM1+3)
  376. & +XCOOR((N3-1)*IDIM1+3)+XCOOR((N4-1)*IDIM1+3))/4.D0
  377. XCOOR(KF*IDIM1)=(XCOOR(N1*IDIM1)+XCOOR(N2*IDIM1)
  378. & +XCOOR(N3*IDIM1)+XCOOR(N4*IDIM1))/4.D0
  379. 854 CONTINUE
  380.  
  381. 640 CONTINUE
  382.  
  383. 52 CONTINUE
  384. CG Normalement, il n'y a pas besoin de désactiver MELAF et MELEME
  385. CG vu qu'ils sont réutilisés juste après
  386. CG IF(NBS.NE.1)THEN
  387. CG SEGDES IPT2
  388. CG SEGDES IPT1
  389. CG ENDIF
  390. 50 CONTINUE
  391. CG SEGDES MELAF
  392. CG SEGDES MELEME
  393.  
  394. CALL CRTABL(MTBT)
  395. CALL NOMOBJ('TABLE','tabletmp',MTBT)
  396.  
  397. CALL ECMO(MTBT,'MELAF','MAILLAGE',MELAF)
  398. IF(IXV.EQ.0)XVAL=XCOOR(KF*IDIM1)*(1.D-4)+1.D-8
  399. CALL ECROBJ('MAILLAGE',MELAF)
  400. WRITE(6,1951)
  401. 1951 FORMAT(1H+,' Creation des points face ')
  402. CALL ECRREE(XVAL)
  403. CALL PRELIM(0)
  404. CALL LIROBJ('MAILLAGE',MELAF,1,IRET)
  405. CALL ECMO(MTBT,'MELAF','MAILLAGE',MELAF)
  406. CALL ECRCHA('POI1')
  407. CALL ECROBJ('MAILLAGE',MELAF)
  408. CALL PRCHAN
  409. CALL LIROBJ('MAILLAGE',MF1,1,IRET)
  410. IF(IRET.EQ.0)RETURN
  411. CALL ECMO(MTBT,'MF1','MAILLAGE',MF1)
  412. CALL KNBEL(MF1,NBFA)
  413.  
  414. C Ici On cree les points centre
  415. C write(6,*)' Ici On cree les points centre'
  416.  
  417. CALL ECROBJ('MAILLAGE',MELEM0)
  418. CALL CRECTR
  419. CALL LIROBJ('MAILLAGE',MELEM1,1,IRET)
  420. IF(IRET.EQ.0)RETURN
  421.  
  422. IF(IQUAD.EQ.1)THEN
  423.  
  424. C Cas des éléments quadratiques on cree des TRI7,QUA9...
  425. C write(6,*)' Cas des éléments quadratiques'
  426.  
  427. SEGACT MELEME,MELEM1
  428. NBSOUS=LISOUS(/1)
  429. NBSOU2=NBSOUS
  430. IF(NBSOUS.EQ.0)NBSOU2=1
  431. KP=0
  432. DO 1880 L=1,NBSOU2
  433. IPT1=MELEME
  434. IF(NBSOU2.NE.1)IPT1=LISOUS(L)
  435. SEGACT IPT1
  436. NBNN=IPT1.NUM(/1)+1
  437. IF(IPT1.ITYPEL.EQ.3)NBNN=IPT1.NUM(/1)
  438. NBELEM=IPT1.NUM(/2)
  439. NBREF=0
  440. IF(L.EQ.1.AND.NBSOU2.EQ.1)THEN
  441. SEGINI MELEMQ
  442. IPT2=MELEMQ
  443. ELSEIF(L.EQ.1.AND.NBSOU2.NE.1)THEN
  444. NBNN=0
  445. NBELEM=0
  446. NBREF=0
  447. SEGINI MELEMQ
  448. NBNN=IPT1.NUM(/1)+1
  449. IF(IPT1.ITYPEL.EQ.3)NBNN=IPT1.NUM(/1)
  450. NBELEM=IPT1.NUM(/2)
  451. NBSOUS=0
  452. NBREF=0
  453. SEGINI IPT2
  454. MELEMQ.LISOUS(1)=IPT2
  455. NBSOUS=NBSOU2
  456. ELSE
  457. NBSOUS=0
  458. NBREF=0
  459. SEGINI IPT2
  460. MELEMQ.LISOUS(L)=IPT2
  461. NBSOUS=NBSOU2
  462. ENDIF
  463.  
  464. IF(IPT1.ITYPEL.EQ.6)THEN
  465. IPT2.ITYPEL=7
  466. DO 1883 K=1,NBELEM
  467. KP=KP+1
  468. DO 1882 I=1,NBNN-1
  469. IPT2.NUM(I,K)=IPT1.NUM(I,K)
  470. 1882 CONTINUE
  471. IPT2.NUM(NBNN,K)=MELEM1.NUM(1,KP)
  472. 1883 CONTINUE
  473. ELSEIF(IPT1.ITYPEL.EQ.3)THEN
  474. IPT2.ITYPEL=3
  475. DO 1885 K=1,NBELEM
  476. DO 18851 I=1,NBNN
  477. IPT2.NUM(I,K)=IPT1.NUM(I,K)
  478. 18851 CONTINUE
  479. 1885 CONTINUE
  480. ELSEIF(IPT1.ITYPEL.EQ.10)THEN
  481. IPT2.ITYPEL=11
  482. DO 1886 K=1,NBELEM
  483. KP=KP+1
  484. DO 1887 I=1,NBNN-1
  485. IPT2.NUM(I,K)=IPT1.NUM(I,K)
  486. 1887 CONTINUE
  487. IPT2.NUM(NBNN,K)=MELEM1.NUM(1,KP)
  488. 1886 CONTINUE
  489. ELSE
  490. WRITE(6,*)' Type d''élément non encore prévu'
  491. ENDIF
  492.  
  493. 1880 CONTINUE
  494. CALL ECMO(MTBT,'MELEMQ','MAILLAGE',MELEMQ)
  495. ENDIF
  496.  
  497.  
  498. C<<<<<<<<<<<<<
  499. CALL ECMO(MTBT,'MELEM1','MAILLAGE',MELEM1)
  500. C CALL ECMO(MTBT,'MELEM0','MAILLAGE',MELEM0)
  501. C CALL ECMO(MTBT,'MELAF','MAILLAGE',MELAF)
  502.  
  503. IF(IELIM.NE.0)THEN
  504.  
  505. WRITE(6,1952)
  506. 1952 FORMAT(1H+,' Elimination entre points centre et points face')
  507. CALL ECROBJ('MAILLAGE',MELEM1)
  508. CALL ECRREE(XVAL)
  509. CALL ECROBJ('MAILLAGE',MELAF)
  510. CALL PRELIM(0)
  511. CALL LIROBJ('MAILLAGE',MELEM1,1,IRET)
  512. IF(IRET.EQ.0)RETURN
  513.  
  514. WRITE(6,1954)
  515. 1954 FORMAT(1H+,' Elimination entre points face et points sommet')
  516. CALL ECROBJ('MAILLAGE',MELEM0)
  517. CALL ECRREE(XVAL)
  518. CALL ECROBJ('MAILLAGE',MELAF)
  519. CALL PRELIM(0)
  520. CALL LIROBJ('MAILLAGE',MELEM0,1,IRET)
  521. IF(IRET.EQ.0)RETURN
  522.  
  523. ENDIF
  524.  
  525. C Ici On cree les connectivites FACEL (SEG3)
  526. C -> In KRIPAD : SEGINI MLENTI
  527. C -> In KRIPAD : SEGACT MF1
  528. CALL KRIPAD(MF1,MLENTI)
  529. SEGDES MF1
  530. SEGACT MELEM1
  531.  
  532. NBNN=3
  533. NBELEM=NBFA
  534. NBSOUS=0
  535. NBREF=0
  536. SEGINI MFD
  537. MFD.ITYPEL=3
  538. SEGACT MELAF
  539. NBSOUS=MELAF.LISOUS(/1)
  540. IF(NBSOUS.EQ.0)NBSOUS=1
  541. NK=0
  542. DO 784 NS=1,NBSOUS
  543. IF(NBSOUS.NE.1)THEN
  544. MELEME=MELAF.LISOUS(NS)
  545. SEGACT MELEME
  546. ELSE
  547. MELEME=MELAF
  548. ENDIF
  549. NEL=NUM(/2)
  550. NP =NUM(/1)
  551. DO 783 K=1,NEL
  552. NK=NK+1
  553. NNK=MELEM1.NUM(1,NK)
  554. DO 782 I=1,NP
  555. NUF=NUM(I,K)
  556. NUF1=LECT(NUF)
  557. MFD.NUM(1,NUF1)=NNK
  558. MFD.NUM(2,NUF1)=NUF
  559. 782 CONTINUE
  560. 783 CONTINUE
  561. CG Pas besoin de désactiver
  562. CG IF(NBSOUS.NE.1)SEGDES MELEME
  563. CG SEGDES MELEME
  564. 784 CONTINUE
  565.  
  566. NK=NK+1
  567. DO 785 NS=NBSOUS,1,-1
  568. IF(NBSOUS.NE.1)THEN
  569. MELEME=MELAF.LISOUS(NS)
  570. CG Pas besoin de réactiver
  571. CG SEGACT MELEME
  572. ELSE
  573. MELEME=MELAF
  574. ENDIF
  575. NEL=NUM(/2)
  576. NP =NUM(/1)
  577. DO 786 K=NEL,1,-1
  578. NK=NK-1
  579. NNK=MELEM1.NUM(1,NK)
  580. DO 787 I=1,NP
  581. NUF=NUM(I,K)
  582. NUF1=LECT(NUF)
  583. MFD.NUM(3,NUF1)=NNK
  584. 787 CONTINUE
  585. 786 CONTINUE
  586. CG Pas besoin de désactiver mais après, il s'appelle IPT1 !
  587. CG IF(NBSOUS.NE.1)SEGDES MELEME
  588. 785 CONTINUE
  589. CG SEGDES MELAF
  590. SEGDES MFD
  591. SEGDES MELEM1
  592.  
  593.  
  594. C ici on cree les connectivites face --> sommet
  595.  
  596. CG Sous-entendu : NBFA=nb_éléments(MF1)
  597. SEGINI TRAV
  598. SEGACT MELEM0
  599. CG SEGACT MELAF
  600. NBSOUS=MELAF.LISOUS(/1)
  601. IF(NBSOUS.EQ.0)NBSOUS=1
  602. DO 338 L=1,NBSOUS
  603. IF(NBSOUS.NE.1)THEN
  604. IPT1=MELAF.LISOUS(L)
  605. IPT2=MELEM0.LISOUS(L)
  606. CG Déja activé plus haut
  607. CG SEGACT IPT1
  608. SEGACT IPT2
  609. ELSE
  610. IPT1=MELAF
  611. IPT2=MELEM0
  612. ENDIF
  613. NP =IPT1.NUM(/1)
  614. NEL=IPT1.NUM(/2)
  615. IP=LNBSO(IPT2.ITYPEL)
  616. DO 339 K=1,NEL
  617. DO 3391 I=1,NP
  618. NUF=IPT1.NUM(I,K)
  619. NUF=LECT(NUF)
  620. ITRAV(NUF,1)=IPT2
  621. ITRAV(NUF,2)=IP
  622. ITRAV(NUF,3)=I
  623. ITRAV(NUF,4)=K
  624. 3391 CONTINUE
  625. 339 CONTINUE
  626. IF(NBSOUS.NE.1)SEGDES IPT1
  627. 338 CONTINUE
  628. SEGDES MELAF
  629. SEGSUP MLENTI
  630.  
  631. C write(6,*)' Fin premiere partie '
  632. CALL INITI(NPS,4,0)
  633. DO 340 L=1,NBFA
  634. IP=ITRAV(L,2)
  635. I =ITRAV(L,3)
  636. NBS=IKAS(5,I,IP)
  637. C write(6,*)' IP,I,nbs=',IP,I,nbs
  638. NPS(NBS)=NPS(NBS)+1
  639. 340 CONTINUE
  640. C write(6,*)' NPS=',NPS
  641. NT=0
  642. DO 341 I=1,4
  643. IF(NPS(I).NE.0)THEN
  644. NT=NT+1
  645. IT=I
  646. ENDIF
  647. 341 CONTINUE
  648. NBREF=0
  649. IF(NT.EQ.1)THEN
  650. NBSOUS=0
  651. NBELEM=NPS(IT)
  652. NBNN=IT
  653. SEGINI MELEME
  654. ITYPEL=LTPL(IT)
  655. NPS(IT)=MELEME
  656. ELSE
  657. NBSOUS=NT
  658. NBELEM=0
  659. NBNN=0
  660. SEGINI MELEME
  661. JJ=0
  662. DO 342 J=1,4
  663. IF(NPS(J).EQ.0)GO TO 342
  664. JJ=JJ+1
  665. NBSOUS=0
  666. NBREF=0
  667. NBNN=J
  668. NBELEM=NPS(J)
  669. SEGINI IPT3
  670. LISOUS(JJ)=IPT3
  671. IPT3.ITYPEL=LTPL(J)
  672. NPS(J)=IPT3
  673. C write(6,*)' ipt3=',ipt3,' j=',j,' jj=',jj
  674. 342 CONTINUE
  675. ENDIF
  676. MPFD=MELEME
  677. C write(6,*)' Fin deuxieme partie MPFD=',MPFD
  678.  
  679. CALL INITI(MPS,4,0)
  680.  
  681. DO 343 L=1,NBFA
  682. IPT2=ITRAV(L,1)
  683. IP=ITRAV(L,2)
  684. I =ITRAV(L,3)
  685. K =ITRAV(L,4)
  686. NBS=IKAS(5,I,IP)
  687. IPT3=NPS(NBS)
  688. MPS(NBS)=MPS(NBS)+1
  689. KK=MPS(NBS)
  690. DO 344 J=1,NBS
  691. JJ=IKAS(J,I,IP)
  692. C write(6,*)'j,kk=',j,kk,' jj,k',jj,k,' nbs=',nbs
  693. IPT3.NUM(J,KK)=IPT2.NUM(JJ,K)
  694. 344 CONTINUE
  695. 343 CONTINUE
  696.  
  697. IF(MPFD.LISOUS(/1).NE.0)THEN
  698. NSO=MPFD.LISOUS(/1)
  699. DO 765 I=1,NSO
  700. IPT3=MPFD.LISOUS(I)
  701. SEGDES IPT3
  702. 765 CONTINUE
  703. ENDIF
  704. SEGDES MPFD
  705.  
  706. IF(MELEM0.LISOUS(/1).NE.0)THEN
  707. NSO=MELEM0.LISOUS(/1)
  708. DO 766 I=1,NSO
  709. IPT3=MELEM0.LISOUS(I)
  710. SEGDES IPT3
  711. 766 CONTINUE
  712. SEGDES MELEM0
  713. ENDIF
  714.  
  715. SEGSUP TRAV
  716. IF(KINC.EQ.1)THEN
  717. WRITE(6,1953)
  718. 1953 FORMAT(1H+
  719. $ ,' Elimination avec les points d''un autre domaine')
  720. CALL ECMO(MTBT,'MFD','MAILLAGE',MFD)
  721. CALL ECMO(MTBT,'MPFD','MAILLAGE',MPFD)
  722. CALL ECROBJ('MAILLAGE',MELEF1)
  723. CALL ECROBJ('MAILLAGE',MELEMC)
  724. CALL PRFUSE
  725. CALL ECROBJ('MAILLAGE',MELES1)
  726. CALL PRFUSE
  727. CALL LIROBJ('MAILLAGE',IPT1,1,IRET)
  728. IF(IRET.EQ.0)RETURN
  729. CALL ECMO(MTBT,'IPT1','MAILLAGE',IPT1)
  730. CALL ECROBJ('MAILLAGE',MF1)
  731. CALL ECROBJ('MAILLAGE',MELEM1)
  732. CALL PRFUSE
  733. CALL LIROBJ('MAILLAGE',IPT2,1,IRET)
  734. IF(IRET.EQ.0)RETURN
  735. CALL ECMO(MTBT,'IPT2','MAILLAGE',IPT2)
  736. CALL ECROBJ('MAILLAGE',IPT1)
  737. CALL ECRREE(XVAL)
  738. CALL ECROBJ('MAILLAGE',IPT2)
  739. C write(6,*)' Avant prelim ipt1=',ipt1,' ipt2',ipt2
  740. CALL PRELIM(0)
  741. CALL LIROBJ('MAILLAGE',IPT3,1,IRET)
  742. C write(6,*)' retour PRELIM IPT3=',IPT3
  743. SEGSUP IPT1
  744. SEGSUP IPT2
  745. C SEGSUP IPT3
  746. ENDIF
  747. SEGSUP MTBT
  748. CALL ECROBJ('MAILLAGE',MF1)
  749. CALL ECROBJ('MAILLAGE',MFD)
  750. CALL ECROBJ('MAILLAGE',MPFD)
  751. CALL ECROBJ('MAILLAGE',MELEM1)
  752. CALL ECROBJ('MAILLAGE',MELAF)
  753.  
  754. RETURN
  755.  
  756. 90 CONTINUE
  757. WRITE(6,*)' Retour anormal de KFCE '
  758. RETURN
  759. END
  760.  
  761.  
  762.  
  763.  
  764.  
  765.  
  766.  
  767.  
  768.  
  769.  

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