Télécharger prtran.eso

Retour à la liste

Numérotation des lignes :

  1. C PRTRAN SOURCE BP208322 16/11/18 21:20:32 9177
  2. C PREPARATION DE LA TRANSLATION ET DE LA ROTATION D'UNE LIGNE
  3. C
  4. C MODIFICATION NOVEMBRE 1984 INTRODUCTION DE LA DEGENERESCENCE DANS
  5. C LE CAS DE ROTATION DONT L'AXE PASSE PAR UN (OU DEUX) POINT DE
  6. C LA LIGNE (MODIFICATION NON TERMINE)
  7. C
  8. SUBROUTINE PRTRAN(IOPTG)
  9. IMPLICIT INTEGER(I-N)
  10. IMPLICIT REAL*8 (A-H,O-Z)
  11. DIMENSION XCO(4)
  12. DIMENSION XROT1(3),XROT2(3)
  13. CHARACTER*4 MCLE(2)
  14. -INC CCREEL
  15. -INC CCOPTIO
  16. logical ltelq
  17. SEGMENT TABPAR
  18. REAL*8 TABPA1(NCOUCH)
  19. ENDSEGMENT
  20. -INC CCGEOME
  21. -INC SMCOORD
  22. -INC SMELEME
  23. SEGMENT ICPR
  24. INTEGER ICPR1(2,NBELEC)
  25. ENDSEGMENT
  26. SEGMENT ICPP
  27. INTEGER ICPP1(XCOOR(/1)/(IDIM+1))
  28. ENDSEGMENT
  29. COMMON/CTOURN/XPT1,YPT1,ZPT1,XV1,YV1,ZV1,XV2,YV2,ZV2,XVEC,YVEC,
  30. # ZVEC,ANGLE,ICLE
  31. DATA MCLE/'DINI','DFIN'/
  32. XDIS=0.D0
  33. YDIS=0.D0
  34. ZDIS=0.D0
  35. IMPOI=0
  36. IMPOF=0
  37. C Y A T IL UN DECOUPAGE IMPOSE
  38. INBR=0
  39. CALL MESLIR(-236)
  40. CALL LIRENT(INBR,0,IRETOU)
  41.  
  42. * IF (IRETOU.EQ.1) INBR=MAX(1,INBR)
  43. IF (IDIM.EQ.3.AND.IOPTG.EQ.2) IOPTG=3
  44. IF (KSURF(ILCOUR).EQ.0) CALL ERREUR(16)
  45. C CAS DE LA ROTATION DONNEE OBLIGATOIRE L'ANGLE
  46. IF (IOPTG.EQ.1) GOTO 1
  47. IOB=0
  48. IF (INBR.EQ.0) IOB=1
  49. CALL MESLIR(-235)
  50. CALL LIRREE(XXX,IOB,IRETOU)
  51. FLOT=XXX
  52. IF (IERR.NE.0) RETURN
  53. IF (IRETOU.EQ.1) GOTO 2
  54. IF (INBR.NE.0) FLOT=INBR
  55. INBR=0
  56. 2 CONTINUE
  57. ANGLE=FLOT*XPI/180.D0
  58.  
  59. IF (IERR.NE.0) RETURN
  60. 1 CONTINUE
  61. C Y A T-IL DES DENSITES IMPOSEES
  62. 3 CONTINUE
  63. CALL MESLIR(-234)
  64. CALL LIRMOT(MCLE,2,IRETOU,0)
  65. IF (IRETOU.EQ.1) THEN
  66. CALL MESLIR(-170)
  67. CALL LIRREE(XXX,1,IRETOU)
  68. DEN1D=XXX
  69. IF (IERR.NE.0) RETURN
  70. IMPOI=1
  71. GOTO 3
  72. ELSEIF (IRETOU.EQ.2) THEN
  73. CALL MESLIR(-169)
  74. CALL LIRREE(XXX,1,IRETOU)
  75. DEN2D=XXX
  76. IF (IERR.NE.0) RETURN
  77. IMPOF=1
  78. GOTO 3
  79. ENDIF
  80. CALL MESLIR(-131)
  81. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  82. IF (IERR.NE.0) RETURN
  83. CALL EXTRLI(IPT1,3,IRET,-1)
  84. IF (IERR.NE.0) RETURN
  85. IFUSE=0
  86. IF (IPT1.NE.IRET) IFUSE=IPT1
  87. IPT1=IRET
  88. IF (IOPTG.EQ.1) CALL MESLIR(-233)
  89. IF (IOPTG.EQ.2) CALL MESLIR(-232)
  90. CALL LIROBJ('POINT ',IP1,1,IRETOU)
  91. IF (IOPTG.EQ.3) THEN
  92. CALL MESLIR(-231)
  93. CALL LIROBJ('POINT ',IP2,1,IRETOU)
  94. IF (IERR.NE.0) RETURN
  95. ENDIF
  96. 12 SEGACT IPT1
  97. 11 SEGACT MCOORD
  98. NBNN=IPT1.NUM(/1)
  99. * VERIFIER TYPE D'ELEMENT ACCEPTABLE
  100. IF (IPT1.ITYPEL.NE.2.AND.IPT1.ITYPEL.NE.3) CALL ERREUR(16)
  101. IF (IERR.NE.0) RETURN
  102. NBELEM=IPT1.NUM(/2)
  103. XG=0.D0
  104. YG=0.D0
  105. ZG=0.D0
  106. DEN1=0.D0
  107. IBOUCL=0
  108. IF (IPT1.NUM(1,1).EQ.IPT1.NUM(NBNN,NBELEM)) IBOUCL=1
  109. DO 17 I=1,NBNN
  110. DO 171 J=1,NBELEM
  111. IREF=IPT1.NUM(I,J)*(IDIM+1)
  112. XG=XCOOR(IREF-IDIM)+XG
  113. YG=XCOOR(IREF-IDIM+1)+YG
  114. IF (IDIM.GE.3) ZG=XCOOR(IREF-IDIM+2)+ZG
  115. DEN1=XCOOR(IREF)+DEN1
  116. 171 CONTINUE
  117. 17 CONTINUE
  118. XG=XG/(NBNN*NBELEM)
  119. YG=YG/(NBNN*NBELEM)
  120. ZG=ZG/(NBNN*NBELEM)
  121. DEN1=DEN1/(NBNN*NBELEM)
  122. IF (IMPOI.EQ.1) DEN1=DEN1D
  123. DEN1A=DEN1
  124. DEN1B=DEN1
  125. IF (IOPTG.NE.1) GOTO 13
  126. IREF=IP1*(IDIM+1)
  127. IREFT=IREF-IDIM
  128. XTRAN=XCOOR(IREF-IDIM)
  129. YTRAN=XCOOR(IREF-IDIM+1)
  130. ZTRAN=0
  131. IF (IDIM.GE.3) ZTRAN=XCOOR(IREF-IDIM+2)
  132. DEN2=XCOOR(IREF)
  133. IF (IMPOF.EQ.1) DEN2=DEN2D
  134. DEN2A=DEN2
  135. DEN2B=DEN2
  136. XDIS=XTRAN
  137. YDIS=YTRAN
  138. ZDIS=ZTRAN
  139. DLONG=SQRT(XDIS**2+YDIS**2+ZDIS**2)
  140. GOTO 16
  141. 13 IREF=IP1*(IDIM+1)
  142. XROT1(1)=XCOOR(IREF-IDIM)
  143. XROT1(2)=XCOOR(IREF-IDIM+1)
  144. XROT1(3)=XCOOR(IREF-IDIM+2)
  145. IF (IDIM.EQ.2) XROT1(3)=0
  146. DEN2=XCOOR(IREF)
  147. IF (IMPOF.EQ.1) DEN2=DEN2D
  148. DDIS=ABS(XG-XROT1(1))+ABS(YG-XROT1(2))+ABS(ZG-XROT1(3))
  149. IF (IOPTG.EQ.3) GOTO 15
  150. XROT2(1)=XROT1(1)
  151. XROT2(2)=XROT1(2)
  152. XROT2(3)=DDIS
  153. GOTO 18
  154. 15 IREF=IP2*(IDIM+1)
  155. XROT2(1)=XCOOR(IREF-IDIM)
  156. XROT2(2)=XCOOR(IREF-IDIM+1)
  157. XROT2(3)=XCOOR(IREF-IDIM+2)
  158. DEN2=(DEN2+XCOOR(IREF))/2.D0
  159. IF (IMPOF.EQ.1) DEN2=DEN2D
  160. 18 CONTINUE
  161. DEN2A=DEN2
  162. DEN2B=DEN2
  163. XPT1=XROT1(1)
  164. YPT1=XROT1(2)
  165. ZPT1=XROT1(3)
  166. XVEC=XROT2(1)-XROT1(1)
  167. YVEC=XROT2(2)-XROT1(2)
  168. ZVEC=XROT2(3)-XROT1(3)
  169. RAY=SQRT(XVEC**2+YVEC**2+ZVEC**2)
  170. XVEC=XVEC/RAY
  171. YVEC=YVEC/RAY
  172. ZVEC=ZVEC/RAY
  173.  
  174. C Ajout DI VALENTIN : on rajoute la normale dans le
  175. C tableau de points
  176.  
  177. NORMAL = XCOOR(/1)/(IDIM+1) + 1
  178. NBPTS = NORMAL
  179. SEGADJ MCOORD
  180.  
  181. XCOOR((NORMAL-1)*(IDIM+1)+1) = XVEC
  182. XCOOR((NORMAL-1)*(IDIM+1)+2) = YVEC
  183. XCOOR((NORMAL-1)*(IDIM+1)+3) = ZVEC
  184.  
  185. C Fin de l'ajout
  186.  
  187.  
  188. XV1=XG-XROT1(1)
  189. YV1=YG-XROT1(2)
  190. ZV1=ZG-XROT1(3)
  191. PV1=XV1*XVEC+YV1*YVEC+ZV1*ZVEC
  192. XV1=XV1-PV1*XVEC
  193. YV1=YV1-PV1*YVEC
  194. ZV1=ZV1-PV1*ZVEC
  195. RAY=SQRT(XV1**2+YV1**2+ZV1**2)
  196. XV1=XV1/RAY
  197. YV1=YV1/RAY
  198. ZV1=ZV1/RAY
  199. XV2=YVEC*ZV1-ZVEC*YV1
  200. YV2=ZVEC*XV1-XVEC*ZV1
  201. ZV2=XVEC*YV1-YVEC*XV1
  202. IREF=IPT1.NUM(1,1)*(IDIM+1)-IDIM
  203. X1=XCOOR(IREF)
  204. Y1=XCOOR(IREF+1)
  205. Z1=XCOOR(IREF+2)
  206. IF (IDIM.EQ.2) Z1=0.D0
  207. XV=X1-XPT1
  208. YV=Y1-YPT1
  209. ZV=Z1-ZPT1
  210. PV=XV*XVEC+YV*YVEC+ZV*ZVEC
  211. XV=XV-PV*XVEC
  212. YV=YV-PV*YVEC
  213. ZV=ZV-PV*ZVEC
  214. RL1=SQRT(XV**2+YV**2+ZV**2)
  215. * ON CREE LES DEUX CENTRES DES CERCLES POUR LES COTES 2 ET 4
  216. NBPTA=XCOOR(/1)/(IDIM+1)
  217. NBPTS=NBPTA+2
  218. SEGADJ MCOORD
  219. XCOOR(NBPTA*(IDIM+1)+1)=XPT1+PV*XVEC
  220. XCOOR(NBPTA*(IDIM+1)+2)=YPT1+PV*YVEC
  221. IF (IDIM.GE.3) XCOOR(NBPTA*(IDIM+1)+3)=ZPT1+PV*ZVEC
  222. XCOOR((NBPTA+1)*(IDIM+1))=DEN2
  223. NBPTA=NBPTA+1
  224. NUCEN1=NBPTA
  225. IREF=IPT1.NUM(IPT1.NUM(/1),IPT1.NUM(/2))*(IDIM+1)-IDIM
  226. X1=XCOOR(IREF)
  227. Y1=XCOOR(IREF+1)
  228. Z1=XCOOR(IREF+2)
  229. IF (IDIM.EQ.2) Z1=0.D0
  230. XV=X1-XPT1
  231. YV=Y1-YPT1
  232. ZV=Z1-ZPT1
  233. PV=XV*XVEC+YV*YVEC+ZV*ZVEC
  234. XV=XV-PV*XVEC
  235. YV=YV-PV*YVEC
  236. ZV=ZV-PV*ZVEC
  237. RL2=SQRT(XV**2+YV**2+ZV**2)
  238. XCOOR(NBPTA*(IDIM+1)+1)=XPT1+PV*XVEC
  239. XCOOR(NBPTA*(IDIM+1)+2)=YPT1+PV*YVEC
  240. IF (IDIM.GE.3) XCOOR(NBPTA*(IDIM+1)+3)=ZPT1+PV*ZVEC
  241. XCOOR((NBPTA+1)*(IDIM+1))=DEN2
  242. NBPTA=NBPTA+1
  243. NUCEN2=NBPTA
  244. C RAYON MOYEN
  245. C ANGLE EN RADIANS D'OU LONGUEUR MOYENNE
  246. DLONG=ABS(RAY*ANGLE)
  247. 16 CONTINUE
  248. DENI=DEN1
  249. DECA=DEN2-DEN1
  250. DEN1=DEN1/DLONG
  251. DEN2=DEN2/DLONG
  252. CALL DECOUP(INBR,DEN1,DEN2,APROG,NCOUCH,DENI,DECA,DLONG)
  253. IF (IOPTG.NE.1) DLONG=RAY*ANGLE
  254. IF (INBR.LE.0) INBR=-NCOUCH
  255. NX=NCOUCH-1
  256. IF (IIMPI.EQ.1) WRITE (IOIMP,1000) NCOUCH,APROG
  257. 1000 FORMAT(/' COUCHES ',I6,' RAISON ',G12.5)
  258. NBNN=4
  259. NBELEM=IPT1.NUM(/2)*NCOUCH
  260. NBSOUS=0
  261. NBREF=4
  262. SEGINI MELEME
  263. SEGINI TABPAR
  264. ITYPEL=8
  265. IDEB=XCOOR(/1)/(IDIM+1)+1
  266. INCR=IPT1.ITYPEL-1
  267. NBELEC=IPT1.NUM(/2)
  268. SEGINI ICPR
  269. C ON FAIT D'ABORD L' EXTREMITEE
  270. SEGINI ICPP
  271. DO 52 I=1,ICPP1(/1)
  272. ICPP1(I)=0
  273. 52 CONTINUE
  274. IF (IOPTG.NE.1) GOTO 51
  275. ICLE=1
  276. XCO(4)=0
  277. DO 200 I=1,IDIM+1
  278. XCO(I)=XCOOR(IREFT-1+I)
  279. 200 CONTINUE
  280. CALL ADDITE(XCO,IPT1,IPT3,ICPP,0)
  281. IF (IERR.NE.0) RETURN
  282. GOTO 50
  283. 51 ICLE=2
  284. CALL ADDITE(XROT1,IPT1,IPT3,ICPP,0)
  285. 50 CONTINUE
  286. SEGSUP ICPP
  287. SEGACT IPT3
  288. CALL INVERS(IPT3,IPT4)
  289. SEGDES IPT4
  290. LISREF(3)=IPT4
  291. C ON REMPLIT LE TABLEAU ICPR DES PTS EFFECTIFS
  292. IDEB=XCOOR(/1)/(IDIM+1)+1
  293. DO 70 I=1,2
  294. DO 701 J=1,NBELEC
  295. ICPR1(I,J)=0
  296. 701 CONTINUE
  297. 70 CONTINUE
  298. LCPR=0
  299. DO 71 J=1,NBELEC
  300. DO 711 I=1,2
  301. I1=IPT1.NUM((I-1)*INCR+1,J)
  302. LCPR=LCPR+1
  303. DO 72 JJ=1,J
  304. DO 721 II=1,2
  305. IF (IPT1.NUM((II-1)*INCR+1,JJ).NE.I1) GOTO 721
  306. IF (II.NE.I) GOTO 73
  307. IF (JJ.EQ.J) GOTO 711
  308. 73 ICPR1(I,J)=II+(JJ-1)*2
  309. LCPR=LCPR-1
  310. IF (J.EQ.NBELEC.AND.I.EQ.2) GOTO 75
  311. GOTO 711
  312. 75 IF (IBOUCL.EQ.1) GOTO 711
  313. ICPR1(I,J)=0
  314. ICPR1(II,JJ)=I+(J-1)*2
  315. GOTO 711
  316. 721 CONTINUE
  317. 72 CONTINUE
  318. 711 CONTINUE
  319. 71 CONTINUE
  320. C ON NE S'OCCUPE QUE DE FABRIQUER DES RECTANGLES A 4 NOEUDS POUR
  321. C LE MOMENT D'ABORD LES POINTS DU BAS QUI NE SONT PAS A FABRIQUER
  322. DIN=DEN1
  323. DO 40 I=1,IPT1.NUM(/2)
  324. NUM(1,I)=IPT1.NUM(1,I)
  325. NUM(2,I)=IPT1.NUM(1+INCR,I)
  326. 40 CONTINUE
  327. ILASI=IDEB-1
  328. ILASJ=ILASI+(INCR*NX)+INCR-1
  329. IF (IBOUCL.EQ.1) ILASJ=ILASI
  330. ILAS=ILASJ+INCR*NX+INCR
  331. DO 42 ICOUCH=1,NCOUCH
  332. DIN=DIN*APROG
  333. TABPA1(ICOUCH)=DIN
  334. IF (NCOUCH.EQ.ICOUCH) GOTO 41
  335. ILASI=ILASI+INCR
  336. ILASJ=ILASJ+INCR
  337. INI=(ICOUCH-1)*IPT1.NUM(/2)
  338. NUM(1,1+INI+NBELEC)=ILASI
  339. NUM(4,1+INI)=ILASI
  340. NUM(2,INI+2*NBELEC)=ILASJ
  341. NUM(3,INI+NBELEC)=ILASJ
  342. DO 421 J=1,IPT1.NUM(/2)
  343. DO 422 I=1,2
  344. ILL=ILAS
  345. IF (I.EQ.1.AND.J.EQ.1) GOTO 422
  346. IF (I.EQ.2.AND.J.EQ.NBELEC) GOTO 422
  347. IF (ICPR1(I,J).NE.0) ILL=NUM(MOD(ICPR1(I,J)-1,2)+1,
  348. # (ICPR1(I,J)-1)/2+1+INI+NBELEC)
  349. NUM(I,J+INI+NBELEC)=ILL
  350. NUM(5-I,J+INI)=ILL
  351. IF (ICPR1(I,J).NE.0) GOTO 422
  352. ILAS=ILL+1
  353. 422 CONTINUE
  354. 421 CONTINUE
  355. 42 CONTINUE
  356. TABPA1(NCOUCH)=DIN*APROG
  357. 41 CONTINUE
  358. INI=(NCOUCH-1)*IPT1.NUM(/2)
  359. DO 43 I=1,NBELEC
  360. NUM(4,INI+I)=IPT3.NUM(1,I)
  361. NUM(3,INI+I)=IPT3.NUM(1+INCR,I)
  362. 43 CONTINUE
  363. DO 44 I=1,NCOUCH
  364. DO 441 J=1,IPT1.NUM(/2)
  365. II=(I-1)*IPT1.NUM(/2)+J
  366. ICOLOR(II)=IPT1.ICOLOR(J)
  367. 441 CONTINUE
  368. 44 CONTINUE
  369. LISREF(1)=IPT1
  370. C CREATION DES BORDS LATERAUX PAR LIGNE
  371. C PRESENTEMENT CAS DE LA TRANSLATION OU DE LA ROTATION
  372. C IMPOSONS ILCOUR POUR CETTE MANIP (LES BORDS LATERAUX DOIVENT ETRE
  373. C CONSISTANT AVEC LES AUTRES )
  374. ILSAUV=ILCOUR
  375. IDSAUV=IDCOUL
  376. ILCOUR=IPT1.ITYPEL
  377. IDCOUL=IPT1.ICOLOR(1)
  378. ITYPL=1
  379. LP2=IPT3.NUM(1,1)
  380.  
  381. IF (IOPTG.EQ.1) THEN
  382. CALL ECROBJ('POINT ',LP2)
  383. LP1=IPT1.NUM(1,1)
  384. CALL ECROBJ('POINT ',LP1)
  385. INBB=INBR
  386. CALL LIGNE(ITYPL,0,DEN1A,DEN2A,INBB)
  387.  
  388. ELSE
  389. ITYPL=3
  390. DEN1A=DEN1A*RL1/RAY
  391. DEN2A=DEN2A*RL1/RAY
  392. DEN1B=DEN1B*RL2/RAY
  393. DEN2B=DEN2B*RL2/RAY
  394. LP1=IPT1.NUM(1,1)
  395. INBB=INBR
  396. CALL ARC(LP1,NUCEN1,NORMAL,ANGLE,INBB,DEN1A,DEN2A,LP2)
  397. ENDIF
  398.  
  399. C RESTAURER ILCOUR,IDSAUV
  400. ILCOUR=ILSAUV
  401. IDCOUL=IDSAUV
  402. IF (IERR.NE.0) RETURN
  403. CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  404. SEGACT IPT2
  405. CALL INVERS(IPT2,IPT4)
  406. SEGDES IPT2
  407. LISREF(4)=IPT4
  408. SEGDES IPT4
  409. IF (IBOUCL.EQ.0) GOTO 46
  410. LISREF(2)=IPT2
  411. GOTO 45
  412. 46 CONTINUE
  413. LP1=IPT3.NUM(IPT3.NUM(/1),IPT3.NUM(/2))
  414.  
  415. IF (IOPTG.EQ.1) THEN
  416. CALL ECROBJ('POINT ',LP1)
  417. LP1=IPT1.NUM(IPT1.NUM(/1),IPT1.NUM(/2))
  418. CALL ECROBJ('POINT ',LP1)
  419. ILCOUR=IPT1.ITYPEL
  420. IDCOUL=IPT1.ICOLOR(IPT1.NUM(/2))
  421. CALL LIGNE(ITYPL,0,DEN1B,DEN2B,INBR)
  422.  
  423. ELSE
  424. LPLAUR = LP1
  425. LP1=IPT1.NUM(IPT1.NUM(/1),IPT1.NUM(/2))
  426. ILCOUR=IPT1.ITYPEL
  427. IDCOUL=IPT1.ICOLOR(IPT1.NUM(/2))
  428. CALL ARC(LP1,NUCEN2,NORMAL,ANGLE,INBB,DEN1B,DEN2B,LPLAUR)
  429.  
  430. ENDIF
  431.  
  432. CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  433. ILCOUR=ILSAUV
  434. IF (IERR.NE.0) RETURN
  435. SEGACT IPT2
  436. LISREF(2)=IPT2
  437. 45 CONTINUE
  438. SEGSUP IPT3
  439. C ON RESTAURE ILCOUR
  440. ILCOUR=ILSAUV
  441. IDCOUL=IDSAUV
  442. C CREATION DES POINTS (PAS LES POINTS MILIEUX QUI SERONT FABRIQUES
  443. C EVENTUELLEMENT LORS DE LA CONVERSION DES ELEMENTS)
  444. DPAR=0
  445. SEGACT MCOORD
  446. IADR=XCOOR(/1)/(IDIM+1)
  447. NBPTS=IADR+(NCOUCH-1)*IPT1.NUM(/2)*2
  448. SEGADJ MCOORD
  449. IF (NCOUCH.EQ.1) GOTO 60
  450. DO 61 I=2,NCOUCH
  451. DIN=TABPA1(I-1)
  452. DPAR=DPAR+DIN
  453. IF (IOPTG.EQ.1) GOTO 83
  454. ANG=DPAR*DLONG/RAY
  455. SI=SIN(ANG)
  456. CO=COS(ANG)
  457. 83 CONTINUE
  458. IF (IPT1.NUM(/2).EQ.1) GOTO 60
  459. DO 62 J=1,IPT1.NUM(/2)
  460. DO 621 K=1,2
  461. IF (K.EQ.1.AND.J.EQ.1) GOTO 621
  462. IF (K.EQ.2.AND.J.EQ.NBELEC) GOTO 621
  463. IF (ICPR1(K,J).NE.0) GOTO 621
  464. IREF=(IDIM+1)*IPT1.NUM((K-1)*INCR+1,J)-IDIM
  465. IF (IOPTG.NE.1) GOTO 84
  466. XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF)+DPAR*XDIS
  467. XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+1)+DPAR*YDIS
  468. IF (IDIM.NE.2) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+2)+DPAR
  469. $ *ZDIS
  470. GOTO 85
  471. 84 X1=XCOOR(IREF)-XPT1
  472. Y1=XCOOR(IREF+1)-YPT1
  473. Z1=XCOOR(IREF+2)-ZPT1
  474. IF (IDIM.EQ.2) Z1=0
  475. XV=X1*XV1+Y1*YV1+Z1*ZV1
  476. YV=X1*XV2+Y1*YV2+Z1*ZV2
  477. ZV=X1*XVEC+Y1*YVEC+Z1*ZVEC
  478. XD=XV*CO-YV*SI
  479. YD=XV*SI+YV*CO
  480. ZD=ZV
  481. XCOOR(IADR*(IDIM+1)+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1
  482. XCOOR(IADR*(IDIM+1)+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1
  483. IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XD*ZV1+YD*ZV2+ZD
  484. $ *ZVEC+ZPT1
  485. 85 XCOOR((IADR+1)*(IDIM+1))=DENI+DECA*DPAR
  486. IADR=IADR+1
  487. 621 CONTINUE
  488. 62 CONTINUE
  489. 61 CONTINUE
  490. 60 CONTINUE
  491. NBPTS=IADR
  492. SEGADJ MCOORD
  493. IF (KSURF(ILCOUR).EQ.8) GOTO 101
  494. IF (KSURF(ILCOUR).NE.4) GOTO 102
  495. NBNN=3
  496. NBELEM=2*NUM(/2)
  497. NBREF=4
  498. NBSOUS=0
  499. SEGINI IPT1
  500. IPT1.ITYPEL=4
  501. IPT1.LISREF(1)=LISREF(1)
  502. IPT1.LISREF(2)=LISREF(2)
  503. IPT1.LISREF(3)=LISREF(3)
  504. IPT1.LISREF(4)=LISREF(4)
  505. DO 103 I=1,NUM(/2),2
  506. J=2*I-1
  507. IPT1.NUM(1,J)=NUM(1,I)
  508. IPT1.NUM(2,J)=NUM(2,I)
  509. IPT1.NUM(3,J)=NUM(3,I)
  510. IPT1.ICOLOR(J)=ICOLOR(I)
  511. J=J+1
  512. IPT1.NUM(1,J)=NUM(1,I)
  513. IPT1.NUM(2,J)=NUM(3,I)
  514. IPT1.NUM(3,J)=NUM(4,I)
  515. IPT1.ICOLOR(J)=ICOLOR(I)
  516. J=J+1
  517. IF (J.GT.IPT1.NUM(/2)) GOTO 103
  518. IPT1.NUM(1,J)=NUM(1,I+1)
  519. IPT1.NUM(2,J)=NUM(2,I+1)
  520. IPT1.NUM(3,J)=NUM(4,I+1)
  521. IPT1.ICOLOR(J)=ICOLOR(I+1)
  522. J=J+1
  523. IPT1.NUM(1,J)=NUM(2,I+1)
  524. IPT1.NUM(2,J)=NUM(3,I+1)
  525. IPT1.NUM(3,J)=NUM(4,I+1)
  526. IPT1.ICOLOR(J)=ICOLOR(I+1)
  527. 103 CONTINUE
  528. SEGSUP MELEME
  529. MELEME=IPT1
  530. GOTO 101
  531. 102 CONTINUE
  532. IF (KSURF(ILCOUR).NE.10.AND.KSURF(ILCOUR).NE.6) GOTO 104
  533. C ON FAIT DES QUA8 OU DES TRI6
  534. NBNN=8
  535. NBELEM=NUM(/2)
  536. NBREF=4
  537. NBSOUS=0
  538. SEGINI IPT5
  539. IPT5.ITYPEL=10
  540. IPT1=LISREF(1)
  541. IPT2=LISREF(2)
  542. IPT3=LISREF(3)
  543. IPT4=LISREF(4)
  544. IPT5.LISREF(1)=IPT1
  545. IPT5.LISREF(2)=IPT2
  546. IPT5.LISREF(3)=IPT3
  547. IPT5.LISREF(4)=IPT4
  548. SEGACT IPT1,IPT2,IPT3,IPT4
  549. DO 105 J=1,NUM(/1)
  550. JJ=2*J-1
  551. DO 1051 I=1,NBELEM
  552. IPT5.NUM(JJ,I)=NUM(J,I)
  553. 1051 CONTINUE
  554. 105 CONTINUE
  555. DO 135 I=1,NBELEM
  556. IPT5.ICOLOR(I)=ICOLOR(I)
  557. 135 CONTINUE
  558. NLIG=IPT1.NUM(/2)
  559. DO 106 I=1,NLIG
  560. IPT5.NUM(2,I)=IPT1.NUM(2,I)
  561. IPT5.NUM(6,NBELEM+1-I)=IPT3.NUM(2,I)
  562. 106 CONTINUE
  563. DPAR=0
  564. NBPTS=IADR+NCOUCH*NLIG*3
  565. SEGADJ MCOORD
  566. DO 107 I=1,NCOUCH
  567. IPT5.NUM(8,NLIG*(I-1)+1)=IPT4.NUM(2,NCOUCH+1-I)
  568. IPT5.NUM(4,NLIG*I)=IPT2.NUM(2,I)
  569. C ON FAIT D'ABORD LES NOEUDS 2 DU HAUT (6 DU BAS)
  570. C CREATION DES NOEUDS
  571. DIN=TABPA1(I)
  572. DPAR=DPAR+DIN
  573. IF (IOPTG.EQ.1) GOTO 110
  574. ANG=DPAR*DLONG/RAY
  575. SI=SIN(ANG)
  576. CO=COS(ANG)
  577. 110 CONTINUE
  578. IF (I.EQ.NCOUCH) GOTO 108
  579. DO 109 J=1,NLIG
  580. IREF=(IDIM+1)*(IPT1.NUM(2,J)-1)
  581. IF (IOPTG.NE.1) GOTO 111
  582. XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+DPAR*XDIS
  583. XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+DPAR*YDIS
  584. IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+DPAR
  585. $ *ZDIS
  586. GOTO 112
  587. 111 X1=XCOOR(IREF+1)-XPT1
  588. Y1=XCOOR(IREF+2)-YPT1
  589. Z1=XCOOR(IREF+3)-ZPT1
  590. IF (IDIM.EQ.2) Z1=0.D0
  591. XV=X1*XV1+Y1*YV1+Z1*ZV1
  592. YV=X1*XV2+Y1*YV2+Z1*ZV2
  593. ZV=X1*XVEC+Y1*YVEC+Z1*ZVEC
  594. XD=XV*CO-YV*SI
  595. YD=XV*SI+YV*CO
  596. ZD=ZV
  597. XCOOR(IADR*(IDIM+1)+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1
  598. XCOOR(IADR*(IDIM+1)+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1
  599. IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XD*ZV1+YD*ZV2+ZD*ZVEC
  600. $ +ZPT1
  601. 112 XCOOR((IADR+1)*(IDIM+1))=DENI+DECA*DPAR
  602. IADR=IADR+1
  603. C ON MET LE NOEUD DANS LES ELEMENTS
  604. IPT5.NUM(6,(I-1)*NLIG+J)=IADR
  605. IPT5.NUM(2,I*NLIG+J)=IADR
  606. 109 CONTINUE
  607. 108 CONTINUE
  608. IF (NLIG.EQ.1) GOTO 113
  609. C ON MET LES NOEUDS 4 DE GAUCHE ET 8 DE DROITE
  610. C CREATION DES NOEUDS
  611. EPAR=DPAR-TABPA1(I)*0.5D0
  612. IF (IOPTG.EQ.1) GOTO 114
  613. ANG=EPAR*DLONG/RAY
  614. SI=SIN(ANG)
  615. CO=COS(ANG)
  616. 114 CONTINUE
  617. DO 115 J=1,NLIG
  618. DO 1151 K=1,2
  619. IF (K.EQ.1.AND.J.EQ.1) GOTO 1151
  620. IF (K.EQ.2.AND.J.EQ.NLIG) GOTO 1151
  621. IF (ICPR1(K,J).NE.0) GOTO 116
  622. IREF=(IPT1.NUM(2*K-1,J)-1)*(IDIM+1)
  623. IF (IOPTG.NE.1) GOTO 117
  624. XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+EPAR*XDIS
  625. XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+EPAR*YDIS
  626. IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+EPAR
  627. $ *ZDIS
  628. GOTO 118
  629. 117 X1=XCOOR(IREF+1)-XPT1
  630. Y1=XCOOR(IREF+2)-YPT1
  631. Z1=XCOOR(IREF+3)-ZPT1
  632. IF (IDIM.EQ.2) Z1=0
  633. XV=X1*XV1+Y1*YV1+Z1*ZV1
  634. YV=X1*XV2+Y1*YV2+Z1*ZV2
  635. ZV=X1*XVEC+Y1*YVEC+Z1*ZVEC
  636. XD=XV*CO-YV*SI
  637. YD=XV*SI+YV*CO
  638. ZD=ZV
  639. XCOOR(IADR*(IDIM+1)+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1
  640. XCOOR(IADR*(IDIM+1)+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1
  641. IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XD*ZV1+YD*ZV2+ZD
  642. $ *ZVEC+ZPT1
  643. 118 XCOOR((IADR+1)*(IDIM+1))=DEN1+DECA*EPAR
  644. IADR=IADR+1
  645. 116 CONTINUE
  646. C NOEUDS DES ELEM
  647. IF (ICPR1(K,J).NE.0) GOTO 119
  648. IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IADR
  649. GOTO 1151
  650. 119 CONTINUE
  651. IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IPT5.NUM(4*(2-MOD(ICPR1(K
  652. $ ,J)-1,2)),(ICPR1(K,J)+1)/2+(I-1)*NLIG)
  653. 1151 CONTINUE
  654. 115 CONTINUE
  655. 113 CONTINUE
  656. 107 CONTINUE
  657. NBPTS=IADR
  658. SEGADJ MCOORD
  659. SEGSUP MELEME
  660. MELEME=IPT5
  661. SEGDES IPT1,IPT2,IPT3,IPT4
  662. IF (KSURF(ILCOUR).NE.6) GOTO 101
  663. C ON FAIT DES TRI6
  664. NBNN=6
  665. NBELEM=2*NUM(/2)
  666. NBREF=4
  667. NBSOUS=0
  668. SEGINI IPT1
  669. IPT1.ITYPEL=6
  670. IPT1.LISREF(1)=LISREF(1)
  671. IPT1.LISREF(2)=LISREF(2)
  672. IPT1.LISREF(3)=LISREF(3)
  673. IPT1.LISREF(4)=LISREF(4)
  674. DPAR=0
  675. IALT=1
  676. NBPTS=IADR+NCOUCH*NLIG
  677. SEGADJ MCOORD
  678. DO 120 I=1,NCOUCH
  679. DIN=TABPA1(I)
  680. DPAR=DPAR+DIN
  681. EPAR=DPAR-DIN*0.5D0
  682. IF (IOPTG.EQ.1) GOTO 121
  683. ANG=EPAR*DLONG/RAY
  684. SI=SIN(ANG)
  685. CO=COS(ANG)
  686. 121 CONTINUE
  687. DO 1201 J=1,NLIG
  688. INU=(I-1)*NLIG+J
  689. IALT=3-IALT
  690. C CREATION DU POINT SUPPLEMENTAIRE
  691. IREF=(NUM(2,J)-1)*(IDIM+1)
  692. IF (IOPTG.NE.1) GOTO 122
  693. XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+EPAR*XDIS
  694. XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+EPAR*YDIS
  695. IF (IDIM.EQ.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+EPAR
  696. $ *ZDIS
  697. GOTO 123
  698. 122 X1=XCOOR(IREF+1)-XPT1
  699. Y1=XCOOR(IREF+2)-YPT1
  700. Z1=XCOOR(IREF+3)-ZPT1
  701. IF (IDIM.EQ.2) Z1=0.D0
  702. XV=X1*XV1+Y1*YV1+Z1*ZV1
  703. YV=X1*XV2+Y1*YV2+Z1*ZV2
  704. ZV=X1*XVEC+Y1*YVEC+Z1*ZVEC
  705. XD=XV*CO-YV*SI
  706. YD=XV*SI+YV*CO
  707. ZD=ZV
  708. XCOOR(IADR*(IDIM+1)+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1
  709. XCOOR(IADR*(IDIM+1)+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1
  710. IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XD*ZV1+YD*ZV2+ZD*ZVEC
  711. $ +ZPT1
  712. 123 XCOOR((IADR+1)*(IDIM+1))=DENI+DECA*EPAR
  713. IADR=IADR+1
  714. ITR1=2*INU-1
  715. ITR2=2*INU
  716. GOTO (124,125),IALT
  717. C CREATION DES TRIANGLES
  718. 124 IPT1.NUM(1,ITR1)=NUM(1,INU)
  719. IPT1.NUM(2,ITR1)=NUM(2,INU)
  720. IPT1.NUM(3,ITR1)=NUM(3,INU)
  721. IPT1.NUM(5,ITR1)=NUM(7,INU)
  722. IPT1.NUM(6,ITR1)=NUM(8,INU)
  723. IPT1.NUM(4,ITR1)=IADR
  724. IPT1.NUM(1,ITR2)=NUM(3,INU)
  725. IPT1.NUM(2,ITR2)=NUM(4,INU)
  726. IPT1.NUM(3,ITR2)=NUM(5,INU)
  727. IPT1.NUM(4,ITR2)=NUM(6,INU)
  728. IPT1.NUM(5,ITR2)=NUM(7,INU)
  729. IPT1.NUM(6,ITR2)=IADR
  730. IPT1.ICOLOR(ITR1)=ICOLOR(INU)
  731. IPT1.ICOLOR(ITR2)=ICOLOR(INU)
  732. GOTO 126
  733. 125 IPT1.NUM(1,ITR1)=NUM(1,INU)
  734. IPT1.NUM(2,ITR1)=NUM(2,INU)
  735. IPT1.NUM(3,ITR1)=NUM(3,INU)
  736. IPT1.NUM(4,ITR1)=NUM(4,INU)
  737. IPT1.NUM(5,ITR1)=NUM(5,INU)
  738. IPT1.NUM(6,ITR1)=IADR
  739. IPT1.NUM(1,ITR2)=NUM(5,INU)
  740. IPT1.NUM(2,ITR2)=NUM(6,INU)
  741. IPT1.NUM(3,ITR2)=NUM(7,INU)
  742. IPT1.NUM(4,ITR2)=NUM(8,INU)
  743. IPT1.NUM(5,ITR2)=NUM(1,INU)
  744. IPT1.NUM(6,ITR2)=IADR
  745. IPT1.ICOLOR(ITR1)=ICOLOR(INU)
  746. IPT1.ICOLOR(ITR2)=ICOLOR(INU)
  747. GOTO 126
  748. 126 CONTINUE
  749. 1201 CONTINUE
  750. 120 CONTINUE
  751. SEGSUP MELEME
  752. MELEME=IPT1
  753. GOTO 101
  754. 104 CONTINUE
  755. 101 CONTINUE
  756. SEGSUP TABPAR,ICPR
  757. C S'IL Y A LIEU EXAMINER LA DEGENERESCENCE (ROTATION)
  758. SEGDES IPT1
  759. ** degsur n'a pas grand sens en 3D et ne marche pas
  760. ***** IF (IOPTG.NE.1) CALL DEGSUR(MELEME,IP1,IP2)
  761. IF (IFUSE.EQ.0) GOTO 63
  762. IPT5=IFUSE
  763. SEGACT IPT5,MELEME
  764. ltelq=.false.
  765. CALL FUSE(IPT5,MELEME,IRET,ltelq)
  766. SEGACT IPT5,MELEME
  767. IF (ITYPEL.EQ.IPT5.ITYPEL) SEGSUP MELEME
  768. SEGDES IPT5
  769. MELEME=IRET
  770. 63 CONTINUE
  771. CALL ECROBJ('MAILLAGE',MELEME)
  772. SEGDES MELEME
  773. RETURN
  774. END
  775.  
  776.  
  777.  
  778.  
  779.  
  780.  
  781.  
  782.  
  783.  
  784.  
  785.  
  786.  
  787.  
  788.  
  789.  
  790.  
  791.  
  792.  
  793.  

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