Télécharger la plaquette Cast3M


fr en

Télécharger homoth.eso

Retour à la liste

Numérotation des lignes : 

homoth

  1. C HOMOTH    SOURCE    SP204843  25/03/14    21:15:05     12201          
  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.  
  12. -INC PPARAM
  13. -INC CCOPTIO
  14. -INC SMCOORD
  15. -INC SMELEME
  16. -INC CCGEOME
  17. -INC CCTOURN
  18.       SEGMENT INOSUP(0)
  19.       SEGMENT INOEUD(NNODE)
  20.  
  21.       ICLE=3
  22. C  Lecture du rapport non nul de l'homothetie
  23.       CALL LIRREE(XXX,1,IRETOU)
  24.       ANGLE=XXX
  25.       IF (ANGLE.EQ.0.D0) CALL ERREUR(21)
  26.       IF (IERR.NE.0) RETURN
  27. C  Lecture d'un maillage, sinon lecture d'un point
  28.       CALL MESLIR(-131)
  29.       CALL LIROBJ('MAILLAGE',IP1,0,IROT)
  30.       IF (IROT.EQ.0) THEN
  31.         CALL MESLIR(-131)
  32.         CALL LIROBJ('POINT   ',IP2,1,IRETOU)
  33.       ENDIF
  34. C  Lecture du centre de l'affinite
  35.       CALL MESLIR(-165)
  36.       CALL LIROBJ('POINT   ',IPT1,1,IRETOU)
  37.       IF (IERR.NE.0) RETURN
  38. C  Lecture éventuelle d'autres points
  39.       IF (IROT.EQ.0) THEN
  40.          SEGINI INOSUP
  41.  11      CONTINUE
  42.          CALL LIROBJ('POINT   ',IP3,0,IRET)
  43.          IF (IRET.EQ.1) THEN
  44.             INOSUP(**)=IP3
  45.             GOTO 11
  46.          ENDIF
  47.          NNODE=INOSUP(/1)+1
  48.          SEGINI INOEUD
  49.          INOEUD(1)=IP2
  50.          IF (INOSUP(/1).GT.0) THEN
  51.             INOEUD(2)=IPT1
  52.             DO INODE=1,INOSUP(/1)-1
  53.                INOEUD(2+INODE)=INOSUP(INODE)
  54.             ENDDO
  55.             IPT1=INOSUP(INOSUP(/1))
  56.          ENDIF
  57.          SEGSUP INOSUP
  58.       ENDIF
  59. *
  60.       SEGACT MCOORD*mod
  61.       IREF=IPT1*(IDIM+1)-IDIM
  62.       XPT1=XCOOR(IREF)
  63.       YPT1=0.D0
  64.       ZPT1=0.D0
  65.       IF (IDIM.GE.2) THEN
  66.         YPT1=XCOOR(IREF+1)
  67.         IF (IDIM.GE.3) ZPT1=XCOOR(IREF+2)
  68.       ENDIF
  69.  
  70.       IF (IROT.EQ.1) THEN
  71.         CALL INTOPE(IP1)
  72.       ELSE
  73.          idimp1=IDIM+1
  74.          NBPTS=nbpts+NNODE
  75.          SEGADJ MCOORD
  76.          DO INODE=1,NNODE
  77.             IP2=INOEUD(INODE)
  78.             IP3=NBPTS-(NNODE-INODE)
  79.             IREF=(IP2-1)*idimp1
  80.             IPTH=(IP3-1)*idimp1
  81.             XCOOR(IPTH+1)=XPT1+ANGLE*(XCOOR(IREF+1)-XPT1)
  82.             XCOOR(IPTH+idimp1)=ANGLE*XCOOR(IREF+idimp1)
  83.             IF (IDIM.GE.2) THEN
  84.                XCOOR(IPTH+2)=YPT1+ANGLE*(XCOOR(IREF+2)-YPT1)
  85.                IF (IDIM.GE.3) XCOOR(IPTH+3)=ZPT1+ANGLE*(XCOOR(IREF+3)
  86.      $              -ZPT1)
  87.             ENDIF
  88.          ENDDO
  89.          SEGSUP INOEUD
  90. * Il faut renvoyer les noeuds dans le bon ordre
  91.          DO INODE=1,NNODE
  92.             IP3=NBPTS-(INODE-1)
  93.             CALL ECROBJ('POINT   ',IP3)
  94.          ENDDO
  95.       ENDIF
  96.       RETURN
  97.       END
  98.  
  99.  
  100.  
  101.  
  102.  
  103.  
  104.  
  105.  

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