Télécharger deplac.eso

Retour à la liste

Numérotation des lignes :

  1. C DEPLAC SOURCE BP208322 13/06/27 21:15:05 7783
  2.  
  3. C CE SOUS-PROGRAMME A POUR PROPOS DE DEPLACER L'ENSEMBLE DES POINTS
  4. C CONTENUS DANS UN OBJET
  5. C 09/2003 : Modifications dans le cas IDIM=1.
  6.  
  7. SUBROUTINE DEPLAC
  8.  
  9. IMPLICIT INTEGER(I-N)
  10. IMPLICIT REAL*8 (A-H,O-Z)
  11.  
  12. -INC CCREEL
  13. -INC CCOPTIO
  14. -INC SMCOORD
  15. -INC SMELEME
  16. -INC SMCHPOI
  17.  
  18. CHARACTER*4 MCLE(11)
  19. CHARACTER*4 MCL2(3)
  20. CHARACTER*4 MCL3(7)
  21. CHARACTER*4 MCL4(2)
  22. CHARACTER*4 MCL5(2)
  23. DIMENSION XU(3),XV(3),XW(3),XP(3)
  24. REAL*8 XXX,RAP
  25. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  26.  
  27. DATA NCLE / 11 /
  28. DATA MCLE / 'PLUS','MOIN','TOUR','HOMO','AFFI','SYME','PROJ',
  29. . 'COOR','MILI','BARS','DEDU' /
  30. DATA MCL2 / 'POIN','DROI','PLAN' /
  31. DATA MCL3 / 'PLAN','SPHE','CYLI','CONI','TORI','DROI','CERC' /
  32. DATA MCL4 / 'CYLI','CONI' /
  33. DATA MCL5 / 'CYLI','CART' /
  34.  
  35. C Lecture de l'option de la directive DEPLACER
  36. CALL LIRMOT(MCLE,NCLE,ICLE,1)
  37. IF (IERR.NE.0) RETURN
  38. C Cas IDIM=1, seules les options suivantes sont disponibles :
  39. C 'PLUS','MOIN','HOMO','SYME','MILI','DEDU'
  40. IF (IDIM.EQ.1) THEN
  41. IF ((ICLE.NE.1).AND.(ICLE.NE.2).AND.(ICLE.NE.4).AND.
  42. . (ICLE.NE.6).AND.(ICLE.NE.9).AND.(ICLE.NE.11)) THEN
  43. MOTERR(1:4)=MCLE(ICLE)
  44. INTERR(1)=IDIM
  45. CALL ERREUR(971)
  46. RETURN
  47. ENDIF
  48. ENDIF
  49.  
  50. idimp1=IDIM+1
  51. ITYPLU=2
  52.  
  53. C Option BARS : Elements de BARSOUM
  54. C ---------------
  55. C Deplacement des noeuds milieu autour de la pointe de fissure
  56. IF (ICLE.EQ.10) THEN
  57. CALL BARSOU
  58. RETURN
  59. ENDIF
  60.  
  61. C Option DEDU :
  62. C ---------------
  63. C Transformation affine definie par au plus (IDIM+1) points
  64. IF (ICLE.EQ.11) THEN
  65. CALL DEDU(1)
  66. RETURN
  67. ENDIF
  68.  
  69. CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU)
  70. ITYPSA=MELEME
  71. IF (IRETOU.NE.1) THEN
  72. ITYPLU=1
  73. CALL LIROBJ('POINT',IP,1,IRETOU)
  74. IF (IERR.NE.0) RETURN
  75. ITYPSA=IP
  76. CALL CRELEM(IP)
  77. MELEME=IP
  78. ENDIF
  79. SEGACT MCOORD*MOD
  80.  
  81. C Option MILI :
  82. C ---------------
  83. IF (ICLE.EQ.9) GOTO 1900
  84.  
  85. C Remplissage du tableau ICPR des points a deplacer
  86. SEGINI ICPR
  87. C Est-ce bien utile apres un SEGINI ?
  88. c DO i=1,ICPR(/1)
  89. c ICPR(i)=0
  90. c ENDDO
  91. c petite numerotation locale dans ICPR
  92. NICPR=0
  93. SEGACT MELEME
  94. IPT1=MELEME
  95. DO io=1,MAX(1,LISOUS(/1))
  96. IF (LISOUS(/1).NE.0) THEN
  97. IPT1=LISOUS(io)
  98. SEGACT IPT1
  99. ENDIF
  100. DO i=1,IPT1.NUM(/1)
  101. DO j=1,IPT1.NUM(/2)
  102. I1=IPT1.NUM(i,j)
  103. if(ICPR(I1).eq.0) then
  104. NICPR=NICPR+1
  105. ICPR(I1)=NICPR
  106. endif
  107. ENDDO
  108. ENDDO
  109. IF (LISOUS(/1).NE.0) SEGDES IPT1
  110. ENDDO
  111. SEGDES MELEME
  112.  
  113. C Lecture des donnees supplementaires (selon ICLE) et action
  114. C ICLE=1 : PLUS 1 POINT (VECTEUR)
  115. C ICLE=2 : MOIN 1 POINT (VECTEUR)
  116. C ICLE=3 : TOUR 1 NOMBRE (ANGLE) 1 OU 2 POINTS (AXE 2 OU 3 D)
  117. C ICLE=4 : HOMO 1 NOMBRE (RAPPORT) 1 POINT (CENTRE)
  118. C ICLE=5 : AFFI 1 NOMBRE (RAPPORT) 1 POINT (INVARIANT)
  119. C 1 POINT(VECTEUR)
  120. C ICLE=6 : SYME 1 MOT (POIN DROI OU PLAN) 1,2 OU 3 POINTS
  121. C ICLE=7 : PROJ 1 MOT (PLAN SPHE CYLI CONI TORI DROI CERC)
  122. C DES DONNEES EN RAPPORT
  123. C ICLE=8 : COOR 1 MOT (CART CYLI)
  124. GOTO (100,200,300,400,500,600,700,1800),ICLE
  125.  
  126. C Option PLUS :
  127. C ---------------
  128. 100 XSENS=1.D0
  129. GOTO 201
  130. C Option MOIN :
  131. C ---------------
  132. 200 XSENS=-1.D0
  133. 201 CALL LIROBJ('POINT',IP,0,IRETOU)
  134. IF (IERR.NE.0) GOTO 10000
  135. IF (IRETOU.EQ.0) THEN
  136. CALL LIROBJ('CHPOINT ',IPCH,1,IRETOU)
  137. IF (IERR.NE.0) GOTO 10000
  138. CALL DEPCHP(ICPR,IPCH,XSENS)
  139. GOTO 1000
  140. ENDIF
  141. IREF=idimp1*(IP-1)
  142. DO j=1,IDIM
  143. XV(j)=XCOOR(IREF+j)*XSENS
  144. ENDDO
  145. DO i=1,ICPR(/1)
  146. IF (ICPR(i).NE.0) THEN
  147. IREF=idimp1*(i-1)
  148. DO j=1,IDIM
  149. XCOOR(IREF+j)=XCOOR(IREF+j)+XV(j)
  150. ENDDO
  151. ENDIF
  152. ENDDO
  153. GOTO 1000
  154.  
  155. C Option TOUR :
  156. C ---------------
  157. c lecture de l'angle
  158. 300 CALL LIRREE(ANG,0,IRETOU)
  159. IF (IERR.NE.0) GOTO 10000
  160. IPCH1=0
  161. C -- bp (nouvelle option 06/2013) : TOUR CHPOint --
  162. IF (IRETOU.EQ.0) THEN
  163. CALL LIROBJ('CHPOINT ',IPCH1,1,IRET1)
  164. IF (IERR.NE.0) GOTO 10000
  165. c creation d'un MPOVAL coherent avec ICPR
  166. c avec comme composantes COS et SIN
  167. N=NICPR
  168. NC=2
  169. SEGINI,MPOVAL
  170. DO I=1,N
  171. VPOCHA(I,1)=1.D0
  172. c VPOCHA(I,2)=0.D0 =sin(0)
  173. ENDDO
  174. c remplissage du MPOVAL depuis le MCHPO1
  175. MCHPO1=IPCH1
  176. SEGACT,MCHPO1
  177. DO IP=1,MCHPO1.IPCHP(/1)
  178. MSOUP1=MCHPO1.IPCHP(IP)
  179. SEGACT,MSOUP1
  180. IPT1=MSOUP1.IGEOC
  181. SEGACT,IPT1
  182. MPOVA1=MSOUP1.IPOVAL
  183. SEGACT,MPOVA1
  184. N1 = MPOVA1.VPOCHA(/1)
  185. NC1 = MPOVA1.VPOCHA(/2)
  186. IF (NC1.ne.1) THEN
  187. call ERREUR(180)
  188. GOTO 10000
  189. ENDIF
  190. DO 303 J1=1,N1
  191. I = ICPR(IPT1.NUM(1,J1))
  192. IF(I.eq.0) GOTO 303
  193. ANG=MPOVA1.VPOCHA(J1,1)/180.D0*XPI
  194. VPOCHA(I,1)=COS(ANG)
  195. VPOCHA(I,2)=SIN(ANG)
  196. 303 CONTINUE
  197. SEGDES,MPOVA1,IPT1
  198. SEGDES,MSOUP1
  199. ENDDO
  200. SEGDES,MCHPO1
  201. ELSE
  202. ANG=ANG/180.D0*XPI
  203. CO=COS(ANG)
  204. SI=SIN(ANG)
  205. ENDIF
  206. c lecture des points centre et axe + fabrication repere de rotation
  207. CALL LIROBJ('POINT',IP1,1,IRETOU)
  208. IF (IDIM.EQ.3) CALL LIROBJ('POINT',IP2,1,IRETOU)
  209. IF (IERR.NE.0) GOTO 10000
  210. IREF=idimp1*(IP1-1)
  211. XP(1)=XCOOR(IREF+1)
  212. XP(2)=XCOOR(IREF+2)
  213. IF (IDIM.LT.3) THEN
  214. XP(3)=0.D0
  215. XW(1)=0.D0
  216. XW(2)=0.D0
  217. XW(3)=1.D0
  218. ELSE
  219. XP(3)=XCOOR(IREF+3)
  220. IREF=idimp1*(IP2-1)
  221. XW(1)=XCOOR(IREF+1)-XP(1)
  222. XW(2)=XCOOR(IREF+2)-XP(2)
  223. XW(3)=XCOOR(IREF+3)-XP(3)
  224. XN=SQRT(XW(1)**2+XW(2)**2+XW(3)**2)
  225. IF (XN.EQ.0.D0) CALL ERREUR(21)
  226. IF (IERR.NE.0) GOTO 10000
  227. XW(1)=XW(1)/XN
  228. XW(2)=XW(2)/XN
  229. XW(3)=XW(3)/XN
  230. ENDIF
  231. XU(1)=-XW(2)
  232. XU(2)=XW(1)
  233. XN=SQRT(XU(1)**2+XU(2)**2)
  234. IF (XN.GE.0.1D0) THEN
  235. XU(3)=0.D0
  236. XU(1)=XU(1)/XN
  237. XU(2)=XU(2)/XN
  238. ELSE
  239. XU(1)=0.D0
  240. XU(2)=-XW(3)
  241. XU(3)=XW(2)
  242. XN=SQRT(XU(2)**2+XU(3)**2)
  243. XU(2)=XU(2)/XN
  244. XU(3)=XU(3)/XN
  245. ENDIF
  246. XV(1)=XW(2)*XU(3)-XW(3)*XU(2)
  247. XV(2)=XW(3)*XU(1)-XW(1)*XU(3)
  248. XV(3)=XW(1)*XU(2)-XW(2)*XU(1)
  249. c boucle sur les noeuds + rotation
  250. DO i=1,ICPR(/1)
  251. IF (ICPR(i).NE.0) THEN
  252. IREF=idimp1*(i-1)
  253. XD=XCOOR(IREF+1)-XP(1)
  254. YD=XCOOR(IREF+2)-XP(2)
  255. ZD=0.D0
  256. IF (IDIM.EQ.3) ZD=XCOOR(IREF+3)-XP(3)
  257. XE=XD*XU(1)+YD*XU(2)+ZD*XU(3)
  258. YE=XD*XV(1)+YD*XV(2)+ZD*XV(3)
  259. ZE=XD*XW(1)+YD*XW(2)+ZD*XW(3)
  260. IF(IPCH1.ne.0) THEN
  261. CO = VPOCHA(ICPR(i),1)
  262. SI = VPOCHA(ICPR(i),2)
  263. ENDIF
  264. XD=XE*CO-YE*SI
  265. YD=XE*SI+YE*CO
  266. ZD=ZE
  267. XCOOR(IREF+1)=XD*XU(1)+YD*XV(1)+ZD*XW(1)+XP(1)
  268. XCOOR(IREF+2)=XD*XU(2)+YD*XV(2)+ZD*XW(2)+XP(2)
  269. IF (IDIM.EQ.3) XCOOR(IREF+3)=XD*XU(3)+YD*XV(3)+ZD*XW(3)+XP(3)
  270. ENDIF
  271. ENDDO
  272. IF(IPCH1.ne.0) SEGSUP,MPOVAL
  273. GOTO 1000
  274.  
  275. C Option HOMO :
  276. C ---------------
  277. 400 CALL LIRREE(RAP,1,IRETOU)
  278. CALL LIROBJ('POINT',IP,1,IRETOU)
  279. IF (RAP.EQ.0.D0) CALL ERREUR(36)
  280. IF (IERR.NE.0) GOTO 10000
  281. IREF=idimp1*(IP-1)
  282. DO j=1,IDIM
  283. XP(j)=XCOOR(IREF+j)
  284. ENDDO
  285. DO i=1,ICPR(/1)
  286. IF (ICPR(i).NE.0) THEN
  287. IREF=idimp1*(i-1)
  288. DO j=1,IDIM
  289. XCOOR(IREF+j)=XP(j)+RAP*(XCOOR(IREF+j)-XP(j))
  290. ENDDO
  291. ENDIF
  292. ENDDO
  293. GOTO 1000
  294.  
  295. C Option AFFI :
  296. C ---------------
  297. 500 CALL LIRREE(RAP,1,IRETOU)
  298. CALL LIROBJ('POINT',IPC,1,IRETOU)
  299. CALL LIROBJ('POINT',IPV,1,IRETOU)
  300. IF (RAP.EQ.0.D0) CALL ERREUR(36)
  301. IF (IERR.NE.0) GOTO 10000
  302. RAP=RAP-1.
  303. IREF=idimp1*(IPC-1)
  304. XP(1)=XCOOR(IREF+1)
  305. XP(2)=XCOOR(IREF+2)
  306. XP(3)=0.D0
  307. IF (IDIM.EQ.3) XP(3)=XCOOR(IREF+3)
  308. IREF=idimp1*(IPV-1)
  309. XV(1)=XCOOR(IREF+1)-XP(1)
  310. XV(2)=XCOOR(IREF+2)-XP(2)
  311. XV(3)=0.D0
  312. IF (IDIM.EQ.3) XV(3)=XCOOR(IREF+3)-XP(3)
  313. XN=XV(1)**2+XV(2)**2+XV(3)**2
  314. IF (XN.EQ.0.D0) CALL ERREUR(21)
  315. IF (IERR.NE.0) GOTO 10000
  316. XN=SQRT(XN)
  317. XV(1)=XV(1)/XN
  318. XV(2)=XV(2)/XN
  319. XV(3)=XV(3)/XN
  320. DO i=1,ICPR(/1)
  321. IF (ICPR(i).NE.0) THEN
  322. IREF=idimp1*(i-1)
  323. XU(1)=XCOOR(IREF+1)-XP(1)
  324. XU(2)=XCOOR(IREF+2)-XP(2)
  325. XU(3)=0.D0
  326. IF (IDIM.EQ.3) XU(3)=XCOOR(IREF+3)-XP(3)
  327. SCA=(XU(1)*XV(1)+XU(2)*XV(2)+XU(3)*XV(3))*RAP
  328. DO j=1,IDIM
  329. XCOOR(IREF+j)=XP(j)+XU(j)+SCA*XV(j)
  330. ENDDO
  331. ENDIF
  332. ENDDO
  333. GOTO 1000
  334.  
  335. C Option SYME :
  336. C ---------------
  337. 600 CALL LIRMOT(MCL2,3,JCLE,1)
  338. IF (IERR.NE.0) GOTO 10000
  339. IF ((IDIM.EQ.1).AND.(JCLE.NE.1)) THEN
  340. MOTERR(1:4)=MCL2(JCLE)
  341. INTERR(1)=IDIM
  342. CALL ERREUR(971)
  343. GOTO 10000
  344. ENDIF
  345. GOTO (610,620,630),JCLE
  346.  
  347. C Option SYME POIN :
  348. C --------------------
  349. 610 CALL LIROBJ('POINT',IP,1,IRETOU)
  350. IF (IERR.NE.0) GOTO 10000
  351. IREF=idimp1*(IP-1)
  352. DO j=1,IDIM
  353. XP(j)=2*XCOOR(IREF+j)
  354. ENDDO
  355. DO i=1,ICPR(/1)
  356. IF (ICPR(i).NE.0) THEN
  357. IREF=idimp1*(i-1)
  358. DO j=1,IDIM
  359. XCOOR(IREF+j)=XP(j)-XCOOR(IREF+j)
  360. ENDDO
  361. ENDIF
  362. ENDDO
  363. GOTO 1000
  364.  
  365. C Option SYME DROI :
  366. C --------------------
  367. 620 CALL LIROBJ('POINT',IP1,1,IRETOU)
  368. CALL LIROBJ('POINT',IP2,1,IRETOU)
  369. IF (IERR.NE.0) GOTO 10000
  370. IREF=idimp1*(IP1-1)
  371. XP(1)=XCOOR(IREF+1)
  372. XP(2)=XCOOR(IREF+2)
  373. XP(3)=0.D0
  374. IF (IDIM.EQ.3) XP(3)=XCOOR(IREF+3)
  375. IREF=idimp1*(IP2-1)
  376. XU(1)=XCOOR(IREF+1)-XP(1)
  377. XU(2)=XCOOR(IREF+2)-XP(2)
  378. XU(3)=0.D0
  379. IF (IDIM.EQ.3) XU(3)=XCOOR(IREF+3)-XP(3)
  380. XN=XU(1)**2+XU(2)**2+XU(3)**2
  381. IF (XN.EQ.0.D0) CALL ERREUR(21)
  382. IF (IERR.NE.0) GOTO 10000
  383. XN=SQRT(XN)
  384. XU(1)=XU(1)/XN
  385. XU(2)=XU(2)/XN
  386. XU(3)=XU(3)/XN
  387. DO i=1,ICPR(/1)
  388. IF (ICPR(i).NE.0) THEN
  389. IREF=idimp1*(i-1)
  390. XV(1)=XCOOR(IREF+1)-XP(1)
  391. XV(2)=XCOOR(IREF+2)-XP(2)
  392. XV(3)=0.D0
  393. IF (IDIM.GE.3) XV(3)=XCOOR(IREF+3)-XP(3)
  394. SCA=2*(XU(1)*XV(1)+XU(2)*XV(2)+XU(3)*XV(3))
  395. DO j=1,IDIM
  396. XCOOR(IREF+j)=XP(j)+SCA*XU(j)-XV(j)
  397. ENDDO
  398. ENDIF
  399. ENDDO
  400. GOTO 1000
  401.  
  402. C Option SYME PLAN :
  403. C --------------------
  404. 630 IF (IDIM.EQ.2) CALL ERREUR(21)
  405. IF (IERR.NE.0) GOTO 10000
  406. CALL LIROBJ('POINT',IP1,1,IRETOU)
  407. CALL LIROBJ('POINT',IP2,1,IRETOU)
  408. CALL LIROBJ('POINT',IP3,1,IRETOU)
  409. IF (IERR.NE.0) GOTO 10000
  410. IREF=idimp1*(IP1-1)
  411. XP(1)=XCOOR(IREF+1)
  412. XP(2)=XCOOR(IREF+2)
  413. XP(3)=XCOOR(IREF+3)
  414. IREF=idimp1*(IP2-1)
  415. XU(1)=XCOOR(IREF+1)-XP(1)
  416. XU(2)=XCOOR(IREF+2)-XP(2)
  417. XU(3)=XCOOR(IREF+3)-XP(3)
  418. IREF=idimp1*(IP3-1)
  419. XV(1)=XCOOR(IREF+1)-XP(1)
  420. XV(2)=XCOOR(IREF+2)-XP(2)
  421. XV(3)=XCOOR(IREF+3)-XP(3)
  422. XW(1)=XU(2)*XV(3)-XU(3)*XV(2)
  423. XW(2)=XU(3)*XV(1)-XU(1)*XV(3)
  424. XW(3)=XU(1)*XV(2)-XU(2)*XV(1)
  425. XN=XW(1)**2+XW(2)**2+XW(3)**2
  426. IF (XN.EQ.0.D0) CALL ERREUR(21)
  427. IF (IERR.NE.0) GOTO 10000
  428. XN=SQRT(XN)
  429. XW(1)=XW(1)/XN
  430. XW(2)=XW(2)/XN
  431. XW(3)=XW(3)/XN
  432. DO i=1,ICPR(/1)
  433. IF (ICPR(i).NE.0) THEN
  434. IREF=idimp1*(i-1)
  435. XU(1)=XCOOR(IREF+1)-XP(1)
  436. XU(2)=XCOOR(IREF+2)-XP(2)
  437. XU(3)=XCOOR(IREF+3)-XP(3)
  438. SCA=2*(XU(1)*XW(1)+XU(2)*XW(2)+XU(3)*XW(3))
  439. XCOOR(IREF+1)=XP(1)+XU(1)-SCA*XW(1)
  440. XCOOR(IREF+2)=XP(2)+XU(2)-SCA*XW(2)
  441. XCOOR(IREF+3)=XP(3)+XU(3)-SCA*XW(3)
  442. ENDIF
  443. ENDDO
  444. GOTO 1000
  445.  
  446. C Option SYME PROJ :
  447. C --------------------
  448. 700 CALL LIRMOT(MCL4,2,ITYYP,0)
  449. C Lecture du vecteur de projection ou du centre (projection conique)
  450. CALL LIROBJ('POINT',IP1,1,IRETOU)
  451. IF (IERR.NE.0) GOTO 10000
  452. IREF=idimp1*(IP1-1)
  453. XVECS=XCOOR(IREF+1)
  454. YVECS=XCOOR(IREF+2)
  455. ZVECS=0.D0
  456. IF (IDIM.GE.3) ZVECS=XCOOR(IREF+3)
  457. ICARR=1
  458. IF (ITYYP.NE.0) ICARR=0
  459. CALL LIRMOT(MCL3,7,JCLE,ICARR)
  460. IF (IERR.NE.0) GOTO 10000
  461. IF (JCLE.EQ.0) THEN
  462. JCLE=ITYYP+2
  463. ITYYP=0
  464. ENDIF
  465. IF ((IDIM.EQ.2).AND.(JCLE.LE.5)) CALL ERREUR(34)
  466. IF ((IDIM.EQ.3).AND.(JCLE.GE.6)) CALL ERREUR(34)
  467. IF (IERR.NE.0) GOTO 10000
  468. C Projection cylindrique normalisation du vecteur
  469. IF (ITYYP.NE.2) THEN
  470. SVECS=SQRT(XVECS*XVECS+YVECS*YVECS+ZVECS*ZVECS)
  471. IF (SVECS.EQ.0.D0) CALL ERREUR(21)
  472. IF (IERR.NE.0) GOTO 10000
  473. XVEC=XVECS/SVECS
  474. YVEC=YVECS/SVECS
  475. ZVEC=ZVECS/SVECS
  476. ENDIF
  477. GOTO (710,720,730,740,750,760,770),JCLE
  478.  
  479. C Option PROJ PLAN :
  480. C --------------------
  481. 710 CALL LIROBJ('POINT',IP1,1,IRETOU)
  482. CALL LIROBJ('POINT',IP2,1,IRETOU)
  483. CALL LIROBJ('POINT',IP3,1,IRETOU)
  484. IF (IERR.NE.0) GOTO 10000
  485. IREF=idimp1*(IP1-1)
  486. XPT1=XCOOR(IREF+1)
  487. YPT1=XCOOR(IREF+2)
  488. ZPT1=XCOOR(IREF+3)
  489. IREF=idimp1*(IP2-1)
  490. XV2=XCOOR(IREF+1)-XPT1
  491. YV2=XCOOR(IREF+2)-YPT1
  492. ZV2=XCOOR(IREF+3)-ZPT1
  493. IREF=idimp1*(IP3-1)
  494. XV3=XCOOR(IREF+1)-XPT1
  495. YV3=XCOOR(IREF+2)-YPT1
  496. ZV3=XCOOR(IREF+3)-ZPT1
  497. XV1=YV2*ZV3-ZV2*YV3
  498. YV1=ZV2*XV3-XV2*ZV3
  499. ZV1=XV2*YV3-YV2*XV3
  500. SV1=SQRT(XV1*XV1+YV1*YV1+ZV1*ZV1)
  501. IF (SV1.EQ.0.D0) CALL ERREUR(21)
  502. IF (IERR.NE.0) GOTO 10000
  503. XV1=XV1/SV1
  504. YV1=YV1/SV1
  505. ZV1=ZV1/SV1
  506. GOTO 780
  507.  
  508. C Option PROJ SPHE :
  509. C --------------------
  510. 720 CALL LIROBJ('POINT',IPCEN,1,IRETOU)
  511. CALL LIROBJ('POINT',IP1,1,IRETOU)
  512. IF (IERR.NE.0) GOTO 10000
  513. IREF=(IPCEN-1)*idimp1
  514. XPT1=XCOOR(IREF+1)
  515. YPT1=XCOOR(IREF+2)
  516. ZPT1=XCOOR(IREF+3)
  517. IREF=(IP1-1)*idimp1
  518. XV1=XCOOR(IREF+1)-XPT1
  519. YV1=XCOOR(IREF+2)-YPT1
  520. ZV1=XCOOR(IREF+3)-ZPT1
  521. ANGLE=SQRT(XV1*XV1+YV1*YV1+ZV1*ZV1)
  522. IF (ANGLE.EQ.0.D0) CALL ERREUR(21)
  523. IF (IERR.NE.0) GOTO 10000
  524. GOTO 780
  525.  
  526. C Option PROJ CYLI :
  527. C --------------------
  528. 730 CALL LIROBJ('POINT',IPOIN1,1,IRETOU)
  529. CALL LIROBJ('POINT',IPOIN2,1,IRETOU)
  530. CALL LIROBJ('POINT',IP1,1,IRETOU)
  531. IF (IERR.NE.0) GOTO 10000
  532. IREF=(IPOIN1-1)*idimp1
  533. XPT1=XCOOR(IREF+1)
  534. YPT1=XCOOR(IREF+2)
  535. ZPT1=XCOOR(IREF+3)
  536. IREF=(IPOIN2-1)*idimp1
  537. XV1=XCOOR(IREF+1)-XPT1
  538. YV1=XCOOR(IREF+2)-YPT1
  539. ZV1=XCOOR(IREF+3)-ZPT1
  540. S=SQRT(XV1*XV1+YV1*YV1+ZV1*ZV1)
  541. IF (S.EQ.0.D0) CALL ERREUR(21)
  542. IF (IERR.NE.0) GOTO 10000
  543. XV1=XV1/S
  544. YV1=YV1/S
  545. ZV1=ZV1/S
  546. IREF=(IP1-1)*idimp1
  547. XV2=XCOOR(IREF+1)-XPT1
  548. YV2=XCOOR(IREF+2)-YPT1
  549. ZV2=XCOOR(IREF+3)-ZPT1
  550. XV3=YV1*ZV2-ZV1*YV2
  551. YV3=ZV1*XV2-XV1*ZV2
  552. ZV3=XV1*YV2-YV1*XV2
  553. ANGLE=SQRT(XV3*XV3+YV3*YV3+ZV3*ZV3)
  554. IF (ANGLE.EQ.0) CALL ERREUR(21)
  555. IF (IERR.NE.0) RETURN
  556. GOTO 780
  557.  
  558. C Option PROJ CONI :
  559. C --------------------
  560. 740 CALL LIROBJ('POINT',IPT1,1,IRETOU)
  561. CALL LIROBJ('POINT',IP1,1,IRETOU)
  562. CALL LIROBJ('POINT',IP2,1,IRETOU)
  563. IF (IERR.NE.0) GOTO 10000
  564. IREF=(IPT1-1)*idimp1
  565. XPT1=XCOOR(IREF+1)
  566. YPT1=XCOOR(IREF+2)
  567. ZPT1=XCOOR(IREF+3)
  568. IREF=(IP1-1)*idimp1
  569. XV1=XCOOR(IREF+1)-XPT1
  570. YV1=XCOOR(IREF+2)-YPT1
  571. ZV1=XCOOR(IREF+3)-ZPT1
  572. SV1=SQRT(XV1*XV1+YV1*YV1+ZV1*ZV1)
  573. IF (SV1.EQ.0.D0) CALL ERREUR(21)
  574. IF (IERR.NE.0) GOTO 10000
  575. XV1=XV1/SV1
  576. YV1=YV1/SV1
  577. ZV1=ZV1/SV1
  578. IREF=(IP2-1)*idimp1
  579. XV2=XCOOR(IREF+1)-XPT1
  580. YV2=XCOOR(IREF+2)-YPT1
  581. ZV2=XCOOR(IREF+3)-ZPT1
  582. SV2=SQRT(XV2*XV2+YV2*YV2+ZV2*ZV2)
  583. IF (SV2.EQ.0.D0) CALL ERREUR(21)
  584. IF (IERR.NE.0) GOTO 10000
  585. XV2=XV2/SV2
  586. YV2=YV2/SV2
  587. ZV2=ZV2/SV2
  588. ANGLE=(XV1*XV2+YV1*YV2+ZV1*ZV2)**2
  589. GOTO 780
  590.  
  591. C Option PROJ TORI
  592. C ------------------
  593. 750 CALL LIROBJ('POINT',IPT1,1,IRETOU)
  594. CALL LIROBJ('POINT',IPAX,1,IRETOU)
  595. CALL LIROBJ('POINT',IPCS,1,IRETOU)
  596. CALL LIROBJ('POINT',IP1 ,1,IRETOU)
  597. IF (IERR.NE.0) GOTO 10000
  598. IREF=(IPT1-1)*idimp1
  599. XPT1=XCOOR(IREF+1)
  600. YPT1=XCOOR(IREF+2)
  601. ZPT1=XCOOR(IREF+3)
  602. IREF=(IPAX-1)*idimp1
  603. XV1=XCOOR(IREF+1)-XPT1
  604. YV1=XCOOR(IREF+2)-YPT1
  605. ZV1=XCOOR(IREF+3)-ZPT1
  606. SV1=XV1*XV1+YV1*YV1+ZV1*ZV1
  607. IF (SV1.EQ.0.D0) CALL ERREUR(21)
  608. IF (IERR.NE.0) GOTO 10000
  609. SV1=SQRT(SV1)
  610. XV1=XV1/SV1
  611. YV1=YV1/SV1
  612. ZV1=ZV1/SV1
  613. IREF=(IPCS-1)*idimp1
  614. XV2=XCOOR(IREF+1)-XPT1
  615. YV2=XCOOR(IREF+2)-YPT1
  616. ZV2=XCOOR(IREF+3)-ZPT1
  617. SCA=XV2*XV1+YV2*YV1+ZV2*ZV1
  618. XPT1=XPT1+SCA*XV1
  619. YPT1=YPT1+SCA*YV1
  620. ZPT1=ZPT1+SCA*ZV1
  621. XV2=XV2-SCA*XV1
  622. YV2=YV2-SCA*YV1
  623. ZV2=ZV2-SCA*ZV1
  624. GR2=XV2*XV2+YV2*YV2+ZV2*ZV2
  625. IF (GR2.EQ.0.D0) CALL ERREUR(21)
  626. IF (IERR.NE.0) GOTO 10000
  627. IREF=(IP1-1)*idimp1
  628. XV2=XCOOR(IREF+1)-XPT1
  629. YV2=XCOOR(IREF+2)-YPT1
  630. ZV2=XCOOR(IREF+3)-ZPT1
  631. SCA=XV2*XV1+YV2*YV1+ZV2*ZV1
  632. XC=XV2-SCA*XV1
  633. YC=YV2-SCA*YV1
  634. ZC=ZV2-SCA*ZV1
  635. SC=XC*XC+YC*YC+ZC*ZC
  636. IF (SC.EQ.0.D0) CALL ERREUR(21)
  637. IF (IERR.NE.0) GOTO 10000
  638. RAP=SQRT(GR2/SC)
  639. XC=XC*RAP
  640. YC=YC*RAP
  641. ZC=ZC*RAP
  642. PR2=(XV2-XC)**2+(YV2-YC)**2+(ZV2-ZC)**2
  643. IF (PR2.EQ.0.D0) CALL ERREUR(21)
  644. IF (IERR.NE.0) GOTO 10000
  645. XV2=PR2
  646. YV2=GR2
  647. GOTO 780
  648.  
  649. C Option PROJ DROI :
  650. C --------------------
  651. 760 CALL LIROBJ('POINT',IP1,1,IRETOU)
  652. CALL LIROBJ('POINT',IP2,1,IRETOU)
  653. IF (IERR.NE.0) GOTO 10000
  654. IREF=(IP1-1)*idimp1
  655. XPT1=XCOOR(IREF+1)
  656. YPT1=XCOOR(IREF+2)
  657. ZPT1=0.D0
  658. IREF=(IP2-1)*idimp1
  659. XV2=XCOOR(IREF+1)-XPT1
  660. YV2=XCOOR(IREF+2)-YPT1
  661. ZV2=0.D0
  662. XV3=0.D0
  663. YV3=0.D0
  664. ZV3=1.D0
  665. XV1=YV2*ZV3-ZV2*YV3
  666. YV1=ZV2*XV3-XV2*ZV3
  667. ZV1=XV2*YV3-YV2*XV3
  668. SV1=SQRT(XV1*XV1+YV1*YV1+ZV1*ZV1)
  669. IF (SV1.EQ.0.D0) CALL ERREUR(21)
  670. IF (IERR.NE.0) GOTO 10000
  671. XV1=XV1/SV1
  672. YV1=YV1/SV1
  673. ZV1=ZV1/SV1
  674. GOTO 780
  675.  
  676. C Option PROJ CERC :
  677. C --------------------
  678. 770 CALL LIROBJ('POINT',IPCEN,1,IRETOU)
  679. CALL LIROBJ('POINT',IP1,1,IRETOU)
  680. IF (IERR.NE.0) GOTO 10000
  681. IREF=(IPCEN-1)*idimp1
  682. XPT1=XCOOR(IREF+1)
  683. YPT1=XCOOR(IREF+2)
  684. ZPT1=0.D0
  685. IREF=(IP1-1)*idimp1
  686. XV1=XCOOR(IREF+1)-XPT1
  687. YV1=XCOOR(IREF+2)-YPT1
  688. ZV1=0.D0
  689. ANGLE=SQRT(XV1*XV1+YV1*YV1+ZV1*ZV1)
  690. IF (ANGLE.EQ.0.D0) CALL ERREUR(21)
  691. IF (IERR.NE.0) GOTO 10000
  692. GOTO 780
  693. C Traitement commun - Options PROJ
  694. 780 DO i=1,ICPR(/1)
  695. IF (ICPR(i).NE.0) THEN
  696. IREF=(i-1)*idimp1
  697. XPOIN=XCOOR(IREF+1)
  698. YPOIN=XCOOR(IREF+2)
  699. ZPOIN=0.D0
  700. IF (IDIM.GE.3) ZPOIN=XCOOR(IREF+3)
  701. IF (ITYYP.EQ.2) THEN
  702. XVEC=XVECS-XPOIN
  703. YVEC=YVECS-YPOIN
  704. ZVEC=ZVECS-ZPOIN
  705. SVEC=SQRT(XVEC*XVEC+YVEC*YVEC+ZVEC*ZVEC)
  706. IF (SVEC.EQ.0.D0) CALL ERREUR(21)
  707. IF (IERR.NE.0) RETURN
  708. XVEC=XVEC/SVEC
  709. YVEC=YVEC/SVEC
  710. ZVEC=ZVEC/SVEC
  711. ENDIF
  712. GOTO (810,820,830,840,850,860,870),JCLE
  713. C Option PROJ PLAN
  714. 810 XV2=XPOIN-XPT1
  715. YV2=YPOIN-YPT1
  716. ZV2=ZPOIN-ZPT1
  717. DENUM=XV2*XV1+YV2*YV1+ZV2*ZV1
  718. DENOM=XVEC*XV1+YVEC*YV1+ZVEC*ZV1
  719. IF (DENOM.EQ.0.D0) CALL ERREUR(21)
  720. IF (IERR.NE.0) GOTO 10000
  721. RAP=-DENUM/DENOM
  722. XPOIN=XPOIN+RAP*XVEC
  723. YPOIN=YPOIN+RAP*YVEC
  724. ZPOIN=ZPOIN+RAP*ZVEC
  725. GOTO 880
  726. C Option PROJ SPHE
  727. 820 XV1=XPT1-XPOIN
  728. YV1=YPT1-YPOIN
  729. ZV1=ZPT1-ZPOIN
  730. SCA=XVEC*XV1+YVEC*YV1+ZVEC*ZV1
  731. XV1=XVEC*SCA
  732. YV1=YVEC*SCA
  733. ZV1=ZVEC*SCA
  734. S2=(XPOIN+XV1-XPT1)**2+(YPOIN+YV1-YPT1)**2+(ZPOIN+ZV1-ZPT1)**2
  735. IF (S2.GT.(ANGLE*ANGLE)) CALL ERREUR(21)
  736. IF (IERR.NE.0) GOTO 10000
  737. C=SQRT(ANGLE*ANGLE-S2)
  738. IF (SCA.LT.0.D0) C=-C
  739. XPOIN=XPOIN+XV1-C*XVEC
  740. YPOIN=YPOIN+YV1-C*YVEC
  741. ZPOIN=ZPOIN+ZV1-C*ZVEC
  742. GOTO 880
  743. C Option PROJ CYLI
  744. 830 XV2=YVEC*ZV1-ZVEC*YV1
  745. YV2=ZVEC*XV1-XVEC*ZV1
  746. ZV2=XVEC*YV1-YVEC*XV1
  747. S2V2=XV2*XV2+YV2*YV2+ZV2*ZV2
  748. IF (S2V2.EQ.0.D0) CALL ERREUR(21)
  749. IF (IERR.NE.0) GOTO 10000
  750. C2=(XVEC*XV1+YVEC*YV1+ZVEC*ZV1)**2
  751. IF (C2.EQ.1.D0) CALL ERREUR(21)
  752. IF (IERR.NE.0) GOTO 10000
  753. XV3=XPT1-XPOIN
  754. YV3=YPT1-YPOIN
  755. ZV3=ZPT1-ZPOIN
  756. XV4=YV3*ZV1-ZV3*YV1
  757. YV4=ZV3*XV1-XV3*ZV1
  758. ZV4=XV3*YV1-YV3*XV1
  759. DNUM=(XV4*XVEC+YV4*YVEC+ZV4*ZVEC)**2
  760. DIS2=DNUM/S2V2
  761. IF (DIS2.GT.ANGLE**2) CALL ERREUR(21)
  762. IF (IERR.NE.0) GOTO 10000
  763. DMU=SQRT((ANGLE**2-DIS2)/(1.D0-C2))
  764. DNUM=XV2*XV4+YV2*YV4+ZV2*ZV4
  765. DLA=DNUM/S2V2
  766. DMU=SIGN(DMU,DLA)
  767. XPOIN=XPOIN+XVEC*(DLA-DMU)
  768. YPOIN=YPOIN+YVEC*(DLA-DMU)
  769. ZPOIN=ZPOIN+ZVEC*(DLA-DMU)
  770. GOTO 880
  771. C Option PROJ CONI
  772. 840 XV2=XPOIN-XPT1
  773. YV2=YPOIN-YPT1
  774. ZV2=ZPOIN-ZPT1
  775. VECV1=XVEC*XV1+YVEC*YV1+ZVEC*ZV1
  776. VEC2=XVEC*XVEC+YVEC*YVEC+ZVEC*ZVEC
  777. V2V1=XV2*XV1+YV2*YV1+ZV2*ZV1
  778. VECV2=XVEC*XV2+YVEC*YV2+ZVEC*ZV2
  779. V22=XV2*XV2+YV2*YV2+ZV2*ZV2
  780. A=VECV1*VECV1-ANGLE*VEC2
  781. B=2*(V2V1*VECV1-ANGLE*VECV2)
  782. C=V2V1*V2V1-ANGLE*V22
  783. DELTA=B*B-4*A*C
  784. IF (DELTA.LT.0.D0) CALL ERREUR(21)
  785. IF (IERR.NE.0) GOTO 10000
  786. DEL=SQRT(DELTA)
  787. X1=(-B+DEL)/(2*A)
  788. X2=(-B-DEL)/(2*A)
  789. X=X2
  790. IF (ABS(X1).LT.ABS(X2)) X=X1
  791. XPOIN=XPOIN+X*XVEC
  792. YPOIN=YPOIN+X*YVEC
  793. ZPOIN=ZPOIN+X*ZVEC
  794. GOTO 880
  795. C Option PROJ TORI
  796. 850 PR2=XV2
  797. GR2=YV2
  798. XOP=XPOIN-XPT1
  799. YOP=YPOIN-YPT1
  800. ZOP=ZPOIN-ZPT1
  801. OPV=XOP*XVEC+YOP*YVEC+ZOP*ZVEC
  802. R2=XOP*XOP+YOP*YOP+ZOP*ZOP-GR2-PR2
  803. VA=XVEC*XV1+YVEC*YV1+ZVEC*ZV1
  804. QR2VA2=4*GR2*VA*VA
  805. OPA=XOP*XV1+YOP*YV1+ZOP*ZV1
  806. HR2PV=8*GR2*OPA*VA
  807. R=4*GR2*OPA*OPA-4*PR2*GR2
  808. RLMD=0.D0
  809. C Resolution de l'equation du 4eme degre par iteration
  810. DO iter=1,25
  811. EXP1=RLMD*(RLMD+2*OPV)+R2
  812. FDLM=EXP1*EXP1+QR2VA2*RLMD*RLMD+HR2PV*RLMD+R
  813. FPDLM=4*EXP1*(RLMD+OPV)+QR2VA2*2*RLMD+HR2PV
  814. IF (FPDLM.EQ.0.D0) CALL ERREUR(40)
  815. IF (IERR.NE.0) GOTO 10000
  816. CORR=FDLM/FPDLM
  817. RLMD=RLMD-CORR
  818. IF ((RLMD.NE.0.D0).AND.(ABS(CORR/RLMD).LT.1E-5)) GOTO 851
  819. ENDDO
  820. CALL ERREUR(40)
  821. GOTO 10000
  822. 851 XPOIN=XPOIN+RLMD*XVEC
  823. YPOIN=YPOIN+RLMD*YVEC
  824. ZPOIN=ZPOIN+RLMD*ZVEC
  825. GOTO 880
  826. C Option PROJ DROI
  827. 860 XV2=XPOIN-XPT1
  828. YV2=YPOIN-YPT1
  829. ZV2=0.D0
  830. DENUM=XV2*XV1+YV2*YV1+ZV2*ZV1
  831. DENOM=XVEC*XV1+YVEC*YV1+ZVEC*ZV1
  832. IF (DENOM.EQ.0.D0) CALL ERREUR(21)
  833. IF (IERR.NE.0) GOTO 10000
  834. RAP=-DENUM/DENOM
  835. XPOIN=XPOIN+RAP*XVEC
  836. YPOIN=YPOIN+RAP*YVEC
  837. ZPOIN=ZPOIN+RAP*ZVEC
  838. GOTO 880
  839. C Option PROJ CERC
  840. 870 XV1=XPT1-XPOIN
  841. YV1=YPT1-YPOIN
  842. ZV1=0.D0
  843. SCA=XVEC*XV1+YVEC*YV1+ZVEC*ZV1
  844. XV1=XVEC*SCA
  845. YV1=YVEC*SCA
  846. ZV1=ZVEC*SCA
  847. S2=(XPOIN+XV1-XPT1)**2+(YPOIN+YV1-YPT1)**2+(ZPOIN+ZV1-ZPT1)**2
  848. IF (S2.GT.ANGLE**2) CALL ERREUR(21)
  849. IF (IERR.NE.0) GOTO 10000
  850. C=SQRT(ANGLE*ANGLE-S2)
  851. IF (SCA.LT.0.D0) C=-C
  852. XPOIN=XPOIN+XV1-C*XVEC
  853. YPOIN=YPOIN+YV1-C*YVEC
  854. ZPOIN=ZPOIN+ZV1-C*ZVEC
  855. GOTO 880
  856. C Traitement commun des options
  857. 880 XCOOR(IREF+1)=XPOIN
  858. XCOOR(IREF+2)=YPOIN
  859. IF (IDIM.EQ.3) XCOOR(IREF+3)=ZPOIN
  860. ENDIF
  861. ENDDO
  862. GOTO 1000
  863.  
  864. C Option COOR : Changement de systeme de coordonnees
  865. C ---------------
  866. 1800 CALL LIRMOT(MCL5,2,ICYLI,1)
  867. IF (IERR.NE.0) GOTO 10000
  868. IF (ICYLI.EQ.1) THEN
  869. CALL LIROBJ('POINT ',IP1,1,IRETOU)
  870. IF (IERR.NE.0) GO TO 10000
  871. CALL LIROBJ('POINT ',IP2,1,IRETOU)
  872. IF (IERR.NE.0) GO TO 10000
  873. IF (IDIM.EQ.3) CALL LIROBJ('POINT ',IP3,1,IRETOU)
  874. IF (IERR.NE.0) GO TO 10000
  875. ENDIF
  876. C Transformation des coordonnees cartesiennes en cylindriques
  877. IF (ICYLI.EQ.1) THEN
  878. IREF=(IP1-1)*idimp1
  879. XP11=XCOOR(IREF+1)
  880. XP12=XCOOR(IREF+2)
  881. XP13=0.D0
  882. IF (IDIM.EQ.3) XP13=XCOOR(IREF+3)
  883. IREF=(IP2-1)*idimp1
  884. XP21=XCOOR(IREF+1)-XP11
  885. XP22=XCOOR(IREF+2)-XP12
  886. XP23=0.D0
  887. IF(IDIM.EQ.3) XP23 = XCOOR(IREF+3)-XP13
  888. XL=SQRT(XP21*XP21+XP22*XP22+XP23*XP23)
  889. IF (XL.EQ.0.D0) THEN
  890. CALL ERREUR(21)
  891. GOTO 10000
  892. ENDIF
  893. XP21=XP21/XL
  894. XP22=XP22/XL
  895. YP21=-XP22
  896. YP22=XP21
  897. YP23=0.D0
  898. IF (IDIM.EQ.3) THEN
  899. XP23=XP23/XL
  900. XP31=XP21
  901. XP32=XP22
  902. XP33=XP23
  903. IREF=(IP3-1)*idimp1
  904. XP21=XCOOR(IREF+1)-XP11
  905. XP22=XCOOR(IREF+2)-XP12
  906. XP23=XCOOR(IREF+3)-XP13
  907. XXX=XP21*XP31+XP22*XP32+XP23*XP33
  908. XP21=XP21-XXX*XP31
  909. XP22=XP22-XXX*XP32
  910. XP23=XP23-XXX*XP33
  911. XL=SQRT(XP21*XP21+XP22*XP22+XP23*XP23)
  912. IF (XL.EQ.0.D0) THEN
  913. CALL ERREUR(21)
  914. GOTO 10000
  915. ENDIF
  916. XP21=XP21/XL
  917. XP22=XP22/XL
  918. XP23=XP23/XL
  919. YP21=XP32*XP23-XP33*XP22
  920. YP22=XP33*XP21-XP31*XP23
  921. YP23=XP31*XP22-XP32*XP21
  922. ENDIF
  923. SCA=180.D0/XPI
  924. DO i=1,ICPR(/1)
  925. IF (ICPR(i).NE.0) THEN
  926. IREF=(i-1)*idimp1
  927. XD=XCOOR(IREF+1)-XP11
  928. YD=XCOOR(IREF+2)-XP12
  929. ZD=0.D0
  930. IF (IDIM.EQ.3) THEN
  931. ZD=XCOOR(IREF+3)-XP13
  932. ZF=XD*XP31+YD*XP32+ZD*XP33
  933. XD=XD-ZF*XP31
  934. YD=YD-ZF*XP32
  935. ZD=ZD-ZF*XP33
  936. ENDIF
  937. XA=XD*XP21+YD*XP22+ZD*XP23
  938. YA=XD*YP21+YD*YP22+ZD*YP23
  939. RHO=SQRT(XA*XA+YA*YA)
  940. TETA=ATAN2(YA,XA)
  941. XCOOR(IREF+1)=RHO
  942. XCOOR(IREF+2)=TETA*SCA
  943. IF (IDIM.EQ.3) XCOOR(IREF+3)=ZF
  944. ENDIF
  945. ENDDO
  946. C Transformation des coordonnees cylindriques en cartesiennes
  947. C L'axe X est conserve, ainsi que l'axe Z.
  948. ELSE IF (ICYLI.EQ.2) THEN
  949. SCA=XPI/180.D0
  950. DO i=1,ICPR(/1)
  951. IF (ICPR(I).NE.0) THEN
  952. IREF=(i-1)*idimp1
  953. XD=XCOOR(IREF+1)
  954. YD=XCOOR(IREF+2)*SCA
  955. XCOOR(IREF+1)=XD*COS(YD)
  956. XCOOR(IREF+2)=XD*SIN(YD)
  957. ENDIF
  958. ENDDO
  959. ENDIF
  960. GOTO 1000
  961.  
  962. C Fin normale de l'operateur - Ecriture des objets (ICLE = 1 a 8)
  963. C -----------------------------------------------------------------
  964. 1000 SEGSUP ICPR
  965. IF (ITYPLU.EQ.1) CALL ECROBJ('POINT',ITYPSA)
  966. IF (ITYPLU.EQ.2) CALL ECROBJ('MAILLAGE',ITYPSA)
  967. RETURN
  968.  
  969. C Option MILI :
  970. C ---------------
  971. 1900 IF (IDIM.GE.2) THEN
  972. CALL ECROBJ('MAILLAGE',MELEME)
  973. CALL CHANLG
  974. CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  975. IF (IERR.NE.0) RETURN
  976. ENDIF
  977. SEGACT MELEME
  978. IPT1=MELEME
  979. INSO=LISOUS(/1)
  980. DO j=1,MAX(1,INSO)
  981. IF (INSO.NE.0) THEN
  982. IPT1=LISOUS(j)
  983. SEGACT IPT1
  984. ENDIF
  985. IF (IPT1.ITYPEL.EQ.3) THEN
  986. DO i=1,IPT1.NUM(/2)
  987. IRef1=idimp1*(IPT1.NUM(1,i)-1)
  988. IRef2=idimp1*(IPT1.NUM(3,i)-1)
  989. IRef3=idimp1*(IPT1.NUM(2,i)-1)
  990. X1=XCOOR(IRef1+1)
  991. X2=XCOOR(IRef2+1)
  992. X3=XCOOR(IRef3+1)
  993. X2X1=X2-X1
  994. X3M=(X2+X1)*0.5-X3
  995. XNUM=X2X1*X3M
  996. XDEN=X2X1*X2X1
  997. IF (IDIM.GE.2) THEN
  998. Y1=XCOOR(IRef1+2)
  999. Y2=XCOOR(IRef2+2)
  1000. Y3=XCOOR(IRef3+2)
  1001. Y2Y1=Y2-Y1
  1002. Y3M=(Y2+Y1)*0.5-Y3
  1003. XNUM=XNUM+Y2Y1*Y3M
  1004. XDEN=XDEN+Y2Y1*Y2Y1
  1005. IF (IDIM.GE.3) THEN
  1006. Z1=XCOOR(IRef1+3)
  1007. Z2=XCOOR(IRef2+3)
  1008. Z3=XCOOR(IRef3+3)
  1009. Z2Z1=Z2-Z1
  1010. Z3M=(Z2+Z1)*0.5-Z3
  1011. XNUM=XNUM+Z2Z1*Z3M
  1012. XDEN=XDEN+Z2Z1*Z2Z1
  1013. ENDIF
  1014. ENDIF
  1015. IF (XDEN.LT.1.D-20) THEN
  1016. wrITE (6,*) 'noeud double ' , IPT1.NUM(1,i)
  1017. xnum = 0.D0
  1018. xden = 1.D0
  1019. c RETURN
  1020. endif
  1021. XLAMBD=XNUM/XDEN
  1022. XCOOR(IRef3+1)=X3+XLAMBD*X2X1
  1023. IF (IDIM.GE.2) THEN
  1024. XCOOR(IRef3+2)=Y3+XLAMBD*Y2Y1
  1025. IF (IDIM.GE.3) THEN
  1026. XCOOR(IRef3+3)=Z3+XLAMBD*Z2Z1
  1027. ENDIF
  1028. ENDIF
  1029. ENDDO
  1030. ENDIF
  1031. SEGDES IPT1
  1032. ENDDO
  1033. SEGDES MELEME
  1034. RETURN
  1035.  
  1036. C Traitement des erreurs (options ICLE = 1 a 8)
  1037. C -----------------------------------------------
  1038. 10000 SEGSUP ICPR
  1039. RETURN
  1040.  
  1041. END
  1042.  
  1043.  
  1044.  
  1045.  
  1046.  
  1047.  
  1048.  
  1049.  
  1050.  
  1051.  

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