C ITRC      SOURCE    PV        09/03/12    21:25:37     6325           
      SUBROUTINE ITRC 
CA   Ph. MIRANDA 
CD   30/11/2001 
CC-------------------------------------------------------------------------- 
CC 
CC     Le sous-programme ITRC calcule par une methode analytique exacte 
CC     l'intersection entre des segments (connus par les coordonnees de 
CC     leurs extremites) et les facettes triangulaires d'un maillage  
CC     (connues par les coordonnees de leurs 3 extremites et leurs  
CC     normales).  
CC 
CC     ITRC reprend les fonctionnalites de la procedure GIBIANE @INTERC  
CC     concue par R.Mitteau (CEA/DSM/DRFC) et B.Riou (CSSI) en oct 1998. 
CC 
CC     version initiale : Ph.Miranda (CSSI)    en nov 2001 
CC     modification     : T.Charras  (CEA/DM2S) en oct 2003 
CC     modification     : A.Moal     (CSSI)    en jan 2004 
CC  
CC     Syntaxe generale : 
CC 
CC     CHDIST MINTER = ITRC CHOLD CHNEW TOL TAB1 ; 
CC 
CC-------------------------------------------------------------------------- 
CE     En entree : 
CE 
CE     CHOLD : coordonnees des points extremites initiales des segments 
CE            (type CHPOINT a 3 composantes)  
CE     CHNEW : coordonnees des points extremites finales des segments 
CE            (type CHPOINT a 3 composantes appuye sur le meme support 
CE             que CH_OLD)  
CE     TOL   : tolerance (type FLOTTANT) 
CE     TAB1  : Table qui doit contenir les parametres suivants en entree 
CE 
CE      <chamx1 (type MCHAML) coordonnee x du premier noeud de l'element 
CE      <chamy1 (type MCHAML) coordonnee y du premier noeud de l'element 
CE      <chamz1 (type MCHAML) coordonnee z du premier noeud de l'element 
CE 
CE      <chamx2 (type MCHAML) coordonnee x du deuxieme noeud de l'element   
CE      <chamy2 (type MCHAML) coordonnee y du deuxieme noeud de l'element   
CE      <chamz2 (type MCHAML) coordonnee z du deuxieme noeud de l'element   
CE 
CE      <chamx3 (type MCHAML) coordonnee x du troisieme noeud de l'element   
CE      <chamy3 (type MCHAML) coordonnee y du troisieme noeud de l'element   
CE      <chamz3 (type MCHAML) coordonnee z du troisieme noeud de l'element   
CE                 
CE      <cosx (type MCHAML) cosinus directeur selon x 
CE      <cosy (type MCHAML) cosinus directeur selon y 
CE      <cosz (type MCHAML) cosinus directeur selon z 
CC 
CS      En sortie : 
CS 
CS      CHDIST : CHPOINT appuye sur le support de CHOLD et contenant 
CS               le pas si pas d'intersection et la distance entre  
CS               point initial du segment et le point d'intersection  
CS               a la facette sinon (type CHPOINT) 
CS      MINTER : contient les noeuds intersectes du support de CHOLD. 
CS               (type MAILLAGE)  
CS 
CC      Remarque : il est necessaire de travailler avec les champs par  
CC                 element du maillage interceptant et non pas avec les 
CC                 coordonnées des points de l'objet maillage car ces  
CC                 champs peuvent avoir subi des changements de repere 
CC  
CC-------------------------------------------------------------------------- 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z) 
C 
-INC CCOPTIO 
-INC SMCHPOI 
-INC SMCHAML 
-INC SMELEME 
-INC SMCOORD 
-INC CCGEOME 
-INC CCREEL 
-INC SMTABLE 
C 
      SEGMENT MTRAV1 
        REAL*8 XPN(NZ1,NBP),YPN(NZ1,NBP),ZPN(NZ1,NBP) 
        REAL*8 XPN1(NZ1,NBP),YPN1(NZ1,NBP),ZPN1(NZ1,NBP) 
        REAL*8 CHPAS(NZ1,NBP),CHPAS0(NZ1,NBP) 
        LOGICAL INTER(NZ1,NBP) 
      ENDSEGMENT 
