Télécharger regle.eso

Retour à la liste

Numérotation des lignes :

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

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