Esope source files

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