C 
      SEGMENT MTRAV2 
        REAL*8 COORFAC(NZ2,NEL,3,3) 
        REAL*8 TXN(NZ2,NEL),TYN(NZ2,NEL),TZN(NZ2,NEL) 
      ENDSEGMENT 
C 
      POINTEUR CHOLD.MCHPOI,CHNEW.MCHPOI 
      POINTEUR CHX1.MCHPOI,CHX2.MCHPOI,CHX3.MCHPOI 
      POINTEUR CHY1.MCHPOI,CHY2.MCHPOI,CHY3.MCHPOI 
      POINTEUR CHZ1.MCHPOI,CHZ2.MCHPOI,CHZ3.MCHPOI 
      POINTEUR TAB1.MTABLE 
      POINTEUR ICHOLD.MELEME 
      POINTEUR CHCOSX.MCHAML,CHCOSY.MCHAML,CHCOSZ.MCHAML 
C 
      CHARACTER*8 MTYPR 
      CHARACTER*4 REP 
      CHARACTER*9 MOTCLE(12) 
      logical login,logre
      character*4 charre
C 
C  LECTURE DES OBJETS 
C 
      CALL LIROBJ('CHPOINT',CHOLD,1,IRETOU) 
      IF (IERR .NE. 0) RETURN 
      CALL LIROBJ('CHPOINT',CHNEW,1,IRETOU) 
      IF (IERR .NE. 0) RETURN 
      CALL LIRREE(TOL1,1,IRETOU) 
      IF (IERR .NE. 0) RETURN 
      CALL LIROBJ('TABLE   ',TAB1,1,IRETOU) 
      IF (IERR .NE. 0) RETURN 
C 
C  Dimensionnement des tableaux du segment MTRAV1 
C 
      MCHPOI=CHOLD 
      SEGACT MCHPOI 
      NZ1=IPCHP(/1) 
      DO 50 I=1,IPCHP(/1) 
         MSOUPO=IPCHP(I) 
         SEGACT MSOUPO 
         MELEME=IGEOC 
         SEGACT MELEME 
         IF (I .EQ. 1) NBP=NUM(/2) 
         IF (NUM(/2) .GT. NBP) NBP=NUM(/2) 
         SEGDES MELEME 
         SEGDES MSOUPO 
50    CONTINUE 
      SEGINI MTRAV1 
C 
C 
C   EXTRACTION DES COORDONNEES DES POINTS Pn et Pn+1 a partir des CHPOINT  
C       CHOLD et CHNEW 
C 
      DO 100 I=1,IPCHP(/1) 
         MSOUPO=IPCHP(I) 
         SEGACT MSOUPO 
         ICHOLD=IGEOC 
         MPOVAL=IPOVAL 
         SEGACT MPOVAL 
         DO 200 J=1,NOCOMP(/2) 
             IF (NOCOMP(J).EQ. 'X   ')then 
              do 331 k=1,vpocha(/1) 
                XPN(I,K)=VPOCHA(K,J) 
  331         continue 
             elseif(NOCOMP(J).EQ. 'Y   ') then  
              do 332 k=1,vpocha(/1) 
                YPN(I,K)=VPOCHA(K,J) 
  332         continue 
             elseif(NOCOMP(J).EQ. 'Z   ')then 
              do 333 k=1,vpocha(/1)   
                ZPN(I,K)=VPOCHA(K,J) 
  333         continue 
             endif 
200      CONTINUE 
         SEGDES MPOVAL 
         SEGDES MELEME 
         SEGDES MSOUPO 
100   CONTINUE 
      SEGDES MCHPOI 
