Sources Esope | Cast3M

tritse
C TRITSE    SOURCE    CHAT      05/01/13    03:48:00     5004
      SUBROUTINE TRITSE(NN,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
     >                   NOETRI,NBE,COORD,INTER,NINTER)
C     *************************************************************
C     OBJET : DETECTE L'ENSEMBLE DES ELEMENTS INTERSECTANT UN SEGMENT
C
C     EN ENTREE:
C        NN() : LES INDICES DES NOEUDS DU SEGMENT
C
C        ITRTRI,NBNMAX,ITRNOE,NBCMAX,NOETRI,NBE,COORD : LE MAILLAGE
C
C        NINTER : TAILLE DU TABLEAU INTER
C
C     EN SORTIE:
C        INTER  :  TABLEAU DES ELEMENTS INTERSECTANT NN
C                  ILS SONT ORDONNEES DE NN(1) VERS NN(2)
C        NINTER:  NOMBRE D'ELEMENTS INTERSECTANT NN
C                  -1 SI LE SEGMENT EST EXTERIEUR OU PASSE PAR UN NOEUD
C                  -2 SI INTER(NINTER) TROP PETIT
C     NIVEAU  : MODULE
C     *****************************************************************
      IMPLICIT INTEGER(I-N)
      INTEGER   NN(*),ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX
      INTEGER   NOETRI(*),NBE,INTER(*),NINTER
      REAL*8      COORD(*)
C
      REAL*8      XN(4), DROITE(3), PZERO, X(3),Y(3)
      INTEGER   NLO(3),NBNN,IDE,IDIMC,NBN,I,IT1,IT2,I1,I2,IERR
      INTEGER   ITD,IAD,ITF,IAF,ITS,IARET(3),NBA,ISOM(3),NBS,NS
      INTEGER   NINMAX
C
      NINMAX = NINTER
      NINTER = 0
      IDE = 2
      NBNN = 2
      IDIMC = 2
      NBN = 3
      CALL SFRIDE(NN,NBNN,IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
     >                   NOETRI,NBE,IT1,IT2,I1,I2)
C
      IF((IT1.NE.0).OR.(IT2.NE.0))GO TO 999
C
C     --- LE SEGMENT N'EST PAS RESPECTE ---
C
      NLO(1) = NN(1)
      NLO(2) = NN(2)
      NLO(3) = NN(1)
C
C     --- RECHERCHE DU TRIANGLE DE DEPART ---
C
      CALL TRDBSE(NLO,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
     >                   NOETRI,COORD,ITD,IAD)
      IF(ITD.EQ.0)GOTO 888
      NINTER=NINTER+1
C     ----- BUG_14 : 28.03.97 O.STAB ---
      IF( NINTER.GT. NINMAX )THEN
        NINTER = -2
        GOTO 999
      ENDIF
      INTER(NINTER)= ITD
C
C     --- RECHERCHE DU TRIANGLE D'ARRIVEE ---
C
      CALL TRDBSE(NLO(2),ITRNOE,NBNMAX,ITRTRI,NBCMAX,
     >                   NOETRI,COORD,ITF,IAF)
      IF(ITF.EQ.0)GOTO 888
C     -----------------------------------------
      DO 5 I=1,IDIMC
        XN(I)      = COORD((NN(1)-1)*IDIMC+I)
        XN(IDIMC+I)= COORD((NN(2)-1)*IDIMC+I)
   5  CONTINUE
      PZERO = 1.D-10 *((XN(3)-XN(1))**2 + (XN(4)-XN(2))**2)
C      CALL G2DDRO2P( XN, DROITE ) REMPLACE PAR O.STAB
      CALL DR2PO( COORD((NN(1)-1)*IDIMC+1),
     >                COORD((NN(2)-1)*IDIMC+1),DROITE,IERR)
C     -----------------------------------------
      ITS = ITRTRI((ITD-1)*NBCMAX+IAD)
C     --------------------------------------------
   10 IF( ITS .EQ. ITF )GO TO 90
      NINTER=NINTER+1
C     ----- BUG_14 : 28.03.97 O.STAB ---
      IF( NINTER.GT. NINMAX )THEN
        NINTER = -2
        GOTO 999
      ENDIF
      INTER(NINTER)= ITS
      DO 20 I=1,NBN
        NS = ITRNOE((ITS-1)*NBNMAX+I)
        X(I)  = COORD((NS-1)*IDIMC+1)
        Y(I)  = COORD((NS-1)*IDIMC+2)
   20 CONTINUE
      CALL INDRPO(X,Y,NBN,DROITE,PZERO,NBA,IARET,NBS,ISOM)
      IF( NBA .NE.2 )GOTO 888
      IF( ITRTRI((ITS-1)*NBCMAX+IARET(1)).EQ.INTER(NINTER-1))THEN
        ITS = ITRTRI((ITS-1)*NBCMAX+IARET(2))
      ELSE
        ITS = ITRTRI((ITS-1)*NBCMAX+IARET(1))
      ENDIF
      GO TO 10
C     --- ON A FINI ---
   90 NINTER=NINTER+1
C     ----- BUG_14 : 28.03.97 O.STAB ---
      IF( NINTER.GT. NINMAX )THEN
        NINTER = -2
        GOTO 999
      ENDIF
      INTER(NINTER)= ITF
      GOTO 999
  888 NINTER= -1
  999 END