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

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