Télécharger rafpyr.eso

Retour à la liste

Numérotation des lignes :

  1. C RAFPYR SOURCE BP208322 16/11/18 21:20:44 9177
  2. SUBROUTINE RAFPYR(IPT2,ICPR,KARPOS,KARETE,KMILIE,MELVA2,NACREE,
  3. .KARAF,IPT4,JPLANS,JPLAN3,JPLCOM,JNOEFA,IPT7,JFARAF,KARET2,IPT5,
  4. .XDEN)
  5. IMPLICIT REAL*8(A-H,O-Z)
  6. IMPLICIT INTEGER(I-N)
  7. -INC CCOPTIO
  8. -INC SMCOORD
  9. -INC CCGEOME
  10. -INC SMELEME
  11. -INC SMCHPOI
  12. -INC SMMODEL
  13. -INC SMCHAML
  14. C
  15. C======================================================================
  16. C Declarations
  17. C======================================================================
  18. SEGMENT ICPR((XCOOR(/1)/(IDIM+1)),2)
  19. SEGMENT XDEN((XCOOR(/1)/(IDIM+1)))
  20. SEGMENT KARETE(NBNDS,NCOL)
  21. SEGMENT KARET2(NBNDS,NCOL)
  22. SEGMENT KMILIE(NBNDS,NCOL)
  23. SEGMENT KARPOS(NBNDS)
  24. SEGMENT JPLANS(JPLA1,JPLA2)
  25. SEGMENT JPLAN3(JPLA1,JPLA2)
  26. SEGMENT JPLCOM(JPLA1)
  27. SEGMENT JNOEFA(JNBFA,5)
  28. SEGMENT JFARAF(JNBFA,LLLL)
  29. SEGMENT NUMNOE(INUMNO)
  30. SEGMENT IWORK2(JNBSOM)
  31. SEGMENT IWORK1(IJKLMN)
  32. C
  33. C====================================================================
  34. C Initialisations
  35. C====================================================================
  36. SEGACT JPLANS,JPLCOM,JNOEFA,JPLAN3*MOD
  37. SEGACT IPT2,ICPR,KARPOS,KARETE,KMILIE*MOD,MELVA2,JFARAF*MOD
  38. IJKLMN=4
  39. ipt7=0
  40. SEGINI IWORK1
  41. IWORK1(1)=4
  42. IWORK1(2)=8
  43. IWORK1(3)=6
  44. IWORK1(4)=10
  45. NCOMPL=LNELM(1,(IPT2.ITYPEL-1)*2+2)
  46. C
  47. MBOUCL=0
  48. NBPYR=0
  49. 52 CONTINUE
  50. MBOUCL=MBOUCL+1
  51. C
  52. NBNN=NBNNE(LNELM(2,(IPT2.ITYPEL-1)*2+1))
  53. INELM=LNELM(1,(IPT2.ITYPEL-1)*2+1)
  54. C
  55. C Creation du squelette du maillage resultat
  56. NBELEM=IPT2.NUM(/2)-KARAF+INELM*KARAF
  57. NBSOUS=0
  58. NBREF=0
  59. SEGINI IPT4
  60. IPT4.ITYPEL=LNELM(2,(IPT2.ITYPEL-1)*2+1)
  61. LPO2=LPOS2(IPT2.ITYPEL)
  62. NBPT0=XCOOR(/1)/(IDIM+1)
  63. NBPT1=XCOOR(/1)/(IDIM+1)
  64. NBPTS=NBPT1+NACREE+KARAF*NBINTE(IPT2.ITYPEL)
  65. SEGADJ MCOORD,XDEN
  66. INUMNO=NBRAF(IPT2.ITYPEL)
  67. SEGINI NUMNOE
  68. LCOMP=1
  69. C
  70. NCOMPT=0
  71. DO 53 IARAF=1,MELVA2.VELCHE(/2)
  72. IF (MELVA2.VELCHE(1,IARAF).EQ.1) NCOMPT=NCOMPT+1
  73. 53 CONTINUE
  74. NUELM=1
  75. NBNN=NBNNE(IPT2.ITYPEL-2)
  76. NBELEM=NCOMPT*4
  77. NBSOUS=0
  78. NBREF=0
  79. SEGINI IPT5
  80. IPT5.ITYPEL=IPT2.ITYPEL-2
  81. C
  82. C
  83. C======================================================================
  84. C Phase de raffinement 3D
  85. C====================================================================== !
  86. C=======================================
  87. C A) Boucle sur les elements a raffiner !
  88. C=======================================
  89. DO 6 IARAF=1,MELVA2.VELCHE(/2)
  90. IF (MELVA2.VELCHE(1,IARAF).NE.1) THEN
  91. DO 1 IJKL=1,IPT2.NUM(/1)
  92. IPT4.NUM(IJKL,NBELEM)=IPT2.NUM(IJKL,IARAF)
  93. 1 CONTINUE
  94. NBELEM=NBELEM-1
  95. GOTO 6
  96. ENDIF
  97. NBPYR=NBPYR+1
  98. JCOMPT=0
  99. JPOS5=LPOS5(IPT2.ITYPEL)
  100. C
  101. C==========================================================
  102. C B) Boucle sur les noeuds a creer pour raffiner l'element !
  103. C==========================================================
  104. DO 4 I=1,NBRAF(IPT2.ITYPEL)
  105. JPOS1=LPOS1(1,I+LPOS2(IPT2.ITYPEL)-1)
  106. JLONG=LPOS1(2,I+LPOS2(IPT2.ITYPEL)-1)
  107. JLISN=LPOS3(IPT2.ITYPEL)+JCOMPT
  108. LTYPNO=JTYPNO(JPOS5-1+I)
  109. C
  110. C-------------------------------
  111. C ** B.1 / On est sur une arete !
  112. C-------------------------------
  113. IF (LTYPNO.EQ.0) THEN
  114. NPTA=IPT2.NUM(LISNOE(JLISN),IARAF)
  115. NPTB=IPT2.NUM(LISNOE(JLISN+1),IARAF)
  116. NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1))
  117. NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1))
  118. DO 2 K=1,MAX(1,KARPOS(NMIN))
  119. IF (KARETE(NMIN,K).EQ.NMAX) NEXIST=K
  120. 2 CONTINUE
  121. IF (KMILIE(NMIN,NEXIST).GT.0) THEN
  122. NUMNOE(I)=KMILIE(NMIN,NEXIST)
  123. JCOMPT=JCOMPT+JLONG
  124. GOTO 4
  125. ELSE
  126. NBPT1=NBPT1+1
  127. NUMNOE(I)=NBPT1
  128. KMILIE(NMIN,NEXIST)=NBPT1
  129. ENDIF
  130. C
  131. C------------------------------
  132. C ** B.2 / On est sur une face !
  133. C------------------------------
  134. C Il faut identifier cette face (numero, sommets...)
  135. ELSEIF ((LTYPNO.GT.0).AND.(LTYPNO.LT.7)) THEN
  136. C => a) On initialise toutes les donnees relatives a cette face
  137. JTYPEL=IPT2.ITYPEL
  138. JLTEL2=LTEL(1,JTYPEL)-1+LTYPNO
  139. JLTEL2=LTEL(2,JTYPEL)-1+LTYPNO
  140. JLDEL1=LDEL(1,JLTEL2)
  141. JTYFAC=IWORK1(JLDEL1)
  142. JLDEL2=LDEL(2,JLTEL2)
  143. JNBSOM=NBSOM(JTYFAC)
  144. JSPOS=NSPOS(JTYFAC)
  145. C => b) On identifie les sommets de la face (n° global)
  146. SEGINI IWORK2
  147. DO 10 IAA=1,JNBSOM
  148. NGLOBA=IPT2.NUM(LFAC(JLDEL2-1+IBSOM(JSPOS-1+IAA)),IARAF)
  149. IWORK2(IAA)=NGLOBA
  150. 10 CONTINUE
  151. C => c) On classe ces sommets par ordre croissant (NPTA < NPTB < NPTC)
  152. NPTA=(XCOOR(/1)/(IDIM+1))+1
  153. NPTB=NPTA+1
  154. NPTC=NPTB+1
  155. DO 11 ICC=1,JNBSOM
  156. IF (IWORK2(ICC).LT.NPTA) THEN
  157. NPTC=NPTB
  158. NPTB=NPTA
  159. NPTA=IWORK2(ICC)
  160. ELSEIF (IWORK2(ICC).LT.NPTB) THEN
  161. NPTC=NPTB
  162. NPTB=IWORK2(ICC)
  163. ELSEIF (IWORK2(ICC).LT.NPTC) THEN
  164. NPTC=IWORK2(ICC)
  165. ENDIF
  166. 11 CONTINUE
  167. C => d) On passe ces sommets en n° locale
  168. NPTA2=ICPR(NPTA,1)
  169. NPTB2=ICPR(NPTB,1)
  170. NPTC2=ICPR(NPTC,1)
  171. IF ((NPTA2.LT.NPTB2).AND.(NPTA2.LT.NPTC2)) THEN
  172. NPTA=NPTA2
  173. NPTB=MIN(NPTB2,NPTC2)
  174. NPTC=MAX(NPTB2,NPTC2)
  175. ENDIF
  176. IF ((NPTB2.LT.NPTA2).AND.(NPTB2.LT.NPTC2)) THEN
  177. NPTA=NPTB2
  178. NPTB=MIN(NPTA2,NPTC2)
  179. NPTC=MAX(NPTA2,NPTC2)
  180. ENDIF
  181. IF ((NPTC2.LT.NPTA2).AND.(NPTC2.LT.NPTB2)) THEN
  182. NPTA=NPTC2
  183. NPTB=MIN(NPTA2,NPTB2)
  184. NPTC=MAX(NPTA2,NPTB2)
  185. ENDIF
  186. C => e) On cherche le numero de la face
  187. NEXIS2=0
  188. DO 12 IEE=1,JPLCOM(NPTA)
  189. MTMP=JPLANS(NPTA,IEE)
  190. JJ1=JNOEFA(MTMP,1)
  191. JJ2=JNOEFA(MTMP,2)
  192. JJ3=JNOEFA(MTMP,3)
  193. IF(JJ1.EQ.NPTA.AND.JJ2.EQ.NPTB.AND.JJ3.EQ.NPTC) THEN
  194. NEXIS2=IEE
  195. ENDIF
  196. 12 CONTINUE
  197. JNUMFA=JPLANS(NPTA,NEXIS2)
  198. C
  199. C---------------------------------
  200. C ** B.3 / Raffinement de la face !
  201. C---------------------------------
  202. KTEST1=JPLAN3(NPTA,NEXIS2)
  203. KTEST2=NBINTE(JTYFAC)
  204. C => a) Si la face est de type QUA4 (un seul noeud a creer, au milieu)
  205. IF (JTYFAC.EQ.8) THEN
  206. IF (KTEST1.LT.KTEST2) THEN
  207. NBPT1=NBPT1+1
  208. NUMNOE(I)=NBPT1
  209. JPLAN3(NPTA,NEXIS2)=JPLAN3(NPTA,NEXIS2)+1
  210. JFARAF(JNUMFA,1)=NBPT1
  211. ELSEIF (KTEST1.EQ.KTEST2) THEN
  212. NUMNOE(I)=JFARAF(JNUMFA,1)
  213. JFARAF(JNUMFA,1)=0
  214. JCOMPT=JCOMPT+JLONG
  215. GOTO 4
  216. ELSE
  217. WRITE(*,*) 'ERREUR'
  218. ENDIF
  219. ENDIF
  220. C => b) Si la face n'est pas de type QUA4 (donc de type TRI6 ou QUA8)
  221. IF (JTYFAC.NE.8) THEN
  222. IF (KTEST1.LT.KTEST2) THEN
  223. NBPT1=NBPT1+1
  224. NUMNOE(I)=NBPT1
  225. JPLAN3(NPTA,NEXIS2)=JPLAN3(NPTA,NEXIS2)+1
  226. NEXIS3=0
  227. XCO2=0.25
  228. DO 13 KBB=1,JLONG
  229. XCO1=XCOEFF(JPOS1-1+KBB)
  230. IF (XCO1.EQ.XCO2) NEXIS3=KBB
  231. 13 CONTINUE
  232. JFARAF(JNUMFA,2*(KTEST1)+1)=NBPT1
  233. IF (NEXIS3.NE.0) THEN
  234. NGLOB=IPT2.NUM(LISNOE(JLISN-1+NEXIS3),IARAF)
  235. JFARAF(JNUMFA,2*(KTEST1)+2)=NGLOB
  236. ELSE
  237. JFARAF(JNUMFA,2*(KTEST1)+2)=0
  238. ENDIF
  239. ELSEIF (KTEST1.EQ.KTEST2) THEN
  240. NEXIS3=0
  241. NEXIS4=0
  242. XCO2=0.25
  243. DO 14 KBB=1,JLONG
  244. XCO1=XCOEFF(JPOS1-1+KBB)
  245. IF (XCO1.EQ.XCO2) NEXIS3=KBB
  246. 14 CONTINUE
  247. IF (NEXIS3.NE.0) THEN
  248. NGLOB=IPT2.NUM(LISNOE(JLISN-1+NEXIS3),IARAF)
  249. DO 15 KAA=2,JFARAF(/2),2
  250. IF (JFARAF(JNUMFA,KAA).EQ.NGLOB) NEXIS4=KAA
  251. 15 CONTINUE
  252. NUMNOE(I)=JFARAF(JNUMFA,NEXIS4-1)
  253. JFARAF(JNUMFA,NEXIS4-1)=0
  254. ELSE
  255. DO 16 KAA=2,JFARAF(/2),2
  256. IF (JFARAF(JNUMFA,KAA).EQ.0) NEXIS4=KAA
  257. 16 CONTINUE
  258. NUMNOE(I)=JFARAF(JNUMFA,NEXIS4-1)
  259. JFARAF(JNUMFA,NEXIS4-1)=0
  260. ENDIF
  261. JCOMPT=JCOMPT+JLONG
  262. GOTO 4
  263. ENDIF
  264. ENDIF
  265. C
  266. C------------------------------------------------------
  267. C ** B.4 / On est a l'interieur du volume de l'element !
  268. C------------------------------------------------------
  269. ELSEIF (LTYPNO.EQ.7) THEN
  270. NBPT1=NBPT1+1
  271. NUMNOE(I)=NBPT1
  272. ENDIF
  273. C
  274. IF (NBPT1.EQ.NBPTS) THEN
  275. NBPTS=NBPTS+200
  276. SEGADJ MCOORD,XDEN
  277. ENDIF
  278. C
  279. C==============================
  280. C C) Creation du nouveau point !
  281. C==============================
  282. C On continue ici que lorsque l'on doit creer un nouveau point
  283. XPT=0.
  284. YPT=0.
  285. ZPT=0.
  286. XDEN1=0.D0
  287. DO 3 J=1,JLONG
  288. NGLOB=IPT2.NUM(LISNOE(JLISN-1+J),IARAF)
  289. XINI=XCOOR((NGLOB-1)*(IDIM+1)+1)
  290. YINI=XCOOR((NGLOB-1)*(IDIM+1)+2)
  291. ZINI=XCOOR((NGLOB-1)*(IDIM+1)+3)
  292. XPT=XPT+XINI*XCOEFF(JPOS1-1+J)
  293. YPT=YPT+YINI*XCOEFF(JPOS1-1+J)
  294. ZPT=ZPT+ZINI*XCOEFF(JPOS1-1+J)
  295. XDEN1=XDEN1+XDEN(NGLOB)*XCOEFF(JPOS1-1+J)
  296. 3 CONTINUE
  297. XCOOR((NBPT1-1)*(IDIM+1)+1)=XPT
  298. XCOOR((NBPT1-1)*(IDIM+1)+2)=YPT
  299. XCOOR((NBPT1-1)*(IDIM+1)+3)=ZPT
  300. XDEN(NBPT1)=XDEN1
  301. JCOMPT=JCOMPT+JLONG
  302.  
  303. C======================================================================
  304. 4 CONTINUE
  305. C======================================================================
  306. JPOS4=LPOS4(IPT2.ITYPEL)
  307. C
  308. C===================================
  309. C D) Creation des nouveaux elements !
  310. C===================================
  311. C On remplit la portion de IPT4 relative aux elements crees a partir
  312. C de la division de l'element IARAF (indice de boucle 1).
  313. C Cette portion de IPT4 contient les colonnes dont la valeur s'etend
  314. C de INELM*(LCOMP-1)+1 a INELM*LCOMP.
  315. NBNN=NBNNE(LNELM(2,(KTYP-1)*2+1))
  316. DO 5 J=1,INELM
  317. DO 5 I=1,IPT4.NUM(/1)
  318. NTEMP=LIELM(JPOS4-1+NBNN*(J-1)+I)
  319. IF (NTEMP.GT.NBNN) THEN
  320. IPT4.NUM(I,INELM*(LCOMP-1)+J)=NUMNOE(NTEMP-NBNN)
  321. ELSE
  322. IPT4.NUM(I,INELM*(LCOMP-1)+J)=IPT2.NUM(NTEMP,IARAF)
  323. ENDIF
  324. 5 CONTINUE
  325. LCOMP=LCOMP+1
  326. C
  327. KTYP=IPT2.ITYPEL
  328. IF (KTYP.EQ.25) JPOS41=561+5*6
  329. IF (KTYP.EQ.26) JPOS41=685
  330. DO 34 JJ=1,IPT5.NUM(/2)
  331. DO 33 II=1,IPT5.NUM(/1)
  332. NTEMP=LIELM(JPOS41-1+II)
  333. IF (NTEMP.GT.NBNN) THEN
  334. IPT5.NUM(II,NUELM)=NUMNOE(NTEMP-NBNN)
  335. ELSE
  336. IPT5.NUM(II,NUELM)=IPT2.NUM(NTEMP,IARAF)
  337. ENDIF
  338. 33 CONTINUE
  339. JPOS41=JPOS41+NBNNE(KTYP-2)
  340. NUELM=NUELM+1
  341. 34 CONTINUE
  342. C
  343. 6 CONTINUE
  344. C
  345. NBPTS=NBPT1
  346. SEGADJ MCOORD,XDEN
  347. C
  348. C=======================================================================
  349. C Preparation du maillage de relations
  350. C=======================================================================
  351. C==================================
  352. C A) Relations dues aux faces (3D) !
  353. C==================================
  354. C Tous les noeuds qui restent dans JFARAF sont a creer en tant que
  355. C relations de conformite
  356. C---------------------------------
  357. C ** A.1 / Initialisation de IPT5 !
  358. C---------------------------------
  359. C 1/ Comptage du nombre de noeuds soumis a des relations
  360. NBRELA=0
  361. DO 114 IHF=1,JFARAF(/1)
  362. IF (JNOEFA(IHF,5).EQ.0) GOTO 114
  363. IF (JFARAF(IHF,1).EQ.0) GOTO 114
  364. DO 113 JF=1,JFARAF(/2),2
  365. IF (JFARAF(IHF,JF).NE.0) NBRELA=NBRELA+1
  366. 113 CONTINUE
  367. 114 CONTINUE
  368. C
  369. C 2/ Creation de IPT5
  370. IF (NBRELA.EQ.0) THEN
  371. IPT5=0
  372. GOTO 210
  373. ENDIF
  374. C IF (IPT2.ITYPEL.EQ.14) NBNN=4
  375. C IF (IPT2.ITYPEL.EQ.15) NBNN=8
  376. C IF (IPT2.ITYPEL.EQ.17) NBNN=5
  377. C IF (IPT2.ITYPEL.EQ.24) NBNN=5
  378. NBNN=10
  379. NBELEM=NBRELA
  380. NBSOUS=0
  381. NBREF=0
  382. SEGINI IPT5
  383. IPT5.ITYPEL=48
  384. C
  385. C 3/ Renseignement des noeuds support des relations
  386. NBRELA=0
  387. DO 116 IPF=1,JFARAF(/1)
  388. IF (JNOEFA(IPF,5).EQ.0) GOTO 116
  389. IF (JFARAF(IPF,1).EQ.0) GOTO 116
  390. DO 115 JF=1,JFARAF(/2),2
  391. IF (JFARAF(IPF,JF).EQ.0) GOTO 115
  392. NBRELA=NBRELA+1
  393. IPT5.NUM(1,NBRELA)=JFARAF(IPF,JF)
  394. 115 CONTINUE
  395. 116 CONTINUE
  396. C
  397. C-----------------------------------------------------
  398. C ** A.2 / Recherche des noeuds formant les relations !
  399. C-----------------------------------------------------
  400. C 1/ Boucle sur l'ensemble des noeuds a creer
  401. DO 200 IARAF=1,MELVA2.VELCHE(/2)
  402. IF (MELVA2.VELCHE(1,IARAF).NE.1) GOTO 200
  403. JCOMPT=0
  404. JPOS5=LPOS5(IPT2.ITYPEL)
  405. DO 190 I=1,NBRAF(IPT2.ITYPEL)
  406. JPOS1=LPOS1(1,I+LPOS2(IPT2.ITYPEL)-1)
  407. JLONG=LPOS1(2,I+LPOS2(IPT2.ITYPEL)-1)
  408. JLISN=LPOS3(IPT2.ITYPEL)+JCOMPT
  409. LTYPNO=JTYPNO(JPOS5-1+I)
  410. IF ((LTYPNO.EQ.0).OR.(LTYPNO.EQ.7)) GOTO 189
  411. C
  412. C 2/ Preparation pour trouver le noeud et la face en question
  413. JTYPEL=IPT2.ITYPEL
  414. JLTEL2=LTEL(2,JTYPEL)-1+LTYPNO
  415. JLDEL1=LDEL(1,JLTEL2)
  416. JTYFAC=IWORK1(JLDEL1)
  417. JLDEL2=LDEL(2,JLTEL2)
  418. JNBSOM=NBSOM(JTYFAC)
  419. JSPOS=NSPOS(JTYFAC)
  420. SEGINI IWORK2
  421. C
  422. C 3/ Classement des 3 sommets par ordre croissant de n° globale
  423. DO 100 IAA=1,JNBSOM
  424. NGLOBA=IPT2.NUM(LFAC(JLDEL2-1+IBSOM(JSPOS-1+IAA)),IARAF)
  425. IWORK2(IAA)=NGLOBA
  426. 100 CONTINUE
  427. NPTA=(XCOOR(/1)/(IDIM+1))+1
  428. NPTB=NPTA+1
  429. NPTC=NPTB+1
  430. DO 110 ICC=1,JNBSOM
  431. IF (IWORK2(ICC).LT.NPTA) THEN
  432. NPTC=NPTB
  433. NPTB=NPTA
  434. NPTA=IWORK2(ICC)
  435. ELSEIF (IWORK2(ICC).LT.NPTB) THEN
  436. NPTC=NPTB
  437. NPTB=IWORK2(ICC)
  438. ELSEIF (IWORK2(ICC).LT.NPTC) THEN
  439. NPTC=IWORK2(ICC)
  440. ENDIF
  441. 110 CONTINUE
  442. C
  443. C 4/ Classement des 3 sommets par ordre croissant de n° locale
  444. NPTA2=ICPR(NPTA,1)
  445. NPTB2=ICPR(NPTB,1)
  446. NPTC2=ICPR(NPTC,1)
  447. IF ((NPTA2.LT.NPTB2).AND.(NPTA2.LT.NPTC2)) THEN
  448. NPTA=NPTA2
  449. NPTB=MIN(NPTB2,NPTC2)
  450. NPTC=MAX(NPTB2,NPTC2)
  451. ENDIF
  452. IF ((NPTB2.LT.NPTA2).AND.(NPTB2.LT.NPTC2)) THEN
  453. NPTA=NPTB2
  454. NPTB=MIN(NPTA2,NPTC2)
  455. NPTC=MAX(NPTA2,NPTC2)
  456. ENDIF
  457. IF ((NPTC2.LT.NPTA2).AND.(NPTC2.LT.NPTB2)) THEN
  458. NPTA=NPTC2
  459. NPTB=MIN(NPTA2,NPTB2)
  460. NPTC=MAX(NPTA2,NPTB2)
  461. ENDIF
  462. C
  463. C 5/ Recherche du numero de la face
  464. NEXIS2=0
  465. DO 120 IEE=1,JPLCOM(NPTA)
  466. MTMP=JPLANS(NPTA,IEE)
  467. JJ1=JNOEFA(MTMP,1)
  468. JJ2=JNOEFA(MTMP,2)
  469. JJ3=JNOEFA(MTMP,3)
  470. IF(JJ1.EQ.NPTA.AND.JJ2.EQ.NPTB.AND.JJ3.EQ.NPTC) THEN
  471. NEXIS2=IEE
  472. ENDIF
  473. 120 CONTINUE
  474. JNUMFA=JPLANS(NPTA,NEXIS2)
  475. C
  476. C 6/ Recherche du numero global du point
  477. IF (JNOEFA(JNUMFA,5).EQ.0) GOTO 189
  478. IF (JTYFAC.EQ.8) INOEGL=JFARAF(JNUMFA,1)
  479. IF (JTYFAC.NE.8) THEN
  480. NEXIS3=0
  481. NEXIS4=0
  482. XCO2=0.25
  483. DO 140 KBB=1,JLONG
  484. XCO1=XCOEFF(JPOS1-1+KBB)
  485. IF (XCO1.EQ.XCO2) NEXIS3=KBB
  486. 140 CONTINUE
  487. IF (NEXIS3.NE.0) THEN
  488. NGLOB=IPT2.NUM(LISNOE(JLISN-1+NEXIS3),IARAF)
  489. DO 150 KAA=2,JFARAF(/2),2
  490. IF (JFARAF(JNUMFA,KAA).EQ.NGLOB) NEXIS4=KAA
  491. 150 CONTINUE
  492. INOEGL=JFARAF(JNUMFA,NEXIS4-1)
  493. ELSE
  494. DO 160 KAA=2,JFARAF(/2),2
  495. IF (JFARAF(JNUMFA,KAA).EQ.0) NEXIS4=KAA
  496. 160 CONTINUE
  497. INOEGL=JFARAF(JNUMFA,NEXIS4-1)
  498. ENDIF
  499. ENDIF
  500. C
  501. C------------------------------
  502. C ** A.3 / Remplissage de IPT5 !
  503. C------------------------------
  504. C 1/ Recherche de la position du point dans IPT5
  505. NEXIS5=0
  506. DO 170 IGG=1,IPT5.NUM(/2)
  507. IF (INOEGL.EQ.IPT5.NUM(1,IGG)) NEXIS5=IGG
  508. 170 CONTINUE
  509. IF (NEXIS5.EQ.0) GOTO 189
  510. C
  511. C 2/ Renseignement des points formant les relations
  512. DO 180 IHH=1,JLONG
  513. IPT5.NUM(1+IHH,NEXIS5)=IPT2.NUM(LISNOE(JLISN-1+IHH),IARAF)
  514. 180 CONTINUE
  515. IF (JLONG.EQ.4) IPT5.NUM(10,NEXIS5)=3
  516. IF (JLONG.EQ.5) IPT5.NUM(10,NEXIS5)=4
  517. IF (JLONG.EQ.8) THEN
  518. IF (JPOS1.EQ.16) IPT5.NUM(10,NEXIS5)=5
  519. IF (JPOS1.EQ.24) IPT5.NUM(10,NEXIS5)=6
  520. ENDIF
  521. 189 CONTINUE
  522. JCOMPT=JCOMPT+JLONG
  523. 190 CONTINUE
  524. 200 CONTINUE
  525. 210 CONTINUE
  526. C
  527. C===================================
  528. C B) Relations dues aux aretes (2D) !
  529. C===================================
  530. C On cree un maillage IPT6 contenant tous les noeuds soumis a des
  531. C relations
  532. C
  533. SEGSUP KARET2
  534. NBNDS=KARETE(/1)
  535. NCOL=KARETE(/2)
  536. SEGINI KARET2
  537. ILPL=LPL(IPT2.ITYPEL)
  538. ILPT=LPT(IPT2.ITYPEL)
  539. DO 317 J=1,IPT4.NUM(/2)
  540. DO 317 K=1,ILPL*2-1,2
  541. NPTA=IPT4.NUM(KSEGM(ILPT+K-1),J)
  542. NPTB=IPT4.NUM(KSEGM(ILPT+K),J)
  543. IF((NPTA.GT.NBPT0).OR.(NPTB.GT.NBPT0)) THEN
  544. GOTO 317
  545. ENDIF
  546. NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1))
  547. NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1))
  548. NEXIST=0
  549. DO 316 I=1,MAX(1,KARPOS(NMIN))
  550. IF (KARETE(NMIN,I).EQ.NMAX) THEN
  551. KARET2(NMIN,I)=KARET2(NMIN,I)+1
  552. ENDIF
  553. 316 CONTINUE
  554. 317 CONTINUE
  555.  
  556. C 1/ Comptage du nombre de noeuds soumis a des relations
  557. NBELEM=0
  558. DO 27 J=1,KMILIE(/2)
  559. DO 27 I=1,KMILIE(/1)
  560. IF (KARET2(I,J).EQ.0) GOTO 27
  561. IF (KMILIE(I,J).GT.0) NBELEM=NBELEM+1
  562. 27 CONTINUE
  563. C
  564. C 2/ Creation de IPT6
  565. IPT6=0
  566. IF (NBELEM.EQ.0) GOTO 999
  567. NBNN=5
  568. NBREF=0
  569. NBSOUS=0
  570. SEGINI IPT6
  571. IPT6.ITYPEL=48
  572. C
  573. C 3/ Renseignement des noeuds support des relations
  574. DO 28 J=1,KMILIE(/2)
  575. DO 28 I=1,KMILIE(/1)
  576. IF (KARET2(I,J).EQ.0) GOTO 28
  577. IF (KMILIE(I,J).GT.0) THEN
  578. NBREF=NBREF+1
  579. IPT6.NUM(1,NBREF)=KMILIE(I,J)
  580. ENDIF
  581. 28 CONTINUE
  582. C
  583. C 4/ Recherche des noeuds formant les relations
  584. DO 24 IARAF=1,MELVA2.VELCHE(/2)
  585. IF (MELVA2.VELCHE(1,IARAF).NE.1) GOTO 24
  586. JCOMPT=0
  587. JPOS5=LPOS5(IPT2.ITYPEL)
  588. DO 23 I=1,NBRAF(IPT2.ITYPEL)
  589. JPOS1=LPOS1(1,I+LPOS2(IPT2.ITYPEL)-1)
  590. JLONG=LPOS1(2,I+LPOS2(IPT2.ITYPEL)-1)
  591. JLISN=LPOS3(IPT2.ITYPEL)+JCOMPT
  592. LTYPNO=JTYPNO(JPOS5-1+I)
  593. IF (LTYPNO.NE.0) GOTO 22
  594. NPTA=IPT2.NUM(LISNOE(JLISN),IARAF)
  595. NPTB=IPT2.NUM(LISNOE(JLISN+1),IARAF)
  596. NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1))
  597. NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1))
  598. DO 29 K=1,MAX(1,KARPOS(NMIN))
  599. IF (KARETE(NMIN,K).EQ.NMAX) NEXIST=K
  600. 29 CONTINUE
  601. IF (KARET2(NMIN,NEXIST).EQ.0) GOTO 22
  602. IF (KMILIE(NMIN,NEXIST).EQ.0) GOTO 22
  603. NEXIS5=0
  604. DO 20 MM=1,IPT6.NUM(/2)
  605. INOEGL=KMILIE(NMIN,NEXIST)
  606. INRELA=IPT6.NUM(1,MM)
  607. IF (INOEGL.EQ.INRELA) NEXIS5=MM
  608. 20 CONTINUE
  609. C
  610. C 5/ Renseignement des noeuds formant les relations
  611. DO 21 IHH=1,JLONG
  612. IPT6.NUM(1+IHH,NEXIS5)=IPT2.NUM(LISNOE(JLISN-1+IHH),IARAF)
  613. 21 CONTINUE
  614. IF (JLONG.EQ.2) IPT6.NUM(5,NEXIS5)=1
  615. IF (JLONG.EQ.3) IPT6.NUM(5,NEXIS5)=2
  616. 22 CONTINUE
  617. JCOMPT=JCOMPT+JLONG
  618. 23 CONTINUE
  619. 24 CONTINUE
  620.  
  621. 444 CONTINUE
  622.  
  623. C
  624. C============================================
  625. C C) Creation du maillage de relations final !
  626. C============================================
  627. IF (IPT5.EQ.0) THEN
  628. IPT7=IPT6
  629. GOTO 999
  630. ENDIF
  631. NBELEM=IPT5.NUM(/2)+IPT6.NUM(/2)
  632. C NBNN=MAX(IPT5.NUM(/1),IPT6.NUM(/1))
  633. NBNN=10
  634. NBREF=0
  635. NBSOUS=0
  636. SEGINI IPT7
  637. IPT7.ITYPEL=48
  638. DO 42 NEO=1,IPT5.NUM(/2)
  639. DO 42 MOR=1,10
  640. IPT7.NUM(MOR,NEO)=IPT5.NUM(MOR,NEO)
  641. IPT7.ICOLOR(NEO)=IPT5.ICOLOR(NEO)
  642. 42 CONTINUE
  643. NN5 = IPT5.NUM(/2)
  644. DO 43 NEO=IPT5.NUM(/2)+1,IPT6.NUM(/2)+IPT5.NUM(/2)
  645. DO 43 MOR=1,IPT6.NUM(/1)
  646. IF (MOR.LT.IPT6.NUM(/1)) THEN
  647. IPT7.NUM(MOR,NEO)=IPT6.NUM(MOR,NEO-NN5)
  648. ELSE
  649. IPT7.NUM(10,NEO)=IPT6.NUM(MOR,NEO-NN5)
  650. ENDIF
  651. IPT7.ICOLOR(NEO)=IPT6.ICOLOR(NEO-NN5)
  652. 43 CONTINUE
  653. WRITE(*,*) ' |-> raffinement OK'
  654. C=======================================================================
  655. C Fin du programme
  656. C=======================================================================
  657. GOTO 999
  658. WRITE(*,*) '****************************************************'
  659. WRITE(*,*) 'TABLEAU JNOEFA'
  660. DO 64 I=1,JNOEFA(/1)
  661. WRITE(*,1000) I,':',(JNOEFA(I,J), J=1,JNOEFA(/2))
  662. 64 CONTINUE
  663. WRITE(*,*) '****************************************************'
  664. WRITE(*,*) 'TABLEAU JFARAF'
  665. WRITE(*,*) 'Nb colonnes = ',JFARAF(/2)
  666. DO 63 I=1,JFARAF(/1)
  667. WRITE(*,1000) I,':',(JFARAF(I,J), J=1,JFARAF(/2))
  668. 63 CONTINUE
  669. GOTO 999
  670. WRITE(*,*) '****************************************************'
  671. WRITE(*,*) 'TABLEAU JPLANS'
  672. DO 61 I=1,JPLANS(/1)
  673. WRITE(*,1000) I,':',(JPLANS(I,J), J=1,JPLANS(/2))
  674. 61 CONTINUE
  675. WRITE(*,*) '****************************************************'
  676. WRITE(*,*) 'TABLEAU JPLAN3'
  677. DO 62 I=1,JPLAN3(/1)
  678. WRITE(*,1000) I,':',(JPLAN3(I,J), J=1,JPLAN3(/2))
  679. 62 CONTINUE
  680. WRITE(*,*) '****************************************************'
  681. WRITE(*,*) 'TABLEAU ICPR'
  682. DO 98 I=1,ICPR(/1)
  683. WRITE(*,*) I,': ',ICPR(I,1),' ',ICPR(I,2)
  684. 98 CONTINUE
  685. 1000 FORMAT (1I3,A,24I4)
  686. 999 CONTINUE
  687. RETURN
  688. END
  689.  
  690.  
  691.  
  692.  
  693.  
  694.  
  695.  
  696.  
  697.  

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