C 
      MCHPOI=CHNEW 
      SEGACT MCHPOI 
      DO 110 I=1,IPCHP(/1) 
         MSOUPO=IPCHP(I) 
         SEGACT MSOUPO 
         MPOVAL=IPOVAL 
         SEGACT MPOVAL 
         DO 210 J=1,NOCOMP(/2) 
               IF (NOCOMP(J).EQ. 'X   ')then 
                   DO 310 K=1,VPOCHA(/1) 
                    XPN1(I,K)=VPOCHA(K,J) 
  310              CONTINUE 
               ELSEIF (NOCOMP(J).EQ. 'Y   ')then 
                   DO 311 K=1,VPOCHA(/1) 
                    YPN1(I,K)=VPOCHA(K,J) 
  311              CONTINUE 
               ELSEIF (NOCOMP(J).EQ. 'Z   ')then 
                   DO 312 K=1,VPOCHA(/1) 
                    ZPN1(I,K)=VPOCHA(K,J) 
  312              CONTINUE 
               ENDIF 
210      CONTINUE          
         SEGDES MPOVAL 
         SEGDES MSOUPO 
110   CONTINUE 
      SEGDES MCHPOI 
C 
         MOTCLE(1) = '<COSX    ' 
         MOTCLE(2) = '<COSY    ' 
         MOTCLE(3) = '<COSZ    ' 
         MOTCLE(4) = '<CHAMX1  ' 
         MOTCLE(5) = '<CHAMY1  ' 
         MOTCLE(6) = '<CHAMZ1  ' 
         MOTCLE(7) = '<CHAMX2  ' 
         MOTCLE(8) = '<CHAMY2  ' 
         MOTCLE(9) = '<CHAMZ2  ' 
         MOTCLE(10) = '<CHAMX3  ' 
         MOTCLE(11) = '<CHAMY3  ' 
         MOTCLE(12) = '<CHAMZ3  ' 
C 
      SEGACT TAB1 
      CALL ACCTAB(TAB1,'MOT     ',IVALIN,XVALIN,MOTCLE(1),LOGIN,IOBIN, 
     .                 'MCHAML  ',IVALRE,XVALRE,CHARRE,LOGRE,CHCOSX) 
      CALL ACCTAB(TAB1,'MOT     ',IVALIN,XVALIN,MOTCLE(2),LOGIN,IOBIN, 
     .                 'MCHAML  ',IVALRE,XVALRE,CHARRE,LOGRE,CHCOSY) 
      CALL ACCTAB(TAB1,'MOT     ',IVALIN,XVALIN,MOTCLE(3),LOGIN,IOBIN, 
     .                 'MCHAML  ',IVALRE,XVALRE,CHARRE,LOGRE,CHCOSZ) 
C 
      MCHELM=CHCOSX 
      SEGACT MCHELM 
C 
C  Dimensionnement des tableaux du segment MTRAV2 
C 
      NZ2 = ICHAML(/1) 
      DO 60 I=1,ICHAML(/1) 
         MCHAML=ICHAML(I) 
         SEGACT MCHAML 
         DO 70 IC=1,IELVAL(/1) 
             IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 
                MELVAL=IELVAL(IC) 
                SEGACT MELVAL 
                IF (I .EQ. 1) NEL=VELCHE(/2) 
                IF (VELCHE(/2) .GT. NEL) NEL=VELCHE(/2) 
                SEGDES MELVAL 
             ENDIF 
70      CONTINUE 
        SEGDES MCHAML 
60    CONTINUE 
      SEGINI MTRAV2 
C 
C  Extraction des trois cosinus directeurs (CHAMELEM) a partir de TAB1 
C  Les elements du maillage associe sont ici des POI1 
C         
      DO 120 I=1,ICHAML(/1) 
         MCHAML=ICHAML(I) 
         SEGACT MCHAML 
         DO 220 IC=1,IELVAL(/1) 
             IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 
                MELVAL=IELVAL(IC) 
                SEGACT MELVAL 
                DO 320 IEL=1,VELCHE(/2) 
                   TXN(I,IEL) = VELCHE(1,IEL) 
320             CONTINUE 
                SEGDES MELVAL 
             ENDIF 
220      CONTINUE 
         SEGDES MCHAML 
120   CONTINUE 
      SEGDES MCHELM 
