C COCHPO    SOURCE    CB215821  20/11/25    13:21:39     10792          
      SUBROUTINE COCHPO(I0,I1,ITAI,ITAF)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C    CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C    C CE SUBROUTINE VERIFIE QUE LES CHPOINTI0 ET I1 SONT BIEN IDENTIQUE
C    C EVENTUELLEMENT IL REMET LA LISTE ITAI SOUS LA FORME CORRESPONDANT
C    C A I0
C    C  ECRIT PAR FARVACQUE
C    C  APPELE PAR :FUSOLU
C    C  APPELLE ERREUR(60)
C    CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
-INC SMELEME

-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMSOLUT
-INC SMCOORD
C
      CHARACTER*(LOCOMP) ICOMP
      SEGMENT ICPR(nbpts)
      SEGMENT ICPRR(nbpts)
      SEGMENT ITRAV(4,NSOUP)
      SEGMENT ITRACO(NC)
C
C ITRAV(1,I)=NPOIN (NBRE DE POINTS DANS LE IEME SOUPO)
C ITRAV(2,I)=J : AU MSOUPO I CORRESPOND LE MSOUP1 J
C ITRAV(3,I)=0 : AUCUN CHANGEMENT A APPLIQUER AU MSOUPO I (SINON =1)
C ITRAV(4,I)=ITRACO : CONTIENT LE POINTEUR DU SEGMENT ITRACO
C CCC ITRACO(J)=K : LA COMPOSANTE A LA POSITION J DANS MCHPO1 EST A LA
C CCC  POSITION K DANS MCHPOI
C CCC MCHPOI SERA LA CONFIGURATION FINALE
C
      MCHPOI=I0
      MCHPO1=I1
      SEGACT MCHPO1,MCHPOI
      NSOUP=MCHPO1.IPCHP(/1)
      IF(NSOUP.EQ.IPCHP(/1)) GO TO 1
C     LES 2 CHPOINTS DOIVENT AVOIR LE MEME NOMBRE DE SOUS CHAMPS
      CALL ERREUR(60)
      GO TO 5000
 1    CONTINUE
      SEGINI ITRAV
      SEGINI ICPR
      SEGINI ICPRR
      ICPR1=nbpts
      DO 10 I=1,ICPR1
 10   ICPR(I)=0
C
C *** BOUCLE SUR LES SOUPO DE MCHPOI
C *** DANS ICPR(I) ON MET LE NUMERO DU SOUPO OU SE TROUVE LE POINT I
C *** ICPRR(I)=K SIGNIFIE QUE I EST LE KIEME POINT DU SOUPO
C
      DO 2 I=1,NSOUP
      MSOUPO=IPCHP(I)
      SEGACT MSOUPO
      MELEME=IGEOC
      SEGACT MELEME
      NPOIN=NUM(/2)
      ITRAV(1,I)=NPOIN
      DO 3 IPP=1,NPOIN
      J=NUM(1,IPP)
      ICPR(J)=I
      ICPRR(J)=IPP
 3    CONTINUE
      SEGDES MELEME,MSOUPO
 2    CONTINUE
C

      ICHPOI=MCHPOI
      CALL NUHARM(ICHPOI,IFO,IHAR)
      MCHPOI=ICHPOI
C   IFO=1 TOUTES LES HARMONIQUES SONT IDENTIQUES ...
C   ON PEUT METTRE ENSEMBLE DU MODE N ET DU MODE M
C
C***  BOUCLE SUR LES MSOUP1 DE MCHPO1
C
      DO 4 I=1,NSOUP
      MSOUP1=MCHPO1.IPCHP(I)
      SEGACT MSOUP1
      MELEME=MSOUP1.IGEOC
      SEGACT MELEME
      NPOIN=NUM(/2)
      IP1=NUM(1,1)
      ISOUPO=ICPR(IP1)
      IF(ICPRR(IP1).NE.1) ITRAV(3,ISOUPO)=1
      IF(ISOUPO.NE.0)    GO TO 5
C     POINT NON COMMUN AUX 2 CHPOINT
      CALL ERREUR(60)
      GO TO 5000
C
 5    CONTINUE
      IF(NPOIN.EQ.ITRAV(1,ISOUPO)) GO TO 6
C     LES 2 SOUPO N ONT PAS LE MEME NOMBRE DE POINTS
      CALL ERREUR(60)
      GO TO 5000
C
 6    CONTINUE
      ITRAV(2,ISOUPO)=I
      IF(NPOIN.EQ.1) GO TO 9
      DO 8 IPP=2,NPOIN
      IP1=NUM(1,IPP)
      IF(ICPRR(IP1).NE.IPP) ITRAV(3,ISOUPO)=1
      IF(ICPR(IP1).EQ.ISOUPO)GO TO 8
C     POINT NON COMMUN AUX 2 MSOUPO
      CALL ERREUR(60)
      GO TO 5000
 8    CONTINUE
 9    CONTINUE
      MSOUPO=IPCHP(ISOUPO)
      SEGACT MSOUPO
      NC=NOCOMP(/2)
      IF(MSOUP1.NOCOMP(/2).EQ.NC) GO TO 12
      CALL ERREUR(60)
