Sources Esope | Cast3M

symetr
C SYMETR    SOURCE    SP204843  24/03/15    21:15:08     11871          
 
C  Sousprogramme relaisant la symetrie d'un ou plusieurs objets
C  10/2003 : modifications traitant du cas IDIM=1
 
      SUBROUTINE SYMETR
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
      COMMON / CTOURN / XPT1,YPT1,ZPT1,XV1,YV1,ZV1,XV2,YV2,ZV2,
     .                  XVEC,YVEC,ZVEC,ANGLE,ICLE,XP1,YP1,ZP1
 
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC SMELEME
 
      CHARACTER*4 MCLE(3)
      DATA MCLE / 'POIN','DROI','PLAN' /
      SEGMENT ICPR(nbpts)
 
      idimp1=IDIM+1
 
C  Lecture du mot-cle
      CALL MESLIR(-242)
      CALL LIRMOT(MCLE,3,ICLE,1)
      IF (IERR.NE.0) RETURN
      IF (((IDIM.EQ.1).AND.(ICLE.NE.1)).OR.
     .    ((IDIM.EQ.2).AND.(ICLE.EQ.3))) THEN
        MOTERR(1:4)=MCLE(ICLE)
        INTERR(1)=IDIM
        CALL ERREUR(971)
      ENDIF
      ICLE=ICLE+4
 
C  Lecture des objets a transformer
      CALL MESLIR(-131)
      CALL LIROBJ('MAILLAGE',IP1,0,IROT)
      CALL MESLIR(-131)
      IF (IROT.EQ.0) THEN
        CALL LIROBJ('POINT ',IP1,1,IRETOU)
        IF (IERR.NE.0) RETURN
      ELSE
        CALL LIROBJ('CHPOINT ',IP2,0,IROT1)
      ENDIF
C  Lecture des points definissant la symetrie
      MOTERR(1:4)=MCLE(ICLE-4)
      CALL MESLIR(-241)
      CALL LIROBJ('POINT ',IPT1,1,IRETOU)
      IF (ICLE.GT.5) THEN
        MOTERR(1:4)=MCLE(ICLE-4)
        CALL MESLIR(-240)
        CALL LIROBJ('POINT ',IPT2,1,IRETOU)
        IF (IERR.NE.0) RETURN
        IF (ICLE.GT.6) THEN
          MOTERR(1:4)=MCLE(ICLE-4)
          CALL MESLIR(-239)
          CALL LIROBJ('POINT ',IPT3,1,IRETOU)
          IF (IERR.NE.0) RETURN
        ENDIF
      ENDIF
 
C  Recuperation des coordonnees des points definissant la symetrie
C  Coordonnees stockees dans le COMMON CTOURN
      SEGACT MCOORD
      IREF=(IPT1-1)*idimp1
      XPT1=XCOOR(IREF+1)
      YPT1=0.
      IF (IDIM.GE.2) YPT1=XCOOR(IREF+2)
      ZPT1=0.
      IF (IDIM.GE.3) ZPT1=XCOOR(IREF+3)
C  Rappel : ICLE=6 valide pour IDIM=2 ou 3 - ICLE=7 pour IDIM=3
      IF (ICLE.GT.5) THEN
        IREF=(IPT2-1)*idimp1
        XPT2=XCOOR(IREF+1)
        YPT2=XCOOR(IREF+2)
        ZPT2=0.
        IF (IDIM.GE.3) ZPT2=XCOOR(IREF+3)
        XVEC=XPT2-XPT1
        YVEC=YPT2-YPT1
        ZVEC=ZPT2-ZPT1
        DVEC=SQRT(XVEC*XVEC+YVEC*YVEC+ZVEC*ZVEC)
        IF (DVEC.EQ.0.) THEN
          CALL ERREUR(21)
          RETURN
        ENDIF
C  Cas ICLE=6 : (XYZ)VEC vecteur directeur de la droite POIN1 POIN2
        XVEC=XVEC/DVEC
        YVEC=YVEC/DVEC
        ZVEC=ZVEC/DVEC
        IF (ICLE.GT.6) THEN
          IREF=(IPT3-1)*idimp1
          XPT3=XCOOR(IREF+1)
          YPT3=XCOOR(IREF+2)
          ZPT3=0.
          IF (IDIM.GE.3) ZPT3=XCOOR(IREF+3)
          XV1=XVEC
          YV1=YVEC
          ZV1=ZVEC
          XV2=XPT3-XPT1
          YV2=YPT3-YPT1
          ZV2=ZPT3-ZPT1
          XVEC=YV1*ZV2-ZV1*YV2
          YVEC=ZV1*XV2-XV1*ZV2
          ZVEC=XV1*YV2-YV1*XV2
          DVEC=SQRT(XVEC*XVEC+YVEC*YVEC+ZVEC*ZVEC)
          IF (DVEC.EQ.0.) THEN
            CALL ERREUR(21)
            RETURN
          ENDIF
C  Cas ICLE=7 : (XYZ)VEC normale (unitaire) au plan POIN1 POIN2 POIN3
          XVEC=XVEC/DVEC
          YVEC=YVEC/DVEC
          ZVEC=ZVEC/DVEC
        ENDIF
      ENDIF
 
C  Transformation d'un MAILLAGE
      IF (IROT.EQ.1) THEN
C  Transformation d'un MAILLAGE et d'un CHPOINT
        IF (IROT1.EQ.1) THEN
          CALL INTOP1(IP2,IP1)
        ELSE
C  Transformation d'un MAILLAGE seul
          CALL INTOPE(IP1)
        ENDIF
        RETURN
      ENDIF
 
C  Transformation du point IP1 (LIROBJ)
      IREF=(IP1-1)*idimp1
      XD=XCOOR(IREF+1)-XPT1
      YD=0.
      IF (IDIM.GE.2) YD=XCOOR(IREF+2)-YPT1
      ZD=0.
      IF (IDIM.GE.3) ZD=XCOOR(IREF+3)-ZPT1
      XDENS=XCOOR(IREF+idimp1)
      segact mcoord*mod
      nbpts=nbpts+1
      SEGADJ MCOORD
      IREF=(NBPTS-1)*idimp1
      ICAS=ICLE-4
      GOTO (11,12,13),ICAS
C  Option 'POINT' (1D/2D/3D) :
C ----------------------------
  11  XCOOR(IREF+1)=XPT1-XD
      IF (IDIM.GE.2) XCOOR(IREF+2)=YPT1-YD
      IF (IDIM.GE.3) XCOOR(IREF+3)=ZPT1-ZD
      GOTO 15
C  Option 'DROIT' (2D/3D) :
C --------------------------
  12  PVEC=2*(XD*XVEC+YD*YVEC+ZD*ZVEC)
      XCOOR(IREF+1)=XPT1+PVEC*XVEC-XD
      XCOOR(IREF+2)=YPT1+PVEC*YVEC-YD
      IF (IDIM.GE.3) XCOOR(IREF+3)=ZPT1+PVEC*ZVEC-ZD
      GOTO 15
C  Option 'PLAN' (3D) :
C ----------------------
  13  PVEC=2*(XD*XVEC+YD*YVEC+ZD*ZVEC)
      XCOOR(IREF+1)=XPT1+XD-PVEC*XVEC
      XCOOR(IREF+2)=YPT1+YD-PVEC*YVEC
      XCOOR(IREF+3)=ZPT1+ZD-PVEC*ZVEC
C  Ecriture du point transforme :
  15  XCOOR(IREF+idimp1)=XDENS
      CALL ECROBJ('POINT ',NBPTS)
 
      RETURN
      END