C 
      MCHELM=CHCOSY 
      SEGACT MCHELM 
      DO 130 I=1,ICHAML(/1) 
         MCHAML=ICHAML(I) 
         SEGACT MCHAML 
         DO 230 IC=1,IELVAL(/1) 
             IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 
                MELVAL=IELVAL(IC) 
                SEGACT MELVAL 
                DO 330 IEL=1,VELCHE(/2) 
                   TYN(I,IEL) = VELCHE(1,IEL) 
330             CONTINUE 
                SEGDES MELVAL 
             ENDIF 
230      CONTINUE 
         SEGDES MCHAML 
130   CONTINUE 
      SEGDES MCHELM 
C 
      MCHELM=CHCOSZ 
      SEGACT MCHELM 
      DO 140 I=1,ICHAML(/1) 
         MCHAML=ICHAML(I) 
         SEGACT MCHAML 
         DO 240 IC=1,IELVAL(/1) 
             IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 
                MELVAL=IELVAL(IC) 
                SEGACT MELVAL 
                DO 340 IEL=1,VELCHE(/2) 
                   TZN(I,IEL) = VELCHE(1,IEL) 
340             CONTINUE 
                SEGDES MELVAL 
             ENDIF 
240      CONTINUE 
         SEGDES MCHAML 
140   CONTINUE 
      SEGDES MCHELM 
C 
C   Extraction des coordonnees des 3 points de chaque facette  
C 
      CALL ACCTAB(TAB1,'MOT     ',IVALIN,XVALIN,MOTCLE(4),LOGIN, 
     .           IOBIN,'MCHAML  ',IVALRE,XVALRE,CHARRE,LOGRE,CHX1) 
      CALL ACCTAB(TAB1,'MOT     ',IVALIN,XVALIN,MOTCLE(5),LOGIN, 
     .           IOBIN,'MCHAML  ',IVALRE,XVALRE,CHARRE,LOGRE,CHY1) 
      CALL ACCTAB(TAB1,'MOT     ',IVALIN,XVALIN,MOTCLE(6),LOGIN, 
     .           IOBIN,'MCHAML  ',IVALRE,XVALRE,CHARRE,LOGRE,CHZ1) 
C 
      MCHELM=CHX1 
      SEGACT MCHELM 
      DO 141 I=1,ICHAML(/1) 
         MCHAML=ICHAML(I) 
         SEGACT MCHAML 
         DO 241 IC=1,IELVAL(/1) 
             IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 
                MELVAL=IELVAL(IC) 
                SEGACT MELVAL 
                DO 341 IEL=1,VELCHE(/2) 
                   COORFAC(I,IEL,1,1) = VELCHE(1,IEL) 
341             CONTINUE 
                SEGDES MELVAL 
             ENDIF 
241      CONTINUE 
         SEGDES MCHAML 
141   CONTINUE 
      SEGDES MCHELM 
C 
      MCHELM=CHY1 
      SEGACT MCHELM 
      DO 142 I=1,ICHAML(/1) 
         MCHAML=ICHAML(I) 
         SEGACT MCHAML 
         DO 242 IC=1,IELVAL(/1) 
             IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 
                MELVAL=IELVAL(IC) 
                SEGACT MELVAL 
                DO 342 IEL=1,VELCHE(/2) 
                   COORFAC(I,IEL,1,2) = VELCHE(1,IEL) 
342             CONTINUE 
                SEGDES MELVAL 
             ENDIF 
242      CONTINUE 
         SEGDES MCHAML 
142   CONTINUE 
      SEGDES MCHELM 
C 
      MCHELM=CHZ1 
      SEGACT MCHELM 
      DO 143 I=1,ICHAML(/1) 
         MCHAML=ICHAML(I) 
         SEGACT MCHAML 
         DO 243 IC=1,IELVAL(/1) 
             IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 
                MELVAL=IELVAL(IC) 
                SEGACT MELVAL 
                DO 343 IEL=1,VELCHE(/2) 
                   COORFAC(I,IEL,1,3) = VELCHE(1,IEL) 
343             CONTINUE 
                SEGDES MELVAL 
             ENDIF 
