Sources Esope | Cast3M

rond
C ROND      SOURCE    CB215821  23/01/25    21:15:33     11573          
C     1234567890124567890124567898012456789012345678901234567890123456
 
C     SOURCE : L. DI VALENTIN    LE 17/06/97
 
C     Cette subroutine appele par l'operateur LIGN (grace au mot cle
C     ROTA) prepare les donnees a transmettre a la subroutine ARC
C     pour construire un arc de cercle dont on connait le centre
C     (CENTRE), un point (POINT1) et l'angle d'ouverture en degre a
C     partir de ce point.
 
C     En dimension 3, il est necessaire de fournir la normale au
C     cercle, ce qui fournit a la fois le plan contenant le cercle
C     et le sens trigonometrique positif dans ce plan.
 
 
      SUBROUTINE ROND
 
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
-INC CCREEL
 
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMCOORD
 
 
      INTEGER INBR,IRET,POINT1,POINT2,NORMAL,CENTRE
      REAL*8  ANGLE,DENS1,DENS2,NORME
      CHARACTER*(4) TYPE*8
      CHARACTER*4 MOTCLE(2)
      logical ltelq
 
 
      DATA MOTCLE/'DINI','DFIN'/
 
 
      INBR = 0
      CALL LIRENT(INBR,0,IRET)
 
 
*     IF (DENS1*DENS2.LE.0.D0.AND.INBR.LE.0) THEN
*        CALL ERREUR(17)
*        RETURN
*     ENDIF
 
 
C     Lecture du centre.
 
      CALL LIROBJ('POINT',CENTRE,1,IRET)
      IF (IRET.EQ.0) RETURN
 
 
C     Si on a un maillage, on extrait le dernier point
      IPT1=0
      CALL LIROBJ('MAILLAGE',IPT1,0,IRET)
      IF (IRET.EQ.1) THEN
         CALL ACTOBJ('MAILLAGE',IPT1,1)
         CALL EXTRPO(IPT1,1,POINT1)
         IF(IERR .NE. 0)RETURN
      ELSE
         CALL LIROBJ('POINT',POINT1,1,IRET)
      ENDIF
      IF (IERR.NE.0) RETURN
 
C     Lecture de l'angle de rotation.
 
      CALL LIRREE(ANGLE,1,IRET)
      IF (IRET.EQ.0) RETURN
 
      ANGLE = ANGLE * XPI / 180.D0
 
 
C     En dimension 3, lecture du point fournissant le sens
C     trigonométrique
 
      IF (IDIM.EQ.3) THEN
         CALL LIROBJ('POINT',NORMAL,1,IRET)
         IF (IRET.EQ.0) RETURN
      ENDIF
 
 
C     On recupere les coordonnees du CENTRE
      SEGACT,MCOORD
 
      XCEN = XCOOR((CENTRE-1)*(IDIM+1) + 1)
      YCEN = XCOOR((CENTRE-1)*(IDIM+1) + 2)
      IF (IDIM.EQ.3) THEN
         ZCEN = XCOOR((CENTRE-1)*(IDIM+1) + 3)
      ENDIF
      DENS2=XCOOR((CENTRE)*(IDIM+1))
 
C     On recupere les coordonnees du vecteur (CENTRE -> POINT1)
 
      X1 = XCOOR((POINT1-1)*(IDIM+1) + 1) - XCEN
      Y1 = XCOOR((POINT1-1)*(IDIM+1) + 2) - YCEN
 
      IF (IDIM.EQ.3) THEN
         Z1 = XCOOR((POINT1-1)*(IDIM+1) + 3) - ZCEN
      ELSE
         Z1 = 0.D0
      ENDIF
      DENS1=XCOOR((POINT1)*(IDIM+1))
 
C     On cree une place memoire pour le deuxieme point extremite
 
      SEGACT,MCOORD*MOD
      NBPTS  = nbpts+1
      POINT2 = NBPTS
      SEGADJ,MCOORD
 
 
C     Calcul des coordonnees de ce point :
 
 
C     Si IDIM = 3 on recupere le vecteur normal.
 
      IF (IDIM.EQ.3) THEN
 
         Xn = XCOOR((NORMAL-1)*(IDIM+1) + 1)
         Yn = XCOOR((NORMAL-1)*(IDIM+1) + 2)
         Zn = XCOOR((NORMAL-1)*(IDIM+1) + 3)
 
         NORME = SQRT(Xn*Xn + Yn*Yn + Zn*Zn)
 
         Xn = Xn/NORME
         Yn = Yn/NORME
         Zn = Zn/NORME
 
      ELSE
 
         Xn = 0.D0
         Yn = 0.D0
         Zn = 1.D0
 
      ENDIF
 
 
C     POINT3 = NORMAL vectoriel POINT1 :
 
      X3 = Yn*Z1 - Zn*Y1
      Y3 = Zn*X1 - Xn*Z1
      Z3 = Xn*Y1 - Yn*X1
 
 
C     Calcul des coordonnees de POINT2 (point extremite)
 
      XCOOR((POINT2-1)*(IDIM+1) + 1) = XCEN + COS(ANGLE)*X1
     &     + SIN(ANGLE)*X3
      XCOOR((POINT2-1)*(IDIM+1) + 2) = YCEN + COS(ANGLE)*Y1
     &     + SIN(ANGLE)*Y3
      IF (IDIM.EQ.3) THEN
         XCOOR((POINT2-1)*(IDIM+1) + 3) = ZCEN + COS(ANGLE)*Z1
     &        + SIN(ANGLE)*Z3
      ENDIF
      DENS2=SQRT(ABS(DENS1*DENS2))
         XCOOR(POINT2*(IDIM+1))=DENS2
 
 
 413  CALL LIRMOT(MOTCLE,2,IRET,0)
 
      IF (IRET.EQ.1) THEN
         CALL LIRREE(DENS1,1,IRET)
         IF (IRET.EQ.0) RETURN
         GOTO 413
 
      ELSEIF (IRET.EQ.2) THEN
         CALL MESLIR(-169)
         CALL LIRREE(DENS2,1,IRET)
         IF (IRET.EQ.0) RETURN
         GOTO 413
 
      ENDIF
 
 
      CALL ARC(POINT1,CENTRE,NORMAL,ANGLE,INBR,DENS1,DENS2,POINT2)      
      SEGDES,MCOORD
 
      IF (IERR.NE.0) RETURN
      IF (IPT1.NE.0) THEN
        CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
        IF (IERR.NE.0) RETURN
        CALL ACTOBJ('MAILLAGE',IPT2,1)
        ltelq=.false.
        CALL FUSE(IPT1,IPT2,IPT3,ltelq)
        IF (IERR.NE.0) RETURN
        SEGSUP IPT2
        CALL ACTOBJ('MAILLAGE',IPT3,1)
        CALL ECROBJ('MAILLAGE',IPT3)
      ENDIF
      RETURN
 
      END