Esope source files

   1 : C AFFINI    SOURCE    CHAT      05/01/12    21:19:24     5004           
   2 : 
   3 : C  Ce sous-programme prepare l'affinite d'un objet
   4 : C  10/2003 : cas IDIM=1, operateur indisponible
   5 : 
   6 :       SUBROUTINE AFFINI
   7 : 
   8 :       IMPLICIT INTEGER(I-N)
   9 :       IMPLICIT REAL*8 (A-H,O-Z)
  10 : 
  11 : -INC CCOPTIO
  12 : -INC SMCOORD
  13 : -INC SMELEME
  14 : 
  15 : C  Segment NON utilise :       SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  16 : 
  17 :       COMMON / CTOURN / XPT1,YPT1,ZPT1,XV1,YV1,ZV1,XV2,YV2,ZV2,
  18 :      .                  XVEC,YVEC,ZVEC,ANGLE,ICLE
  19 : 
  20 :       IF (IDIM.EQ.1) THEN
  21 :         INTERR(1)=IDIM
  21 :         CALL ERREUR(709)
  22 :         RETURN
  23 :       ENDIF
  24 : 
  25 :       ICLE=4
  26 : C  Lecture du rapport de l'affinite
  26 :       CALL MESLIR(-130)
  26 :       CALL LIRREE(XXX,1,IRETOU)
  27 :       ANGLE=XXX
  27 :       IF (ANGLE.EQ.0.) CALL ERREUR(21)
  28 :       IF (IERR.NE.0) RETURN
  29 : C  Lecture d'un maillage, sinon lecture d'un point
  30 :       ICAS=1
  30 :       CALL MESLIR(-131)
  30 :       CALL LIROBJ('MAILLAGE',IOBJ,0,IRETOU)
  31 :       IF (IRETOU.NE.1) THEN
  32 :         ICAS=0
  32 :         CALL MESLIR(-131)
  32 :         CALL LIROBJ('POINT   ',IOBJ,1,IRETOU)
  33 :       ENDIF
  34 : C  Lecture des points definissant l'axe de l'affinite
  34 :       CALL MESLIR(-132)
  34 :       CALL LIROBJ('POINT   ',IPT1,1,IRETOU)
  34 :       CALL MESLIR(-133)
  34 :       CALL LIROBJ('POINT   ',IPT2,1,IRETOU)
  35 :       IF (IERR.NE.0) RETURN
  36 : 
  37 :       idimp1=IDIM+1
  38 :       SEGACT MCOORD
  39 :       IREF=(IPT1-1)*idimp1
  40 :       XPT1=XCOOR(IREF+1)
  41 :       YPT1=XCOOR(IREF+2)
  42 :       ZPT1=0.
  43 :       IF (IDIM.GE.3) ZPT1=XCOOR(IREF+3)
  44 :       IREF=(IPT2-1)*idimp1
  45 :       XPT2=XCOOR(IREF+1)
  46 :       YPT2=XCOOR(IREF+2)
  47 :       ZPT2=0.
  48 :       IF (IDIM.GE.3) ZPT2=XCOOR(IREF+3)
  49 :       XVEC=XPT2-XPT1
  50 :       YVEC=YPT2-YPT1
  51 :       ZVEC=ZPT2-ZPT1
  52 :       DVEC=SQRT(XVEC*XVEC+YVEC*YVEC+ZVEC*ZVEC)
  52 :       IF (DVEC.EQ.0.) CALL ERREUR(21)
  53 :       IF (IERR.NE.0) RETURN
  54 :       XVEC=XVEC/DVEC
  55 :       YVEC=YVEC/DVEC
  56 :       ZVEC=ZVEC/DVEC
  57 :       XV1=-YVEC
  58 :       YV1=XVEC
  59 :       DV1=XV1*XV1+YV1*YV1
  60 :       IF (DV1.GE.0.1) THEN
  61 :         ZV1=0.
  62 :         DV1=SQRT(DV1)
  63 :         XV1=XV1/DV1
  64 :         YV1=YV1/DV1
  65 :       ELSE
  66 :         XV1=0.
  67 :         YV1=-ZVEC
  68 :         ZV1=YVEC
  69 :         DV1=SQRT(YV1*YV1+ZV1*ZV1)
  70 :         YV1=YV1/DV1
  71 :         ZV1=ZV1/DV1
  72 :       ENDIF
  73 :       XV2=YVEC*ZV1-ZVEC*YV1
  74 :       YV2=ZVEC*XV1-XVEC*ZV1
  75 :       ZV2=XVEC*YV1-YVEC*XV1
  76 : 
  77 :       IF (ICAS.EQ.1) THEN
  77 :         CALL INTOPE(IOBJ)
  78 :         RETURN
  79 :       ENDIF
  80 : 
  81 :       IREF=(IOBJ-1)*idimp1
  82 :       XD=XCOOR(IREF+1)-XPT1
  83 :       YD=XCOOR(IREF+2)-YPT1
  84 :       ZD=0.
  85 :       IF (IDIM.GE.3) ZD=XCOOR(IREF+3)-ZPT1
  86 :       XE=XD*XV1+YD*YV1+ZD*ZV1
  87 :       YE=XD*XV2+YD*YV2+ZD*ZV2
  88 :       ZE=XD*XVEC+YD*YVEC+ZD*ZVEC
  89 :       XD=XE
  90 :       YD=YE
  91 :       ZD=ZE*ANGLE
  92 :       NBPTS=XCOOR(/1)/idimp1+1
  93 :       SEGADJ MCOORD
  94 :       IPoin=(NBPTS-1)*idimp1
  95 :       XCOOR(IPoin+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1
  96 :       XCOOR(IPoin+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1
  97 :       IF (IDIM.GE.3) XCOOR(IPoin+3)=XD*ZV1+YD*ZV2+ZD*ZVEC+ZPT1
  98 :       XCOOR(IPoin+idimp1)=XCOOR(IREF+idimp1)
  98 :       CALL ECROBJ('POINT   ',NBPTS)
  99 : 
 100 :       RETURN
 101 :       END
 102 : 
 103 :  
 104 :