Télécharger regle.eso

Retour à la liste

Numérotation des lignes :

regle
  1. C REGLE SOURCE CB215821 21/12/14 21:15:19 11220
  2. C CONSTRUIT LA SURFACE REGLE ENTRE DEUX LIGNES DE MEME LONGUEUR
  3. C
  4. SUBROUTINE REGLE
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7.  
  8. -INC PPARAM
  9. -INC CCOPTIO
  10. -INC CCGEOME
  11. -INC SMCOORD
  12. -INC SMELEME
  13. -INC CCREEL
  14.  
  15. SEGMENT TABPAR(NCOUCH)
  16. SEGMENT ICPR(2,NBELEC)
  17. SEGMENT JCPR(NBPTS)
  18.  
  19. logical ltelq
  20. c * DIMENSION ITEST(0:NBCOUL-1) - NBCOUL stocke dans CCGEOME =16 dans bdata
  21. c DIMENSION ITEST(0:30)
  22. CHARACTER*(4) MLU
  23.  
  24. IDIMP1 = IDIM+1
  25. IMPOI=0
  26. IMPOF=0
  27. DEN1=0.
  28. DEN2=0.
  29. C Y A T IL UN DECOUPAGE IMPOSE
  30. INBR=0
  31. CALL LIRENT(INBR,0,IRETOU)
  32. * IF (IRETOU.EQ.1) INBR=MAX(1,INBR)
  33. * SI INBR NEGATIF ALORS DECOUPAGE IMPOSE AVEC PROGRESSION D'APRES
  34. * LES DENSITES
  35. C Y A T-IL DES DENSITES IMPOSEES
  36. 80 CALL LIRCHA(MLU,0,IRETOU)
  37. IF (IRETOU.EQ.0) GOTO 83
  38. IF (MLU.NE.'DINI') GOTO 81
  39. CALL LIRREE(XXX,1,IRETOU)
  40. DEN1=XXX
  41. IF (IERR.NE.0) RETURN
  42. IMPOI=1
  43. IF (IMPOF.EQ.1) GOTO 83
  44. CALL LIRCHA(MLU,0,IRETOU)
  45. IF (IRETOU.EQ.0) GOTO 83
  46. 81 IF (MLU.NE.'DFIN') GOTO 82
  47. CALL LIRREE(XXX,1,IRETOU)
  48. DEN2=XXX
  49. IF (IERR.NE.0) RETURN
  50. IMPOF=1
  51. IF (IMPOI.EQ.0) GOTO 80
  52. GOTO 83
  53. 82 CALL REFUS
  54. 83 CONTINUE
  55. IF (KSURF(ILCOUR).EQ.0) CALL ERREUR(16)
  56. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  57. IF (IERR.NE.0) RETURN
  58. CALL EXTRLI(IPT1,3,IRET,-1)
  59. IF (IERR.NE.0) RETURN
  60. IFUSE1=0
  61. IF (IPT1.NE.IRET) IFUSE1=IPT1
  62. IPT1=IRET
  63. CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  64. IF (IERR.NE.0) RETURN
  65. CALL EXTRLI(IPT2,1,IRET,1)
  66. IF (IERR.NE.0) RETURN
  67. IFUSE2=0
  68. IF (IPT2.NE.IRET) IFUSE2=IPT2
  69. IPT2=IRET
  70. SEGACT IPT1,IPT2
  71. IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) CALL ERREUR(16)
  72. NBELEM=IPT1.NUM(/2)
  73. IF (NBELEM.NE.IPT2.NUM(/2)) CALL ERREUR(33)
  74. IF (IERR.EQ.0) GOTO 2
  75. 1 SEGDES IPT1,IPT2
  76. RETURN
  77. 2 CONTINUE
  78. c c calcul de la couleur de melange via ITABM:
  79. c c fait ici, on va moyenner sur tous les elements
  80. c DO 90 I=0,(NBCOUL-1)
  81. c 90 ITEST(I)=0
  82. c DO 91 I=1,IPT1.NUM(/2)
  83. c ITEST(IPT1.ICOLOR(I))=1
  84. c 91 CONTINUE
  85. c DO 92 I=1,IPT2.NUM(/2)
  86. c ITEST(IPT2.ICOLOR(I))=1
  87. c 92 CONTINUE
  88. c ICHCOL=-1
  89. c DO 93 I=0,(NBCOUL-1)
  90. c IF (ITEST(I).EQ.1) THEN
  91. c IF (ICHCOL.EQ.-1) THEN
  92. c ICHCOL=I
  93. c ELSE
  94. c ICHCOL=ITABM(ICHCOL,I)
  95. c ENDIF
  96. c ENDIF
  97. c 93 CONTINUE
  98. SEGACT MCOORD*mod
  99. NBNN=IPT1.NUM(/1)
  100. ZG1=0.
  101. ZG2=0.
  102. DLONG=XPETIT
  103. IBOUCL=0
  104. IF (IPT1.NUM(1,1).EQ.IPT1.NUM(NBNN,NBELEM)) IBOUCL=1
  105. IF (IBOUCL.EQ.1.AND.IPT2.NUM(1,1).NE.IPT2.NUM(NBNN,
  106. #NBELEM)) THEN
  107. CALL ERREUR(33)
  108. GOTO 1
  109. ENDIF
  110. DEN1AU=DEN1
  111. DEN2AU=DEN2
  112. DO 10 I=1,NBNN
  113. DO 10 J=1,NBELEM
  114. IREF1=IPT1.NUM(I,J)*IDIMP1-IDIM
  115. XG1=XCOOR(IREF1)
  116. YG1=XCOOR(IREF1+1)
  117. IF (IDIM.GE.3) ZG1=XCOOR(IREF1+2)
  118. DEN1=XCOOR(IREF1+IDIM)+DEN1
  119. IREF2=IPT2.NUM(I,J)*IDIMP1-IDIM
  120. XG2=XCOOR(IREF2)
  121. YG2=XCOOR(IREF2+1)
  122. IF (IDIM.GE.3) ZG2=XCOOR(IREF2+2)
  123. DEN2=XCOOR(IREF2+IDIM)+DEN2
  124. XDIS=XG2-XG1
  125. YDIS=YG2-YG1
  126. ZDIS=ZG2-ZG1
  127. DLONG=SQRT(XDIS*XDIS+YDIS*YDIS+ZDIS*ZDIS)+DLONG
  128. 10 CONTINUE
  129.  
  130. NBTOT=NBNN*NBELEM
  131. DEN1=DEN1/NBTOT
  132. DEN2=DEN2/NBTOT
  133. DLONG=DLONG/NBTOT
  134. DLONG=MAX(XPETIT,DLONG)
  135. IF (IMPOI.EQ.1) DEN1=DEN1AU
  136. IF (IMPOF.EQ.1) DEN2=DEN2AU
  137. DEN1A=DEN1
  138. DEN1B=DEN1
  139. DEN2A=DEN2
  140. DEN2B=DEN2
  141. DEN1=DEN1/DLONG
  142. DEN2=DEN2/DLONG
  143. DENI = 0.
  144. DECA = 0.
  145. CALL DECOUP(INBR,DEN1,DEN2,APROG,NCOUCH,DENI,DECA,DLONG)
  146. NX=NCOUCH-1
  147. IF(DENI.EQ. 0.D0) DENI = DLONG / NCOUCH
  148. IF (IIMPI.EQ.1) WRITE (IOIMP,1000) NCOUCH,APROG
  149. 1000 FORMAT(/' COUCHES ',I6,' RAISON ',G12.5)
  150. NBNN =4
  151. NBELEM=IPT1.NUM(/2)*NCOUCH
  152. NBSOUS=0
  153. NBREF =4
  154. SEGINI MELEME
  155. SEGINI TABPAR
  156. ITYPEL=8
  157. INCR=IPT1.ITYPEL-1
  158. IL=1
  159. NBELEC=IPT1.NUM(/2)
  160. SEGINI ICPR
  161. CALL INVERS(IPT2,IPT4)
  162. SEGDES IPT4
  163. LISREF(3)=IPT4
  164. C ON REMPLIT LE TABLEAU ICPR DES PTS EFFECTIFS
  165. IDEB=nbpts+1
  166.  
  167. SEGINI,JCPR
  168. DO 510 J=1,NBELEC
  169. DO 511 I=1,2
  170. I1=IPT1.NUM((I-1)*INCR+1,J)
  171. IF(JCPR(I1) .EQ. 0)THEN
  172. JCPR(I1)=J
  173. ENDIF
  174. 511 CONTINUE
  175. 510 CONTINUE
  176.  
  177.  
  178. C LCPR=0
  179. DO 51 J=1,NBELEC
  180. DO 51 I=1,2
  181. I1=IPT1.NUM((I-1)*INCR+1,J)
  182. C LCPR=LCPR+1
  183. C DO 52 JJ=1,J
  184. JJ =JCPR(I1)
  185. DO 52 II=1,2
  186. I2=IPT1.NUM((II-1)*INCR+1,JJ)
  187. IF (I2.NE.I1) GOTO 52
  188.  
  189. IF (II.NE.I ) GOTO 53
  190. IF (JJ.EQ.J ) GOTO 51
  191. 53 ICPR(I,J)=II+(JJ-1)*2
  192. C LCPR=LCPR-1
  193. IF (J.EQ.NBELEC.AND.I.EQ.2) GOTO 55
  194. GOTO 51
  195. 55 IF (IBOUCL.EQ.1) GOTO 51
  196. ICPR(I,J)=0
  197. ICPR(II,JJ)=I+(J-1)*2
  198. GOTO 51
  199. 52 CONTINUE
  200. 51 CONTINUE
  201.  
  202. SEGSUP,JCPR
  203.  
  204. C ON NE S'OCCUPE QUE DE FABRIQUER DES RECTANGLES A 4 NOEUDS POUR
  205. C LE MOMENT D'ABORD LES POINTS DU BAS QUI NE SONT PAS A FABRIQUER
  206. DIN=DEN1
  207. DO 60 I=1,IPT1.NUM(/2)
  208. NUM(1,I)=IPT1.NUM(1,I)
  209. NUM(2,I)=IPT1.NUM(1+INCR,I)
  210. c on crée la couleur moyenne par quadrangle
  211. ICOL1 = IPT1.ICOLOR(I)
  212. ICOL2 = IPT2.ICOLOR(I)
  213. ICOLOR(I)=ITABM(ICOL1,ICOL2)
  214. 60 CONTINUE
  215. ILASI=IDEB-1
  216. ILASJ=ILASI+(INCR*NX)+INCR-1
  217. IF (IBOUCL.EQ.1) ILASJ=ILASI
  218. ILAS=ILASJ+INCR*NX+INCR
  219. DO 62 ICOUCH=1,NCOUCH
  220. DIN=DIN*APROG
  221. TABPAR(ICOUCH)=DIN
  222. IF (NCOUCH.EQ.ICOUCH) GOTO 61
  223. ILASI=ILASI+INCR
  224. ILASJ=ILASJ+INCR
  225. INI=(ICOUCH-1)*IPT1.NUM(/2)
  226. NUM(1,1+INI+NBELEC)=ILASI
  227. NUM(4,1+INI)=ILASI
  228. NUM(2,INI+2*NBELEC)=ILASJ
  229. NUM(3,INI+NBELEC)=ILASJ
  230. INI=(ICOUCH-1)*IPT1.NUM(/2)
  231. DO 62 J=1,IPT1.NUM(/2)
  232. ICOLOR(J+INI+NBELEC)=ICOLOR(J)
  233. DO 62 I=1,2
  234. ILL=ILAS
  235. IF (I.EQ.1.AND.J.EQ.1) ILL=ILASI
  236. IF (I.EQ.2.AND.J.EQ.NBELEC) ILL=ILASJ
  237. IF (ICPR(I,J).NE.0) ILL=NUM(MOD(ICPR(I,J)-1,2)+1,
  238. # (ICPR(I,J)-1)/2+1+INI+NBELEC)
  239. NUM(I,J+INI+NBELEC)=ILL
  240. NUM(5-I,J+INI)=ILL
  241. IF (I.EQ.1.AND.J.EQ.1) GOTO 62
  242. IF (I.EQ.2.AND.J.EQ.NBELEC) GOTO 62
  243. IF (ICPR(I,J).NE.0) GOTO 62
  244. ILAS=ILL+1
  245. 62 CONTINUE
  246. TABPAR(NCOUCH)=DIN*APROG
  247. 61 CONTINUE
  248. INI=(NCOUCH-1)*IPT1.NUM(/2)
  249. DO 63 I=1,NBELEC
  250. NUM(4,INI+I)=IPT2.NUM(1,I)
  251. NUM(3,INI+I)=IPT2.NUM(1+INCR,I)
  252. 63 CONTINUE
  253. LISREF(1)=IPT1
  254. C CREATION DES BORDS LATERAUX PAR LIGNE (DROITE)
  255. C IMPOSONS ILCOUR POUR CETTE MANIP (LES BORDS LATERAUX DOIVENT ETRE
  256. C CONSISTANT AVEC LES AUTRES )
  257. ILSAUV=ILCOUR
  258. ILCOUR=IPT1.ITYPEL
  259. ITYPL=1
  260. LP2=IPT2.NUM(1,1)
  261. CALL ECROBJ('POINT ',LP2)
  262. LP1=IPT1.NUM(1,1)
  263. CALL ECROBJ('POINT ',LP1)
  264. C CORRECTION POUR TENIR COMPTE DE LA DIFFERENCE DE LONGUEUR ENTRE
  265. C LE BORD ET LE MILIEU
  266. IREF1=(LP1-1)*IDIMP1
  267. IREF2=(LP2-1)*IDIMP1
  268. DL=0.
  269. DO 67 I=1,IDIM
  270. DL=DL+(XCOOR(IREF1+I)-XCOOR(IREF2+I))**2
  271. 67 CONTINUE
  272. DL=SQRT(DL)
  273. DEN1A=DEN1A*DL/DLONG
  274. DEN2A=DEN2A*DL/DLONG
  275. CALL LIGNE(ITYPL,0,DEN1A,DEN2A,INBR)
  276. IF (IERR.NE.0) GOTO 100
  277. CALL LIROBJ('MAILLAGE',IPT3,1,IRETOU)
  278. SEGACT IPT3
  279. CALL INVERS(IPT3,IPT4)
  280. LISREF(4)=IPT4
  281. SEGDES IPT4
  282. IF (IBOUCL.EQ.0) GOTO 66
  283. LISREF(2)=IPT3
  284. SEGDES IPT3
  285. GOTO 65
  286. 66 CONTINUE
  287. SEGSUP IPT3
  288. LP2=IPT2.NUM(IPT2.NUM(/1),IPT2.NUM(/2))
  289. CALL ECROBJ('POINT ',LP2)
  290. LP1=IPT1.NUM(IPT1.NUM(/1),IPT1.NUM(/2))
  291. CALL ECROBJ('POINT ',LP1)
  292. IREF1=(LP1-1)*IDIMP1
  293. IREF2=(LP2-1)*IDIMP1
  294. DL=0.
  295. DO 68 I=1,IDIM
  296. DL=DL+(XCOOR(IREF1+I)-XCOOR(IREF2+I))**2
  297. 68 CONTINUE
  298. DL=SQRT(DL)
  299. DEN1B=DEN1B*DL/DLONG
  300. DEN2B=DEN2B*DL/DLONG
  301. CALL LIGNE(ITYPL,0,DEN1B,DEN2B,INBR)
  302. CALL LIROBJ('MAILLAGE',IPT3,1,IRETOU)
  303. IF (IERR.NE.0) GOTO 100
  304. SEGDES IPT3
  305. LISREF(2)=IPT3
  306. 65 CONTINUE
  307. C ON RESTAURE ILCOUR
  308. 100 CONTINUE
  309. ILCOUR=ILSAUV
  310. IF (IERR.NE.0) RETURN
  311. C CREATION DES POINTS (PAS LES POINTS MILIEUX QUI SERONT FABRIQUES
  312. C EVENTUELLEMENT LORS DE LA CONVERSION DES ELEMENTS)
  313. DPAR=0.
  314. SEGACT MCOORD*mod
  315. IADR=nbpts
  316. IF (NCOUCH.EQ.1) GOTO 70
  317. NBPTS=IADR+(NCOUCH-1)*IPT1.NUM(/2)*2
  318. SEGADJ MCOORD
  319. DO 71 I=2,NCOUCH
  320. DIN=TABPAR(I-1)
  321. DPAR=DPAR+DIN
  322. IF (IPT1.NUM(/2).EQ.1) GOTO 70
  323. UMDPAR=1.-DPAR
  324. DINA=DENI+DECA*DPAR
  325. DO 72 J=1,IPT1.NUM(/2)
  326. DO 72 K=1,2
  327. IF (K.EQ.1.AND.J.EQ.1) GOTO 72
  328. IF (K.EQ.2.AND.J.EQ.NBELEC) GOTO 72
  329. IF (ICPR(K,J).NE.0) GOTO 72
  330. IREF1=IDIMP1*IPT1.NUM((K-1)*INCR+1,J)-IDIM
  331. IREF2=IDIMP1*IPT2.NUM((K-1)*INCR+1,J)-IDIM
  332. IREFA=IADR*IDIMP1
  333. XCOOR(IREFA+1)=UMDPAR*XCOOR(IREF1) +DPAR*XCOOR(IREF2)
  334. XCOOR(IREFA+2)=UMDPAR*XCOOR(IREF1+1)+DPAR*XCOOR(IREF2+1)
  335. IF(IDIM.NE.2)
  336. #XCOOR(IREFA+3)=UMDPAR*XCOOR(IREF1+2)+DPAR*XCOOR(IREF2+2)
  337. XCOOR(IREFA+IDIMP1)=DINA
  338. IADR=IADR+1
  339. 72 CONTINUE
  340. 71 CONTINUE
  341. 70 CONTINUE
  342. NBPTS=IADR
  343. SEGADJ MCOORD
  344. IPT7=IPT1
  345. IPT8=IPT2
  346. IF (KSURF(ILCOUR).EQ.8) GOTO 101
  347. IF (KSURF(ILCOUR).NE.4) GOTO 102
  348. NBNN=3
  349. NBELEM=2*NUM(/2)
  350. NBREF=4
  351. NBSOUS=0
  352. SEGINI IPT1
  353. IPT1.ITYPEL=4
  354. IPT1.LISREF(1)=LISREF(1)
  355. IPT1.LISREF(2)=LISREF(2)
  356. IPT1.LISREF(3)=LISREF(3)
  357. IPT1.LISREF(4)=LISREF(4)
  358. DO 103 I=1,NUM(/2),2
  359. J=2*I-1
  360. IPT1.NUM(1,J)=NUM(1,I)
  361. IPT1.NUM(2,J)=NUM(2,I)
  362. IPT1.NUM(3,J)=NUM(3,I)
  363. IPT1.ICOLOR(J) = ICOLOR(I)
  364. J=J+1
  365. IPT1.NUM(1,J)=NUM(1,I)
  366. IPT1.NUM(2,J)=NUM(3,I)
  367. IPT1.NUM(3,J)=NUM(4,I)
  368. IPT1.ICOLOR(J) = ICOLOR(I)
  369. J=J+1
  370. IF (J.GT.IPT1.NUM(/2)) GOTO 103
  371. IPT1.NUM(1,J)=NUM(1,I+1)
  372. IPT1.NUM(2,J)=NUM(2,I+1)
  373. IPT1.NUM(3,J)=NUM(4,I+1)
  374. IPT1.ICOLOR(J) = ICOLOR(I)
  375. J=J+1
  376. IPT1.NUM(1,J)=NUM(2,I+1)
  377. IPT1.NUM(2,J)=NUM(3,I+1)
  378. IPT1.NUM(3,J)=NUM(4,I+1)
  379. IPT1.ICOLOR(J) = ICOLOR(I)
  380. 103 CONTINUE
  381. SEGSUP MELEME
  382. MELEME=IPT1
  383. GOTO 101
  384. 102 CONTINUE
  385. * write (6,*) ' ilcour ksurf ',ilcour,ksurf(ilcour)
  386.  
  387. IF (KSURF(ILCOUR).NE.10.AND.KSURF(ILCOUR).NE.6) GOTO 104
  388. if (ipt7.itypel.ne.3) goto 104
  389. C ON FAIT DES QUA8 OU DES TRI6
  390. NBNN=8
  391. NBELEM=NUM(/2)
  392. NBREF=4
  393. NBSOUS=0
  394. SEGINI IPT5
  395. IPT5.ITYPEL=10
  396. IPT1=LISREF(1)
  397. IPT2=LISREF(2)
  398. IPT3=LISREF(3)
  399. IPT4=LISREF(4)
  400. IPT5.LISREF(1)=IPT1
  401. IPT5.LISREF(2)=IPT2
  402. IPT5.LISREF(3)=IPT3
  403. IPT5.LISREF(4)=IPT4
  404. SEGACT IPT1,IPT2,IPT3,IPT4
  405. DO 105 J=1,NUM(/1)
  406. JJ=2*J-1
  407. DO 105 I=1,NBELEM
  408. IPT5.NUM(JJ,I)=NUM(J,I)
  409. 105 CONTINUE
  410. NLIG=IPT1.NUM(/2)
  411. DO 106 I=1,NLIG
  412. IPT5.NUM(2,I)=IPT7.NUM(2,I)
  413. IPT5.NUM(6,NBELEM-NLIG+I)=IPT8.NUM(2,I)
  414. IPT5.ICOLOR(I) = IPT1.ICOLOR(I)
  415. 106 CONTINUE
  416. DPAR=0.
  417. NBPTS=IADR+NCOUCH*3*NLIG
  418. SEGADJ MCOORD
  419. DO 107 I=1,NCOUCH
  420. IPT5.NUM(8,NLIG*(I-1)+1)=IPT4.NUM(2,NCOUCH+1-I)
  421. IPT5.NUM(4,NLIG*I)=IPT2.NUM(2,I)
  422. C ON FAIT D'ABORD LES NOEUDS 2 DU HAUT (6 DU BAS)
  423. C CREATION DES NOEUDS
  424. DIN=TABPAR(I)
  425. DPAR=DPAR+DIN
  426. IF (I.EQ.NCOUCH) GOTO 108
  427. UMDPAR=1.-DPAR
  428. DINA=DENI+DECA*DPAR
  429. DO 109 J=1,NLIG
  430. IREF1=IDIMP1*(IPT7.NUM(2,J)-1)
  431. IREF2=IDIMP1*(IPT8.NUM(2,J)-1)
  432. IREFA=IADR*IDIMP1
  433. XCOOR(IREFA+1)=UMDPAR*XCOOR(IREF1+1)+DPAR*XCOOR(IREF2+1)
  434. XCOOR(IREFA+2)=UMDPAR*XCOOR(IREF1+2)+DPAR*XCOOR(IREF2+2)
  435. IF(IDIM.GE.3)
  436. #XCOOR(IREFA+3)=UMDPAR*XCOOR(IREF1+3)+DPAR*XCOOR(IREF2+3)
  437. XCOOR(IREFA+IDIMP1)=DINA
  438. IADR=IADR+1
  439. C ON MET LE NOEUD DANS LES ELEMENTS
  440. IPT5.NUM(6,(I-1)*NLIG+J)=IADR
  441. IPT5.NUM(2,I*NLIG+J)=IADR
  442. IPT5.ICOLOR(I*NLIG+J) = IPT1.ICOLOR(J)
  443. 109 CONTINUE
  444. 108 CONTINUE
  445. IF (NLIG.EQ.1) GOTO 113
  446. C ON MET LES NOEUDS 4 DE GAUCHE ET 8 DE DROITE
  447. C CREATION DES NOEUDS
  448. EPAR=DPAR-TABPAR(I)*0.5
  449. UMEPAR=1.-EPAR
  450. DINA=DEN1+DECA*EPAR
  451. DO 115 J=1,NLIG
  452. DO 115 K=1,2
  453. IF (K.EQ.1.AND.J.EQ.1) GOTO 115
  454. IF (K.EQ.2.AND.J.EQ.NLIG) GOTO 115
  455. IF (ICPR(K,J).NE.0) GOTO 116
  456. IREF1=(IPT7.NUM(2*K-1,J)-1)*IDIMP1
  457. IREF2=(IPT8.NUM(2*K-1,J)-1)*IDIMP1
  458. IREFA=IADR*IDIMP1
  459. XCOOR(IREFA+1)=UMEPAR*XCOOR(IREF1+1)+EPAR*XCOOR(IREF2+1)
  460. XCOOR(IREFA+2)=UMEPAR*XCOOR(IREF1+2)+EPAR*XCOOR(IREF2+2)
  461. IF(IDIM.GE.3)
  462. #XCOOR(IREFA+3)=UMEPAR*XCOOR(IREF1+3)+EPAR*XCOOR(IREF2+3)
  463. XCOOR(IREFA+IDIMP1)=DINA
  464. IADR=IADR+1
  465. 116 CONTINUE
  466. C NOEUDS DES ELEM
  467. IF (ICPR(K,J).NE.0) GOTO 119
  468. IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IADR
  469. GOTO 115
  470. 119 CONTINUE
  471. IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IPT5.NUM(4*(2-MOD(ICPR(K,J)-1,2)),
  472. # (ICPR(K,J)+1)/2+(I-1)*NLIG)
  473. 115 CONTINUE
  474. 113 CONTINUE
  475. 107 CONTINUE
  476. NBPTS=IADR
  477. SEGADJ MCOORD
  478. SEGSUP MELEME
  479. MELEME=IPT5
  480. SEGDES IPT1,IPT2,IPT3,IPT4,IPT7,IPT8
  481. IF (KSURF(ILCOUR).NE.6) GOTO 101
  482. C ON FAIT DES TRI6
  483. NBNN=6
  484. NBELEM=2*NUM(/2)
  485. NBREF=4
  486. NBSOUS=0
  487. SEGINI IPT1
  488. IPT1.ITYPEL=6
  489. IPT1.LISREF(1)=LISREF(1)
  490. IPT1.LISREF(2)=LISREF(2)
  491. IPT1.LISREF(3)=LISREF(3)
  492. IPT1.LISREF(4)=LISREF(4)
  493. IALT=1
  494. NBPTS=IADR+NCOUCH*NLIG
  495. SEGADJ MCOORD
  496. DO 120 I=1,NCOUCH
  497. DO 120 J=1,NLIG
  498. INU=(I-1)*NLIG+J
  499. IALT=3-IALT
  500. C CREATION DU POINT SUPPLEMENTAIRE
  501. IREF1=(NUM(2,INU)-1)*IDIMP1
  502. IREF2=(NUM(6,INU)-1)*IDIMP1
  503. IREFA=IADR*IDIMP1
  504. XCOOR(IREFA+1)=(XCOOR(IREF1+1)+XCOOR(IREF2+1))*0.5
  505. XCOOR(IREFA+2)=(XCOOR(IREF1+2)+XCOOR(IREF2+2))*0.5
  506. IF (IDIM.GE.3)
  507. #XCOOR(IREFA+3)=(XCOOR(IREF1+3)+XCOOR(IREF2+3))*0.5
  508. XCOOR(IREFA+IDIMP1)=
  509. # (XCOOR(IREF1+IDIMP1)+XCOOR(IREF2+IDIMP1))*0.5
  510. IADR=IADR+1
  511. ITR1=2*INU-1
  512. ITR2=2*INU
  513. GOTO (124,125),IALT
  514. C CREATION DES TRIANGLES
  515. 124 IPT1.NUM(1,ITR1)=NUM(1,INU)
  516. IPT1.NUM(2,ITR1)=NUM(2,INU)
  517. IPT1.NUM(3,ITR1)=NUM(3,INU)
  518. IPT1.NUM(5,ITR1)=NUM(7,INU)
  519. IPT1.NUM(6,ITR1)=NUM(8,INU)
  520. IPT1.NUM(4,ITR1)=IADR
  521. IPT1.NUM(1,ITR2)=NUM(3,INU)
  522. IPT1.NUM(2,ITR2)=NUM(4,INU)
  523. IPT1.NUM(3,ITR2)=NUM(5,INU)
  524. IPT1.NUM(4,ITR2)=NUM(6,INU)
  525. IPT1.NUM(5,ITR2)=NUM(7,INU)
  526. IPT1.NUM(6,ITR2)=IADR
  527. IPT1.ICOLOR(ITR1) = ICOLOR(INU)
  528. IPT1.ICOLOR(ITR2) = ICOLOR(INU)
  529. GOTO 126
  530. 125 IPT1.NUM(1,ITR1)=NUM(1,INU)
  531. IPT1.NUM(2,ITR1)=NUM(2,INU)
  532. IPT1.NUM(3,ITR1)=NUM(3,INU)
  533. IPT1.NUM(4,ITR1)=NUM(4,INU)
  534. IPT1.NUM(5,ITR1)=NUM(5,INU)
  535. IPT1.NUM(6,ITR1)=IADR
  536. IPT1.NUM(1,ITR2)=NUM(5,INU)
  537. IPT1.NUM(2,ITR2)=NUM(6,INU)
  538. IPT1.NUM(3,ITR2)=NUM(7,INU)
  539. IPT1.NUM(4,ITR2)=NUM(8,INU)
  540. IPT1.NUM(5,ITR2)=NUM(1,INU)
  541. IPT1.NUM(6,ITR2)=IADR
  542. IPT1.ICOLOR(ITR1) = ICOLOR(INU)
  543. IPT1.ICOLOR(ITR2) = ICOLOR(INU)
  544. GOTO 126
  545. 126 CONTINUE
  546. 120 CONTINUE
  547. SEGSUP MELEME
  548. MELEME=IPT1
  549. GOTO 101
  550. 104 CONTINUE
  551. 101 CONTINUE
  552. SEGSUP TABPAR,ICPR
  553. c c attribution de la couleur "moyenne"
  554. c DO 152 I=1,NUM(/2)
  555. c 152 ICOLOR(I)=ICHCOL
  556. IF (IFUSE1.EQ.0) GOTO 150
  557. IPT5=IFUSE1
  558. SEGACT IPT5
  559. ltelq=.false.
  560. CALL FUSE(IPT5,MELEME,IRET,ltelq)
  561. SEGDES IPT5,MELEME
  562. MELEME=IRET
  563. 150 CONTINUE
  564. IF (IFUSE2.EQ.0) GOTO 151
  565. IPT5=IFUSE2
  566. SEGACT IPT5
  567. ltelq=.false.
  568. CALL FUSE(MELEME,IPT5,IRET,ltelq)
  569. SEGDES IPT5,MELEME
  570. MELEME=IRET
  571. 151 CONTINUE
  572. CALL ECROBJ('MAILLAGE',MELEME)
  573. SEGDES MELEME
  574. RETURN
  575. END
  576.  
  577.  
  578.  
  579.  
  580.  
  581.  
  582.  
  583.  
  584.  
  585.  
  586.  

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