C KCHA0     SOURCE    CHAT      05/01/13    00:52:35     5004           
      SUBROUTINE KCHA0(ICHP1,IPSG,NBCOMP,NOMTOT,MTRAV,ICCPR)
C-----------------------------------------------------------------------
C  Création du segment de travail MTRAV (et du segment de redirection)
C  associé au champoint ICHP1 sur le maillage de référence IPSG.
C  Le segment de travail contient au plus les composantes contenues
C  dans le tableau NOMTOT (si NBCOMP est différent de 0) .
C-----------------------------------------------------------------------
C
C---------------------------
C Parametres Entree/Sortie :
C---------------------------
C
C E/  ICHP1  : Champoint
C E/  IPSG   : Maillage de référence, en général de type POI1
C E/  NBCOMP : Nombre de composantes à extraire (toutes  NBCOMP = 0)
C E/  NOMTOT : Tableau des noms des composantes à extraire
C S/  MTRAV  : Segment de travail
C S/  ICCPR  : Segment de redirection (ICPR inverse de IGEO dans MTRAV)
C
C-------------------------------------
C Tableaux du segment de redirection :
C-------------------------------------
C
C  ICPR(I)=J : Le noeud I a le numero J dans le MELEME des faces
C  NNGOT     : Nombre de noeuds total du domaine
C
C-----------------------------------------------------------------------
C
C Langage : ESOPE + FORTRAN77
C
C Auteurs : L. DADA
C
C-----------------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER*4 NOMTOT(*)
C
-INC CCOPTIO
-INC SMELEME
-INC SMCHPOI
-INC SMCOORD
-INC TMTRAV
C
      SEGMENT ICCPR
         INTEGER ICPR(NNGOT)
      ENDSEGMENT
C
C- Transforme le maillage en POI1 si maillage quelconque
C- Le maillage POI1 de pointeur IPT1 est actif au retour de CHANGE
C
      IPT1 = IPSG
      SEGACT IPT1
C PPw NBSOUS = LISOUS(/1)
      NBSOUS = IPT1.LISOUS(/1)
C PPw IF ((NBSOUS.NE.0).OR.(ITYPEL.NE.1)) THEN
      IF ((NBSOUS.NE.0).OR.(IPT1.ITYPEL.NE.1)) THEN

         CALL CHANGE(IPT1,1)
         IF (IERR.NE.0) RETURN
      ENDIF
C
C - Création du tableau ICPR pour le maillage IPT1
C
      NNGOT  = XCOOR(/1)/(IDIM+1)
      SEGINI ICCPR
C
      NNNOE = IPT1.NUM(/2)
      IK    = 0
      DO 10 I2=1,NNNOE
         K = IPT1.NUM(1,I2)
         IF (ICPR(K).EQ.0) THEN
            IK      = IK + 1
            ICPR(K) = IK
         ENDIF
 10   CONTINUE
      SEGDES IPT1
C
C - Récupération du nombre de composantes de ICHP1
C
      MCHPOI = ICHP1
      SEGACT MCHPOI
      NSOUPO = IPCHP(/1)
      NNIN   = 0
      DO 20 I=1,NSOUPO
         MSOUPO = IPCHP(I)
         SEGACT MSOUPO
         NNIN   = NNIN + NOCOMP(/2)
 20   CONTINUE
C
C - Création et remplissage de MTRAV
C - Balayage des partitions de ICHP1, utilisation du tableau ICPR
C - Extraction des composantes uniquement contenues dans NOMTOT
C - si NBCOMP.NE.0
C
      SEGINI MTRAV
C
C - Nombre de composantes véritablement dans MTRAV :
C
      NBIN = 0
C
      DO 30 I=1,NSOUPO
         MSOUPO = IPCHP(I)
         NC     = NOCOMP(/2)
         MPOVAL = IPOVAL
         SEGACT MPOVAL
         MELEME = IGEOC
         SEGACT MELEME
         NBELEM = NUM(/2)
         DO 50 ICOMP=1,NC
           IF (NBCOMP.NE.0) THEN
              CALL PLACE(NOMTOT,NBCOMP,IPEXT,NOCOMP(ICOMP))
           ENDIF
           IF ((NBCOMP.EQ.0).OR.(IPEXT.NE.0)) THEN
              CALL PLACE(INCO,NBIN,IPOS,NOCOMP(ICOMP))
              IF ((IPOS.EQ.0).OR.(NHAR(IPOS).NE.NOHARM(ICOMP))) THEN
                 NBIN = NBIN + 1
                 INCO(NBIN) = NOCOMP(ICOMP)
                 NHAR(NBIN) = NOHARM(ICOMP)
                 IPOS = NBIN
              ENDIF
              DO 40 J=1,NBELEM
                 K  = NUM(1,J)
                 IK = ICPR(K)
                 IF (IK.NE.0) THEN
                    IGEO(IK) = K
                    IBIN(IPOS,IK) = 1
                    BB(IPOS,IK)   = VPOCHA(J,ICOMP)
                 ENDIF
 40           CONTINUE
            ENDIF
 
 50      CONTINUE
         SEGDES MELEME
         SEGDES MPOVAL
         SEGDES MSOUPO
 30   CONTINUE
      SEGDES MCHPOI
 
C
      NNIN = NBIN
      SEGADJ MTRAV
C
C - Test si toutes les composantes que l'on voulait extraire sont
C - bien dans le segment de travail
C
      DO 60 I=1,NBCOMP
         CALL PLACE(INCO,NNIN,IPEXT,NOMTOT(I))
         IF (IPEXT.EQ.0) THEN
            MOTERR(1:4) = NOMTOT(I)
            CALL ERREUR(197)
            SEGDES MTRAV,ICCPR
            RETURN
         ENDIF
 60   CONTINUE
 
      SEGDES MTRAV
      SEGDES ICCPR
C
      END