Sources Esope | Cast3M

conge3
C CONGE3    SOURCE    FD218221  23/02/13    21:15:04     11591          
      SUBROUTINE CONGE3 (L1,L2,RCONGE,NCONGE, NL1,LRAC,NL2)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
************************************************************************
*
*                             C O N G E 3
*                             -----------
*
* FONCTION:
* ---------
*
*     CREER UN CONGE DE RACCORDEMENT ENTRE DEUX LIGNES
*
*     TYPE DU CONGE : DOUBLE COUDE
*
*
* MODULES UTILISES:
* -----------------
*
 
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
*
* PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
* -----------
*
*     L1      (E)  PREMIERE LIGNE A RACCORDER
*     L2      (E)  DEUXIEME LIGNE A RACCORDER
*     RCONGE  (E)  RAYON DU CONGE DU RACCORDEMENT
*     NCONGE  (E)  FACTEUR DE DECOUPAGE DU CONGE (CONVENTIONS
*                  CLASSIQUES SUR SON SIGNE)
*                  = 0  SI NON FOURNI
*     NL1     (S)  LIGNE APPUYEE SUR L1 ET ABOUTISSANT SUR LE CONGE
*     LRAC    (S)  CONGE DE RACCORDEMENT
*     NL2     (S)  LIGNE APPUYEE SUR L2 ET COMMENCANT SUR LE CONGE
*
      INTEGER NCONGE
      REAL*8 RCONGE
*
* CONSTANTES:
* -----------
*
*
      PARAMETER (DEMI=0.5D0)
*
* VARIABLES:
* ----------
*
*     RESULT = DROITES PARALLELES ?
*
      INTEGER N,NBNOEU,NBELEM,NL,ND,
     &        ITYPLM,NBSOUS,NBREF,NBNN
      CHARACTER*4 RESULT
*
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     LIONEL VIVAN       30 NOVEMBRE 1987
*
* LANGAGE:
* --------
*
*     ESOPE + FORTRAN77
*
************************************************************************
*
      MELEME=L1
      SEGACT,MELEME
      NL=LISOUS(/1)
      IF (NL.NE.0) THEN
         CALL ERREUR(25)
         RETURN
      END IF
      NBNOEU=NUM(/1)
      NBELEM=NUM(/2)
      IP9=NUM(NBNOEU,NBELEM)
      IP8=NUM(1,NBELEM)
      SEGDES,MELEME
*
      MELEME=L2
      SEGACT,MELEME
      NL=LISOUS(/1)
      IF (NL.NE.0) THEN
         CALL ERREUR(25)
         RETURN
      END IF
      NBNOEU=NUM(/1)
      IP1=NUM(1,1)
      IP2=NUM(NBNOEU,1)
      SEGDES,MELEME
*
*     TEST DROITES PARALLELES , DROITES NON COPLANAIRES
*
      CALL INT2D(IP9,IP8,IP1,IP2,INTERS,RESULT)
      IF (IERR.NE.0) RETURN
      IF (RESULT .EQ. 'NON') THEN
         CALL CONGE4(L1,L2,RCONGE,NCONGE,NL1,LRAC,NL2)
         RETURN
      END IF
      IF (RESULT.EQ.'OK')THEN
         CALL ERREUR(400)
         RETURN
      END IF
*
      CALL EXCOO1(IP9,X9,Y9,Z9,D9)
      CALL EXCOO1(IP8,X8,Y8,Z8,D8)
      CALL EXCOO1(IP1,X1,Y1,Z1,D1)
      CALL EXCOO1(IP2,X2,Y2,Z2,D2)
*
*     RECHERCHE DU POINT C :
*        - SUR LA PERPENDICULAIRE AUX DEUX DROITES PASSANT PAR LE POINT
*        - APPARTENANT A LA DROITE 'L2'
*
      A8921=(X8-X9)*(X2-X1)+(Y8-Y9)*(Y2-Y1)+(Z8-Z9)*(Z2-Z1)
      B8929=(X8-X9)*(X2-X9)+(Y8-Y9)*(Y2-Y9)+(Z8-Z9)*(Z2-Z9)
      XC=X2-(B8929/A8921)*(X2-X1)
      YC=Y2-(B8929/A8921)*(Y2-Y1)
      ZC=Z2-(B8929/A8921)*(Z2-Z1)
      CALL CREPO1(XC,YC,ZC,IPC)
