Télécharger la plaquette Cast3M


fr en

Télécharger symetr.eso

Retour à la liste

Numérotation des lignes : 

symetr

  1. C SYMETR    SOURCE    SP204843  25/03/14    21:15:10     12201          
  2.  
  3. C  Sousprogramme relaisant la symetrie d'un ou plusieurs objets
  4. C  10/2003 : modifications traitant du cas IDIM=1
  5.  
  6.       SUBROUTINE SYMETR
  7.  
  8.       IMPLICIT INTEGER(I-N)
  9.       IMPLICIT REAL*8 (A-H,O-Z)
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13. -INC SMCOORD
  14. -INC SMELEME
  15. -INC CCGEOME
  16. -INC CCTOURN
  17.  
  18.       CHARACTER*4 MCLE(3)
  19.       DATA MCLE / 'POIN','DROI','PLAN' /
  20.       SEGMENT ICPR(nbpts)
  21.  
  22.       idimp1=IDIM+1
  23.  
  24. C  Lecture du mot-cle
  25.       CALL MESLIR(-242)
  26.       CALL LIRMOT(MCLE,3,ICLE,1)
  27.       IF (IERR.NE.0) RETURN
  28.       IF (((IDIM.EQ.1).AND.(ICLE.NE.1)).OR.
  29.      .    ((IDIM.EQ.2).AND.(ICLE.EQ.3))) THEN
  30.         MOTERR(1:4)=MCLE(ICLE)
  31.         INTERR(1)=IDIM
  32.         CALL ERREUR(971)
  33.       ENDIF
  34.       ICLE=ICLE+4
  35.  
  36. C  Lecture des objets a transformer
  37.       CALL MESLIR(-131)
  38.       CALL LIROBJ('MAILLAGE',IP1,0,IROT)
  39.       CALL MESLIR(-131)
  40.       IF (IROT.EQ.0) THEN
  41.         CALL LIROBJ('POINT ',IP1,1,IRETOU)
  42.         IF (IERR.NE.0) RETURN
  43.       ELSE
  44.         CALL LIROBJ('CHPOINT ',IP2,0,IROT1)
  45.       ENDIF
  46. C  Lecture des points definissant la symetrie
  47.       MOTERR(1:4)=MCLE(ICLE-4)
  48.       CALL MESLIR(-241)
  49.       CALL LIROBJ('POINT ',IPT1,1,IRETOU)
  50.       IF (ICLE.GT.5) THEN
  51.         MOTERR(1:4)=MCLE(ICLE-4)
  52.         CALL MESLIR(-240)
  53.         CALL LIROBJ('POINT ',IPT2,1,IRETOU)
  54.         IF (IERR.NE.0) RETURN
  55.         IF (ICLE.GT.6) THEN
  56.           MOTERR(1:4)=MCLE(ICLE-4)
  57.           CALL MESLIR(-239)
  58.           CALL LIROBJ('POINT ',IPT3,1,IRETOU)
  59.           IF (IERR.NE.0) RETURN
  60.         ENDIF
  61.       ENDIF
  62.  
  63. C  Recuperation des coordonnees des points definissant la symetrie
  64. C  Coordonnees stockees dans le COMMON CTOURN
  65.       SEGACT MCOORD
  66.       IREF=(IPT1-1)*idimp1
  67.       XPT1=XCOOR(IREF+1)
  68.       YPT1=0.
  69.       IF (IDIM.GE.2) YPT1=XCOOR(IREF+2)
  70.       ZPT1=0.
  71.       IF (IDIM.GE.3) ZPT1=XCOOR(IREF+3)
  72. C  Rappel : ICLE=6 valide pour IDIM=2 ou 3 - ICLE=7 pour IDIM=3
  73.       IF (ICLE.GT.5) THEN
  74.         IREF=(IPT2-1)*idimp1
  75.         XPT2=XCOOR(IREF+1)
  76.         YPT2=XCOOR(IREF+2)
  77.         ZPT2=0.
  78.         IF (IDIM.GE.3) ZPT2=XCOOR(IREF+3)
  79.         XVEC=XPT2-XPT1
  80.         YVEC=YPT2-YPT1
  81.         ZVEC=ZPT2-ZPT1
  82.         DVEC=SQRT(XVEC*XVEC+YVEC*YVEC+ZVEC*ZVEC)
  83.         IF (DVEC.EQ.0.) THEN
  84.           CALL ERREUR(21)
  85.           RETURN
  86.         ENDIF
  87. C  Cas ICLE=6 : (XYZ)VEC vecteur directeur de la droite POIN1 POIN2
  88.         XVEC=XVEC/DVEC
  89.         YVEC=YVEC/DVEC
  90.         ZVEC=ZVEC/DVEC
  91.         IF (ICLE.GT.6) THEN
  92.           IREF=(IPT3-1)*idimp1
  93.           XPT3=XCOOR(IREF+1)
  94.           YPT3=XCOOR(IREF+2)
  95.           ZPT3=0.
  96.           IF (IDIM.GE.3) ZPT3=XCOOR(IREF+3)
  97.           XV1=XVEC
  98.           YV1=YVEC
  99.           ZV1=ZVEC
  100.           XV2=XPT3-XPT1
  101.           YV2=YPT3-YPT1
  102.           ZV2=ZPT3-ZPT1
  103.           XVEC=YV1*ZV2-ZV1*YV2
  104.           YVEC=ZV1*XV2-XV1*ZV2
  105.           ZVEC=XV1*YV2-YV1*XV2
  106.           DVEC=SQRT(XVEC*XVEC+YVEC*YVEC+ZVEC*ZVEC)
  107.           IF (DVEC.EQ.0.) THEN
  108.             CALL ERREUR(21)
  109.             RETURN
  110.           ENDIF
  111. C  Cas ICLE=7 : (XYZ)VEC normale (unitaire) au plan POIN1 POIN2 POIN3
  112.           XVEC=XVEC/DVEC
  113.           YVEC=YVEC/DVEC
  114.           ZVEC=ZVEC/DVEC
  115.         ENDIF
  116.       ENDIF
  117.  
  118. C  Transformation d'un MAILLAGE
  119.       IF (IROT.EQ.1) THEN
  120. C  Transformation d'un MAILLAGE et d'un CHPOINT
  121.         IF (IROT1.EQ.1) THEN
  122.           CALL INTOP1(IP2,IP1)
  123.         ELSE
  124. C  Transformation d'un MAILLAGE seul
  125.           CALL INTOPE(IP1)
  126.         ENDIF
  127.         RETURN
  128.       ENDIF
  129.  
  130. C  Transformation du point IP1 (LIROBJ)
  131.       IREF=(IP1-1)*idimp1
  132.       XD=XCOOR(IREF+1)-XPT1
  133.       YD=0.
  134.       IF (IDIM.GE.2) YD=XCOOR(IREF+2)-YPT1
  135.       ZD=0.
  136.       IF (IDIM.GE.3) ZD=XCOOR(IREF+3)-ZPT1
  137.       XDENS=XCOOR(IREF+idimp1)
  138.       segact mcoord*mod
  139.       nbpts=nbpts+1
  140.       SEGADJ MCOORD
  141.       IREF=(NBPTS-1)*idimp1
  142.       ICAS=ICLE-4
  143.       GOTO (11,12,13),ICAS
  144. C  Option 'POINT' (1D/2D/3D) :
  145. C ----------------------------
  146.   11  XCOOR(IREF+1)=XPT1-XD
  147.       IF (IDIM.GE.2) XCOOR(IREF+2)=YPT1-YD
  148.       IF (IDIM.GE.3) XCOOR(IREF+3)=ZPT1-ZD
  149.       GOTO 15
  150. C  Option 'DROIT' (2D/3D) :
  151. C --------------------------
  152.   12  PVEC=2*(XD*XVEC+YD*YVEC+ZD*ZVEC)
  153.       XCOOR(IREF+1)=XPT1+PVEC*XVEC-XD
  154.       XCOOR(IREF+2)=YPT1+PVEC*YVEC-YD
  155.       IF (IDIM.GE.3) XCOOR(IREF+3)=ZPT1+PVEC*ZVEC-ZD
  156.       GOTO 15
  157. C  Option 'PLAN' (3D) :
  158. C ----------------------
  159.   13  PVEC=2*(XD*XVEC+YD*YVEC+ZD*ZVEC)
  160.       XCOOR(IREF+1)=XPT1+XD-PVEC*XVEC
  161.       XCOOR(IREF+2)=YPT1+YD-PVEC*YVEC
  162.       XCOOR(IREF+3)=ZPT1+ZD-PVEC*ZVEC
  163. C  Ecriture du point transforme :
  164.   15  XCOOR(IREF+idimp1)=XDENS
  165.       CALL ECROBJ('POINT ',NBPTS)
  166.  
  167.       RETURN
  168.       END
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  

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