243      CONTINUE 
         SEGDES MCHAML 
143   CONTINUE 
      SEGDES MCHELM 
C 
      CALL ACCTAB(TAB1,'MOT     ',IVALIN,XVALIN,MOTCLE(7),LOGIN, 
     .           IOBIN,'MCHAML  ',IVALRE,XVALRE,CHARRE,LOGRE,CHX2) 
      CALL ACCTAB(TAB1,'MOT     ',IVALIN,XVALIN,MOTCLE(8),LOGIN, 
     .           IOBIN,'MCHAML  ',IVALRE,XVALRE,CHARRE,LOGRE,CHY2) 
      CALL ACCTAB(TAB1,'MOT     ',IVALIN,XVALIN,MOTCLE(9),LOGIN, 
     .           IOBIN,'MCHAML  ',IVALRE,XVALRE,CHARRE,LOGRE,CHZ2) 
C 
      MCHELM=CHX2 
      SEGACT MCHELM 
      DO 144 I=1,ICHAML(/1) 
         MCHAML=ICHAML(I) 
         SEGACT MCHAML 
         DO 244 IC=1,IELVAL(/1) 
             IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 
                MELVAL=IELVAL(IC) 
                SEGACT MELVAL 
                DO 344 IEL=1,VELCHE(/2) 
                    COORFAC(I,IEL,2,1) = VELCHE(1,IEL) 
344             CONTINUE 
                SEGDES MELVAL 
             ENDIF 
244      CONTINUE 
         SEGDES MCHAML 
144   CONTINUE 
      SEGDES MCHELM 
C 
      MCHELM=CHY2 
      SEGACT MCHELM 
      DO 145 I=1,ICHAML(/1) 
         MCHAML=ICHAML(I) 
         SEGACT MCHAML 
         DO 245 IC=1,IELVAL(/1) 
             IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 
                MELVAL=IELVAL(IC) 
                SEGACT MELVAL 
                DO 345 IEL=1,VELCHE(/2) 
                   COORFAC(I,IEL,2,2) = VELCHE(1,IEL) 
345             CONTINUE 
                SEGDES MELVAL 
             ENDIF 
245      CONTINUE 
         SEGDES MCHAML 
145   CONTINUE 
      SEGDES MCHELM 
C 
      MCHELM=CHZ2 
      SEGACT MCHELM 
      DO 146 I=1,ICHAML(/1) 
         MCHAML=ICHAML(I) 
         SEGACT MCHAML 
         DO 246 IC=1,IELVAL(/1) 
             IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 
                MELVAL=IELVAL(IC) 
                SEGACT MELVAL 
                DO 346 IEL=1,VELCHE(/2) 
                   COORFAC(I,IEL,2,3) = VELCHE(1,IEL) 
346             CONTINUE 
                SEGDES MELVAL 
             ENDIF 
246      CONTINUE 
         SEGDES MCHAML 
146   CONTINUE 
      SEGDES MCHELM 
C 
      CALL ACCTAB(TAB1,'MOT     ',IVALIN,XVALIN,MOTCLE(10),LOGIN, 
     .           IOBIN,'MCHAML  ',IVALRE,XVALRE,CHARRE,LOGRE,CHX3) 
      CALL ACCTAB(TAB1,'MOT     ',IVALIN,XVALIN,MOTCLE(11),LOGIN, 
     .           IOBIN,'MCHAML  ',IVALRE,XVALRE,CHARRE,LOGRE,CHY3) 
      CALL ACCTAB(TAB1,'MOT     ',IVALIN,XVALIN,MOTCLE(12),LOGIN, 
     .           IOBIN,'MCHAML  ',IVALRE,XVALRE,CHARRE,LOGRE,CHZ3) 
C 
      MCHELM=CHX3 
      SEGACT MCHELM 
      DO 147 I=1,ICHAML(/1) 
         MCHAML=ICHAML(I) 
         SEGACT MCHAML 
         DO 247 IC=1,IELVAL(/1) 
             IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 
                MELVAL=IELVAL(IC) 
                SEGACT MELVAL 
                DO 347 IEL=1,VELCHE(/2) 
                   COORFAC(I,IEL,3,1) = VELCHE(1,IEL) 
