Télécharger affini.eso

Retour à la liste

Numérotation des lignes :

affini
  1. C AFFINI SOURCE PV 20/04/01 21:15:10 10569
  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
  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.  

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