C HOMOTH    SOURCE    SP204843  25/03/14    21:15:05     12201          

C  Ce sous-programme realise une homothetie sur un objet
C  10/2003 : modifications pour prendre en compte cas IDIM=1.

      SUBROUTINE HOMOTH

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)


-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC SMELEME
-INC CCGEOME
-INC CCTOURN
      SEGMENT INOSUP(0)
      SEGMENT INOEUD(NNODE)

      ICLE=3
C  Lecture du rapport non nul de l'homothetie
      CALL LIRREE(XXX,1,IRETOU)
      ANGLE=XXX
      IF (ANGLE.EQ.0.D0) CALL ERREUR(21)
      IF (IERR.NE.0) RETURN
C  Lecture d'un maillage, sinon lecture d'un point
      CALL MESLIR(-131)
      CALL LIROBJ('MAILLAGE',IP1,0,IROT)
      IF (IROT.EQ.0) THEN
        CALL MESLIR(-131)
        CALL LIROBJ('POINT   ',IP2,1,IRETOU)
      ENDIF
C  Lecture du centre de l'affinite
      CALL MESLIR(-165)
      CALL LIROBJ('POINT   ',IPT1,1,IRETOU)
      IF (IERR.NE.0) RETURN
C  Lecture éventuelle d'autres points
      IF (IROT.EQ.0) THEN
         SEGINI INOSUP
 11      CONTINUE
         CALL LIROBJ('POINT   ',IP3,0,IRET)
         IF (IRET.EQ.1) THEN
            INOSUP(**)=IP3
            GOTO 11
         ENDIF
         NNODE=INOSUP(/1)+1
         SEGINI INOEUD
         INOEUD(1)=IP2
         IF (INOSUP(/1).GT.0) THEN
            INOEUD(2)=IPT1
            DO INODE=1,INOSUP(/1)-1
               INOEUD(2+INODE)=INOSUP(INODE)
            ENDDO
            IPT1=INOSUP(INOSUP(/1))
         ENDIF
         SEGSUP INOSUP
      ENDIF
*
      SEGACT MCOORD*mod
      IREF=IPT1*(IDIM+1)-IDIM
      XPT1=XCOOR(IREF)
      YPT1=0.D0
      ZPT1=0.D0
      IF (IDIM.GE.2) THEN
        YPT1=XCOOR(IREF+1)
        IF (IDIM.GE.3) ZPT1=XCOOR(IREF+2)
      ENDIF

      IF (IROT.EQ.1) THEN
        CALL INTOPE(IP1)
      ELSE
         idimp1=IDIM+1
         NBPTS=nbpts+NNODE
         SEGADJ MCOORD
         DO INODE=1,NNODE
            IP2=INOEUD(INODE)
            IP3=NBPTS-(NNODE-INODE)
            IREF=(IP2-1)*idimp1
            IPTH=(IP3-1)*idimp1
            XCOOR(IPTH+1)=XPT1+ANGLE*(XCOOR(IREF+1)-XPT1)
            XCOOR(IPTH+idimp1)=ANGLE*XCOOR(IREF+idimp1)
            IF (IDIM.GE.2) THEN
               XCOOR(IPTH+2)=YPT1+ANGLE*(XCOOR(IREF+2)-YPT1)
               IF (IDIM.GE.3) XCOOR(IPTH+3)=ZPT1+ANGLE*(XCOOR(IREF+3)
     $              -ZPT1)
            ENDIF
         ENDDO
         SEGSUP INOEUD
* Il faut renvoyer les noeuds dans le bon ordre
         DO INODE=1,NNODE
            IP3=NBPTS-(INODE-1)
            CALL ECROBJ('POINT   ',IP3)
         ENDDO
      ENDIF
      RETURN
      END