347             CONTINUE 
                SEGDES MELVAL 
             ENDIF 
247      CONTINUE 
         SEGDES MCHAML 
147   CONTINUE 
      SEGDES MCHELM 
C 
      MCHELM=CHY3 
      SEGACT MCHELM 
      DO 148 I=1,ICHAML(/1) 
         MCHAML=ICHAML(I) 
         SEGACT MCHAML 
         DO 248 IC=1,IELVAL(/1) 
             IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 
                MELVAL=IELVAL(IC) 
                SEGACT MELVAL 
                DO 348 IEL=1,VELCHE(/2) 
                   COORFAC(I,IEL,3,2) = VELCHE(1,IEL) 
348             CONTINUE 
                SEGDES MELVAL 
             ENDIF 
248      CONTINUE 
         SEGDES MCHAML 
148   CONTINUE 
      SEGDES MCHELM 
C 
      MCHELM=CHZ3 
      SEGACT MCHELM 
      DO 149 I=1,ICHAML(/1) 
         MCHAML=ICHAML(I) 
         SEGACT MCHAML 
         DO 249 IC=1,IELVAL(/1) 
             IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 
                MELVAL=IELVAL(IC) 
                SEGACT MELVAL 
                DO 349 IEL=1,VELCHE(/2) 
                   COORFAC(I,IEL,3,3) = VELCHE(1,IEL) 
349             CONTINUE 
                SEGDES MELVAL 
             ENDIF 
249      CONTINUE 
         SEGDES MCHAML 
149   CONTINUE 
      SEGDES MCHELM 
C 
      SEGDES TAB1 
C 
C  Initialisation du tableau des indicateurs d'interception 
C 
      DO 302 I=1,NZ1 
         DO 301 K=1,NBP 
            INTER(I,K)=.FALSE. 
301      CONTINUE 
302   CONTINUE 
C 
C   Boucle sur les facettes du maillage OMBRANT 
C 
      MCHELM=CHX1 
      SEGACT MCHELM 
      DO 400 I=1,ICHAML(/1) 
         MCHAML=ICHAML(I) 
         SEGACT MCHAML 
         DO 450 IC=1,IELVAL(/1) 
            IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 
               MELVAL=IELVAL(IC) 
               SEGACT MELVAL 
               DO 500 J=1,VELCHE(/2) 
                  XA1 =  COORFAC(I,J,1,1) 
                  YA1 =  COORFAC(I,J,1,2) 
                  ZA1 =  COORFAC(I,J,1,3) 
C 
                  XB1 =  COORFAC(I,J,2,1) 
                  YB1 =  COORFAC(I,J,2,2) 
                  ZB1 =  COORFAC(I,J,2,3) 
C 
                  XC1 =  COORFAC(I,J,3,1) 
                  YC1 =  COORFAC(I,J,3,2) 
                  ZC1 =  COORFAC(I,J,3,3) 
C 
C  Boucle sur les sous-zones du maillage OMBRE 
C 
                  DO 550 IZ=1,NZ1 
C 
C  Boucle sur les lignes de champ (ou sur les elements POI1 de OMBRE) 
C 
                     DO 600 K=1,NBP 
                        IF (.NOT. INTER(IZ,K)) THEN 
C 
C  Produits scalaires 
C 
                           PS1 = ((XPN(IZ,K)-XA1)*TXN(I,J)) +  
     .                           ((YPN(IZ,K)-YA1)*TYN(I,J)) + 
     .                           ((ZPN(IZ,K)-ZA1)*TZN(I,J)) 
                           PS2 = ((XPN1(IZ,K)-XA1)*TXN(I,J)) +  
     .                           ((YPN1(IZ,K)-YA1)*TYN(I,J)) + 
     .                           ((ZPN1(IZ,K)-ZA1)*TZN(I,J)) 
