Télécharger proper.eso

Retour à la liste

Numérotation des lignes :

  1. C PROPER SOURCE CB215821 19/07/31 21:16:49 10277
  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,MO8
  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.D0
  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.D0)*360.D0
  130. IF (ANGLE.GT.180.D0) ANGLE=ANGLE-360.D0
  131. IF (ANGLE.LT.(-180.D0)) ANGLE=ANGLE+360.D0
  132. ANGLE=ANGLE*XPI/180.D0
  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=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=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=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=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.D0
  255. XVEC=0.D0
  256. YVEC=0.D0
  257. ZVEC=1.D0
  258. ELSE
  259. DSOBJ=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.1D0) THEN
  289. ZV1=0.D0
  290. DV1=SQRT(DV1)
  291. XV1=XV1/DV1
  292. YV1=YV1/DV1
  293. ELSE
  294. XV1=0.D0
  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=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.D0
  360. XVEC=0.D0
  361. YVEC=0.D0
  362. ZVEC=1.D0
  363. ELSE
  364. DSOBJ=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.1D0) THEN
  394. ZV1=0.D0
  395. DV1=SQRT(DV1)
  396. XV1=XV1/DV1
  397. YV1=YV1/DV1
  398. ELSE
  399. XV1=0.D0
  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=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))
  584. $ THEN
  585. CALL CHDITI(IPOIN1,MELE1,NOUV,ICPR,ISENS)
  586. ELSE IF (ICLE.EQ.2) THEN
  587. CALL ADDITI(Y,MELE1,NOUV,ICPR)
  588. ENDIF
  589. INOUVEL(**)=NOUV
  590. IPT1.LISREF(J)=NOUV
  591. 202 CONTINUE
  592. ENDDO
  593. ENDIF
  594. SEGDES IPT1
  595. IPLMAIL(IMEL)=IPT1
  596. C L'objet est elementaire
  597. ELSE
  598. IF (ITABEL(/1).NE.0) THEN
  599. C Verification si ce maillage n'a pas deja ete transforme
  600. DO K=1,ITABEL(/1)
  601. IF (ITABEL(K).EQ.MELEME) THEN
  602. IPLMAIL(IMEL)=INOUVEL(K)
  603. GOTO 203
  604. ENDIF
  605. ENDDO
  606. ENDIF
  607. C Verification pour DEDU que tous les POINTs de l'objet MELE1 subissent
  608. C la transformation i.e. ont une image, soit ICP(i) non nul
  609. IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) THEN
  610. CALL DEDU2(MELEME,ICPR,IRETOU,ITYP)
  611. IF (IERR.NE.0) THEN
  612. SEGSUP IPLMAIL
  613. GOTO 300
  614. ENDIF
  615. IF (IRETOU.NE.0) THEN
  616. INTERR(1)=L
  617. CALL ERREUR(883)
  618. SEGSUP IPLMAIL
  619. GOTO 300
  620. ENDIF
  621. ENDIF
  622. ITABEL(**)=MELEME
  623. C Operateur DEDU : activation obligatoire du segment ICPR
  624. IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) SEGACT ICPR
  625. C Transformation du maillage MELE1 en NOUV suivant ICLE
  626. IF ((ITOPE.EQ.'POINT ').AND.(ICLE.EQ.1)) THEN
  627. CALL ADDITI(Y,MELEME,NOUV,ICPR)
  628. ELSE IF ((ITOPE.EQ.'CHPOINT ').AND.(ICLE.EQ.1)) THEN
  629. CALL CHDITI(IPOIN1,MELEME,NOUV,ICPR,ISENS)
  630. ELSE IF (ICLE.EQ.2) THEN
  631. CALL ADDITI(Y,MELEME,NOUV,ICPR)
  632. ENDIF
  633. INOUVEL(**)=NOUV
  634. IPLMAIL(IMEL)=NOUV
  635. ENDIF
  636. 203 CONTINUE
  637. SEGDES MELEME
  638. ENDDO
  639. C Fin de la boucle : le maillage support de l'objet L a ete transforme
  640. C Mise a jour de INIFIN (DSOBJ) en consequence avec transformation des
  641. C composantes si l'objet est un CHPOINT ou MCHAML et ICLE=2
  642. C (rotation)
  643. 210 CONTINUE
  644. IF (LETYP.EQ.'MAILLAGE') THEN
  645. INIFIN=IPLMAIL(1)
  646. ELSE IF (LETYP.EQ.'CHPOINT ') THEN
  647. MCHPOI=INIFIN
  648. SEGACT MCHPOI*MOD
  649. DO i=1,IPCHP(/1)
  650. MSOUPO=IPCHP(i)
  651. SEGACT MSOUPO*MOD
  652. IGEOC=IPLMAIL(i)
  653. SEGDES MSOUPO
  654. ENDDO
  655. SEGDES MCHPOI
  656. IF (ICLE.EQ.2) CALL TOCH1(MCHPOI,'CHPOINT ',IRETOU)
  657. ELSE IF (LETYP.EQ.'MCHAML ') THEN
  658. MCHELM=INIFIN
  659. SEGACT MCHELM*MOD
  660. DO i=1,IMACHE(/1)
  661. IMACHE(i)=IPLMAIL(i)
  662. ENDDO
  663. SEGDES MCHELM
  664. IF (ICLE.EQ.2) CALL TOCH1(MCHELM,'MCHAML ',IRETOU)
  665. ELSE IF (LETYP.EQ.'MMODEL ') THEN
  666. MMODEL=INIFIN
  667. SEGACT MMODEL*MOD
  668. DO i=1,KMODEL(/1)
  669. IMODEL=KMODEL(i)
  670. SEGACT IMODEL*MOD
  671. IMAMOD=IPLMAIL(i)
  672. SEGDES IMODEL
  673. ENDDO
  674. SEGDES MMODEL
  675. ELSE IF (LETYP.EQ.'RIGIDITE') THEN
  676. MRIGID=INIFIN
  677. SEGACT MRIGID*MOD
  678. DO i=1,IRIGEL(/2)
  679. IRIGEL(1,i)=IPLMAIL(i)
  680. ENDDO
  681. SEGDES MRIGID
  682. ELSE IF (LETYP.EQ.'POINT ') THEN
  683. C Cas particulier - Syntaxe : POIN2 = POIN1 'PLUS' VECT1 ;
  684. IF (ITOPE.EQ.'POINT ') THEN
  685. IPOIN1=INIPOI
  686. if(icpr(ipoin1).ne.0) then
  687. inifin=icpr(ipoin1)
  688. else
  689. NBPTS=XCOOR(/1)/idimp1+1
  690. inifin=nbpts
  691. SEGADJ MCOORD
  692. IREF=(IPOIN1-1)*idimp1
  693. IPTFIN=(NBPTS-1)*idimp1
  694. IF ((ICPR(IPOIN1).EQ.0).AND.(ICLE.EQ.1)) THEN
  695. DO i=1,IDIM
  696. XCOOR(IPTFIN+i)=XCOOR(IREF+i)+Y(i)
  697. ENDDO
  698. XCOOR(IPTFIN+idimp1)=DENSIT
  699. ELSE IF ((ICPR(IPOIN1).EQ.0).AND.(ICLE.EQ.2)) THEN
  700. XD=XCOOR(IREF+1)-XPT1
  701. YD=XCOOR(IREF+2)-YPT1
  702. ZD=0.D0
  703. IF (IDIM.GE.3) ZD=XCOOR(IREF+3)-ZPT1
  704. XE=XD*XV1+YD*YV1+ZD*ZV1
  705. YE=XD*XV2+YD*YV2+ZD*ZV2
  706. ZE=XD*XVEC+YD*YVEC+ZD*ZVEC
  707. XD=XE*CO-YE*SI
  708. YD=XE*SI+YE*CO
  709. ZD=ZE
  710. XCOOR(IPTFIN+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1
  711. XCOOR(IPTFIN+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1
  712. IF (IDIM.GE.3) XCOOR(IPTFIN+3)=XD*ZV1+YD*ZV2+ZD
  713. $ *ZVEC+ZPT1
  714. XCOOR(IPTFIN+idimp1)=XCOOR(IREF+idimp1)
  715. C** ELSE IF (ICPR(IPOIN1).NE.0) THEN
  716. ENDIF
  717. ICPR(IPOIN1)=INIFIN
  718. endif
  719. ELSE
  720. C Cas particulier - Syntaxe 2 : POIN2 = POIN1 'PLUS' CHPO1 ;
  721. IPT9=IPLMAIL(1)
  722. SEGACT IPT9
  723. INIFIN=IPT9.NUM(1,1)
  724. SEGSUP IPT9
  725. ENDIF
  726. ENDIF
  727. SEGDES DSOBJ
  728. SEGSUP IPLMAIL
  729. 200 CONTINUE
  730. C Fin de la boucle sur les objets DSOBJ a transformer
  731.  
  732. C Ecriture dans la pile des objets transformes
  733. * cas particulier si on avait lu une table
  734. if(itab.ne.0) then
  735. mtable=itab
  736. segact mtable*mod
  737. segact iposi
  738. endif
  739. DO i=NIOBJ-MINIOBJ,1,-1
  740. DSOBJ=PILO(i)
  741. SEGACT DSOBJ
  742. *
  743. IF(LETYP.EQ.'MMODEL ') THEN
  744. MMODEL=INIFIN
  745. SEGACT MMODEL
  746. NSOUS = KMODEL(/1)
  747. * on change les maillages des modeles pointes par un modele MELANGE
  748. * et le pointeur du modele
  749. do im = 1,NSOUS
  750. imodel = kmodel(im)
  751. segact imodel*mod
  752. if (formod(1).eq.'MELANGE') then
  753. if (ivamod(/1).ge.1) then
  754. do ivm1 = 1,ivamod(/1)
  755. if (tymode(ivm1).eq.'IMODEL') then
  756. imode1 = ivamod(ivm1)
  757. segini,imode2=imode1
  758. imode2.imamod = imamod
  759. ivamod(ivm1) = imode2
  760. segdes imode2
  761. endif
  762. enddo
  763. endif
  764. endif
  765. segdes imodel
  766. enddo
  767. SEGDES MMODEL
  768. ENDIF
  769. *
  770. IF(itab.ne.0) then
  771. ipotab=iposit(i)
  772. mtabiv(ipotab)=inifin
  773. ELSE
  774. MO8 = LETYP
  775. IPOI1=INIFIN
  776. CALL ACTOBJ(MO8,IPOI1,1)
  777. CALL ECROBJ(MO8,IPOI1)
  778. ENDIF
  779. SEGDES DSOBJ
  780. ENDDO
  781. if( itab.ne.0) then
  782. call ECROBJ('TABLE ',mtable)
  783. segdes mtable
  784. segsup iposi
  785. endif
  786.  
  787. C Un peu de menage
  788. 300 CONTINUE
  789. SEGSUP ICPR,ITABEL,INOUVEL
  790. GOTO 100
  791.  
  792. C Cas particulier - Operateur MOINS : CHPO1 = 'MOIN' GEO1 GEO2 ;
  793. c Calcul du CHPOINT permettant de passer de GEO1 a GEO2
  794. 500 CONTINUE
  795. SEGINI ICP1
  796. SEGACT IPT1,IPT2
  797. NBSOUS1=IPT1.LISOUS(/1)
  798. NBSOUS2=IPT2.LISOUS(/1)
  799. *Gounand : Utilité ? NBREF1=IPT1.LISREF(/1)
  800. *G NBREF2=IPT2.LISREF(/1)
  801. IF (NBSOUS1.NE.NBSOUS2) GOTO 502
  802. *G IF (NBREF1.NE.NBREF2) GOTO 502
  803. IF (NBSOUS1.EQ.0) THEN
  804. IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 502
  805. IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) GOTO 502
  806. IF (IPT1.NUM(/2).NE.IPT2.NUM(/2)) GOTO 502
  807. CALL PROCHP(IPT1,IPT2,IPOIN1,ICP1)
  808. IF (IERR.NE.0) GOTO 502
  809. ELSE IF (NBSOUS1.NE.0) THEN
  810. DO j=1,NBSOUS1
  811. IPT3=IPT1.LISOUS(j)
  812. IPT4=IPT2.LISOUS(j)
  813. SEGACT IPT3,IPT4
  814. NBSOUS3=IPT3.LISOUS(/1)
  815. NBSOUS4=IPT4.LISOUS(/1)
  816. *G NBREF3=IPT3.LISREF(/1)
  817. *G NBREF4=IPT4.LISREF(/1)
  818. IF (NBSOUS3.NE.NBSOUS4) GOTO 501
  819. *G IF (NBREF3.NE.NBREF4) GOTO 501
  820. IF (IPT3.ITYPEL.NE.IPT4.ITYPEL) GOTO 501
  821. IF (IPT3.NUM(/1).NE.IPT4.NUM(/1)) GOTO 501
  822. IF (IPT3.NUM(/2).NE.IPT4.NUM(/2)) GOTO 501
  823. SEGDES IPT3,IPT4
  824. CALL PROCHP(IPT3,IPT4,IPOIN1,ICP1)
  825. IF (IERR.NE.0) GOTO 501
  826. IF (j.EQ.1) THEN
  827. IPCHP0=IPOIN1
  828. ELSE
  829. CALL FUCHPO(IPCHP0,IPOIN1,IRET)
  830. IPCHP0=IRET
  831. ENDIF
  832. IF (IERR.NE.0) GOTO 501
  833. ENDDO
  834. IPOIN1=IPCHP0
  835. ENDIF
  836. SEGDES IPT1,IPT2
  837. C Ecriture du CHPOINT calcule
  838. CALL ACTOBJ('CHPOINT ',IPOIN1,1)
  839. CALL ECROBJ('CHPOINT ',IPOIN1)
  840. C Pour les autres objets DSOBJ, INIFIN=0 donc pas ecrits ?
  841. DO i=NIOBJ-1,2,-1
  842. DSOBJ=PILO(i)
  843. SEGACT DSOBJ
  844. MO8 = LETYP
  845. IPOI1=INIFIN
  846. CALL ACTOBJ(MO8,IPOI1,1)
  847. CALL ECROBJ(MO8,IPOI1)
  848. ENDDO
  849. GOTO 100
  850.  
  851. C Syntaxe particuliere : CHP1 = GEO1 'MOIN' GEO2 ;
  852. C Erreur dans le calcul du CHPOINT, incompatibilite entre les maillages
  853. 501 CONTINUE
  854. SEGDES IPT3,IPT4
  855. 502 CONTINUE
  856. SEGDES IPT1,IPT2
  857. CALL ERREUR(878)
  858. SEGSUP ICP1
  859.  
  860. C Sortie du sousprogramme - Suppression des segments locaux
  861. 100 CONTINUE
  862. if(PILO.NE.0) then
  863. DO i=1,PILO(/1)
  864. DSOBJ=PILO(i)
  865. SEGSUP DSOBJ
  866. ENDDO
  867. SEGSUP PILO
  868. ENDIF
  869. segsup MLITY
  870. END
  871.  
  872.  
  873.  

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