Esope source files

   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
  21 :       CALL LIRREE(XXX,1,IRETOU)
  22 :       ANGLE=XXX
  22 :       IF (ANGLE.EQ.0.D0) CALL ERREUR(21)
  23 :       IF (IERR.NE.0) RETURN
  24 : C  Lecture d'un maillage, sinon lecture d'un point
  24 :       CALL MESLIR(-131)
  24 :       CALL LIROBJ('MAILLAGE',IP1,0,IROT)
  25 :       IF (IROT.EQ.0) THEN
  25 :         CALL MESLIR(-131)
  25 :         CALL LIROBJ('POINT   ',IP2,1,IRETOU)
  26 :       ENDIF
  27 : C  Lecture du centre de l'affinite
  27 :       CALL MESLIR(-165)
  27 :       CALL LIROBJ('POINT   ',IPT1,1,IRETOU)
  28 :       IF (IERR.NE.0) RETURN
  29 : C  Lecture éventuelle d'autres points
  30 :       IF (IROT.EQ.0) THEN
  31 :          SEGINI INOSUP
  32 :  11      CONTINUE
  32 :          CALL LIROBJ('POINT   ',IP3,0,IRET)
  33 :          IF (IRET.EQ.1) THEN
  34 :             INOSUP(**)=IP3
  35 :             GOTO 11
  36 :          ENDIF
  37 :          NNODE=INOSUP(/1)+1
  38 :          SEGINI INOEUD
  39 :          INOEUD(1)=IP2
  40 :          IF (INOSUP(/1).GT.0) THEN
  41 :             INOEUD(2)=IPT1
  42 :             DO INODE=1,INOSUP(/1)-1
  43 :                INOEUD(2+INODE)=INOSUP(INODE)
  44 :             ENDDO
  45 :             IPT1=INOSUP(INOSUP(/1))
  46 :          ENDIF
  47 :          SEGSUP INOSUP
  48 :       ENDIF
  49 : *
  50 :       SEGACT MCOORD
  51 :       IREF=IPT1*(IDIM+1)-IDIM
  52 :       XPT1=XCOOR(IREF)
  53 :       YPT1=0.D0
  54 :       ZPT1=0.D0
  55 :       IF (IDIM.GE.2) THEN
  56 :         YPT1=XCOOR(IREF+1)
  57 :         IF (IDIM.GE.3) ZPT1=XCOOR(IREF+2)
  58 :       ENDIF
  59 : 
  60 :       IF (IROT.EQ.1) THEN
  60 :         CALL INTOPE(IP1)
  61 :       ELSE
  62 :          idimp1=IDIM+1
  63 :          NBPTS=XCOOR(/1)/idimp1+NNODE
  64 :          SEGADJ MCOORD
  65 :          DO INODE=1,NNODE
  66 :             IP2=INOEUD(INODE)
  67 :             IP3=NBPTS-(NNODE-INODE)
  68 :             IREF=(IP2-1)*idimp1
  69 :             IPTH=(IP3-1)*idimp1
  70 :             XCOOR(IPTH+1)=XPT1+ANGLE*(XCOOR(IREF+1)-XPT1)
  71 :             XCOOR(IPTH+idimp1)=ANGLE*XCOOR(IREF+idimp1)
  72 :             IF (IDIM.GE.2) THEN
  73 :                XCOOR(IPTH+2)=YPT1+ANGLE*(XCOOR(IREF+2)-YPT1)
  74 :                IF (IDIM.GE.3) XCOOR(IPTH+3)=ZPT1+ANGLE*(XCOOR(IREF+3)
  75 :      $              -ZPT1)
  76 :             ENDIF
  77 :          ENDDO
  78 :          SEGSUP INOEUD
  79 : * Il faut renvoyer les noeuds dans le bon ordre
  80 :          DO INODE=1,NNODE
  81 :             IP3=NBPTS-(INODE-1)
  81 :             CALL ECROBJ('POINT   ',IP3)
  82 :          ENDDO
  83 :       ENDIF
  84 :       RETURN
  85 :       END
  86 : 
  87 :  
  88 :  
  89 :