Télécharger affini.eso

Retour à la liste

Numérotation des lignes :

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

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