*
*     DISTANCE ENTRE LES DEUX DROITES
*
      D2D=SQRT((X9-XC)**2+(Y9-YC)**2+(Z9-ZC)**2)
*
*     TEST DE LA VALEUR DE RCONGE
*
      IF (RCONGE.LT.(D2D*DEMI)) THEN
         CALL ERREUR(401)
         RETURN
      END IF
*
*     RECHERCHE DU POINT P1  ,SE SITUE SUR 'L1'
*
      ANG=ASIN((RCONGE-D2D*DEMI)/RCONGE)
      XN9=SQRT((X8-X9)**2+(Y8-Y9)**2+(Z8-Z9)**2)
      XP1=X9+D2D*DEMI*(X8-X9)*TAN(ANG)/XN9
      YP1=Y9+D2D*DEMI*(Y8-Y9)*TAN(ANG)/XN9
      ZP1=Z9+D2D*DEMI*(Z8-Z9)*TAN(ANG)/XN9
      CALL CREPO1(XP1,YP1,ZP1,IPP1)
*
*     RECHERCHE DU POINT P2 ,SE SITUE SUR 'L2'
*
      XN1=SQRT((X2-X1)**2+(Y2-Y1)**2+(Z2-Z1)**2)
      XP2=XC+D2D*DEMI*(X2-X1)*TAN(ANG)/XN1
      YP2=YC+D2D*DEMI*(Y2-Y1)*TAN(ANG)/XN1
      ZP2=ZC+D2D*DEMI*(Z2-Z1)*TAN(ANG)/XN1
      CALL CREPO1(XP2,YP2,ZP2,IPP2)
*
*     RECHERCHE DU POINT O ,MILIEU DE P1 P2
*
      XO=(XP1+XP2)*DEMI
      YO=(YP1+YP2)*DEMI
      ZO=(ZP1+ZP2)*DEMI
      CALL CREPO1(XO,YO,ZO,IPO)
*
*     CREATION DE LA DROITE P1-O
*
      ND=1
      CALL ECRENT(ND)
      CALL ECROBJ('POINT',IPO)
      CALL ECROBJ('POINT',IPP1)
      CALL LIGNE(1,1,DEN1,DEN2,N)
      IF (IERR.NE.0) RETURN
      CALL LIROBJ('MAILLAGE',L3,1,IRETOU)
      IF (IERR.NE.0) RETURN
*
*     CREATION DE LA DROITE O-P2
*
      ND=1
      CALL ECRENT(ND)
      CALL ECROBJ('POINT',IPP2)
      CALL ECROBJ('POINT',IPO)
      CALL LIGNE(1,1,DEN1,DEN2,N)
      IF (IERR.NE.0) RETURN
      CALL LIROBJ('MAILLAGE',L4,1,IRETOU)
      IF (IERR.NE.0) RETURN
*
*     CREATION DU CONGE DOUBLE
*
      NCONGE=(NCONGE+1)/2
      CALL CONGE2(L1,L4,RCONGE,NCONGE,NL1,LRAC1,NL4)
      IF (IERR.NE.0) RETURN
      CALL CONGE2(L3,L2,RCONGE,NCONGE,NL3,LRAC2,NL2)
      IF (IERR.NE.0) RETURN
*
*     LES 2 DEMI-CERCLES ONT UN POINT EN COMMUN:
      MELEME=LRAC1
      SEGACT,MELEME
      NBNOEU=NUM(/1)
      NBELEM=NUM(/2)
      IPO1=NUM(NBNOEU,NBELEM)
      SEGDES,MELEME
      MELEME=LRAC2
      SEGACT,MELEME*MOD
      NUM(1,1)=IPO1
      SEGDES,MELEME
*     ON REUNIT LES 2 DEMI-CERCLES:
      CALL ECROBJ('MAILLAGE',LRAC2)
      CALL ECROBJ('MAILLAGE',LRAC1)
      CALL PRFUSE
      IF (IERR.NE.0) RETURN
      CALL LIROBJ('MAILLAGE',LRAC,1,IRETOU)
      IF (IERR.NE.0) RETURN
      MELEME=LRAC1
      SEGSUP,MELEME
      MELEME=LRAC2
      SEGSUP,MELEME
*
      MELEME=L3
      SEGSUP,MELEME
      MELEME=NL3
      SEGSUP,MELEME
      MELEME=L4
      SEGSUP,MELEME
      MELEME=NL4
      SEGSUP,MELEME
*
      END