Télécharger homoth.eso

Retour à la liste

Numérotation des lignes :

  1. C HOMOTH SOURCE GOUNAND 13/01/17 21:15:01 7668
  2.  
  3. C Ce sous-programme realise une homothetie sur un objet
  4. C 10/2003 : modifications pour prendre en compte cas IDIM=1.
  5.  
  6. SUBROUTINE HOMOTH
  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. SEGMENT INOSUP(0)
  15. SEGMENT INOEUD(NNODE)
  16.  
  17. COMMON / CTOURN / XPT1,YPT1,ZPT1,XV1,YV1,ZV1,XV2,YV2,ZV2,
  18. . XVEC,YVEC,ZVEC,ANGLE,ICLE
  19.  
  20. ICLE=3
  21. C Lecture du rapport non nul de l'homothetie
  22. CALL LIRREE(XXX,1,IRETOU)
  23. ANGLE=XXX
  24. IF (ANGLE.EQ.0.D0) CALL ERREUR(21)
  25. IF (IERR.NE.0) RETURN
  26. C Lecture d'un maillage, sinon lecture d'un point
  27. CALL MESLIR(-131)
  28. CALL LIROBJ('MAILLAGE',IP1,0,IROT)
  29. IF (IROT.EQ.0) THEN
  30. CALL MESLIR(-131)
  31. CALL LIROBJ('POINT ',IP2,1,IRETOU)
  32. ENDIF
  33. C Lecture du centre de l'affinite
  34. CALL MESLIR(-165)
  35. CALL LIROBJ('POINT ',IPT1,1,IRETOU)
  36. IF (IERR.NE.0) RETURN
  37. C Lecture éventuelle d'autres points
  38. IF (IROT.EQ.0) THEN
  39. SEGINI INOSUP
  40. 11 CONTINUE
  41. CALL LIROBJ('POINT ',IP3,0,IRET)
  42. IF (IRET.EQ.1) THEN
  43. INOSUP(**)=IP3
  44. GOTO 11
  45. ENDIF
  46. NNODE=INOSUP(/1)+1
  47. SEGINI INOEUD
  48. INOEUD(1)=IP2
  49. IF (INOSUP(/1).GT.0) THEN
  50. INOEUD(2)=IPT1
  51. DO INODE=1,INOSUP(/1)-1
  52. INOEUD(2+INODE)=INOSUP(INODE)
  53. ENDDO
  54. IPT1=INOSUP(INOSUP(/1))
  55. ENDIF
  56. SEGSUP INOSUP
  57. ENDIF
  58. *
  59. SEGACT MCOORD
  60. IREF=IPT1*(IDIM+1)-IDIM
  61. XPT1=XCOOR(IREF)
  62. YPT1=0.D0
  63. ZPT1=0.D0
  64. IF (IDIM.GE.2) THEN
  65. YPT1=XCOOR(IREF+1)
  66. IF (IDIM.GE.3) ZPT1=XCOOR(IREF+2)
  67. ENDIF
  68.  
  69. IF (IROT.EQ.1) THEN
  70. CALL INTOPE(IP1)
  71. ELSE
  72. idimp1=IDIM+1
  73. NBPTS=XCOOR(/1)/idimp1+NNODE
  74. SEGADJ MCOORD
  75. DO INODE=1,NNODE
  76. IP2=INOEUD(INODE)
  77. IP3=NBPTS-(NNODE-INODE)
  78. IREF=(IP2-1)*idimp1
  79. IPTH=(IP3-1)*idimp1
  80. XCOOR(IPTH+1)=XPT1+ANGLE*(XCOOR(IREF+1)-XPT1)
  81. XCOOR(IPTH+idimp1)=ANGLE*XCOOR(IREF+idimp1)
  82. IF (IDIM.GE.2) THEN
  83. XCOOR(IPTH+2)=YPT1+ANGLE*(XCOOR(IREF+2)-YPT1)
  84. IF (IDIM.GE.3) XCOOR(IPTH+3)=ZPT1+ANGLE*(XCOOR(IREF+3)
  85. $ -ZPT1)
  86. ENDIF
  87. ENDDO
  88. SEGSUP INOEUD
  89. * Il faut renvoyer les noeuds dans le bon ordre
  90. DO INODE=1,NNODE
  91. IP3=NBPTS-(INODE-1)
  92. CALL ECROBJ('POINT ',IP3)
  93. ENDDO
  94. ENDIF
  95. RETURN
  96. END
  97.  
  98.  
  99.  
  100.  
  101.  

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