Télécharger raff.eso

Retour à la liste

Numérotation des lignes :

  1. C RAFF SOURCE PASCAL 20/06/08 21:15:03 10623
  2. SUBROUTINE RAFF
  3. C----------------------------------------------------------------------C
  4. C Operateur RAFF C
  5. C----------------------------------------------------------------------C
  6. C
  7. C Syntaxe 1 : GEO2 = RAFF GEO1 CHPO1 ;
  8. C
  9. C Syntaxe 2 : LRE2 = RAFF LRE1 ENT1 ;
  10. C
  11. C----------------------------------------------------------------------C
  12. IMPLICIT REAL*8(A-H,O-Z)
  13. IMPLICIT INTEGER(I-N)
  14.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC SMCOORD
  18. -INC CCGEOME
  19. -INC SMELEME
  20. -INC SMCHPOI
  21. -INC SMMODEL
  22. -INC SMCHAML
  23. c-INC CCREEL
  24. C
  25. INTEGER MCOL,NCOL
  26. C--------------------------------
  27. C B) VARIABLES RELATIVES A LA 2D !
  28. C--------------------------------
  29. SEGMENT KARETE(NBNDS,NCOL)
  30. SEGMENT KARET2(NBNDS,NCOL)
  31. SEGMENT KMILIE(NBNDS,NCOL)
  32. SEGMENT KARPOS(NBNDS)
  33. C
  34. C--------------------------------
  35. C C) VARIABLES RELATIVES A LA 3D !
  36. C--------------------------------
  37. SEGMENT IRELA(NBNDS)
  38. SEGMENT JPLANS(JPLA1,JPLA2)
  39. SEGMENT JPLAN2(JPLA1,JPLA2)
  40. SEGMENT JPLAN3(JPLA1,JPLA2)
  41. SEGMENT JPLCOM(JPLA1)
  42. SEGMENT JNOEFA(JNBFA,5)
  43. SEGMENT IWORK2(JNBSOM)
  44. SEGMENT JFARAF(JNBFA,LLLL)
  45. SEGMENT IWORK1(IJKLMN)
  46. C--------------------------
  47. C A) VARIABLES 'GENERALES' !
  48. C--------------------------
  49. SEGMENT ICPR(nbpts,2)
  50. SEGMENT LTYPE(NBLIS,2)
  51. SEGMENT LTYPE2(NBLIS2,4)
  52. SEGMENT LTYPE3(NBLIS3,2)
  53. SEGMENT LTYPE4(NBLIS3,2)
  54. c SEGMENT ICHPO
  55. c REAL*8 XR(NBPTCH),YR(NBPTCH),ZR(NBPTCH),DEN(NBPTCH)
  56. c ENDSEGMENT
  57. SEGMENT IDENSI
  58. REAL*8 DENSI(NBNDS)
  59. ENDSEGMENT
  60. SEGMENT XDEN(nbpts)
  61. XPETI= 1E-30
  62. C
  63. C---------------------------------------------------
  64. C D) VARIABLES RELATIVES AUX MAILLAGES DE RELATIONS !
  65. C---------------------------------------------------
  66. POINTEUR IPT10.MELEME
  67. POINTEUR IPT11.MELEME
  68. POINTEUR IPT12.MELEME
  69. POINTEUR IPT13.MELEME
  70.  
  71. POINTEUR IPT14.MELEME
  72. POINTEUR IPT15.MELEME
  73. POINTEUR IPT16.MELEME
  74. SEGMENT MAIREL(NBMAIL)
  75. C=======================================================================
  76. C Lecture des donnees utilisateurs
  77. C=======================================================================
  78. C
  79. C SYNTAXE 2 : cas du LISTREEL
  80. C ---------------------------
  81. CALL LIROBJ('LISTREEL',ILRE1,0,IRETOU)
  82. IF (IERR.NE.0) RETURN
  83. C
  84. IF (IRETOU.NE.0) THEN
  85. ICAS = 0
  86. CALL LIRENT(KR1,0,IRETOU)
  87. IF (IERR.NE.0) RETURN
  88. IF (IRETOU.EQ.0) THEN
  89. CALL LIRREE(XR1,1,IRETOU)
  90. IF (IERR.NE.0) RETURN
  91. ICAS = 2
  92. ELSE
  93. ICAS = 1
  94. ENDIF
  95. CALL RAFLRE(ILRE1,KR1,XR1,ICAS,ILRE2)
  96. IF (IERR.NE.0) RETURN
  97. IF (ILRE2.NE.0) THEN
  98. CALL ECROBJ('LISTREEL',ILRE2)
  99. ELSE
  100. CALL ERREUR(5)
  101. ENDIF
  102. RETURN
  103. ENDIF
  104. C
  105. C SYNTAXE 1 : cas du MAILLAGE
  106. C ---------------------------
  107. C On lit le maillage a raffiner et le champoint de densite a affecter
  108. c ipt1 : maillage initial à raffiner
  109. c mchpo1 : chapoint de densité voulu(que devrai être définit sur ipt1)
  110. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  111. CALL ACTOBJ('MAILLAGE',IPT1,1)
  112. IF (IERR.NE.0) RETURN
  113. CALL LIROBJ('CHPOINT',MCHPO1,1,IRETOU)
  114. CALL ACTOBJ('CHPOINT',MCHPO1,1)
  115. IF (IERR.NE.0) RETURN
  116. C
  117. C=======================================================================
  118. C Initialisations - Declarations
  119. C=======================================================================
  120. NCOL=0
  121. MCOL=0
  122. NBOUCL=0
  123. NPTINI=nbpts
  124. SEGACT IPT1
  125.  
  126. IJKLMN=4
  127. SEGINI IWORK1
  128. IWORK1(1)=4
  129. IWORK1(2)=8
  130. IWORK1(3)=6
  131. IWORK1(4)=10
  132.  
  133. SEGINI,XDEN
  134.  
  135. C
  136. C=======================================================================
  137. C Tests sur les donnees
  138. C=======================================================================
  139. C On teste pour savoir si le maillage IPT1 (maillage 1) a un type
  140. C d'elements implemante.
  141. c TRI3 TRI6 QUA4 QUA8 CUB8 CUB26 PRY6 PR15 TET4 TET10 SURE
  142. C les pyramides 5 et 13 ont été débranchés
  143. c création du tableau
  144. NBLIS=MAX(1,IPT1.LISOUS(/1))
  145. NSURE=0
  146. SEGINI LTYPE
  147. DO 1 INB=1,MAX(1,IPT1.LISOUS(/1))
  148. IF (IPT1.LISOUS(/1).EQ.0) THEN
  149. IPT2=IPT1
  150. ELSE
  151. IPT2=IPT1.LISOUS(INB)
  152. SEGACT IPT2
  153. ENDIF
  154. NT=IPT2.ITYPEL
  155. IF (NT.EQ.48) NSURE=NSURE+1
  156. LTYPE(INB,1)=INB
  157. LTYPE(INB,2)=NT
  158. IF (NT.EQ.16) THEN
  159. write (*,*) 'Attention le raffinement PRI6 a debrancher !'
  160. ENDIF
  161. IF (NT.EQ.23) THEN
  162. write (*,*) 'Attention le raffinement TET4 a debrancher !'
  163. ENDIF
  164. IF ((NT.NE.4).AND.(NT.NE.6).AND.(NT.NE.8).AND.(NT.NE.10).AND.
  165. + (NT.NE.14).AND.(NT.NE.15).AND.(NT.NE.16).AND.(NT.NE.17).AND.
  166. + (NT.NE.23).AND.(NT.NE.24).AND.(NT.NE.48)) THEN
  167. WRITE(*,*) 'Erreur, type d element non pris en compte'
  168. RETURN
  169. ENDIF
  170. c write(*,*) 'type d elem du maillage de depart', LTYPE(INB,1),
  171. c + LTYPE(INB,2)
  172.  
  173. C IF ((NT.NE.4).AND.(NT.NE.6).AND.(NT.NE.8).AND.(NT.NE.10).AND.
  174. C + (NT.NE.14).AND.(NT.NE.15).AND.(NT.NE.16).AND.(NT.NE.17).AND.
  175. C + (NT.NE.23).AND.(NT.NE.24).AND.(NT.NE.48).AND.(NT.NE.25).AND.
  176. C + (NT.NE.26)) RETURN
  177. IF ((IPT1.LISOUS(/1).EQ.0).AND.(NT.EQ.48)) RETURN
  178. 1 CONTINUE
  179.  
  180. C
  181. C=======================================================================
  182. C Separation du maillage initial
  183. C=======================================================================
  184. C Si le maillage initial comporte des lisous de type 48, on le separe
  185. C en deux maillages dont un ne sera compose que des lisous de type 48.
  186. C Maillage d'elements de type 48 : IPT6
  187. C Maillage sans elements de type 48 : IPT5
  188. C IPT1 reste le maillage initial complet
  189. LCONF2=0
  190. IF (NSURE.EQ.0) GOTO 7
  191. LCONF2=1
  192. 7 CONTINUE
  193. C-------------------------------
  194. C A) Creation du maillage IPT6 !
  195. C-------------------------------
  196. C A.1/** Cas ou il n'y a qu'un lisous de type 48
  197. IF (NSURE.EQ.1) THEN
  198. DO 2 K=1,LTYPE(/1)
  199. IF (LTYPE(K,2).EQ.48) IPT6=IPT1.LISOUS(LTYPE(K,1))
  200. 2 CONTINUE
  201. ENDIF
  202. C
  203. C A.2/** Cas ou il y a plusieurs lisous de type 48
  204. IF (NSURE.GT.1) THEN
  205. NBREF=0
  206. NBSOUS=NSURE
  207. NBNN=0
  208. NBELEM=0
  209. SEGINI IPT6
  210. KLISOU=0
  211. DO 3 K=1,LTYPE(/1)
  212. IF (LTYPE(K,2).EQ.48) THEN
  213. KLISOU=KLISOU+1
  214. IPT6.LISOUS(KLISOU)=IPT1.LISOUS(LTYPE(K,1))
  215. ENDIF
  216. 3 CONTINUE
  217. ENDIF
  218. IF (NSURE.EQ.0) THEN
  219. NBREF=0
  220. NBSOUS=NSURE
  221. NBNN=0
  222. NBELEM=0
  223. SEGINI IPT6
  224. ENDIF
  225. C
  226. C------------------------------
  227. C B) Creation de IPT5 !
  228. C------------------------------
  229. C
  230. NBSOUS=LTYPE(/1)-NSURE
  231. NBREF=0
  232. NBNN=0
  233. NBELEM=0
  234. C B.0/** Cas ou il n'y a qu'un lisous en tout
  235. IF ((NBSOUS.EQ.1).AND.(NSURE.EQ.0)) THEN
  236. NBSOUS=0
  237. SEGINI IPT5
  238. IPT5=IPT1
  239. ENDIF
  240. C B.1/** Cas ou il n'y a qu'un lisous de type different de 48
  241. IF ((NBSOUS.EQ.1).AND.(NSURE.NE.0)) THEN
  242. SEGINI IPT5
  243. DO 4 K=1,LTYPE(/1)
  244. IF (LTYPE(K,2).NE.48) IPT5=IPT1.LISOUS(LTYPE(K,1))
  245. 4 CONTINUE
  246. ENDIF
  247. C
  248. C B.2/** Cas ou il y a plusieurs lisous de types differents de 48
  249. IF (NBSOUS.GT.1) THEN
  250. SEGINI IPT5
  251. KLISOU=0
  252. DO 5 K=1,LTYPE(/1)
  253. IF (LTYPE(K,2).NE.48) THEN
  254. KLISOU=KLISOU+1
  255. IPT5.LISOUS(KLISOU)=IPT1.LISOUS(LTYPE(K,1))
  256. ENDIF
  257. 5 CONTINUE
  258. ENDIF
  259.  
  260. c compteur de relaton globale
  261. LCONF3=LCONF2
  262. C=======================================================================
  263. C Debut de la boucle sur les itérations de Raffinement
  264. C=======================================================================
  265. 9 CONTINUE
  266.  
  267. c write(*,*) 'RAFF: ITERATION boucle 9',NBOUCL
  268. c write(*,*) 'ipt5 : ', ipt5
  269. c write(*,*) 'ipt6 : ', ipt6
  270. c write(*,*) 'lconf3 : ', lconf3
  271. C
  272. C=======================================================================
  273. C Renumerotation locale des noeuds du maillage
  274. C=======================================================================
  275. C ICPR(I,1)=J : Le Ieme noeud global est le Jeme local
  276. C ICPR(I,2)=J : Le Ieme noeud global appartient a J elements
  277.  
  278. SEGACT IPT5
  279.  
  280. NBOUCL=NBOUCL+1
  281. SEGINI ICPR
  282. NBNDS=0
  283. NCOL=0
  284. DO 11 INB=1,MAX(1,IPT5.LISOUS(/1))
  285. IF (IPT5.LISOUS(/1).EQ.0) THEN
  286. IPT2=IPT5
  287. ELSE
  288. IPT2=IPT5.LISOUS(INB)
  289. SEGACT IPT2
  290. ENDIF
  291. IF (IPT2.ITYPEL.EQ.48) GOTO 11
  292. DO 10 J=1,IPT2.NUM(/2)
  293. DO 110 I=1,IPT2.NUM(/1)
  294. ITMP=IPT2.NUM(I,J)
  295. IF (ICPR(ITMP,1).NE.0) THEN
  296. ICPR(ITMP,2)=ICPR(ITMP,2)+1
  297. NCOL=MAX(NCOL,ICPR(ITMP,2))
  298. ELSE
  299. NBNDS=NBNDS+1
  300. ICPR(ITMP,1)=NBNDS
  301. ICPR(ITMP,2)=1
  302. NCOL=MAX(NCOL,ICPR(ITMP,2))
  303. ENDIF
  304. 110 CONTINUE
  305. 10 CONTINUE
  306. 11 CONTINUE
  307. IF (IDIM.EQ.2) NCOL=NCOL*2
  308. IF (IDIM.EQ.3) NCOL=NCOL*4
  309. C
  310. C
  311. C
  312. C
  313. C=======================================================================
  314. C Prise en compte des noeuds de relations
  315. C=======================================================================
  316. C IRELA(I,1) = 1 si le noeud I (en numerotation locale) est un noeud
  317. C de relation ("hanging node")
  318. C IRELA(I,1) = 0 sinon
  319. SEGINI IRELA
  320. IF (LCONF3.EQ.0) GOTO 1200
  321. SEGACT IPT6
  322. DO 1218 LAA=1,MAX(1,IPT6.LISOUS(/1))
  323. IF (IPT6.LISOUS(/1).EQ.0) THEN
  324. IPT2=IPT6
  325. ELSE
  326. IPT2=IPT6.LISOUS(LAA)
  327. ENDIF
  328. SEGACT IPT2
  329. IF (IPT2.ITYPEL.NE.48) GOTO 1218
  330. DO 1220 J=1,IPT2.NUM(/2)
  331. IRELA(ICPR(IPT2.NUM(1,J),1))=1
  332. 1220 CONTINUE
  333. 1218 CONTINUE
  334. 1200 CONTINUE
  335.  
  336. C
  337. C=======================================================================
  338. C Prise en compte du champoint de densite
  339. C=======================================================================
  340. C On affecte une densite a chacun des noeuds du maillage. On calcule
  341. C cette densite a partir des densites existantes dans le champoint, a
  342. C l'aide de la fonction RAFDEN.
  343. C Remarque : on ne prend pas en compte les densites qui pourraient
  344. C exister dans le tableau XCOOR.
  345. C
  346.  
  347. C------------------------------------------
  348. C A) Recuperation des valeurs du champoint !
  349. C------------------------------------------
  350. C XDEN(I,1) = densite affectee au noeud I (en numerotation globale)
  351. IF (NBOUCL.EQ.1) THEN
  352. SEGACT MCHPO1
  353. IF (MCHPO1.IPCHP(/1).NE.1) RETURN
  354. MSOUPO=MCHPO1.IPCHP(1)
  355. SEGACT MSOUPO
  356. IPT3=IGEOC
  357. MPOVA1=IPOVAL
  358. SEGACT IPT3
  359. SEGACT MPOVA1
  360. IF (MPOVA1.VPOCHA(/2).NE.1) RETURN
  361. NBPTCH=IPT3.NUM(/2)
  362. c SEGINI ICHPO
  363. DO 13 I=1,NBPTCH
  364. J=IPT3.NUM(1,I)
  365. c XR(I)=XCOOR((J-1)*(IDIM+1)+1)
  366. c YR(I)=XCOOR((J-1)*(IDIM+1)+2)
  367. c IF (IDIM.EQ.3) ZR(I)=XCOOR((J-1)*(IDIM+1)+3)
  368. c DEN(I)=MPOVA1.VPOCHA(I,1)
  369. c if(J.eq.115.or.J.eq.321.or.
  370. c . J.eq.6261.or.J.eq.5815) then
  371. C write(*,*) 'RAFF: #',J,'DEN(',I,'/',NBPTCH,')=',DEN(I)
  372. c endif
  373. XDEN(J)=MPOVA1.VPOCHA(I,1)
  374. 13 CONTINUE
  375. C Rem ;seulement pour les noeud "peres",
  376. C pour les "fils" raff2d remplit XDEN
  377. ENDIF
  378. C
  379. C--------------------------------------------------------------
  380. C B) Affectation d'une densite a chacun des noeuds du maillage !
  381. C--------------------------------------------------------------
  382. C IDENSI(I,1) = densite affectee au noeud I (en numerotation locale)
  383. SEGINI IDENSI
  384. DO 15 INB=1,MAX(1,IPT5.LISOUS(/1))
  385. IF (IPT5.LISOUS(/1).EQ.0) THEN
  386. IPT2=IPT5
  387. ELSE
  388. IPT2=IPT5.LISOUS(INB)
  389. SEGACT IPT2
  390. ENDIF
  391. c write(*,*) 'ipt2 : ', ipt2, 'type', IPT2.ITYPEL
  392. c write(*,*) IPT2.NUM(/2), IPT2.NUM(/1)
  393. c IF (IPT2.ITYPEL.EQ.48) GOTO 15
  394. DO 14 J=1,IPT2.NUM(/2)
  395. DO 114 I=1,IPT2.NUM(/1)
  396. NGLOB=IPT2.NUM(I,J)
  397. NLOC=ICPR(NGLOB,1)
  398. c XPT=XCOOR((NGLOB-1)*(IDIM+1)+1)
  399. c YPT=XCOOR((NGLOB-1)*(IDIM+1)+2)
  400. c ZPT=0
  401. c IF (IDIM.EQ.3) ZPT=XCOOR((NGLOB-1)*(IDIM+1)+3)
  402. c CALL RAFDEN(ICHPO,XPT,YPT,ZPT,IDIM,DENPT)
  403. c DENSI(NLOC)=DENPT
  404. DENSI(NLOC)=XDEN(NGLOB)
  405. c WRITE (*,*) 'densite au pt', NGLOB, XDEN(NGLOB), XPETI
  406. IF (XDEN(NGLOB).LT.XPETI) THEN
  407. WRITE (*,*) 'Champ de densité en entrée nul au point',
  408. + NGLOB, 'impossible de raffiner'
  409. RETURN
  410. ENDIF
  411. 114 CONTINUE
  412. 14 CONTINUE
  413. 15 CONTINUE
  414. C
  415. C=======================================================================
  416. C Remplissage du tableau KARETE
  417. C=======================================================================
  418. C On remplit le tableau KARETE avec les donnees provenant de l'analyse
  419. C du maillage.
  420. C KARETE(i,j)=k : le ieme noeud local forme une arete
  421. C avec le keme noeud local (k>i)
  422. C KARPOS(i)=k : compteur de position (k=nb d'aretes touchant i)
  423. C KARET2(i,j)=k : l'arete i-j appartient a k elements
  424. JPLA1=NBNDS
  425. JPLA2=NCOL
  426. SEGINI KARETE,KARPOS,KARET2
  427. NBARET=0
  428. NCOL=1
  429. DO 18 INB=1,MAX(1,IPT5.LISOUS(/1))
  430. IF (IPT5.LISOUS(/1).EQ.0) THEN
  431. IPT2=IPT5
  432. ELSE
  433. IPT2=IPT5.LISOUS(INB)
  434. SEGACT IPT2
  435. ENDIF
  436. c IF (IPT2.ITYPEL.EQ.48) GOTO 18
  437. ILPL=LPL(IPT2.ITYPEL)
  438. ILPT=LPT(IPT2.ITYPEL)
  439. DO 17 J=1,IPT2.NUM(/2)
  440. DO 117 K=1,ILPL*2-1,2
  441. NPTA=IPT2.NUM(KSEGM(ILPT+K-1),J)
  442. NPTB=IPT2.NUM(KSEGM(ILPT+K),J)
  443. NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1))
  444. NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1))
  445. NEXIST=0
  446. DO 16 I=1,MAX(1,KARPOS(NMIN))
  447. IF (KARETE(NMIN,I).EQ.NMAX) NEXIST=I
  448. 16 CONTINUE
  449. c création d'une nouvelle arrète
  450. IF (NEXIST.EQ.0) THEN
  451. IF ((KARPOS(NMIN)+1).GT.NCOL) THEN
  452. NCOL=KARPOS(NMIN)+1
  453. SEGADJ KARETE, KARET2
  454. ENDIF
  455. KARPOS(NMIN)=KARPOS(NMIN)+1
  456. KARETE(NMIN,KARPOS(NMIN))=NMAX
  457. KARET2(NMIN,KARPOS(NMIN))=1
  458. NBARET=NBARET+1
  459. c NCOL=MAX(NCOL,KARPOS(NMIN))
  460. ENDIF
  461. IF (NEXIST.NE.0) THEN
  462. KARET2(NMIN,NEXIST)=KARET2(NMIN,NEXIST)+1
  463. ENDIF
  464. 117 CONTINUE
  465. 17 CONTINUE
  466. 18 CONTINUE
  467. c SEGADJ KARETE,KARET2
  468. SEGDES KARETE,KARPOS,KARET2
  469. C
  470. C=======================================================================
  471. C Remplissage des tableaux JPLANS et JNOEFA
  472. C=======================================================================
  473. C On remplit les tableaux de description des faces dans le cas 3D.
  474. C JPLANS(i,j)=k : la jeme face dont le plus petit sommet en
  475. C numerotation locale est le sommet i est la face k
  476. C JNOEFA(i,1-3)=j-k-l : Les 3 plus petits sommets en numerotation
  477. C locale de la face i sont les noeuds j,k et l
  478. C JNOEFA(i,4-5)=j-k : La face identifiee par les 3 sommets precedents
  479. C appartient aux lisous de type j et k
  480. C JPLCOM(i)=k : compteur de position (k=nb de faces touchant i)
  481. IF (IDIM.NE.3) GOTO 40
  482. C----------------------------------------------------
  483. C A) Comptage du nombre d'elements total du maillage !
  484. C----------------------------------------------------
  485. NELTOT=0
  486. DO 50 INB=1,MAX(1,IPT5.LISOUS(/1))
  487. IF (IPT5.LISOUS(/1).EQ.0) THEN
  488. IPT2=IPT5
  489. ELSE
  490. IPT2=IPT5.LISOUS(INB)
  491. SEGACT IPT2
  492. ENDIF
  493. NELTOT=NELTOT+IPT2.NUM(/2)
  494. 50 CONTINUE
  495. C
  496. C-------------------------------------------------
  497. C B) Initialisation des tableaux JPLANS et JNOEFA !
  498. C-------------------------------------------------
  499. JNBFA=NELTOT*6
  500. JMAXPL=0
  501. JNUMFA=0
  502. SEGINI JPLANS,JPLCOM,JNOEFA
  503. C
  504. C-----------------------------------------------
  505. C C) Remplissage des tableaux JPLANS et JNOEFA !
  506. C-----------------------------------------------
  507. DO 51 INB=1,MAX(1,IPT5.LISOUS(/1))
  508. IF (IPT5.LISOUS(/1).EQ.0) THEN
  509. IPT2=IPT5
  510. ELSE
  511. IPT2=IPT5.LISOUS(INB)
  512. SEGACT IPT2
  513. ENDIF
  514. C IF (IPT2.ITYPEL.EQ.48) GOTO 51
  515. DO 52 KELEM=1,IPT2.NUM(/2)
  516. JTYPEL=IPT2.ITYPEL
  517. JLTEL1=LTEL(1,JTYPEL)
  518. JLTEL2=LTEL(2,JTYPEL)
  519. DO 53 IBB=1,JLTEL1
  520. JLDEL1=LDEL(1,JLTEL2-1+IBB)
  521. JTYFAC=IWORK1(JLDEL1)
  522. JLDEL2=LDEL(2,JLTEL2-1+IBB)
  523. JNBSOM=NBSOM(JTYFAC)
  524. JSPOS=NSPOS(JTYFAC)
  525. SEGINI IWORK2
  526. DO 54 IAA=1,JNBSOM
  527. NGLOBA=IPT2.NUM(LFAC(JLDEL2-1+IBSOM(JSPOS-1+IAA)),KELEM)
  528. IWORK2(IAA)=NGLOBA
  529. 54 CONTINUE
  530. C
  531. C----------------------------------------------------
  532. C D) Tri des sommets de la face par ordre croissant !
  533. C----------------------------------------------------
  534. C On va ranger les 3 plus petits sommets de la face (en numerotation
  535. C globale) dans les variables NPTA, NPTB, NPTC. On les classe par ordre
  536. C croissant.
  537. C
  538. C 1/ Classement des 3 sommets par ordre croissant (num globale)
  539. NPTA=nbpts+1
  540. NPTB=NPTA+1
  541. NPTC=NPTB+1
  542. DO 55 ICC=1,JNBSOM
  543. IF (IWORK2(ICC).LT.NPTA) THEN
  544. NPTC=NPTB
  545. NPTB=NPTA
  546. NPTA=IWORK2(ICC)
  547. ELSEIF (IWORK2(ICC).LT.NPTB) THEN
  548. NPTC=NPTB
  549. NPTB=IWORK2(ICC)
  550. ELSEIF (IWORK2(ICC).LT.NPTC) THEN
  551. NPTC=IWORK2(ICC)
  552. ENDIF
  553. 55 CONTINUE
  554. C
  555. C 2/ Classement des 3 sommets par ordre croissant (num locale)
  556. NPTA2=ICPR(NPTA,1)
  557. NPTB2=ICPR(NPTB,1)
  558. NPTC2=ICPR(NPTC,1)
  559. IF ((NPTA2.LT.NPTB2).AND.(NPTA2.LT.NPTC2)) THEN
  560. NPTA=NPTA2
  561. NPTB=MIN(NPTB2,NPTC2)
  562. NPTC=MAX(NPTB2,NPTC2)
  563. ENDIF
  564. IF ((NPTB2.LT.NPTA2).AND.(NPTB2.LT.NPTC2)) THEN
  565. NPTA=NPTB2
  566. NPTB=MIN(NPTA2,NPTC2)
  567. NPTC=MAX(NPTA2,NPTC2)
  568. ENDIF
  569. IF ((NPTC2.LT.NPTA2).AND.(NPTC2.LT.NPTB2)) THEN
  570. NPTA=NPTC2
  571. NPTB=MIN(NPTA2,NPTB2)
  572. NPTC=MAX(NPTA2,NPTB2)
  573. ENDIF
  574. C
  575. C----------------------------------------
  576. C E) Renseignement des nouvelles faces !
  577. C----------------------------------------
  578. SEGACT LTYPE
  579. c IHERED=0
  580. c DO 1022 MOI=1,IPT2.NUM(/1)
  581. c IHERED=IHERED+IRELA(ICPR(IPT2.NUM(MOI,KELEM),1))
  582. c 1022 CONTINUE
  583.  
  584. C Si NPTA Ne correspond a aucune face : On cree une face
  585. IF (JPLCOM(NPTA).EQ.0) THEN
  586. JNUMFA=JNUMFA+1
  587. JPLCOM(NPTA)=JPLCOM(NPTA)+1
  588. JPLANS(NPTA,JPLCOM(NPTA))=JNUMFA
  589. JNOEFA(JNUMFA,1)=NPTA
  590. JNOEFA(JNUMFA,2)=NPTB
  591. JNOEFA(JNUMFA,3)=NPTC
  592. JNOEFA(JNUMFA,4)=LTYPE(INB,2)
  593. c IF (IHERED.NE.0) JNOEFA(JNUMFA,5)=LTYPE(INB,2)
  594. C On signale les sous face de faces supportant un sure
  595. C JNOEFA(JNUMFA,5)= 48
  596. IF (LCONF3.NE.0) THEN
  597. SEGACT IPT6
  598. DO 501 LAA1=1,MAX(1,IPT6.LISOUS(/1))
  599. IF (IPT6.LISOUS(/1).EQ.0) THEN
  600. IPT4=IPT6
  601. ELSE
  602. IPT4=IPT6.LISOUS(LAA1)
  603. ENDIF
  604. SEGACT IPT4
  605. IF (IPT4.ITYPEL.NE.48) GOTO 501
  606. IF (IPT4.ICOLOR(1).NE.3) GOTO 501
  607. DO 502,MAA1=1,IPT4.NUM(/2)
  608. NEXI1=0
  609. NEXI2=0
  610. DO 503 ICC1=1,JNBSOM
  611. IF (IWORK2(ICC1).EQ.IPT4.NUM(1, MAA1)) THEN
  612. NEXI1=NEXI1+1
  613. ENDIF
  614. 503 CONTINUE
  615. IF (NEXI1.GT.0) THEN
  616. DO 504 ICC2=1,JNBSOM
  617. DO 1504 INN2=2,IPT4.NUM(/1)
  618. IF (IWORK2(ICC2).EQ.IPT4.NUM(INN2,MAA1)) THEN
  619. NEXI2=NEXI2+1
  620. ENDIF
  621. 1504 CONTINUE
  622. 504 CONTINUE
  623. IF (NEXI2.GT.0) JNOEFA(JNUMFA,5)= 48
  624. ENDIF
  625. 502 CONTINUE
  626. 501 CONTINUE
  627. ENDIF
  628.  
  629.  
  630. C Si NPTA correspond a aumoins une face
  631. ELSE
  632. NEXIST=0
  633. DO 56 IDD=1,JPLCOM(NPTA)
  634. ITEMP1=JPLANS(NPTA,IDD)
  635. NAA=JNOEFA(ITEMP1,1)
  636. NBB=JNOEFA(ITEMP1,2)
  637. NCC=JNOEFA(ITEMP1,3)
  638. C Si la face que actuelle existe déja : on renseigne JNOEFA(NEXIST,5)
  639. IF (NAA.EQ.NPTA.AND.NBB.EQ.NPTB.AND.NCC.EQ.NPTC) THEN
  640. NEXIST=ITEMP1
  641. JNOEFA(NEXIST,5)=LTYPE(INB,2)
  642. ENDIF
  643.  
  644.  
  645. 56 CONTINUE
  646. C Si la face que actuelle n'existe pas : On cree une face
  647. IF (NEXIST.EQ.0) THEN
  648. JNUMFA=JNUMFA+1
  649. JPLCOM(NPTA)=JPLCOM(NPTA)+1
  650. JPLANS(NPTA,JPLCOM(NPTA))=JNUMFA
  651. JNOEFA(JNUMFA,1)=NPTA
  652. JNOEFA(JNUMFA,2)=NPTB
  653. JNOEFA(JNUMFA,3)=NPTC
  654. JNOEFA(JNUMFA,4)=LTYPE(INB,2)
  655. c IF (IHERED.NE.0) JNOEFA(JNUMFA,5)=LTYPE(INB,2)
  656.  
  657. C On signale les sous face de faces supportant un sure
  658. C JNOEFA(JNUMFA,5)= 48
  659. IF (LCONF3.NE.0) THEN
  660. SEGACT IPT6
  661. DO 505 LAA1=1,MAX(1,IPT6.LISOUS(/1))
  662. IF (IPT6.LISOUS(/1).EQ.0) THEN
  663. IPT4=IPT6
  664. ELSE
  665. IPT4=IPT6.LISOUS(LAA1)
  666. ENDIF
  667. SEGACT IPT4
  668. IF (IPT4.ITYPEL.NE.48) GOTO 505
  669. IF (IPT4.ICOLOR(1).NE.3) GOTO 505
  670. DO 506,MAA1=1,IPT4.NUM(/2)
  671. NEXI1=0
  672. NEXI2=0
  673. DO 507 ICC1=1,JNBSOM
  674. IF (IWORK2(ICC1).EQ.IPT4.NUM(1, MAA1)) THEN
  675. NEXI1=NEXI1+1
  676. ENDIF
  677. 507 CONTINUE
  678. IF (NEXI1.GT.0) THEN
  679. DO 508 ICC2=1,JNBSOM
  680. DO 1508 INN2=2,IPT4.NUM(/1)
  681. IF (IWORK2(ICC2).EQ.IPT4.NUM(INN2,MAA1)) THEN
  682. NEXI2=NEXI2+1
  683. ENDIF
  684. 1508 CONTINUE
  685. 508 CONTINUE
  686. IF (NEXI2.GT.0) JNOEFA(JNUMFA,5)= 48
  687. ENDIF
  688. 506 CONTINUE
  689. 505 CONTINUE
  690. ENDIF
  691. ENDIF
  692. ENDIF
  693.  
  694. JMAXPL=MAX(JMAXPL,JPLCOM(NPTA))
  695. 53 CONTINUE
  696. 52 CONTINUE
  697. 51 CONTINUE
  698. JPLA2=JMAXPL
  699. JNBFA=JNUMFA
  700. SEGADJ JPLANS,JPLCOM,JNOEFA
  701. SEGDES LTYPE
  702. C
  703. C=======================================================================
  704. C Pre-remplissage du tableau KMILIE
  705. C=======================================================================
  706. C On remplit le tableau lorsqu'il y a des maillages de relations de
  707. C type 48 (IPT6, LCONF3 non nul)
  708. C KARETE(i,j)=k ET KMILIE(i,j)=n : le noeud global n est situe
  709. C au milieu de l'arete [i,k]
  710. 40 CONTINUE
  711. SEGINI KMILIE
  712. SEGACT KARETE*MOD,KARPOS*MOD,KARET2*MOD
  713. IF (LCONF3.EQ.0) THEN
  714. GOTO 28
  715. ENDIF
  716. 22 CONTINUE
  717. NBRELA=0
  718. SEGACT IPT6
  719. DO 218 LAA=1,MAX(1,IPT6.LISOUS(/1))
  720. IF (IPT6.LISOUS(/1).EQ.0) THEN
  721. IPT2=IPT6
  722. ELSE
  723. IPT2=IPT6.LISOUS(LAA)
  724. ENDIF
  725. SEGACT IPT2
  726. IF (IPT2.ITYPEL.NE.48) GOTO 218
  727. IF ((IPT2.ICOLOR(1).NE.1).AND.(IPT2.ICOLOR(1).NE.2)) GOTO 218
  728. DO 220 J=1,IPT2.NUM(/2)
  729.  
  730. NPTA=IPT2.NUM(2,J)
  731. NPTB=IPT2.NUM(3,J)
  732. NPTC=IPT2.NUM(1,J)
  733. NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1))
  734. NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1))
  735. NEXIST=0
  736. DO 219 I=1,MAX(1,KARPOS(NMIN))
  737. IF (KARETE(NMIN,I).EQ.NMAX) NEXIST=I
  738. 219 CONTINUE
  739.  
  740. IF (NEXIST.NE.0) then
  741. KMILIE(NMIN,NEXIST)=NPTC
  742. c WRITE (*,*) 'REPORT ANCIENNE RELA AU NOEUD:', NPTC
  743. c write (*,*) 'karret2(nmin nexist)', KARET2(NMIN,NEXIST)
  744. KARET2(NMIN,NEXIST)=2
  745. ELSE
  746. IF (IDIM.EQ.2) goto 27
  747. IF ((KARPOS(NMIN)+1).GT.NCOL) THEN
  748. NCOL=KARPOS(NMIN)+1
  749. SEGADJ KARETE, KARET2, KMILIE
  750. ENDIF
  751. JPOSI = KARPOS(NMIN)
  752. KARPOS(NMIN)=JPOSI+1
  753. KARETE(NMIN,JPOSI+1)=NMAX
  754. KARET2(NMIN,JPOSI+1)=2
  755. KMILIE(NMIN,JPOSI+1)=NPTC
  756. c WRITE (*,*) 'création de l arrete:', NMIN, NMAX
  757. ENDIF
  758. C
  759. C-----------------------------------------------
  760. C Prise en compte des relations "hereditaires" !
  761. C-----------------------------------------------
  762. C Cette partie sert a traiter le cas ou un element serait raffine
  763. C plusieurs fois alors qu'a sa frontiere les autres elements ne le
  764. C seraient pas. Il y aurait donc plusieurs points sur une arete ayant
  765. C des relations de conformite et plus seulement le noeud milieu.
  766. C
  767. c dans l'exenple ci dessous où les noeuds C et D sont des hanging nodes
  768. c L'arette [C B] n'a pas encore été créée c'est ce qui est fait ici.
  769. c
  770. c | |
  771. c | |
  772. c |A C D |B
  773. c x---------X----X----X
  774. c | | | |
  775. c | | | |
  776. 27 CONTINUE
  777. IF (IDIM.EQ.2) THEN
  778. C 1/ Test sur la premiere arete : NMIN-NPTC
  779. IF (NEXIST.NE.0) THEN
  780. NEXIS2=0
  781. NMIN2=MIN(NMIN,ICPR(NPTC,1))
  782. NMAX2=MAX(NMIN,ICPR(NPTC,1))
  783. DO 24 I=1,MAX(1,KARPOS(NMIN2))
  784. IF (KARETE(NMIN2,I).EQ.NMAX2) NEXIS2=I
  785. 24 CONTINUE
  786. IF (NEXIS2.EQ.0) THEN
  787. NBRELA=NBRELA+1
  788. JNBCOL=KARETE(/2)
  789. JPOSI=KARPOS(NMIN2)
  790. IF (JNBCOL.GT.JPOSI) THEN
  791. KARPOS(NMIN2)=JPOSI+1
  792. KARETE(NMIN2,JPOSI+1)=NMAX2
  793. KARET2(NMIN2,JPOSI+1)=2
  794. ELSEIF (JNBCOL.EQ.JPOSI) THEN
  795. NCOL=JNBCOL+1
  796. SEGADJ KARETE,KMILIE,KARET2
  797. KARETE(NMIN2,JPOSI+1)=NMAX2
  798. KARPOS(NMIN2)=JPOSI+1
  799. KARET2(NMIN2,JPOSI+1)=2
  800. ENDIF
  801. c WRITE (*,*) 'création de l arrete:', NMIN2, NMAX2
  802. ELSE
  803. KARET2(NMIN2,NEXIS2)=2
  804. ENDIF
  805. C
  806. C 2/ Test sur la deuxieme arete : NMAX-NPTC
  807. NEXIS2=0
  808. NMIN2=MIN(NMAX,ICPR(NPTC,1))
  809. NMAX2=MAX(NMAX,ICPR(NPTC,1))
  810. DO 25 I=1,MAX(1,KARPOS(NMIN2))
  811. IF (KARETE(NMIN2,I).EQ.NMAX2) NEXIS2=I
  812. 25 CONTINUE
  813. IF (NEXIS2.EQ.0) THEN
  814. NBRELA=NBRELA+1
  815. JNBCOL=KARETE(/2)
  816. JPOSI=KARPOS(NMIN2)
  817. IF (JNBCOL.GT.JPOSI) THEN
  818. KARPOS(NMIN2)=JPOSI+1
  819. KARETE(NMIN2,JPOSI+1)=NMAX2
  820. KARET2(NMIN2,JPOSI+1)=2
  821. ELSEIF (JNBCOL.EQ.JPOSI) THEN
  822. NCOL=JNBCOL+1
  823. SEGADJ KARETE,KMILIE,KARET2
  824. KARETE(NMIN2,JPOSI+1)=NMAX2
  825. KARPOS(NMIN2)=JPOSI+1
  826. KARET2(NMIN2,JPOSI+1)=2
  827. ENDIF
  828. c WRITE (*,*) 'création de l arrete:', NMIN2, NMAX2
  829. ELSE
  830. KARET2(NMIN2,NEXIS2)=2
  831. ENDIF
  832. ENDIF
  833. ENDIF
  834. 220 CONTINUE
  835. 218 CONTINUE
  836. IF (NBRELA.NE.0) GOTO 22
  837. 28 CONTINUE
  838.  
  839. C
  840. C
  841. C=======================================================================
  842. C Pre-remplissage du tableau JFARAF
  843. C=======================================================================
  844. C On remplit le tableau JFARAF et JPLAN3 lorsqu'il y a des maillages de
  845. C relations de type 48 (IPT6, LCONF3 non nul).
  846. c
  847. C Si JPLANS(i,j)=k et JFARAF(k , (l-1)*2+1)= n : le noeud n (en
  848. C numérotation globale) est le hanging node au centre de la jieme face
  849. C dont le plus petit sommet en numerotation locale est le sommet i.
  850. C
  851. C Si de plus la face en question est un TRI6 et JFARAF(k , l*2)=m :
  852. C le noeud m (en numérotation globale) est le 4ieme noeud de l'element
  853. C 48 coul 4
  854. C
  855. C Si de plus la face en question est un QUA8-1 et JFARAF(k , l*2)=m :
  856. C le noeud m (en numérotation globale) est le 5eme noeud de l'element
  857. c 48 coul 4
  858. C
  859. C si JPLAN3(i,j)=k il y a k relation de compatibilité de faces associé a
  860. C la jieme face dont le plus petit sommet en numerotation locale est le
  861. C sommet i.
  862.  
  863. IF (IDIM.NE.3) GOTO 711
  864. JNBFA=JNOEFA(/1)
  865. LLLL=10
  866. SEGINI JFARAF
  867. SEGINI JPLAN2,JPLAN3
  868. IF (LCONF3.EQ.0) GOTO 711
  869. MPOS25=0
  870. JNBSOM=0
  871. 1287 CONTINUE
  872. NBRELA=0
  873. DO 670 MIE=1,MAX(1,IPT6.LISOUS(/1))
  874. IF (IPT6.LISOUS(/1).EQ.0) THEN
  875. IPT2=IPT6
  876. ELSE
  877. IPT2=IPT6.LISOUS(MIE)
  878. ENDIF
  879. SEGACT IPT2
  880. IF (IPT2.ITYPEL.NE.48) GOTO 670
  881. IF ((IPT2.ICOLOR(1).EQ.1).OR.(IPT2.ICOLOR(1).EQ.2)) GOTO 670
  882. LIGNUM=IPT2.NUM(/1)
  883. IF (IPT2.ICOLOR(1).EQ.4) MPOS25=4
  884. IF (IPT2.ICOLOR(1).EQ.5) MPOS25=5
  885. IF (IPT2.ICOLOR(1).EQ.3) JNBSOM=4
  886. IF (IPT2.ICOLOR(1).EQ.4) JNBSOM=3
  887. IF (IPT2.ICOLOR(1).EQ.5) JNBSOM=4
  888. IF (IPT2.ICOLOR(1).EQ.6) JNBSOM=4
  889. SEGINI IWORK2
  890. C
  891. C-------------------------
  892. C A) Recherche de la face !
  893. C-------------------------
  894. C 1/ Classement des 3 sommets par ordre croissant (num globale)
  895. DO 671,MAA=1,IPT2.NUM(/2)
  896. DO 673 MBB=1,JNBSOM
  897. IWORK2(MBB)=IPT2.NUM(LIGNUM-JNBSOM+MBB,MAA)
  898. 673 CONTINUE
  899. NPTA=nbpts+1
  900. NPTB=NPTA+1
  901. NPTC=NPTB+1
  902. DO 672 ICC=1,JNBSOM
  903. IF (IWORK2(ICC).LT.NPTA) THEN
  904. NPTC=NPTB
  905. NPTB=NPTA
  906. NPTA=IWORK2(ICC)
  907. ELSEIF (IWORK2(ICC).LT.NPTB) THEN
  908. NPTC=NPTB
  909. NPTB=IWORK2(ICC)
  910. ELSEIF (IWORK2(ICC).LT.NPTC) THEN
  911. NPTC=IWORK2(ICC)
  912. ENDIF
  913. 672 CONTINUE
  914. C
  915. C 2/ Classement des 3 sommets par ordre croissant (num locale)
  916. NPTA1=NPTA
  917. NPTB1=NPTB
  918. NPTC1=NPTC
  919. NPTA2=ICPR(NPTA,1)
  920. NPTB2=ICPR(NPTB,1)
  921. NPTC2=ICPR(NPTC,1)
  922. IF ((NPTA2.LT.NPTB2).AND.(NPTA2.LT.NPTC2)) THEN
  923. NPTA=NPTA2
  924. NPTB=MIN(NPTB2,NPTC2)
  925. NPTC=MAX(NPTB2,NPTC2)
  926. ENDIF
  927. IF ((NPTB2.LT.NPTA2).AND.(NPTB2.LT.NPTC2)) THEN
  928. NPTA=NPTB2
  929. NPTB=MIN(NPTA2,NPTC2)
  930. NPTC=MAX(NPTA2,NPTC2)
  931. ENDIF
  932. IF ((NPTC2.LT.NPTA2).AND.(NPTC2.LT.NPTB2)) THEN
  933. NPTA=NPTC2
  934. NPTB=MIN(NPTA2,NPTB2)
  935. NPTC=MAX(NPTA2,NPTB2)
  936. ENDIF
  937. C
  938. C 3/ Recherche du numero de la face
  939. NEXIS2=0
  940. DO 674 IEE=1,JPLCOM(NPTA)
  941. MTMP=JPLANS(NPTA,IEE)
  942. JJ1=JNOEFA(MTMP,1)
  943. JJ2=JNOEFA(MTMP,2)
  944. JJ3=JNOEFA(MTMP,3)
  945. IF(JJ1.EQ.NPTA.AND.JJ2.EQ.NPTB.AND.JJ3.EQ.NPTC) THEN
  946. NEXIS2=IEE
  947. ENDIF
  948. 674 CONTINUE
  949. c 3.1/ si la face en question n'existe pas, dans le cas général on
  950. c s'arrète
  951. IF ((NEXIS2.EQ.0).AND.(IPT2.ICOLOR(1).NE.3)) THEN
  952. c WRITE (*,*) 'IPT2.ICOLOR(1)', IPT2.ICOLOR(1)
  953. WRITE (*,*) 'Raffinement impossible, le champ de densite
  954. + presente des variations trop brusques'
  955. WRITE (*,*) 'sure concerne', MAA
  956. WRITE (*,*) 'premier nd du sure concerne', IPT2.NUM(1,MAA)
  957. WRITE (*,*) 'numero du 1er nd de la face concernee', NPTA
  958. KARAF2=0
  959. c GOTO 679
  960. ENDIF
  961. c 3.2/ si la face en question n'existe pas dans le cas d'une relation
  962. c de face QUA4 il suffie de la créer
  963.  
  964. IF ((NEXIS2.EQ.0).AND.(IPT2.ICOLOR(1).EQ.3)) THEN
  965. JPLCOM(NPTA)= JPLCOM(NPTA)+1
  966. JNUMFA=JNUMFA+1
  967. JNUMFS=JNUMFA
  968. JNUMF1=JPLCOM(NPTA)
  969. JMAXPL=MAX(JMAXPL,JPLCOM(NPTA))
  970. c 3.2.1/ ajustement des segments
  971. JPLA2=JMAXPL
  972. JNBFA=JNUMFA
  973. SEGADJ JPLANS
  974. SEGADJ JNOEFA
  975. SEGADJ JPLAN3
  976. SEGADJ JFARAF
  977. C 3.2.1 Renseignement des iformation de la nouvelle face dans JPLANS et
  978. c JNOEFA, initialisation de JPLAN3
  979. JPLANS(NPTA,JNUMF1)=JNUMFA
  980. JPLAN3(NPTA,JNUMF1)=0
  981. JNOEFA(JNUMFA,1)= NPTA
  982. JNOEFA(JNUMFA,2)= NPTB
  983. JNOEFA(JNUMFA,3)= NPTC
  984. JNOEFA(JNUMFA,4)= 48
  985. JNOEFA(JNUMFA,5)= 48
  986. ENDIF
  987.  
  988. IF (NEXIS2.NE.0) THEN
  989. JNUMFS=JPLANS(NPTA,NEXIS2)
  990. ENDIF
  991. C
  992. C 4/ Recherche de la position de la face dans JPLANS
  993. NEXIS2=0
  994. DO 675 MAC=1,JPLCOM(NPTA)
  995. IF (JPLANS(NPTA,MAC).EQ.JNUMFS) NEXIS2=MAC
  996. 675 CONTINUE
  997. C
  998. C-------------------------------------
  999. C B) Renseignement de JFARAF et JPLAN3!
  1000. C-------------------------------------
  1001.  
  1002.  
  1003. JPLAN3(NPTA,NEXIS2)=JPLAN3(NPTA,NEXIS2)+1
  1004. LTEMPO=(JPLAN3(NPTA,NEXIS2)-1)*2+1
  1005. JFARAF(JNUMFS,LTEMPO)=IPT2.NUM(1,MAA)
  1006. IF (MPOS25.NE.0) JFARAF(JNUMFS,LTEMPO+1)=IPT2.NUM(MPOS25,MAA)
  1007. IF (JNOEFA(JNUMFS,5).EQ.0) JNOEFA(JNUMFS,5)=48
  1008.  
  1009.  
  1010. 671 CONTINUE
  1011. 670 CONTINUE
  1012. C IF (NBRELA.NE.0) GOTO 1287
  1013. 711 CONTINUE
  1014. C
  1015. C=======================================================================
  1016. C Calcul du critere et raffinement si necessaire
  1017. C=======================================================================
  1018. C Pour calculer le critere, on a besoin d'un modele et d'un chamelem
  1019. C constant egal a 1.
  1020. C
  1021. C------------------------------------------
  1022. C A) Creation d'un modele simple : MMODE1 !
  1023. C------------------------------------------
  1024. MN3=0
  1025. NFOR=1
  1026. NMAT=2
  1027. NPARMO=0
  1028. NOBMOD=0
  1029. N1=1
  1030. SEGINI MMODE1
  1031. SEGINI IMODE1
  1032. MMODE1.KMODEL(1)=IMODE1
  1033. IMODE1.FORMOD(1)='MECANIQUE'
  1034. IMODE1.MATMOD(1)='ELASTIQUE'
  1035. IMODE1.MATMOD(2)='ISOTROPE'
  1036.  
  1037. C
  1038. KARAF2=0
  1039. C=======================================================================
  1040. C Boucle sur les eventuels sous-domaines de IPT5
  1041. C=======================================================================
  1042.  
  1043. c-----------------------------------------------------------------------
  1044. c initialisation de LTYPE3 qui va contenir les tableau LTYP2
  1045. c correspondant à chaque sous domaine de IPT5. Ces tableau LTYP2
  1046. c contiendront eux même les maillages raffinés issue des
  1047. c différents sous domaine de IPT5.
  1048. c LTYPE3(I,1)=LTYP2 pour le sous domaine I de IPT5
  1049. c LTYPE3(I,2)=IRR le permier indice d'un maillage 48 dans LTYP2
  1050. c-----------------------------------------------------------------------
  1051. NBLIS3=MAX(1,IPT5.LISOUS(/1))
  1052. SEGINI LTYPE3
  1053. MCONF=0
  1054. NSUR = 0
  1055. DO 33 INB=1,MAX(1,IPT5.LISOUS(/1))
  1056. NBNN=0
  1057. NBELEM=0
  1058. NBREF=0
  1059. NBSOUS=0
  1060. SEGINI IPT2
  1061. IF (IPT5.LISOUS(/1).EQ.0) THEN
  1062. IPT2=IPT5
  1063. ELSE
  1064. IPT2=IPT5.LISOUS(INB)
  1065. SEGACT IPT2
  1066. ENDIF
  1067.  
  1068. IMODE1.IMAMOD=IPT2
  1069. IMODE1.NEFMOD=IPT2.ITYPEL
  1070. C
  1071. C-------------------------------------------------------
  1072. C B) Creation d'un chamelem constant egal a 1 : MCHEL1 !
  1073. C-------------------------------------------------------
  1074. CALL ZEROP(MMODE1,'NOEUD ',MCHEL1)
  1075. SEGACT MCHEL1*MOD
  1076. MCHEL1.IMACHE(1)=IPT2
  1077. IF (IDIM.EQ.2) MCHEL1.IFOCHE=-1
  1078. IF (IDIM.EQ.3) MCHEL1.IFOCHE=2
  1079. MCHAM1=MCHEL1.ICHAML(1)
  1080. SEGACT MCHAM1
  1081. MELVA1=MCHAM1.IELVAL(1)
  1082. SEGACT MELVA1*MOD
  1083. c DO 399 J=1,IPT2.NUM(/2)
  1084. c MELVA1.VELCHE(1,J)=1.0
  1085. c 399 CONTINUE
  1086. MELVA1.VELCHE(1,1)=1.D0
  1087. C
  1088. C-------------------------------------------------------------
  1089. C C) Calcul de la surface ou du volume des elements : MCHEL2 !
  1090. C-------------------------------------------------------------
  1091. CALL INTGCA(MMODE1,MCHEL1,0,1,IRET,XRET,MCHEL2)
  1092. IF (XRET.LT.XPETI) THEN
  1093. WRITE (*,*) 'Volume(resp surf) de la zone a raffiner nul'
  1094. RETURN
  1095. ENDIF
  1096. SEGACT IPT2
  1097.  
  1098. C
  1099. C---------------------------------------------------------------------
  1100. C D) Creation d'un chamelem indiquant les elements a raffiner MCHAM2 !
  1101. C---------------------------------------------------------------------
  1102. SEGACT KMILIE*MOD
  1103. SEGACT MCHEL2
  1104. MCHAM2=MCHEL2.ICHAML(1)
  1105. SEGACT MCHAM2
  1106. MELVA2=MCHAM2.IELVAL(1)
  1107. SEGACT MELVA2*MOD
  1108. NACREE=0
  1109. KARAF=0
  1110.  
  1111.  
  1112. SEGACT MELVA1
  1113. c boucles sur les éléments de ipt2
  1114. DO 32 J=1,IPT2.NUM(/2)
  1115.  
  1116. XMOY=0
  1117. DO 29 I=1,IPT2.NUM(/1)
  1118. NGLOB=IPT2.NUM(I,J)
  1119. NLOC=ICPR(NGLOB,1)
  1120. DENPT=DENSI(NLOC)
  1121. XMOY=XMOY+DENPT/(IPT2.NUM(/1))
  1122. 29 CONTINUE
  1123.  
  1124. XINT=MELVA2.VELCHE(1,J)
  1125. XDIM=IDIM*1.0
  1126. C Un element est a raffiner si la moyenne des densites affectees a
  1127. C l'ensemble de ses noeuds est inférieure a la racine carree de sa
  1128. C surface (en 2D) ou a la racine cubique de son volume (en 3D)
  1129. C WRITE (*,*) 'XMOY', XMOY, '(XINT**(1/XDIM))',(XINT**(1/XDIM))
  1130. IF ((XMOY-(XINT**(1/XDIM))).LT.0) THEN
  1131. c c y a t'il des +epsilon...?
  1132. c XDIFF = XMOY-(XINT**(1/XDIM))
  1133. c if(XDIFF.ge.0.and.XDIFF.lt.0.001*XMOY) then
  1134. c write(*,*) 'RAFF : XMOY,XDIFF=',XMOY,XDIFF,
  1135. c & 'pour l EF',J,(IPT2.NUM(iou,J),iou=1,IPT2.NUM(/1))
  1136. c endif
  1137. c IF (XDIFF.LT.0) THEN
  1138. MELVA2.VELCHE(1,J)=1
  1139. c KARAF nombre d'éléments à rafiner dans le sous domaine
  1140. KARAF=KARAF+1
  1141. ILPT=LPT(IPT2.ITYPEL)
  1142. ILPL=LPL(IPT2.ITYPEL)
  1143.  
  1144. c boucle sur les segments de l'élément à raffiner
  1145. DO 31 K=1,ILPL*2-1,2
  1146. NPTA=IPT2.NUM(KSEGM(ILPT+K-1),J)
  1147. NPTB=IPT2.NUM(KSEGM(ILPT+K),J)
  1148. NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1))
  1149. NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1))
  1150. NEXIST=0
  1151. DO 30 I=1,MAX(1,KARPOS(NMIN))
  1152. IF (KARETE(NMIN,I).EQ.NMAX) NEXIST=I
  1153. 30 CONTINUE
  1154. c On met dans kmilie les arêtes où il faudra mettre un nouveau noeud
  1155. c On leur associe la valeur -1
  1156. IF (KMILIE(NMIN,NEXIST).EQ.0) THEN
  1157. NACREE=NACREE+1
  1158. KMILIE(NMIN,NEXIST)=-1
  1159. ENDIF
  1160. 31 CONTINUE
  1161. C
  1162. C-------------------------------------------
  1163. C E) Comptage du nombre de faces a raffiner !
  1164. C-------------------------------------------
  1165. C 1/ Initialisations
  1166. IF (IDIM.NE.3) GOTO 32
  1167. JTYPEL=IPT2.ITYPEL
  1168. JLTEL1=LTEL(1,JTYPEL)
  1169. JLTEL2=LTEL(2,JTYPEL)
  1170. DO 73 IBB=1,JLTEL1
  1171. JLDEL1=LDEL(1,JLTEL2-1+IBB)
  1172. JTYFAC=IWORK1(JLDEL1)
  1173. JLDEL2=LDEL(2,JLTEL2-1+IBB)
  1174. C JNBPTS=NBNNE(JTYFAC)
  1175. JNBSOM=NBSOM(JTYFAC)
  1176. JSPOS=NSPOS(JTYFAC)
  1177. SEGINI IWORK2
  1178. DO 74 IAA=1,JNBSOM
  1179. NGLOBA=IPT2.NUM(LFAC(JLDEL2-1+IBSOM(JSPOS-1+IAA)),J)
  1180. IWORK2(IAA)=NGLOBA
  1181. 74 CONTINUE
  1182. C
  1183. C 2/ Classement des 3 sommets par ordre croissant (num globale)
  1184. NPTA=nbpts+1
  1185. NPTB=NPTA+1
  1186. NPTC=NPTB+1
  1187. DO 75 ICC=1,JNBSOM
  1188. IF (IWORK2(ICC).LT.NPTA) THEN
  1189. NPTC=NPTB
  1190. NPTB=NPTA
  1191. NPTA=IWORK2(ICC)
  1192. ELSEIF (IWORK2(ICC).LT.NPTB) THEN
  1193. NPTC=NPTB
  1194. NPTB=IWORK2(ICC)
  1195. ELSEIF (IWORK2(ICC).LT.NPTC) THEN
  1196. NPTC=IWORK2(ICC)
  1197. ENDIF
  1198. 75 CONTINUE
  1199. C
  1200. C 3/ Classement des 3 sommets par ordre croissant (num locale)
  1201. NPTA2=ICPR(NPTA,1)
  1202. NPTB2=ICPR(NPTB,1)
  1203. NPTC2=ICPR(NPTC,1)
  1204. IF ((NPTA2.LT.NPTB2).AND.(NPTA2.LT.NPTC2)) THEN
  1205. NPTA=NPTA2
  1206. NPTB=MIN(NPTB2,NPTC2)
  1207. NPTC=MAX(NPTB2,NPTC2)
  1208. ENDIF
  1209. IF ((NPTB2.LT.NPTA2).AND.(NPTB2.LT.NPTC2)) THEN
  1210. NPTA=NPTB2
  1211. NPTB=MIN(NPTA2,NPTC2)
  1212. NPTC=MAX(NPTA2,NPTC2)
  1213. ENDIF
  1214. IF ((NPTC2.LT.NPTA2).AND.(NPTC2.LT.NPTB2)) THEN
  1215. NPTA=NPTC2
  1216. NPTB=MIN(NPTA2,NPTB2)
  1217. NPTC=MAX(NPTA2,NPTB2)
  1218. ENDIF
  1219. C
  1220. C 4/ Calcul du nombre de points a creer pour raffiner la face
  1221. NEXIS2=0
  1222. DO 76 IEE=1,JPLCOM(NPTA)
  1223. MTMP=JPLANS(NPTA,IEE)
  1224. JJ1=JNOEFA(MTMP,1)
  1225. JJ2=JNOEFA(MTMP,2)
  1226. JJ3=JNOEFA(MTMP,3)
  1227. IF(JJ1.EQ.NPTA.AND.JJ2.EQ.NPTB.AND.JJ3.EQ.NPTC) THEN
  1228. NEXIS2=IEE
  1229. ENDIF
  1230. 76 CONTINUE
  1231. IF (NEXIS2.NE.0) THEN
  1232. KFARAF=JPLAN2(NPTA,NEXIS2)
  1233. IF (KFARAF.EQ.0) THEN
  1234. NACREE=NACREE+NBINTE(JTYFAC)
  1235. JPLAN2(NPTA,NEXIS2)=JPLAN2(NPTA,NEXIS2)+1
  1236. ENDIF
  1237. ENDIF
  1238. 73 CONTINUE
  1239. ELSE
  1240.  
  1241. MELVA2.VELCHE(1,J)=0
  1242. ENDIF
  1243. 32 CONTINUE
  1244.  
  1245. c KARAF2 nombre d'éléments à rafiner sur tout les sous domaines
  1246. KARAF2=KARAF2+KARAF
  1247. c si aucun élément à raffiner on stoque directement IPT2 dans LTYPE3
  1248. c on stoque également les anciennes relations et on passe au
  1249. c sous-domaine suivant.
  1250.  
  1251. c ATTENTION SI NBOUCL=1 il est possible que des relations surabondantes
  1252.  
  1253. c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  1254. c forcage : nb max itération de raff
  1255. c IF (NBOUCL.EQ.3) THEN
  1256. c KARAF2=0
  1257. c KARAF=0
  1258. c ENDIF
  1259. c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  1260. IF (KARAF.EQ.0) THEN
  1261. IF (NBOUCL.EQ.1) THEN
  1262. IF (LCONF3.GT.0) THEN
  1263. SEGACT IPT6
  1264. NBLIS2=1+MAX(1,IPT6.LISOUS(/1))
  1265. SEGINI LTYPE2
  1266. LTYPE2(1,1)=1
  1267. LTYPE2(1,2)=IPT2.ITYPEL
  1268. LTYPE2(1,3)=IPT2
  1269. LTYPE2(1,4)=IPT2.ICOLOR(1)
  1270. LTYPE3(INB,2)=0
  1271. DO 676 MIE=1,MAX(1,IPT6.LISOUS(/1))
  1272. IF (IPT6.LISOUS(/1).EQ.0) THEN
  1273. IPT4=IPT6
  1274. ELSE
  1275. IPT4=IPT6.LISOUS(MIE)
  1276. ENDIF
  1277. NSUR=1
  1278. SEGACT IPT4
  1279. LTYPE2(1+MIE,1)=1+MIE
  1280. LTYPE2(1+MIE,2)=IPT4.ITYPEL
  1281. LTYPE2(1+MIE,3)=IPT4
  1282. LTYPE2(1+MIE,4)=IPT4.ICOLOR(1)
  1283. LTYPE3(INB,2)=2
  1284. 676 CONTINUE
  1285. ELSE
  1286. NBLIS2=1
  1287. SEGINI LTYPE2
  1288. LTYPE2(1,1)=1
  1289. LTYPE2(1,2)=IPT2.ITYPEL
  1290. LTYPE2(1,3)=IPT2
  1291. LTYPE2(1,4)=IPT2.ICOLOR(1)
  1292. LTYPE3(INB,2)=0
  1293. ENDIF
  1294. LTYPE3(INB,1)=LTYPE2
  1295. ELSE
  1296. SEGACT LTYPE4
  1297. LTYPE3(INB,1)=LTYPE4(INB,1)
  1298. LTYPE3(INB,2)=LTYPE4(INB,2)
  1299. ENDIF
  1300. GOTO 33
  1301. ENDIF
  1302. C
  1303. C----------------------------
  1304. C F) Raffinement du maillage !
  1305. C----------------------------
  1306. NML=2
  1307. C
  1308. C 1/ Raffinement d'un maillage 2D
  1309. C On recupere dans MELEME le maillage raffine sans ses relations de
  1310. C conformite et dans IPT8 les relations de ce maillage
  1311. C (IPT8 encore incomplet en sortie de RAFF2D)
  1312. c entrees de raff2D:
  1313. c - IPT2: maillage élémentaire à raffiner
  1314. c (ici sous domaine de ipt5)
  1315. c - ICPR: tableau de passage noeuds local/global
  1316. c (ici à partir de ipt5 interne à la boucle 9)
  1317. c - KARPOS: tableau du nb d'arretes par noeuds
  1318. c (ici à partir de ipt5, mis a jour avec ipt6)
  1319. c - KARETE: tableau des d'arretes KARETE(i,j)=k
  1320. c (ici à partir de ipt5, mis a jour avec ipt6)
  1321. c - KMILIE: tableau des hanging nodes associés au arrètes
  1322. c en entrée: à partir des relations de ipt6 et
  1323. c des nouveau noeuds à construires
  1324. c si relation issue de ipt6
  1325. c KMILIE(i,j)=n : le noeud global n est situe
  1326. c au milieu de l'arete [i,k]
  1327. c si nouvelle relation
  1328. c KMILIE(i,j)=-1 : il faut construire un noeud
  1329. c au milieu de l'arete [i,k]
  1330. c - MELVA2: champ par elem valait 1 pour les élem à raffiner
  1331. c et 0 pour les autres
  1332. c (ici à partir de ipt2 et de densi)
  1333. c - NACREE: nombre de noeuds à créer dans ipt2
  1334. c - KARAF: nombre d'élément à raffiner dans ipt2
  1335. c - IDCP : ??? variable non utilisé ???
  1336. c - XDEN : densité aux noeuds en notation globale
  1337. c (ici à partir de mchpo1)
  1338. c - KARET2: tableau du nombre d'éléments touchant les arretes
  1339. c (ici à partir de ipt5, mis a jour avec ipt6)
  1340. csorties de raff2D :
  1341. c - KMILIE: tableau des hanging nodes associés au arrètes
  1342. c en sortie: à partir des relations donnée en
  1343. c entrée et de celles crées
  1344. c si anciene relation à garder
  1345. c KMILIE(i,j)=n : le noeud global n est situe
  1346. c au milieu de l'arete [i,k]
  1347. c si anciene relation à suprimer
  1348. c KMILIE(i,j)=0 :
  1349. c si nouvelle relation
  1350. c KMILIE(i,j)=n : le noeud n à été construit au
  1351. c milieu de l'arete [i,k]
  1352. c - MELEME: Maillage élémentaire raffiné à partir de ipt2
  1353. c sans relations
  1354. c - IPT8 : Maillage de relation incomplet
  1355. c si J nouvel élément 48:
  1356. c IPT8.NUM(1,j) = nouveau hanging node
  1357. c IPT8.NUM(2:4,j) = autres noeuds de la relation
  1358. c IPT8.NUM(5,j) = 1 si arête a 2 noeuds
  1359. c 2 si arête a 3 noeuds
  1360. c si J nouvel élément 48:
  1361. c IPT8.NUM(1,j) = nouveau hanging node
  1362. c IPT8.NUM(2:5,j) = 0
  1363. c - XDEN : densité aux noeuds en notation globale
  1364. c interpolé aux nouveaux noeuds.
  1365. IF (IDIM.EQ.2) CALL RAFF2D(IPT2,ICPR,KARPOS,KARETE,KMILIE,
  1366. + MELVA2,NACREE,KARAF,MELEME,IDCP,IPT8,KARET2,XDEN)
  1367. C
  1368. C 2/ Raffinement d'un maillage 3D
  1369. IF (IDIM.EQ.3) THEN
  1370. NML=0
  1371. IF ((IPT2.ITYPEL.EQ.25).OR.(IPT2.ITYPEL.EQ.26)) NML=1
  1372. ENDIF
  1373. C a) Maillage 3D contenant des pyramides
  1374. IPT9=0
  1375. IF (NML.EQ.1) CALL RAFPYR(IPT2,ICPR,KARPOS,KARETE,KMILIE,
  1376. + MELVA2,NACREE,KARAF,MELEME,JPLANS,JPLAN3,JPLCOM,JNOEFA,
  1377. + IPT8,JFARAF,KARET2,IPT9,XDEN)
  1378. C b) Maillage 3D sans pyramides
  1379. IF (NML.EQ.0) CALL RAFF3D(IPT2,IPT6,ICPR,KARPOS,KARETE,KMILIE,
  1380. + MELVA2,NACREE,KARAF,MELEME,JPLANS,JPLAN3,JPLCOM,JNOEFA,
  1381. + IPT8,JFARAF,KARET2,XDEN)
  1382. C
  1383. C=======================================================================
  1384. C Creation du maillage de relations de conformite
  1385. C=======================================================================
  1386. C--------------------
  1387. C A) Initialisations !
  1388. C--------------------
  1389. IPT10=0
  1390. IPT11=0
  1391. IPT12=0
  1392. IPT13=0
  1393. IPT14=0
  1394. IPT15=0
  1395. IPT16=0
  1396. MCONF=0
  1397. c IF (KARAF2.EQ.0) GOTO 33
  1398. IF (IPT8.NE.0) THEN
  1399. C
  1400. C---------------------------------------
  1401. C B) Traitement des anciennes relations !
  1402. C---------------------------------------
  1403. C A ce stade, IPT8 contient les relations crees lors du dernier
  1404. C raffinement (noeud de relation + noeuds formant la relation) et les
  1405. C anciennes relations a reporter (noeud de relation seulement)
  1406.  
  1407. C 1/ Recherche de l'existence d'anciennes relations a reporter
  1408. NB10=0
  1409. MLONG=IPT8.NUM(/1)
  1410. DO 775 MM=1,IPT8.NUM(/2)
  1411. IF (IPT8.NUM(MLONG,MM).EQ.0) NB10=NB10+1
  1412. 775 CONTINUE
  1413.  
  1414. IF (NB10.NE.0) THEN
  1415. C
  1416. C 2/ Creation de IPT10
  1417. c MCOL=0
  1418. c NBNN=9
  1419. c NBELEM=NB10
  1420. c NBREF=0
  1421. c NBSOUS=0
  1422. c SEGINI IPT10
  1423. c IPT10.ITYPEL=48
  1424. C
  1425. C 3/ Recherche des anciennes relations a reporter
  1426. C Cette partie permet de compléter IPT8 avec les noeuds formant les
  1427. C relations, pour les anciennes relations à reporter
  1428. DO 628 MM11=1,IPT8.NUM(/2)
  1429. IF (IPT8.NUM(MLONG,MM11).NE.0) GOTO 628
  1430. INRELA=IPT8.NUM(1,MM11)
  1431. c On active pous le cas ou IPT6=IPT2.
  1432. SEGACT IPT6
  1433. DO 625 KOU=1,MAX(1,IPT6.LISOUS(/1))
  1434. IF (IPT6.LISOUS(/1).EQ.0) THEN
  1435. IPT2=IPT6
  1436. ELSE
  1437. IPT2=IPT6.LISOUS(KOU)
  1438. ENDIF
  1439. SEGACT IPT2
  1440. IF (IPT2.ITYPEL.NE.48) GOTO 625
  1441. DO 626 JKG=1,IPT2.NUM(/2)
  1442. INOEGL=IPT2.NUM(1,JKG)
  1443. IF (INOEGL.NE.INRELA) GOTO 626
  1444. MCOL=MCOL+1
  1445. DO 627 MTMP=1,IPT2.NUM(/1)
  1446. IPT8.NUM(MTMP,MM11)=IPT2.NUM(MTMP,JKG)
  1447. IPT8.NUM(MLONG,MM11)= IPT2.ICOLOR(JKG)
  1448. 627 CONTINUE
  1449. GOTO 628
  1450. 626 CONTINUE
  1451. 625 CONTINUE
  1452. 628 CONTINUE
  1453. ENDIF
  1454. c à ce stade le maillage de relation ipt8 est complet
  1455. C
  1456. C---------------------------------------
  1457. C C) Traitement des nouvelles relations !
  1458. C---------------------------------------
  1459. C Ici, IPT8 contient toutes les relations du nouveau maillage
  1460. C On les trie par type de relations
  1461.  
  1462. C 1/ Recherche de l'existence de nouvelles relations
  1463. NB11=0
  1464. NB12=0
  1465. NB13=0
  1466. NB14=0
  1467. NB15=0
  1468. NB16=0
  1469. MLONG=IPT8.NUM(/1)
  1470. DO 776 MM=1,IPT8.NUM(/2)
  1471. IF (IPT8.NUM(MLONG,MM).EQ.1) NB11=NB11+1
  1472. IF (IPT8.NUM(MLONG,MM).EQ.2) NB12=NB12+1
  1473. IF (IPT8.NUM(MLONG,MM).EQ.3) NB13=NB13+1
  1474. IF (IPT8.NUM(MLONG,MM).EQ.4) NB14=NB14+1
  1475. IF (IPT8.NUM(MLONG,MM).EQ.5) NB15=NB15+1
  1476. IF (IPT8.NUM(MLONG,MM).EQ.6) NB16=NB16+1
  1477. 776 CONTINUE
  1478. C
  1479. C 2/ Cas des relations 'aretes a 2 noeuds'
  1480. IF (NB11.NE.0) THEN
  1481. MCONF=MCONF+1
  1482. MCOL=0
  1483. NBNN=3
  1484. NBELEM=NB11
  1485. NBREF=0
  1486. NBSOUS=0
  1487. SEGINI IPT11
  1488. IPT11.ITYPEL=48
  1489. DO 778 MM11=1,IPT8.NUM(/2)
  1490. IF (IPT8.NUM(MLONG,MM11).NE.1) GOTO 778
  1491. MCOL=MCOL+1
  1492. DO 777 MTMP=1,3
  1493. IPT11.NUM(MTMP,MCOL)=IPT8.NUM(MTMP,MM11)
  1494. IPT11.ICOLOR(MCOL)=1
  1495. 777 CONTINUE
  1496. 778 CONTINUE
  1497. ENDIF
  1498. C
  1499. C 3/ Cas des relations 'aretes a 3 noeuds'
  1500. IF (NB12.NE.0) THEN
  1501. MCONF=MCONF+1
  1502. MCOL=0
  1503. NBNN=4
  1504. NBELEM=NB12
  1505. NBREF=0
  1506. NBSOUS=0
  1507. SEGINI IPT12
  1508. IPT12.ITYPEL=48
  1509. DO 668 MM11=1,IPT8.NUM(/2)
  1510. IF (IPT8.NUM(MLONG,MM11).NE.2) GOTO 668
  1511. MCOL=MCOL+1
  1512. DO 667 MTMP=1,4
  1513. IPT12.NUM(MTMP,MCOL)=IPT8.NUM(MTMP,MM11)
  1514. IPT12.ICOLOR(MCOL)=2
  1515. 667 CONTINUE
  1516. 668 CONTINUE
  1517. ENDIF
  1518. C
  1519. C 4/ Cas des relations 'face QUA4'
  1520. IF (NB13.NE.0) THEN
  1521. MCONF=MCONF+1
  1522. MCOL=0
  1523. NBNN=5
  1524. NBELEM=NB13
  1525. NBREF=0
  1526. NBSOUS=0
  1527. SEGINI IPT13
  1528. IPT13.ITYPEL=48
  1529. DO 658 MM11=1,IPT8.NUM(/2)
  1530. IF (IPT8.NUM(MLONG,MM11).NE.3) GOTO 658
  1531. MCOL=MCOL+1
  1532. DO 657 MTMP=1,5
  1533. IPT13.NUM(MTMP,MCOL)=IPT8.NUM(MTMP,MM11)
  1534. IPT13.ICOLOR(MCOL)=3
  1535. 657 CONTINUE
  1536. 658 CONTINUE
  1537. ENDIF
  1538. C
  1539. C 5/ Cas des relations 'face TRI6'
  1540. IF (NB14.NE.0) THEN
  1541. MCONF=MCONF+1
  1542. MCOL=0
  1543. NBNN=7
  1544. NBELEM=NB14
  1545. NBREF=0
  1546. NBSOUS=0
  1547. SEGINI IPT14
  1548. IPT14.ITYPEL=48
  1549. DO 648 MM11=1,IPT8.NUM(/2)
  1550. IF (IPT8.NUM(MLONG,MM11).NE.4) GOTO 648
  1551. MCOL=MCOL+1
  1552. DO 647 MTMP=1,7
  1553. IPT14.NUM(MTMP,MCOL)=IPT8.NUM(MTMP,MM11)
  1554. IPT14.ICOLOR(MCOL)=4
  1555. 647 CONTINUE
  1556. 648 CONTINUE
  1557. ENDIF
  1558. C
  1559. C 6/ Cas des relations 'face QUA8-1'
  1560. IF (NB15.NE.0) THEN
  1561. MCONF=MCONF+1
  1562. MCOL=0
  1563. NBNN=9
  1564. NBELEM=NB15
  1565. NBREF=0
  1566. NBSOUS=0
  1567. SEGINI IPT15
  1568. IPT15.ITYPEL=48
  1569. DO 638 MM11=1,IPT8.NUM(/2)
  1570. IF (IPT8.NUM(MLONG,MM11).NE.5) GOTO 638
  1571. MCOL=MCOL+1
  1572. DO 637 MTMP=1,9
  1573. IPT15.NUM(MTMP,MCOL)=IPT8.NUM(MTMP,MM11)
  1574. IPT15.ICOLOR(MCOL)=5
  1575. 637 CONTINUE
  1576. 638 CONTINUE
  1577. ENDIF
  1578. C
  1579. C 7/ Cas des relations 'face QUA8-2'
  1580. IF (NB16.NE.0) THEN
  1581. MCONF=MCONF+1
  1582. MCOL=0
  1583. NBNN=9
  1584. NBELEM=NB16
  1585. NBREF=0
  1586. NBSOUS=0
  1587. SEGINI IPT16
  1588. IPT16.ITYPEL=48
  1589. DO 678 MM11=1,IPT8.NUM(/2)
  1590. IF (IPT8.NUM(MLONG,MM11).NE.6) GOTO 678
  1591. MCOL=MCOL+1
  1592. DO 677 MTMP=1,9
  1593. IPT16.NUM(MTMP,MCOL)=IPT8.NUM(MTMP,MM11)
  1594. IPT16.ICOLOR(MCOL)=6
  1595. 677 CONTINUE
  1596. 678 CONTINUE
  1597. ENDIF
  1598. C
  1599. ENDIF
  1600. C
  1601. C--------------------------------------
  1602. C D) Creation du maillage de relations !
  1603. C--------------------------------------
  1604. C 1/ Initialisation de MAIREL
  1605. C MAIREL contient tous les maillages de relations, certains étant vides
  1606. C car il n'y a aucune relation du type considéré dans le nveau maillage
  1607. NBMAIL=6
  1608. SEGINI MAIREL
  1609. MAIREL(1)=IPT11
  1610. MAIREL(2)=IPT12
  1611. MAIREL(3)=IPT13
  1612. MAIREL(4)=IPT14
  1613. MAIREL(5)=IPT15
  1614. MAIREL(6)=IPT16
  1615. C
  1616. C 2/ Initialisation de LTYPE2
  1617. C LTYPE2 va contenir tous les sous-objets du nouveau maillage,
  1618. C relations et non relations
  1619. NBLIS2=MCONF+MAX(1,MELEME.LISOUS(/1))
  1620. SEGINI LTYPE2
  1621. C
  1622. C 3/ Renseignement des lisous non 48 dans LTYPE2
  1623. C S'il y a N sous-objets de non-relations dans le nouveau maillage,
  1624. C les N-ièmes premières colonnes de LTYPE2 contiennent ces sous-objets
  1625. DO 685 IZZ=1,MAX(1,MELEME.LISOUS(/1))
  1626. IF (MELEME.LISOUS(/1).EQ.0) THEN
  1627. IPT2=MELEME
  1628. ELSE
  1629. IPT2=MELEME.LISOUS(IZZ)
  1630. SEGACT IPT2
  1631. ENDIF
  1632. LTYPE2(IZZ,1)=IZZ
  1633. LTYPE2(IZZ,2)=IPT2.ITYPEL
  1634. LTYPE2(IZZ,3)=IPT2
  1635. LTYPE2(IZZ,4)=0
  1636. 685 CONTINUE
  1637. C
  1638. C 4/ Renseignement des lisous 48 dans LTYPE2
  1639. C Les colonnes suivantes contiennent les sous-objets de relations,
  1640. C chaque sous-objet correspondant a un type de relations de conformité
  1641. IZZ=NBLIS2-MCONF
  1642. DO 686 IXX=1,6
  1643. IF (MAIREL(IXX).EQ.0) GOTO 686
  1644. IPT2=MAIREL(IXX)
  1645. IZZ=IZZ+1
  1646. LTYPE2(IZZ,1)=IZZ
  1647. LTYPE2(IZZ,2)=IPT2.ITYPEL
  1648. LTYPE2(IZZ,3)=IPT2
  1649. LTYPE2(IZZ,4)=IPT2.ICOLOR(1)
  1650. 686 CONTINUE
  1651. C--------------------------------------
  1652. C E) Renseignement de LTYPE2 interne a
  1653. c la boucle 33 dans LTYPE3 externe a
  1654. c la boucle 33
  1655. C--------------------------------------C
  1656. C
  1657.  
  1658. LTYPE3(INB,1)=LTYPE2
  1659. IF (MCONF.EQ.0) THEN
  1660. LTYPE3(INB,2)=0
  1661. ELSE
  1662. LTYPE3(INB,2)=NBLIS2-MCONF+1
  1663. ENDIF
  1664. c fin de boucle sur les sous domaines d'ipt5
  1665. 33 CONTINUE
  1666. c SEGSUP IPT2
  1667.  
  1668.  
  1669. C Mise a jour des maillages en entrée sortie de la boucle 9
  1670. C IPT5, IPT6, IPT7
  1671. C=======================================================================
  1672. 679 CONTINUE
  1673. C--------------------------------------C
  1674. C A) initialisation
  1675. C--------------------------------------C
  1676.  
  1677. c 1/ initialisaton de IPT7 maillage stockant tout les sous maillage
  1678. c à la fin d'une itération de la boucle 9
  1679. NBS7=0
  1680. DO 331 I3=1,LTYPE3(/1)
  1681. LTYPE2=LTYPE3(I3, 1)
  1682. SEGACT LTYPE2
  1683. NBS7=NBS7+LTYPE2(/1)
  1684. 331 CONTINUE
  1685. IF (NBS7.EQ.1) NBS7=0
  1686. NBNN=0
  1687. NBELEM=0
  1688. NBREF=0
  1689. NBSOUS=NBS7
  1690. SEGINI IPT7
  1691.  
  1692. c 2/ initialisaton de IPT6 maillage stockant tout les sous maillage
  1693. c de relation à la fin d'une itération de la boucle 9
  1694. NBS6=0
  1695.  
  1696. DO 332 I3=1,LTYPE3(/1)
  1697. LTYPE2=LTYPE3(I3, 1)
  1698. SEGACT LTYPE2
  1699. IF (LTYPE3(I3,2).NE.0) NBS6=NBS6+(LTYPE2(/1)-LTYPE3(I3,2)+1)
  1700. 332 CONTINUE
  1701. IF (NBS6.EQ.1) NBS6=0
  1702. NBNN=0
  1703. NBELEM=0
  1704. NBREF=0
  1705. NBSOUS=NBS6
  1706. SEGINI IPT6
  1707. c 3/ initialisaton de IPT5 maillage stockant tout les sous maillage
  1708. c non relation à la fin d'une itération de la boucle 9
  1709. NBS5=0
  1710. DO 333 I3=1,LTYPE3(/1)
  1711. LTYPE2=LTYPE3(I3, 1)
  1712. SEGACT LTYPE2
  1713. IF (LTYPE3(I3,2).EQ.0) THEN
  1714. NBS5=NBS5+LTYPE2(/1)
  1715. ELSE
  1716. NBS5=NBS5+(LTYPE3(I3,2)-1)
  1717. ENDIF
  1718. 333 CONTINUE
  1719. IF (NBS5.EQ.1) NBS5=0
  1720. NBNN=0
  1721. NBELEM=0
  1722. NBREF=0
  1723. NBSOUS=NBS5
  1724. SEGINI IPT5
  1725. C--------------------------------------C
  1726. C B) assemblage des nouveaux maillage à
  1727. c partir des sous maillages stockés
  1728. c dans LTYP3
  1729. C--------------------------------------C
  1730. IND5=0
  1731. IND6=0
  1732. IND7=0
  1733. c 1/assemblage des nouveaux maillage non relation à partir des sous
  1734. c maillages stockés dans LTYP3
  1735.  
  1736. DO 35 I3=1,LTYPE3(/1)
  1737. c extraction d'un LTYPE2 de LTYPE3
  1738. LTYPE2=LTYPE3(I3, 1)
  1739. SEGACT LTYPE2
  1740. c NBNN=0
  1741. c NBELEM=0
  1742. c NBREF=0
  1743. c NBSOUS=0
  1744. DO 613 I2=1,MAX(1,(LTYPE3(I3,2)-1))
  1745. c extraction d'un MAILLAGE non relation de LTYPE2
  1746. IPT2=LTYPE2(I2,3)
  1747. SEGACT IPT2
  1748. IND5=IND5+1
  1749. IF (NBS5.EQ.0) THEN
  1750. IPT5=IPT2
  1751. c write (*,*) 'IPT5.' , IPT5
  1752. c write (*,*) 'type', IPT2.ITYPEL, 'Nbel' , IPT2.num(/2)
  1753. ELSE
  1754. IPT5.LISOUS(IND5)=IPT2
  1755. c write (*,*) 'IPT5.LISOUS(',IND5,')' , IPT5.LISOUS(IND5)
  1756. c write (*,*) 'type', IPT2.ITYPEL, 'Nbel' , IPT2.num(/2)
  1757. ENDIF
  1758. IND7=IND7+1
  1759. IF (NBS7.EQ.0) THEN
  1760. IPT7=IPT2
  1761. ELSE
  1762. IPT7.LISOUS(IND7)=IPT2
  1763. c write (*,*) 'IPT7.LISOUS(',IND7,')' , IPT7.LISOUS(IND7)
  1764. c write (*,*) 'type', IPT2.ITYPEL, 'Nbel' , IPT2.num(/2)
  1765. ENDIF
  1766. 613 CONTINUE
  1767. 35 CONTINUE
  1768.  
  1769. c 2/assemblage des nouveaux maillage de relation à partir des derniers
  1770. c sous maillages stockés dans LTYPE3
  1771.  
  1772. DO 36 I3=1,LTYPE3(/1)
  1773. c extraction d'un LTYPE2 de LTYPE3
  1774. c write (*,*) 'I3', I3
  1775. c write (*,*) 'LTYPE3(I3,2)', LTYPE3(I3,2)
  1776. IF (LTYPE3(I3,2).EQ.0) GOTO 36
  1777. SEGACT LTYPE2
  1778. LTYPE2=LTYPE3(I3, 1)
  1779. NBNN=0
  1780. NBELEM=0
  1781. NBREF=0
  1782. NBSOUS=0
  1783. DO 614 I2=LTYPE3(I3,2), LTYPE2(/1)
  1784. c extraction d'un MAILLAGE de relation de LTYPE2
  1785. c write (*,*) 'I2', I2
  1786. SEGINI IPT2
  1787. IPT2=LTYPE2(I2,3)
  1788. SEGACT IPT2
  1789. c write (*,*) 'IPT2: Type', IPT2.ITYPEL,'nbelem', IPT2.NUM(/2)
  1790. c write (*,*) 'coul IPT2' , IPT2.ICOLOR(1)
  1791. IND6=IND6+1
  1792. IF (NBS6.EQ.0) THEN
  1793. IPT6=IPT2
  1794. c write (*,*) 'IPT6' , IPT6
  1795. c write (*,*) 'type', IPT2.ITYPEL, 'Nbel' , IPT2.num(/2)
  1796. ELSE
  1797. IPT6.LISOUS(IND6)=IPT2
  1798.  
  1799. c write (*,*) 'IPT6.LISOUS(',IND6,')' , IPT6.LISOUS(IND6)
  1800. c write (*,*) 'type', IPT2.ITYPEL, 'Nbel' , IPT2.num(/2)
  1801. ENDIF
  1802. 614 CONTINUE
  1803. 36 CONTINUE
  1804.  
  1805. c 3/ Concatenation des sous maillages de relation de même couleur
  1806.  
  1807. c GG 11 juin 2018 : attention il peut encore y avoir des probleme a la
  1808. c jonctions entre deux sous zones dans le cas ou on raffine plusieurs
  1809. c types d'elments différents (passer cette etape de concaténation dans
  1810. c la boucle 33 ?
  1811.  
  1812. IF (NBS6.EQ.0) then
  1813. IND7=IND7+1
  1814. IPT7.LISOUS(IND7) = IPT6
  1815. c write (*,*) 'IPT7.LISOUS(',IND7,')' , IPT7.LISOUS(IND7)
  1816. c write (*,*) 'type', IPT2.ITYPEL, 'Nbel' , IPT2.num(/2)
  1817.  
  1818. goto 370
  1819. ENDIF
  1820. NBS60 = 0
  1821. SEGACT IPT6
  1822.  
  1823. c boucle sur les couleurs
  1824. NBELEM = 0
  1825. NBNN= 0
  1826. NBREF= 0
  1827. NBSOUS=6
  1828. SEGINI IPT4
  1829. DO 37 ICOUL = 1, 6
  1830. c boucle sur les sous maillages de ipt6
  1831. NCOl = 0
  1832. DO 38 I6 = 1, NBS6
  1833. IPT3 = IPT6.LISOUS(I6)
  1834. SEGACT IPT3
  1835. IF ((IPT3.icolor(1)).EQ.ICOUL) then
  1836. NCOL = NCOL+1
  1837. IF (NCOL.EQ.1) THEN
  1838. SEGINI IPT2
  1839. IPT2 = IPT6.LISOUS(I6)
  1840.  
  1841. ENDIF
  1842. IF (NCOL.GE.2) THEN
  1843.  
  1844. c IPT3 = IPT6.LISOUS(I6)
  1845. c SEGACT IPT3
  1846. c Plusieurs sous maillages de même couleur on concatene IPT2 et IPT3
  1847. NBELEM = IPT2.NUM(/2)
  1848. NBNN= IPT2.NUM(/1)
  1849. NBREF=0
  1850. NBSOUS=0
  1851. NBELE0 = NBELEM
  1852. DO 381 IE3 = 1, IPT3.NUM(/2)
  1853. DO 382 IE2 = 1, NBELE0
  1854. IF ((IPT3.NUM(1,IE3)).EQ.(IPT2.NUM(1,IE2))) GOTO 381
  1855. 382 CONTINUE
  1856. NBELEM = NBELEM +1
  1857. SEGADJ IPT2
  1858. DO IN2 = 1, NBNN
  1859. IPT2.NUM(IN2 , NBELEM) = IPT3.NUM(IN2, IE3)
  1860. IPT2.icolor(NBELEM) = IPT3.icolor(IE3)
  1861. ENDDO
  1862. 381 CONTINUE
  1863. ENDIF
  1864. ENDIF
  1865. 38 CONTINUE
  1866. IF (NCOL.GE.1) THEN
  1867. IPT4.LISOUS(ICOUL) = IPT2
  1868. NBS60= NBS60+1
  1869. ENDIF
  1870.  
  1871. 37 CONTINUE
  1872.  
  1873. c mise a jour de ipt6 et ipt7
  1874. IF (NBS60.EQ.1) then
  1875. IPT6 = IPT2
  1876. segact ipt6
  1877.  
  1878. c write (*,*) 'IPT6' , IPT6
  1879. c write (*,*) 'type', IPT6.ITYPEL, 'Nbel' , IPT6.num(/2)
  1880. IND7=IND7+1
  1881. IPT7.LISOUS(IND7) = IPT2
  1882. c write (*,*) 'IPT7.LISOUS(',IND7,')' , IPT7.LISOUS(IND7)
  1883. c write (*,*) 'type', IPT2.ITYPEL, 'Nbel' , IPT2.num(/2)
  1884. ELSE
  1885. SEGACT IPT4
  1886. NBELEM = 0
  1887. NBNN = 0
  1888. NBREF = 0
  1889. NBSOUS = NBS60
  1890. SEGINI IPT6
  1891. IS6=0
  1892. DO ICOUL = 1, 6
  1893. IF ((IPT4.LISOUS(ICOUL)).NE.0) THEN
  1894. IS6 = IS6+1
  1895. IPT6.LISOUS(IS6)= IPT4.LISOUS(ICOUL)
  1896. c write (*,*) 'IPT6.LISOUS(',IND6,')' , IPT6.LISOUS(IND6)
  1897. c write (*,*) 'type', IPT4.ITYPEL, 'Nbel' , IPT4.num(/2)
  1898.  
  1899. IND7=IND7+1
  1900. IPT7.LISOUS(IND7) = IPT4.LISOUS(ICOUL)
  1901. ENDIF
  1902. ENDDO
  1903. ENDIF
  1904. 370 CONTINUE
  1905. NBELEM = 0
  1906. NBNN = 0
  1907. NBREF = 0
  1908. NBSOUS = IND7
  1909.  
  1910. SEGADJ IPT7
  1911.  
  1912. SEGINI LTYPE4
  1913. LTYPE4 = LTYPE3
  1914.  
  1915. c mise a jour du nombre global de relations
  1916. LCONF3 = MCONF
  1917.  
  1918.  
  1919. C
  1920. C=======================================================================
  1921. C Test sur la progression du raffinement
  1922. C=======================================================================
  1923. C
  1924. C
  1925. C CB215821 Retrait du caractere *MOD le cas echeant
  1926. SEGACT IPT5,MCHPO1,MSOUPO,MPOVA1,IPT3,KMILIE
  1927. c SEGSUP ICPR,KARETE,KARPOS,KARET2,ICHPO,IDENSI
  1928. c SEGSUP ICPR,KARETE,KARPOS,KARET2,IDENSI
  1929. SEGSUP KARETE,KARPOS,KARET2
  1930. SEGSUP MCHAM1,MELVA1,MCHAM2,MELVA2,IMODE1
  1931. SEGSUP MMODE1,MCHEL1,MCHEL2
  1932.  
  1933. IF ((IDIM.EQ.3).AND.(NBOUCL.NE.1)) SEGSUP JPLANS,JPLAN2,JPLAN3,
  1934. +JPLCOM,JNOEFA,IWORK2,JFARAF, IPT9
  1935.  
  1936.  
  1937. C S'il y a eu a raffiner des elements lors de l'iteration courante,
  1938. C on passe a l'iteration suivante
  1939. C
  1940. c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  1941. c forcage : nb max itération de raff
  1942. c IF (NBOUCL.EQ.3) THEN
  1943. c KARAF2=0
  1944. c KARAF=0
  1945. c ENDIF
  1946. c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  1947. IF (KARAF2.NE.0) GOTO 9
  1948.  
  1949.  
  1950.  
  1951. C
  1952. C ### SORTIE TEMPORAIRE DU PROGRAMME ###
  1953. C Si on est a la premiere iteration de RAFF et qu'il n'y a pas
  1954. C d'elements a raffiner, on retourne en sortie le maillage de depart,
  1955. C donné en entree
  1956. IF ((KARAF2.EQ.0).AND.(NBOUCL.EQ.1)) THEN
  1957. WRITE(*,*) 'il n est pas necessaire de raffiner le maillage'
  1958. MELEME=IPT1
  1959. GOTO 998
  1960.  
  1961. ENDIF
  1962.  
  1963.  
  1964. C
  1965. C
  1966. C=======================================================================
  1967. C Mises a jour diverses
  1968. C=======================================================================
  1969. C ** On affecte une densite a chaque noeud que l'on a cree
  1970. c DO 37 I=NPTINI+1,XCOOR(/1)/(IDIM+1)
  1971. c XCOOR(I*(IDIM+1))=DENSI(ICPR(I,1))
  1972. c 37 CONTINUE
  1973.  
  1974. C
  1975. C=======================================================================
  1976. C Fin du programme
  1977. C=======================================================================
  1978.  
  1979. MELEME=IPT7
  1980.  
  1981. SEGSUP XDEN
  1982. 998 CONTINUE
  1983.  
  1984. CALL ACTOBJ('MAILLAGE',MELEME,1)
  1985. CALL ECROBJ('MAILLAGE',MELEME)
  1986.  
  1987. END
  1988.  
  1989.  
  1990.  
  1991.  
  1992.  
  1993.  
  1994.  

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