Télécharger la plaquette Cast3M


fr en

Télécharger affini.eso

Retour à la liste

Numérotation des lignes : 

affini

  1. C AFFINI    SOURCE    SP204843  24/03/15    21:15:02     11871          
  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.  
  12. -INC PPARAM
  13. -INC CCOPTIO
  14. -INC SMCOORD
  15. -INC SMELEME
  16.  
  17. C  Segment NON utilise :       SEGMENT ICPR(nbpts)
  18.  
  19.       COMMON / CTOURN / XPT1,YPT1,ZPT1,XV1,YV1,ZV1,XV2,YV2,ZV2,
  20.      .                  XVEC,YVEC,ZVEC,ANGLE,ICLE,XP1,YP1,ZP1
  21.  
  22.       IF (IDIM.EQ.1) THEN
  23.         INTERR(1)=IDIM
  24.         CALL ERREUR(709)
  25.         RETURN
  26.       ENDIF
  27.  
  28.       ICLE=4
  29. C  Lecture du rapport de l'affinite
  30.       CALL MESLIR(-130)
  31.       CALL LIRREE(XXX,1,IRETOU)
  32.       ANGLE=XXX
  33.       IF (ANGLE.EQ.0.) CALL ERREUR(21)
  34.       IF (IERR.NE.0) RETURN
  35. C  Lecture d'un maillage, sinon lecture d'un point
  36.       ICAS=1
  37.       CALL MESLIR(-131)
  38.       CALL LIROBJ('MAILLAGE',IOBJ,0,IRETOU)
  39.       IF (IRETOU.NE.1) THEN
  40.         ICAS=0
  41.         CALL MESLIR(-131)
  42.         CALL LIROBJ('POINT   ',IOBJ,1,IRETOU)
  43.       ENDIF
  44. C  Lecture des points definissant l'axe de l'affinite
  45.       CALL MESLIR(-132)
  46.       CALL LIROBJ('POINT   ',IPT1,1,IRETOU)
  47.       CALL MESLIR(-133)
  48.       CALL LIROBJ('POINT   ',IPT2,1,IRETOU)
  49.       IF (IERR.NE.0) RETURN
  50.  
  51.       idimp1=IDIM+1
  52.       SEGACT MCOORD*mod
  53.       IREF=(IPT1-1)*idimp1
  54.       XPT1=XCOOR(IREF+1)
  55.       YPT1=XCOOR(IREF+2)
  56.       ZPT1=0.
  57.       IF (IDIM.GE.3) ZPT1=XCOOR(IREF+3)
  58.       IREF=(IPT2-1)*idimp1
  59.       XPT2=XCOOR(IREF+1)
  60.       YPT2=XCOOR(IREF+2)
  61.       ZPT2=0.
  62.       IF (IDIM.GE.3) ZPT2=XCOOR(IREF+3)
  63.       XVEC=XPT2-XPT1
  64.       YVEC=YPT2-YPT1
  65.       ZVEC=ZPT2-ZPT1
  66.       DVEC=SQRT(XVEC*XVEC+YVEC*YVEC+ZVEC*ZVEC)
  67.       IF (DVEC.EQ.0.) CALL ERREUR(21)
  68.       IF (IERR.NE.0) RETURN
  69.       XVEC=XVEC/DVEC
  70.       YVEC=YVEC/DVEC
  71.       ZVEC=ZVEC/DVEC
  72.       XV1=-YVEC
  73.       YV1=XVEC
  74.       DV1=XV1*XV1+YV1*YV1
  75.       IF (DV1.GE.0.1) THEN
  76.         ZV1=0.
  77.         DV1=SQRT(DV1)
  78.         XV1=XV1/DV1
  79.         YV1=YV1/DV1
  80.       ELSE
  81.         XV1=0.
  82.         YV1=-ZVEC
  83.         ZV1=YVEC
  84.         DV1=SQRT(YV1*YV1+ZV1*ZV1)
  85.         YV1=YV1/DV1
  86.         ZV1=ZV1/DV1
  87.       ENDIF
  88.       XV2=YVEC*ZV1-ZVEC*YV1
  89.       YV2=ZVEC*XV1-XVEC*ZV1
  90.       ZV2=XVEC*YV1-YVEC*XV1
  91.  
  92.       IF (ICAS.EQ.1) THEN
  93.         CALL INTOPE(IOBJ)
  94.         RETURN
  95.       ENDIF
  96.  
  97.       IREF=(IOBJ-1)*idimp1
  98.       XD=XCOOR(IREF+1)-XPT1
  99.       YD=XCOOR(IREF+2)-YPT1
  100.       ZD=0.
  101.       IF (IDIM.GE.3) ZD=XCOOR(IREF+3)-ZPT1
  102.       XE=XD*XV1+YD*YV1+ZD*ZV1
  103.       YE=XD*XV2+YD*YV2+ZD*ZV2
  104.       ZE=XD*XVEC+YD*YVEC+ZD*ZVEC
  105.       XD=XE
  106.       YD=YE
  107.       ZD=ZE*ANGLE
  108.       SEGADJ MCOORD
  109.       IPoin=(NBPTS-1)*idimp1
  110.       XCOOR(IPoin+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1
  111.       XCOOR(IPoin+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1
  112.       IF (IDIM.GE.3) XCOOR(IPoin+3)=XD*ZV1+YD*ZV2+ZD*ZVEC+ZPT1
  113.       XCOOR(IPoin+idimp1)=XCOOR(IREF+idimp1)
  114.       CALL ECROBJ('POINT   ',NBPTS)
  115.  
  116.       RETURN
  117.       END
  118.  
  119.  
  120.  
  121.  
  122.  
  123.  
  124.  

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