C     PAS LE MEME NOMBRE DE COMPOSANTE
      GO TO 5000
 12   CONTINUE
      SEGINI ITRACO
      DO 13 IC=1,NC
      ICOMP=MSOUP1.NOCOMP(IC)
      IHARM=MSOUP1.NOHARM(IC)
      DO 14 ICC=1,NC
      IF(NOCOMP(ICC).NE.ICOMP) GO TO 14
      IF(IFO.NE.1.AND.NOHARM(ICC).NE.IHARM) GO TO 14
      IF(IC.NE.ICC)ITRAV(3,ISOUPO)=1
      ITRACO(IC)=ICC
      GO TO 13
 14   CONTINUE
      CALL ERREUR(60)
C     N ONT PAS LES MEMES COMPOSANTES
      GO TO 5000
 13   CONTINUE
      ITRAV(4,ISOUPO)=ITRACO
      SEGDES ITRACO
C
      SEGDES MSOUPO,MELEME,MSOUP1
 4    CONTINUE
      SEGDES MCHPO1
C
C
      DO 30 I=1,NSOUP
      IF(ITRAV(3,I).NE.0) GO TO 41
 30   CONTINUE
C     IL N Y A AUCUNE MODIF A FAIRE SUR LES MPOVAL
C
      DO 31 I=1,NSOUP
      IF(ITRAV(2,I).EQ.I) GO TO 31
      GO TO 41
 31   CONTINUE
C     IL N Y A AUCUNE MODIF A FAIRE ON SORT
      ITAF=ITAI
      GO TO 60
C
 41   CONTINUE
C *** SI IVAL=0  IL FAUT SEULEMENT PERMUTER LES MSOUP1
C *** SI IVAL=1 ON DOIT REMPLACER LES MSOUP1 PAR DES MSOUP2
C
      MSOLE1=ITAI
      SEGACT MSOLE1
      LTAB=MSOLE1.ISOLEN(/1)
      N=LTAB
      SEGINI MSOLEN
      DO 42 IT=1,LTAB
      ISOLEN(IT)=MSOLE1.ISOLEN(IT)
 42   CONTINUE
      SEGDES MSOLE1
C
      DO 50 IT=1,LTAB
      MCHPO1=ISOLEN(IT)
      SEGACT MCHPO1
      NSOUPO=NSOUP
      NAT=MCHPO1.JATTRI(/1)
      SEGINI MCHPO2
      MCHPO2.IFOPOI=IFOPOI
*  on reprend les meme attributs
      DO 101 INAT=1,NAT
          MCHPO2.JATTRI(INAT) = MCHPO1.JATTRI(INAT)
 101  CONTINUE
*
      DO 52 IS=1,NSOUPO
      MSOUP1=MCHPO1.IPCHP(ITRAV(2,IS))
      IF(ITRAV(3,IS).NE.0) GO TO 53
      MCHPO2.IPCHP(IS)=MSOUP1
      GO TO 52
 53   CONTINUE
      MSOUPO=IPCHP(IS)
      SEGACT MSOUPO,MSOUP1
      NC=MSOUP1.NOCOMP(/2)
      SEGINI MSOUP2
      MSOUP2.IGEOC=IGEOC
      DO 54 IC=1,NC
      MSOUP2.NOCOMP(IC)=NOCOMP(IC)
      MSOUP2.NOHARM(IC)=NOHARM(IC)
      IF(IFO.EQ.1) MSOUP2.NOHARM(IC)=MSOUP1.NOHARM(IC)
 54   CONTINUE
      MELEME=MSOUP1.IGEOC
      SEGACT MELEME
      MPOVA1=MSOUP1.IPOVAL
      SEGACT MPOVA1
      N=MPOVA1.VPOCHA(/1)
      NC=MPOVA1.VPOCHA(/2)
      SEGINI MPOVAL
      ITRACO=ITRAV(4,IS)
      SEGACT ITRACO
      DO 20 IN=1,N
      DO 20 IC=1,NC
      IP1=ICPRR(NUM(1,IN))
      VPOCHA(IP1,ITRACO(IC))=MPOVA1.VPOCHA(IN,IC)
 20   CONTINUE
      SEGDES ITRACO
      SEGDES MPOVA1,MPOVAL,MELEME
      MSOUP2.IPOVAL=MPOVAL
      SEGDES MSOUP2,MSOUP1,MSOUPO
      MCHPO2.IPCHP(IS)=MSOUP2
 52   CONTINUE
      SEGDES MCHPO2,MCHPO1
      ISOLEN(IT)=MCHPO2
 50   CONTINUE
      SEGDES MSOLEN
      ITAF=MSOLEN
C
 60   CONTINUE
      DO 58 I=1,NSOUP
      ITRACO=ITRAV(4,I)
      SEGSUP ITRACO
 58   CONTINUE
      SEGSUP ITRAV
      SEGSUP ICPR,ICPRR
      SEGDES MCHPOI
 5000 CONTINUE
      RETURN
      END