C             -> --> 
C   Calcul de PnPn+1 : 
C 
                           DEX = XPN1(IZ,K) - XPN(IZ,K) 
                           DEY = YPN1(IZ,K) - YPN(IZ,K) 
                           DEZ = ZPN1(IZ,K) - ZPN(IZ,K) 
C 
C   calcul de la distance de connection par defaut 
C 
             CHPAS0(IZ,K) = (DEX*DEX + DEY*DEY + DEZ*DEZ)**.5 
C 
C   Test d'intersection avec le plan de la facette 
C 
                  IF ( (PS1*PS2 .LT. (-1*TOL1*TOL1))  
     .             .OR. (PS2 .EQ. 0.) )               THEN 
C 
C                   -> -->   -> 
C   Calcul de AD1 = PnPn+1 . N  : 
C 
                AD1 = DEX*TXN(I,J) + DEY*TYN(I,J) + DEZ*TZN(I,J) 
C 
C   Test de detection des lignes de champ paralleles a la facette 
C 
                           IF (ABS(AD1) .GT. TOL1) THEN 
C 
C 
C    Calcul des points d'intersection M entre les lignes de champ et  
C                                             le plan de la facette 
C 
                           XM = ( (XA1*DEX*TXN(I,J)) - 
     .                          ((((YPN(IZ,K)-YA1)*DEX)- 
     .                             (XPN(IZ,K)*DEY))*TYN(I,J)) - 
     .                          ((((ZPN(IZ,K)-ZA1)*DEX)- 
     .                       (XPN(IZ,K)*DEZ))*TZN(I,J)) ) / AD1 
C 
                           YM = ( (YA1*DEY*TYN(I,J)) - 
     .                          ((((ZPN(IZ,K)-ZA1)*DEY)- 
     .                             (YPN(IZ,K)*DEZ))*TZN(I,J)) - 
     .                          ((((XPN(IZ,K)-XA1)*DEY)- 
     .                       (YPN(IZ,K)*DEX))*TXN(I,J)) ) / AD1 
C 
                           ZM = ( (ZA1*DEZ*TZN(I,J)) - 
     .                          ((((XPN(IZ,K)-XA1)*DEZ)- 
     .                             (ZPN(IZ,K)*DEX))*TXN(I,J)) - 
     .                          ((((YPN(IZ,K)-YA1)*DEZ)- 
     .                       (ZPN(IZ,K)*DEY))*TYN(I,J)) ) / AD1 
C 
C   Calcul des vecteurs AM, BM, CM 
C 
                           XAM = XM - XA1 
                           XBM = XM - XB1 
                           XCM = XM - XC1 
C 
C 
                           YAM = YM - YA1 
                           YBM = YM - YB1 
                           YCM = YM - YC1 
C 
                           ZAM = ZM - ZA1 
                           ZBM = ZM - ZB1 
                           ZCM = ZM - ZC1 
C 
C   Denominateurs 
C 
                           DX = (YCM*ZBM)-(ZCM*YBM)+(ZAM*YBM)- 
     .                          (ZAM*YCM)-(YAM*ZBM)+(YAM*ZCM) 
C 
                           DY = (ZCM*XBM)-(XCM*ZBM)+(XAM*ZBM)- 
     .                          (XAM*ZCM)-(ZAM*XBM)+(ZAM*XCM) 
C 
                           DZ = (YCM*XBM)-(XCM*YBM)+(XAM*YBM)- 
     .                          (XAM*YCM)-(YAM*XBM)+(YAM*XCM) 
C 
                           IF (ABS(DZ) .GT. TOL1) THEN 
                               D1 = DZ 
                               A1 = YCM*XBM-XCM*YBM 
                               B1 = YAM*XCM-XAM*YCM 
                               C1 = YBM*XAM-XBM*YAM 
                           ELSEIF (ABS(DY) .GT. TOL1) THEN 
                               D1 = DY 
                               A1 = ZCM*XBM-XCM*ZBM 
                               B1 = ZAM*XCM-XAM*ZCM 
                               C1 = ZBM*XAM-XBM*ZAM 
                           ELSE 
                               D1 = DX 
                               A1 = YCM*ZBM-ZCM*YBM 
                               B1 = YAM*ZCM-ZAM*YCM 
                               C1 = YBM*ZAM-ZBM*YAM 
                           ENDIF 
