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

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