Télécharger proper.eso

Retour à la liste

Numérotation des lignes :

  1. C PROPER SOURCE BP208322 17/04/19 21:15:04 9398
  2.  
  3. C-----------------------------------------------------------------------
  4. C Ce sous programme gere les operateurs 'PLUS', 'MOIN' et 'TOUR',
  5. C ainsi que les options 'TRAN' et 'ROTA' de de l'operateur 'DEDU'
  6. C
  7. C OBJ2 = OBJ1 'PLUS' POIN1 / CHPO1 ;
  8. C OBJ1 : type POINT, MAILLAGE, CHPOINT, MCHAML, MMODEL, RIGIDITE
  9. C
  10. C OBJ2 = OBJ1 'MOIN' POIN1 / CHPO1 ;
  11. C OBJ1 : type POINT, MAILLAGE, CHPOINT, MCHAML, MMODEL, RIGIDITE
  12. C
  13. C CHPO1 = GEO2 'MOIN' GEO1 ;
  14. C GEO2, GEO1 : type MAILLAGE, CHPO1 : type CHPO1
  15. C determination du CHPOINT dont les points support correspond aux
  16. C points de GEO1 et permettant d'obtenir GEO2 a partir de GEO1.
  17. C
  18. C OBJ2 = OBJ1 'TOUR' FLOT1 POIN1 (POIN2) ;
  19. C OBJ1 : type POINT, MAILLAGE, CHPOINT, MCHAML, MMODEL, (RIGIDITE ?)
  20. C Certaines composantes subissent egalement la rotation.
  21. C (Appel via tourne.eso - non disponible en DIMEnsion 1)
  22. C
  23. C OBJ2 = OBJ1 'DEDU' 'TRAN' GEO1 GEO2 ;
  24. C OBJ1 : type POINT, MAILLAGE, CHPOINT, MCHAML, MMODEL, RIGIDITE
  25. C GEO1, GEO2 : type MAILLAGE (GEO2 image de GEO1)
  26. C (Appel via dedu.eso)
  27. C
  28. C OBJ2 = OBJ1 'DEDU' FLOT1 POIN1 (POIN2 si 3D) 'ROTA' GEO1 GEO2 ;
  29. C OBJ1 : type POINT, MAILLAGE, CHPOINT, MCHAML, MMODEL, RIGIDITE
  30. C GEO1, GEO2 : type MAILLAGE (GEO2 image de GEO1 par la ROTAtion)
  31. C POIN1 (POIN2) : type POINT (centre ou axe de la rotation)
  32. C FLOT1 : type FLOTTANT (angle de rotation)
  33. C (Appel via dedu.eso - non disponible en DIMEnsion 1)
  34. C-----------------------------------------------------------------------
  35. C Remarques :
  36. C -----------
  37. C Dans le cas des syntaxes particulieres (1) POIN2 = POIN1 'PLUS' VECT1
  38. C (ou POIN2 = POIN1 'MOIN' VECT1), et (2) POIN2 = POIN1 'TOUR' FLOT1
  39. C PT1 (PT2) , la densite du POIN2 obtenu est, dans le cas (1), la den-
  40. C site COURANTE definie via l'operateur 'DENSITE', et, dans le cas (2),
  41. C identique a celle du POIN1.
  42. C Pour toutes les autres types d'objets et syntaxes, la densite des
  43. C points transformes est identique a celle des points d'origine.
  44. C-----------------------------------------------------------------------
  45. C 11/1997 : KICH
  46. C 10/2003 : modifications pour le cas IDIM=1.
  47. * 07/2007 : PM initialisation de NBREF dans le cas d'un point en entrée
  48. c 07/2009 : BP pour DEDU 'TRAN' avec rigidite, DEDU3.eso teste si IPOIN1 = translation?
  49. C-----------------------------------------------------------------------
  50.  
  51. SUBROUTINE PROPER(ITYP)
  52.  
  53. IMPLICIT INTEGER(I-N)
  54. IMPLICIT REAL*8 (A-H,O-Z)
  55.  
  56. -INC CCOPTIO
  57. -INC CCREEL
  58. -INC SMCOORD
  59. -INC SMELEME
  60. -INC CCGEOME
  61. -INC SMRIGID
  62. -INC SMCHPOI
  63. -INC SMMODEL
  64. -INC SMCHAML
  65. -INC SMTABLE
  66.  
  67.  
  68. DIMENSION Y(3)
  69. CHARACTER*4 MOT1
  70. CHARACTER*8 ITOPE
  71.  
  72. COMMON / CTOURN / XPT1,YPT1,ZPT1,XV1,YV1,ZV1,XV2,YV2,ZV2,
  73. . XVEC,YVEC,ZVEC,ANGLE,ICLE
  74.  
  75. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  76. SEGMENT ICP1(XCOOR(/1)/(IDIM+1))
  77. SEGMENT MLITY
  78. CHARACTER*8 LITY2(NTY2)
  79. ENDSEGMENT
  80. SEGMENT IPOSI
  81. integer IPOSIT(mlotab)
  82. ENDSEGMENT
  83.  
  84. C PILO : liste de pointeurs sur les objets DSOBJ a transformer
  85. SEGMENT PILO(0)
  86. SEGMENT DSOBJ
  87. INTEGER INIPOI,INIFIN
  88. CHARACTER*8 LETYP
  89. ENDSEGMENT
  90.  
  91. C IPLMAIL : liste des maillages elementaires d'un objet a transformer
  92. SEGMENT IPLMAIL(0)
  93.  
  94. C ITABEL : contient, initialement, tous les maillages elementaires du
  95. C maillage initial GEO1, puis tous les maillages elementaires et refe-
  96. C rence des objets initiaux qui ont deja ete transformes afin d'eviter
  97. C de les transporter plusieurs fois
  98. C INOUVEL : contient l'image des maillages elementaires et references
  99. C par la transformation changeant GEO1 en GEO2
  100. C GEO1 --> GEO2 et ITABEL(i) --> INOUVEL(i)
  101. SEGMENT ITABEL(0)
  102. SEGMENT INOUVEL(0)
  103.  
  104. idimp1=IDIM+1
  105. ANGLE=0.
  106.  
  107. C Signification de ITYP (argument de PROPER) :
  108. C - ITYP = 1 : operateur PLUS
  109. C - ITYP = 2 : operateur MOIN
  110. C - ITYP = 3 : operateur TOUR (via sp tourne.eso)
  111. C - ITYP = 4 : operateur DEDU 'TRAN' (via sp dedu.eso)
  112. C - ITYP = 5 : operateur DEDU 'ROTA' (via sp dedu.eso)
  113. IF ((ITYP.EQ.1).OR.(ITYP.EQ.4)) THEN
  114. ICLE=1
  115. ISENS=1
  116. ENDIF
  117. IF (ITYP.EQ.2) THEN
  118. ICLE=1
  119. ISENS=-1
  120. ENDIF
  121. IF ((ITYP.EQ.3).OR.(ITYP.EQ.5)) THEN
  122. ICLE=2
  123. C Lecture (obligatoire) de l'angle de rotation
  124. CALL LIRREE(FLO1,1,IRETOU)
  125. IF (IRETOU.EQ.0) THEN
  126. CALL ERREUR(884)
  127. RETURN
  128. ENDIF
  129. ANGLE=FLO1-INT(FLO1/360.)*360.
  130. IF (ANGLE.GT.180.) ANGLE=ANGLE-360.
  131. IF (ANGLE.LT.(-180.)) ANGLE=ANGLE+360.
  132. ANGLE=ANGLE*XPI/180.
  133. CO=COS(ANGLE)
  134. SI=SIN(ANGLE)
  135. ENDIF
  136. C Rappel : ICLE=2 (rotation) n'est disponible que si IDIM = 2 ou 3
  137.  
  138. C Nombre d'objets definissant l'operation a effectuer
  139. IF ((ITYP.EQ.1).OR.(ITYP.EQ.2)) MINIOBJ=1
  140. IF ((ITYP.EQ.3).AND.(IDIM.EQ.2)) MINIOBJ=1
  141. IF ((ITYP.EQ.3).AND.(IDIM.GE.3)) MINIOBJ=2
  142. IF (ITYP.EQ.4) MINIOBJ=2
  143. IF ((ITYP.EQ.5).AND.(IDIM.EQ.2)) MINIOBJ=3
  144. IF ((ITYP.EQ.5).AND.(IDIM.GE.3)) MINIOBJ=4
  145.  
  146. C Tableau des types d'objets pouvant etre transformes
  147. NTY2=6
  148. SEGINI MLITY
  149. LITY2(1)='POINT '
  150. LITY2(2)='MAILLAGE'
  151. LITY2(3)='CHPOINT '
  152. LITY2(4)='MMODEL '
  153. LITY2(5)='MCHAML '
  154. LITY2(6)='RIGIDITE'
  155. SEGDES MLITY
  156. ITOPE=' '
  157. itab=0
  158. C Stockage dans le segment PILO (pointeur IP1) de tous les objets,
  159. C donnes en entree a l'operateur et dont le type est inclus dans MLITY
  160. C (type POINT,MAILLAGE,CHPOINT,MCHAML,MMODEL ou RIGIDITE)
  161. CALL EMPIL1(IP1,MLITY,IRETOU,itab,iposi)
  162. PILO=ip1
  163. segact pilo
  164. IF (IERR.NE.0) GO TO 100
  165. IF (IRETOU.EQ.20) THEN
  166. MOTERR(1:30) ='POINT ou MAILLAGE ou CHPOINT'
  167. CALL ERREUR(881)
  168. GOTO 100
  169. ENDIF
  170.  
  171. PILO=IP1
  172. SEGACT PILO
  173. NIOBJ=PILO(/1)
  174. C Erreur si pas assez d'objets (pas d'objets a transformer de donner)
  175. IF (NIOBJ.LE.MINIOBJ) THEN
  176. MOTERR(1:30) =' d autres arguments '
  177. CALL ERREUR(881)
  178. GOTO 100
  179. ENDIF
  180.  
  181. C Lecture des MINIOBJ objets definissant la transformation a effectuer
  182. C ======================================================================
  183. DSOBJ=nint(PILO(NIOBJ))
  184. SEGACT DSOBJ
  185. ITOPE=LETYP
  186. IPOIN1=INIPOI
  187. SEGDES DSOBJ
  188. C Option DEDU 'TRAN' :
  189. C ----------------------
  190. IF (ITYP.EQ.4) THEN
  191. C Syntaxe incorrecte : maillage GEO2 attendu
  192. IF (ITOPE.NE.'MAILLAGE') THEN
  193. MOTERR(1:30) ='un MAILLAGE '
  194. CALL ERREUR(881)
  195. GOTO 100
  196. ENDIF
  197. IPT2=IPOIN1
  198. DSOBJ=nint(PILO(NIOBJ-1))
  199. SEGACT DSOBJ
  200. IPT1=INIPOI
  201. ITOPE=LETYP
  202. SEGDES DSOBJ
  203. C Syntaxe incorrecte : maillage GEO1 attendu
  204. IF (ITOPE.NE.'MAILLAGE') THEN
  205. MOTERR(1:30) = 'un MAILLAGE '
  206. CALL ERREUR(881)
  207. GOTO 100
  208. ENDIF
  209. CALL DEDU1(IPT1,IPT2,ICP1,ITABEL,INOUVEL,IPOIN1)
  210. IF (IERR.NE.0) GOTO 100
  211. ITOPE='CHPOINT '
  212. ICPR=ICP1
  213. SEGACT ITABEL*MOD,INOUVEL*MOD
  214. ENDIF
  215. C Option DEDU 'ROTA' :
  216. C ----------------------
  217. IF (ITYP.EQ.5) THEN
  218. C Syntaxe incorrecte : maillage GEO2 attendu
  219. IF (ITOPE.NE.'MAILLAGE') THEN
  220. MOTERR(1:30) ='un MAILLAGE '
  221. CALL ERREUR(881)
  222. GOTO 100
  223. ENDIF
  224. IPT2=IPOIN1
  225. DSOBJ=nint(PILO(NIOBJ-1))
  226. SEGACT DSOBJ
  227. IPT1=INIPOI
  228. ITOPE=LETYP
  229. SEGDES DSOBJ
  230. C Syntaxe incorrecte : maillage GEO1 attendu
  231. IF (ITOPE.NE.'MAILLAGE') THEN
  232. MOTERR(1:30) = 'un MAILLAGE '
  233. CALL ERREUR(881)
  234. GOTO 100
  235. ENDIF
  236. CALL DEDU1(IPT1,IPT2,ICP1,ITABEL,INOUVEL,IPOIN1)
  237. IF (IERR.NE.0) GOTO 100
  238. DSOBJ=nint(PILO(NIOBJ-2))
  239. SEGACT DSOBJ
  240. IPOIN1=INIPOI
  241. ITOPE=LETYP
  242. SEGDES DSOBJ
  243. C Syntaxe incorrecte : POINT attendu (centre 2D, 2nd point axe 3D)
  244. IF (ITOPE.NE.'POINT ') THEN
  245. MOTERR(1:30) = 'un POINT '
  246. CALL ERREUR(881)
  247. GOTO 100
  248. ENDIF
  249. SEGACT MCOORD
  250. IREF=IPOIN1*idimp1-IDIM
  251. XPT1=XCOOR(IREF)
  252. YPT1=XCOOR(IREF+1)
  253. IF (IDIM.LT.3) THEN
  254. ZPT1=0.
  255. XVEC=0.
  256. YVEC=0.
  257. ZVEC=1.
  258. ELSE
  259. DSOBJ=nint(PILO(NIOBJ-3))
  260. SEGACT DSOBJ
  261. ITOPE=LETYP
  262. IPT2=INIPOI
  263. SEGDES DSOBJ
  264. C Syntaxe incorrecte : POIN1 attendu en 3D (1er point axe rotation)
  265. IF (ITOPE.NE.'POINT ') THEN
  266. MOTERR(1:30) = 'deux POINTs '
  267. CALL ERREUR(881)
  268. GOTO 100
  269. ENDIF
  270. XPT2=XPT1
  271. YPT2=YPT1
  272. ZPT2=XCOOR(IREF+2)
  273. IREF=IPT2*idimp1-IDIM
  274. XPT1=XCOOR(IREF)
  275. YPT1=XCOOR(IREF+1)
  276. ZPT1=XCOOR(IREF+2)
  277. XVEC=XPT2-XPT1
  278. YVEC=YPT2-YPT1
  279. ZVEC=ZPT2-ZPT1
  280. DVEC=SQRT(XVEC*XVEC+YVEC*YVEC+ZVEC*ZVEC)
  281. XVEC=XVEC/DVEC
  282. YVEC=YVEC/DVEC
  283. ZVEC=ZVEC/DVEC
  284. ENDIF
  285. XV1=-YVEC
  286. YV1=XVEC
  287. DV1=XV1*XV1+YV1*YV1
  288. IF (DV1.GE.0.1) THEN
  289. ZV1=0.
  290. DV1=SQRT(DV1)
  291. XV1=XV1/DV1
  292. YV1=YV1/DV1
  293. ELSE
  294. XV1=0.
  295. YV1=-ZVEC
  296. ZV1=YVEC
  297. DV1=SQRT(YV1*YV1+ZV1*ZV1)
  298. YV1=YV1/DV1
  299. ZV1=ZV1/DV1
  300. ENDIF
  301. XV2=YVEC*ZV1-ZVEC*YV1
  302. YV2=ZVEC*XV1-XVEC*ZV1
  303. ZV2=XVEC*YV1-YVEC*XV1
  304. ICPR=ICP1
  305. SEGACT ITABEL*MOD,INOUVEL*MOD
  306. ENDIF
  307. C Operateurs PLUS et MOIN :
  308. C ---------------------------
  309. IF ((ITYP.EQ.1).OR.(ITYP.EQ.2)) THEN
  310. IF ((ITOPE.NE.'MAILLAGE').AND.(ITOPE.NE.'POINT ').AND.
  311. . (ITOPE.NE.'CHPOINT ')) THEN
  312. C Syntaxe incorrecte : le vecteur VEC1, le champ par point CHPO1 ou
  313. C le maillage GEO1 etait attendu
  314. MOTERR(1:30) ='un POINT, CHPOINT ou MAILLAGE'
  315. CALL ERREUR(881)
  316. GOTO 100
  317. ENDIF
  318. C Deplacement (translation) donne par un vecteur VEC1
  319. IF (ITOPE.EQ.'POINT ') THEN
  320. IREF=(IPOIN1-1)*idimp1
  321. SEGACT MCOORD
  322. DO i=1,IDIM
  323. Y(i)=XCOOR(IREF+i)*ISENS
  324. ENDDO
  325. C Deplacement donne par un champ point CHPO1
  326. ELSE IF (ITOPE.EQ.'CHPOINT ') THEN
  327. C Cas particulier : operateur MOINS - maillage GEO1 donne
  328. ELSE IF (ITOPE.EQ.'MAILLAGE') THEN
  329. IPT1=IPOIN1
  330. DSOBJ=nint(PILO(NIOBJ-1))
  331. SEGACT DSOBJ
  332. IPT2=INIPOI
  333. ITOPE=LETYP
  334. SEGDES DSOBJ
  335. C Syntaxe incorrecte : maillage GEO2 attendu
  336. IF (ITOPE.NE.'MAILLAGE') THEN
  337. MOTERR(1:30) = 'un MAILLAGE '
  338. CALL ERREUR(881)
  339. GOTO 100
  340. ENDIF
  341. GOTO 500
  342. ENDIF
  343. SEGINI ICPR,INOUVEL,ITABEL
  344. ENDIF
  345. C Operateur TOUR :
  346. C ------------------
  347. IF (ITYP.EQ.3) THEN
  348. C Syntaxe incorrecte : POINT attendu (centre 2D, 2nd point axe 3D)
  349. IF (ITOPE.NE.'POINT ') THEN
  350. MOTERR(1:30) = 'un POINT '
  351. CALL ERREUR(881)
  352. GOTO 100
  353. ENDIF
  354. SEGACT MCOORD
  355. IREF=IPOIN1*idimp1-IDIM
  356. XPT1=XCOOR(IREF)
  357. YPT1=XCOOR(IREF+1)
  358. IF (IDIM.LT.3) THEN
  359. ZPT1=0.
  360. XVEC=0.
  361. YVEC=0.
  362. ZVEC=1.
  363. ELSE
  364. DSOBJ=nint(PILO(NIOBJ-1))
  365. SEGACT DSOBJ
  366. ITOPE=LETYP
  367. IPT2=INIPOI
  368. SEGDES DSOBJ
  369. C Syntaxe incorrecte : POINT attendu en 3D (1er point axe rotation)
  370. IF (ITOPE.NE.'POINT ') THEN
  371. MOTERR(1:30) = 'deux POINTs '
  372. CALL ERREUR(881)
  373. GOTO 100
  374. ENDIF
  375. XPT2=XPT1
  376. YPT2=YPT1
  377. ZPT2=XCOOR(IREF+2)
  378. IREF=IPT2*idimp1-IDIM
  379. XPT1=XCOOR(IREF)
  380. YPT1=XCOOR(IREF+1)
  381. ZPT1=XCOOR(IREF+2)
  382. XVEC=XPT2-XPT1
  383. YVEC=YPT2-YPT1
  384. ZVEC=ZPT2-ZPT1
  385. DVEC=SQRT(XVEC*XVEC+YVEC*YVEC+ZVEC*ZVEC)
  386. XVEC=XVEC/DVEC
  387. YVEC=YVEC/DVEC
  388. ZVEC=ZVEC/DVEC
  389. ENDIF
  390. XV1=-YVEC
  391. YV1=XVEC
  392. DV1=XV1*XV1+YV1*YV1
  393. IF (DV1.GE.0.1) THEN
  394. ZV1=0.
  395. DV1=SQRT(DV1)
  396. XV1=XV1/DV1
  397. YV1=YV1/DV1
  398. ELSE
  399. XV1=0.
  400. YV1=-ZVEC
  401. ZV1=YVEC
  402. DV1=SQRT(YV1*YV1+ZV1*ZV1)
  403. YV1=YV1/DV1
  404. ZV1=ZV1/DV1
  405. ENDIF
  406. XV2=YVEC*ZV1-ZVEC*YV1
  407. YV2=ZVEC*XV1-XVEC*ZV1
  408. ZV2=XVEC*YV1-YVEC*XV1
  409. SEGINI ICPR,INOUVEL,ITABEL
  410. ENDIF
  411.  
  412. C Boucle sur tous les objets a transformer
  413. C ==========================================
  414. DO 200 L=1,NIOBJ-MINIOBJ
  415. DSOBJ=nint(PILO(L))
  416. SEGACT DSOBJ*MOD
  417. SEGINI IPLMAIL
  418. C IPLMAIL contient tous les maillages elementaires de l'objet L initial
  419. C Creation objet transforme (INIFIN) par copie objet initial (INIPOI)
  420. IF (LETYP.EQ.'MAILLAGE') THEN
  421. IPLMAIL(**)=INIPOI
  422. ELSE IF (LETYP.EQ.'CHPOINT ') THEN
  423. MCHPO1=INIPOI
  424. CALL COPIE2(MCHPO1,MCHPOI)
  425. INIFIN=MCHPOI
  426. SEGACT MCHPOI
  427. DO i=1,IPCHP(/1)
  428. MSOUPO=IPCHP(i)
  429. SEGACT MSOUPO
  430. IPLMAIL(**)=IGEOC
  431. SEGDES MSOUPO
  432. ENDDO
  433. SEGDES MCHPOI
  434. ELSE IF (LETYP.EQ.'MCHAML ') THEN
  435. MCHEL1=INIPOI
  436. CALL COPIE8(MCHEL1,MCHELM)
  437. INIFIN=MCHELM
  438. SEGACT MCHELM
  439. DO i=1,IMACHE(/1)
  440. IPLMAIL(**)=IMACHE(i)
  441. ENDDO
  442. SEGDES MCHELM
  443. ELSE IF (LETYP.EQ.'MMODEL ') THEN
  444. MMODE1=INIPOI
  445. CALL COPIE9(MMODE1,MMODEL)
  446. INIFIN=MMODEL
  447. SEGACT MMODEL
  448. DO i=1,KMODEL(/1)
  449. IMODEL=KMODEL(i)
  450. SEGACT IMODEL
  451. IPLMAIL(**)=IMAMOD
  452. SEGDES IMODEL
  453. ENDDO
  454. SEGDES MMODEL
  455. ELSE IF (LETYP.EQ.'RIGIDITE') THEN
  456. C Syntaxe incorrecte SSI objets RIGIDITE transformes via un CHPOINT
  457. c IPOIN1 qui n'est pas une translation => test dans DEDU3
  458. XERR1 = 0.D0
  459. IF (ITOPE.EQ.'CHPOINT ') THEN
  460. if(ITYP.eq.4) call DEDU3(IPOIN1,XERR1)
  461. if(ITYP.eq.5) XERR1 = 1.D0
  462. ENDIF
  463. IF (XERR1.GT.(1.D-10)) THEN
  464. CALL ERREUR(882)
  465. GOTO 100
  466. ENDIF
  467. RI1=INIPOI
  468. SEGINI,MRIGID=RI1
  469. INIFIN=MRIGID
  470. DO i=1,IRIGEL(/2)
  471. IPLMAIL(**)=IRIGEL(1,i)
  472. ENDDO
  473. SEGDES MRIGID
  474. ELSE IF (LETYP.EQ.'POINT ') THEN
  475. C Cas particulier syntaxe : POIN2 = POIN1 PLUS (MOIN) CHPO1;
  476. C Creation d'un maillage IPT9 contenant un element POI1
  477. IF (ITOPE.EQ.'CHPOINT ') THEN
  478. NBNN=1
  479. NBELEM=1
  480. NBSOUS=0
  481. NBREF=0
  482. SEGINI MELEME
  483. NUM(1,1)=INIPOI
  484. SEGDES MELEME
  485. IPT9=MELEME
  486. IPLMAIL(**)=IPT9
  487. ELSE
  488. C Cas particulier syntaxe : POIN2 = POIN1 PLUS (MOIN) VECT1;
  489. GOTO 210
  490. ENDIF
  491. ENDIF
  492. C Boucle sur les sous-zones de l'objet L a transformer
  493. C Pour ne transformer qu'une seule fois les maillages elementaires, on
  494. C verifie si la zone elementaire est presente dans ITABEL. Si ce n'est
  495. C pas le cas, on doit alors transformer cette zone et on met a jour
  496. C ITABEL et INOUVEL en consequence.
  497. C IPLMAIL contient initialement le maillage a transformer et a la fin
  498. C de la boucle le maillage image (transforme)
  499. DO IMEL=1,IPLMAIL(/1)
  500. MELEME=IPLMAIL(IMEL)
  501. SEGACT MELEME
  502. NBSOUS=LISOUS(/1)
  503. NBREF=LISREF(/1)
  504. C Transformation des sous-objets s'ils existents
  505. IF (NBSOUS.NE.0) THEN
  506. NBNN=0
  507. NBELEM=0
  508. SEGINI IPT1
  509. C Boucle sur les sous-objets
  510. DO J=1,NBSOUS
  511. IF (ITABEL(/1).NE.0) THEN
  512. DO K=1,ITABEL(/1)
  513. C Verification si ce maillage n'a pas deja ete transforme
  514. IF (ITABEL(K).EQ.LISOUS(J)) THEN
  515. IPT1.LISOUS(J)=INOUVEL(K)
  516. GOTO 201
  517. ENDIF
  518. ENDDO
  519. ENDIF
  520. MELE1=LISOUS(J)
  521. C Verification pour DEDU que tous les POINTs de l'objet MELE1 subissent
  522. C la transformation i.e. ont une image, soit ICP(i) non nul
  523. IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) THEN
  524. CALL DEDU2(MELE1,ICPR,IRETOU,ITYP)
  525. IF (IERR.NE.0) THEN
  526. SEGSUP IPLMAIL
  527. GOTO 300
  528. ENDIF
  529. IF (IRETOU.NE.0) THEN
  530. INTERR(1)=L
  531. CALL ERREUR(883)
  532. SEGSUP IPLMAIL
  533. GOTO 300
  534. ENDIF
  535. ENDIF
  536. ITABEL(**)=LISOUS(J)
  537. C Operateur DEDU : activation obligatoire du segment ICPR
  538. IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) SEGACT ICPR
  539. C Transformation du maillage MELE1 en NOUV suivant ICLE
  540. IF ((ITOPE.EQ.'POINT ').AND.(ICLE.EQ.1)) THEN
  541. CALL ADDITI(Y,MELE1,NOUV,ICPR)
  542. ELSE IF ((ITOPE.EQ.'CHPOINT ').AND.(ICLE.EQ.1)) THEN
  543. CALL CHDITI(IPOIN1,MELE1,NOUV,ICPR,ISENS)
  544. ELSE IF (ICLE.EQ.2) THEN
  545. CALL ADDITI(Y,MELE1,NOUV,ICPR)
  546. ENDIF
  547. INOUVEL(**)=NOUV
  548. IPT1.LISOUS(J)=NOUV
  549. 201 CONTINUE
  550. ENDDO
  551. C Boucle sur les references si elles existent
  552. IF (NBREF.NE.0) THEN
  553. DO J=1,NBREF
  554. DO K=1,ITABEL(/1)
  555. C Verification si ce maillage n'a pas deja ete transforme
  556. IF (ITABEL(K).EQ.LISREF(J)) THEN
  557. IPT1.LISREF(J)=INOUVEL(K)
  558. GOTO 202
  559. ENDIF
  560. ENDDO
  561. MELE1=LISREF(J)
  562. C Verification pour DEDU que tous les POINTs de l'objet MELE1 subissent
  563. C la transformation i.e. ont une image, soit ICP(i) non nul
  564. IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) THEN
  565. CALL DEDU2(MELE1,ICPR,IRETOU,ITYP)
  566. IF (IERR.NE.0) THEN
  567. SEGSUP IPLMAIL
  568. GOTO 300
  569. ENDIF
  570. IF (IRETOU.NE.0) THEN
  571. INTERR(1)=L
  572. CALL ERREUR(883)
  573. SEGSUP IPLMAIL
  574. GOTO 300
  575. ENDIF
  576. ENDIF
  577. ITABEL(**)=LISREF(J)
  578. C Operateur DEDU : activation obligatoire du segment ICPR
  579. IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) SEGACT ICPR
  580. C Transformation du maillage MELE1 en NOUV suivant ICLE
  581. IF ((ITOPE.EQ.'POINT ').AND.(ICLE.EQ.1)) THEN
  582. CALL ADDITI(Y,MELE1,NOUV,ICPR)
  583. ELSE IF ((ITOPE.EQ.'CHPOINT ').AND.(ICLE.EQ.1)) THEN
  584. CALL CHDITI(IPOIN1,MELE1,NOUV,ICPR,ISENS)
  585. ELSE IF (ICLE.EQ.2) THEN
  586. CALL ADDITI(Y,MELE1,NOUV,ICPR)
  587. ENDIF
  588. INOUVEL(**)=NOUV
  589. IPT1.LISREF(J)=NOUV
  590. 202 CONTINUE
  591. ENDDO
  592. ENDIF
  593. SEGDES IPT1
  594. IPLMAIL(IMEL)=IPT1
  595. C L'objet est elementaire
  596. ELSE
  597. IF (ITABEL(/1).NE.0) THEN
  598. C Verification si ce maillage n'a pas deja ete transforme
  599. DO K=1,ITABEL(/1)
  600. IF (ITABEL(K).EQ.MELEME) THEN
  601. IPLMAIL(IMEL)=INOUVEL(K)
  602. GOTO 203
  603. ENDIF
  604. ENDDO
  605. ENDIF
  606. C Verification pour DEDU que tous les POINTs de l'objet MELE1 subissent
  607. C la transformation i.e. ont une image, soit ICP(i) non nul
  608. IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) THEN
  609. CALL DEDU2(MELEME,ICPR,IRETOU,ITYP)
  610. IF (IERR.NE.0) THEN
  611. SEGSUP IPLMAIL
  612. GOTO 300
  613. ENDIF
  614. IF (IRETOU.NE.0) THEN
  615. INTERR(1)=L
  616. CALL ERREUR(883)
  617. SEGSUP IPLMAIL
  618. GOTO 300
  619. ENDIF
  620. ENDIF
  621. ITABEL(**)=MELEME
  622. C Operateur DEDU : activation obligatoire du segment ICPR
  623. IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) SEGACT ICPR
  624. C Transformation du maillage MELE1 en NOUV suivant ICLE
  625. IF ((ITOPE.EQ.'POINT ').AND.(ICLE.EQ.1)) THEN
  626. CALL ADDITI(Y,MELEME,NOUV,ICPR)
  627. ELSE IF ((ITOPE.EQ.'CHPOINT ').AND.(ICLE.EQ.1)) THEN
  628. CALL CHDITI(IPOIN1,MELEME,NOUV,ICPR,ISENS)
  629. ELSE IF (ICLE.EQ.2) THEN
  630. CALL ADDITI(Y,MELEME,NOUV,ICPR)
  631. ENDIF
  632. INOUVEL(**)=NOUV
  633. IPLMAIL(IMEL)=NOUV
  634. ENDIF
  635. 203 CONTINUE
  636. SEGDES MELEME
  637. ENDDO
  638. C Fin de la boucle : le maillage support de l'objet L a ete transforme
  639. C Mise a jour de INIFIN (DSOBJ) en consequence avec transformation des
  640. C composantes si l'objet est un CHPOINT ou MCHAML et ICLE=2 (rotation)
  641. 210 IF (LETYP.EQ.'MAILLAGE') THEN
  642. INIFIN=IPLMAIL(1)
  643. ELSE IF (LETYP.EQ.'CHPOINT ') THEN
  644. MCHPOI=INIFIN
  645. SEGACT MCHPOI*MOD
  646. DO i=1,IPCHP(/1)
  647. MSOUPO=IPCHP(i)
  648. SEGACT MSOUPO*MOD
  649. IGEOC=IPLMAIL(i)
  650. SEGDES MSOUPO
  651. ENDDO
  652. SEGDES MCHPOI
  653. IF (ICLE.EQ.2) CALL TOCH1(MCHPOI,'CHPOINT ',IRETOU)
  654. ELSE IF (LETYP.EQ.'MCHAML ') THEN
  655. MCHELM=INIFIN
  656. SEGACT MCHELM*MOD
  657. DO i=1,IMACHE(/1)
  658. IMACHE(i)=IPLMAIL(i)
  659. ENDDO
  660. SEGDES MCHELM
  661. IF (ICLE.EQ.2) CALL TOCH1(MCHELM,'MCHAML ',IRETOU)
  662. ELSE IF (LETYP.EQ.'MMODEL ') THEN
  663. MMODEL=INIFIN
  664. SEGACT MMODEL*MOD
  665. DO i=1,KMODEL(/1)
  666. IMODEL=KMODEL(i)
  667. SEGACT IMODEL*MOD
  668. IMAMOD=IPLMAIL(i)
  669. SEGDES IMODEL
  670. ENDDO
  671. SEGDES MMODEL
  672. ELSE IF (LETYP.EQ.'RIGIDITE') THEN
  673. MRIGID=INIFIN
  674. SEGACT MRIGID*MOD
  675. DO i=1,IRIGEL(/2)
  676. IRIGEL(1,i)=IPLMAIL(i)
  677. ENDDO
  678. SEGDES MRIGID
  679. ELSE IF (LETYP.EQ.'POINT ') THEN
  680. C Cas particulier - Syntaxe : POIN2 = POIN1 'PLUS' VECT1 ;
  681. IF (ITOPE.EQ.'POINT ') THEN
  682. IPOIN1=INIPOI
  683. if(icpr(ipoin1).ne.0) then
  684. inifin=icpr(ipoin1)
  685. else
  686. NBPTS=XCOOR(/1)/idimp1+1
  687. inifin=nbpts
  688. SEGADJ MCOORD
  689. IREF=(IPOIN1-1)*idimp1
  690. IPTFIN=(NBPTS-1)*idimp1
  691. IF ((ICPR(IPOIN1).EQ.0).AND.(ICLE.EQ.1)) THEN
  692. DO i=1,IDIM
  693. XCOOR(IPTFIN+i)=XCOOR(IREF+i)+Y(i)
  694. ENDDO
  695. XCOOR(IPTFIN+idimp1)=DENSIT
  696. ELSE IF ((ICPR(IPOIN1).EQ.0).AND.(ICLE.EQ.2)) THEN
  697. XD=XCOOR(IREF+1)-XPT1
  698. YD=XCOOR(IREF+2)-YPT1
  699. ZD=0.
  700. IF (IDIM.GE.3) ZD=XCOOR(IREF+3)-ZPT1
  701. XE=XD*XV1+YD*YV1+ZD*ZV1
  702. YE=XD*XV2+YD*YV2+ZD*ZV2
  703. ZE=XD*XVEC+YD*YVEC+ZD*ZVEC
  704. XD=XE*CO-YE*SI
  705. YD=XE*SI+YE*CO
  706. ZD=ZE
  707. XCOOR(IPTFIN+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1
  708. XCOOR(IPTFIN+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1
  709. IF (IDIM.GE.3) XCOOR(IPTFIN+3)=XD*ZV1+YD*ZV2+ZD*ZVEC+ZPT1
  710. XCOOR(IPTFIN+idimp1)=XCOOR(IREF+idimp1)
  711. C** ELSE IF (ICPR(IPOIN1).NE.0) THEN
  712. ICPR(IPOIN1)=INIFIN
  713. ENDIF
  714. endif
  715. ELSE
  716. C Cas particulier - Syntaxe 2 : POIN2 = POIN1 'PLUS' CHPO1 ;
  717. SEGSUP IPT9
  718. IPT9=IPLMAIL(1)
  719. SEGACT IPT9
  720. INIFIN=IPT9.NUM(1,1)
  721. SEGSUP IPT9
  722. ENDIF
  723. ENDIF
  724. SEGDES DSOBJ
  725. SEGSUP IPLMAIL
  726. 200 CONTINUE
  727. C Fin de la boucle sur les objets DSOBJ a transformer
  728.  
  729. C Ecriture dans la pile des objets transformes
  730. * cas particulier si on avait lu une table
  731. if(itab.ne.0) then
  732. mtable=itab
  733. segact mtable*mod
  734. segact iposi
  735. endif
  736. DO i=NIOBJ-MINIOBJ,1,-1
  737. DSOBJ=nint(PILO(i))
  738. SEGACT DSOBJ
  739. *
  740. IF(LETYP.EQ.'MMODEL ') THEN
  741. MMODEL=INIFIN
  742. SEGACT MMODEL
  743. NSOUS = KMODEL(/1)
  744. * on change les maillages des modeles pointes par un modele MELANGE
  745. * et le pointeur du modele
  746. do im = 1,NSOUS
  747. imodel = kmodel(im)
  748. segact imodel*mod
  749. if (formod(1).eq.'MELANGE') then
  750. if (ivamod(/1).ge.1) then
  751. do ivm1 = 1,ivamod(/1)
  752. if (tymode(ivm1).eq.'IMODEL') then
  753. imode1 = ivamod(ivm1)
  754. segini,imode2=imode1
  755. imode2.imamod = imamod
  756. ivamod(ivm1) = imode2
  757. segdes imode2
  758. endif
  759. enddo
  760. endif
  761. endif
  762. segdes imodel
  763. enddo
  764. SEGDES MMODEL
  765. ENDIF
  766. *
  767. IF(itab.ne.0) then
  768. ipotab=iposit(i)
  769. mtabiv(ipotab)=inifin
  770. ELSE
  771. CALL ECROBJ(LETYP,INIFIN)
  772. ENDIF
  773. SEGDES DSOBJ
  774. ENDDO
  775. if( itab.ne.0) then
  776. call ecrobj('TABLE ',mtable)
  777. segdes mtable
  778. segsup iposi
  779. endif
  780.  
  781. C Un peu de menage
  782. 300 SEGSUP ICPR,ITABEL,INOUVEL
  783. GOTO 100
  784.  
  785. C Cas particulier - Operateur MOINS : CHPO1 = 'MOIN' GEO1 GEO2 ;
  786. c Calcul du CHPOINT permettant de passer de GEO1 a GEO2
  787. 500 SEGINI ICP1
  788. SEGACT IPT1,IPT2
  789. NBSOUS1=IPT1.LISOUS(/1)
  790. NBSOUS2=IPT2.LISOUS(/1)
  791. *Gounand : Utilité ? NBREF1=IPT1.LISREF(/1)
  792. *G NBREF2=IPT2.LISREF(/1)
  793. IF (NBSOUS1.NE.NBSOUS2) GOTO 502
  794. *G IF (NBREF1.NE.NBREF2) GOTO 502
  795. IF (NBSOUS1.EQ.0) THEN
  796. IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 502
  797. IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) GOTO 502
  798. IF (IPT1.NUM(/2).NE.IPT2.NUM(/2)) GOTO 502
  799. CALL PROCHP(IPT1,IPT2,IPOIN1,ICP1)
  800. IF (IERR.NE.0) GOTO 502
  801. ELSE IF (NBSOUS1.NE.0) THEN
  802. DO j=1,NBSOUS1
  803. IPT3=IPT1.LISOUS(j)
  804. IPT4=IPT2.LISOUS(j)
  805. SEGACT IPT3,IPT4
  806. NBSOUS3=IPT3.LISOUS(/1)
  807. NBSOUS4=IPT4.LISOUS(/1)
  808. *G NBREF3=IPT3.LISREF(/1)
  809. *G NBREF4=IPT4.LISREF(/1)
  810. IF (NBSOUS3.NE.NBSOUS4) GOTO 501
  811. *G IF (NBREF3.NE.NBREF4) GOTO 501
  812. IF (IPT3.ITYPEL.NE.IPT4.ITYPEL) GOTO 501
  813. IF (IPT3.NUM(/1).NE.IPT4.NUM(/1)) GOTO 501
  814. IF (IPT3.NUM(/2).NE.IPT4.NUM(/2)) GOTO 501
  815. SEGDES IPT3,IPT4
  816. CALL PROCHP(IPT3,IPT4,IPOIN1,ICP1)
  817. IF (IERR.NE.0) GOTO 501
  818. IF (j.EQ.1) THEN
  819. IPCHP0=IPOIN1
  820. ELSE
  821. CALL FUCHPO(IPCHP0,IPOIN1,IRET)
  822. IPCHP0=IRET
  823. ENDIF
  824. IF (IERR.NE.0) GOTO 501
  825. ENDDO
  826. IPOIN1=IPCHP0
  827. ENDIF
  828. SEGDES IPT1,IPT2
  829. C Ecriture du CHPOINT calcule
  830. CALL ECROBJ('CHPOINT ',IPOIN1)
  831. C Pour les autres objets DSOBJ, INIFIN=0 donc pas ecrits ?
  832. DO i=NIOBJ-1,2,-1
  833. DSOBJ=nint(PILO(i))
  834. SEGACT DSOBJ
  835. CALL ECROBJ(LETYP,INIFIN)
  836. SEGDES DSOBJ
  837. ENDDO
  838. GOTO 100
  839.  
  840. C Syntaxe particuliere : CHP1 = GEO1 'MOIN' GEO2 ;
  841. C Erreur dans le calcul du CHPOINT, incompatibilite entre les maillages
  842. 501 SEGDES IPT3,IPT4
  843. 502 SEGDES IPT1,IPT2
  844. CALL ERREUR(878)
  845. SEGSUP ICP1
  846.  
  847. C Sortie du sousprogramme - Suppression des segments locaux
  848. 100 if(PILO.NE.0) then
  849. DO i=1,PILO(/1)
  850. DSOBJ=nint(PILO(i))
  851. SEGSUP DSOBJ
  852. ENDDO
  853. SEGSUP PILO
  854. ENDIF
  855. segsup MLITY
  856. RETURN
  857. END
  858.  
  859.  
  860.  
  861.  
  862.  
  863.  
  864.  
  865.  
  866.  
  867.  
  868.  
  869.  
  870.  
  871.  
  872.  
  873.  
  874.  
  875.  
  876.  
  877.  
  878.  
  879.  

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