C 
C    Coordonnees barycentriques 
C  
                           ALPHA = A1 / D1 
                           BETA =  B1 / D1 
                           GAMMA = C1 / D1 
C   
                           IF ( (ALPHA .GE. 0.) .AND. 
     .                          (BETA  .GE. 0.) .AND. 
     .                          (GAMMA .GE. 0.)      ) THEN 
C 
                                    INTER(IZ,K)=.TRUE. 
C 
C   Calcul de d(Pn,M) : 
C 
                         CHPAS(IZ,K) = ((XPN(IZ,K)-XM)**2. +  
     .          (YPN(IZ,K)-YM)**2. + (ZPN(IZ,K)-ZM)**2.)**.5 
                                 ENDIF 
                              ENDIF 
                           ENDIF 
                        ENDIF 
600                  CONTINUE 
550               CONTINUE 
500            CONTINUE 
               SEGDES MELVAL 
            ENDIF 
450      CONTINUE 
         SEGDES MCHAML 
400   CONTINUE 
      SEGDES MCHELM 
C 
C-------------------------------------------------------- 
C 
C  Creation du maillage MINTER des points d'intersection 
C 
      NBNN = 1 
      NBELEM = NBP 
      NBSOUS = 0 
      NBREF = 0 
      SEGINI MELEME 
      MINTER  = MELEME 
      ITYPEL = 1 
C 
C   Construction de MINTER 
C 
      IPT1 = ICHOLD 
      SEGACT IPT1 
      NINTER = 0 
      DO 701 I=1,NZ1 
         DO 700 K=1,NBP 
            IF (INTER(I,K)) THEN 
               NINTER = NINTER+1 
               NUM(1,NINTER) = IPT1.NUM(1,K) 
            ENDIF 
700      CONTINUE 
701   CONTINUE 
      NBELEM = NINTER 
      SEGADJ MELEME 
      SEGDES MELEME,IPT1 
C-------------------------------------------------------- 
C 
C  Creation du CHPOINT CHDIST 
C 
C segment MCHPOI 
      NAT = 1 
      NSOUPO = NZ1 
      SEGINI MCHPOI 
      ICHDIS = MCHPOI 
      IFOPOI = 2 
      JATTRI(1) = 2 
C segment MSOUPO 
      NC = 1 
      DO 901 I=1,NZ1 
         SEGINI MSOUPO 
         IPCHP(I)=MSOUPO 
         NOCOMP(1)= 'SCAL' 
C segment MELEME : maillage associe a CHDIST 
         NBNN = 1 
         NBELEM = NBP 
         NBSOUS = 0 
         NBREF = 0 
C 
C   LE CHAMPOINT CHDIST S'APPUIE SUR LE MEME MAILLAGE QUE CHOLD 
C 
         IGEOC=ICHOLD 
C 
C   Construction de MPOVAL 
C 
         N = NBP 
         SEGINI MPOVAL 
         IPOVAL=MPOVAL 
C 
C   On met la valeur de la distance de connection dans le chpoint CHDIST 
C       Ce point n'existera plus dans le prochain maillage MINTER 
C 
         DO 900 K=1,NBP 
            IF (INTER(I,K)) THEN 
                VPOCHA(K,1)=CHPAS(I,K) 
            ELSE 
                VPOCHA(K,1)=CHPAS0(I,K) 
            ENDIF 
900      CONTINUE 
C 
         SEGDES MPOVAL 
         SEGDES MSOUPO 
901   CONTINUE 
      SEGDES MCHPOI 
C 
C-------------------------------------------------------- 
C 
C   Ecriture des nouveaux objets en sortie 
C 
      CALL ECROBJ('MAILLAGE',MINTER) 
C 
      CALL ECROBJ('CHPOINT ',ICHDIS) 
C 
      SEGSUP MTRAV1 
      SEGSUP MTRAV2 
C 
      RETURN 
      END