C PROCHP    SOURCE    PV        22/01/18    21:15:07     11267          

C=======================================================================
C  Sous programme appele par PROPER et DEDU1
C  Creation du CHPOINT MCHPO4 de deplacement du MAILLAGE elementaire
C  IPT1 vers le MAILLAGE elementaire IPT2
C  11/1997 : KICH
C  10/2003 : Modifications pour integration du cas IDIM=1
C=======================================================================

      SUBROUTINE PROCHP (IPT1,IPT2,MCHPO4,IP1)

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)


-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC SMELEME
-INC CCGEOME
-INC SMCHPOI

      SEGMENT ICPR(nbpts)
      SEGMENT ICP1(nbpts)

      idimp1=IDIM+1

      ICP1=IP1
C  Determination des noeuds supports du CHPOINT
      SEGINI,IPT3=IPT1
      CALL CHANGE(IPT3,1)
      SEGINI,IPT4=IPT2
      CALL CHANGE(IPT4,1)

C  Initialisation du CHPOINT de nature DISCRETE sur un unique MAILLAGE
      NSOUPO=1
      NAT=2
      SEGINI,MCHPO4
      MCHPOI=MCHPO4
      JATTRI(1)=1
      MTYPOI='DEPLACEM'
      MOCHDE='CHAMP CREE PAR PROPER'
      IFOPOI=IFOUR
      NC=IDIM
      SEGINI,MSOUP5
      IPCHP(1)=MSOUP5
      MSOUPO=MSOUP5
      SEGDES,MCHPO4
      IF (IFOMOD.EQ.3) THEN
        NOCOMP(1)='UX  '
      ELSE IF (IFOMOD.EQ.4.OR.IFOMOD.EQ.5) THEN
        NOCOMP(1)='UR  '
      ELSE IF (IFOMOD.EQ.0.OR.IFOMOD.EQ.1) THEN
        NOCOMP(1)='UR  '
        NOCOMP(2)='UZ  '
      ELSE
        NOCOMP(1)='UX  '
        NOCOMP(2)='UY  '
        IF (NC.GE.3) NOCOMP(3)='UZ  '
      ENDIF
      DO i=1,NC
        NOHARM(i)=NIFOUR
      ENDDO
      IGEOC=IPT3
      N=IPT3.NUM(/2)
      SEGINI,MPOVA5
      MPOVAL=MPOVA5
      IPOVAL=MPOVA5
      SEGDES,MSOUP5
C  Calcul des valeurs du CHPOINT
      SEGACT,IPT4,IPT3
      SEGACT,MCOORD
      SEGACT,ICP1*MOD
      DO i=1,N
        IF (ICP1(IPT3.NUM(1,i)).EQ.0) THEN
          ICP1(IPT3.NUM(1,i))=IPT4.NUM(1,i)
        ELSE IF (ICP1(IPT3.NUM(1,i)).NE.IPT4.NUM(1,i)) THEN
          GOTO 800
        ENDIF
        IREF4=(IPT4.NUM(1,i)-1)*idimp1
        IREF3=(IPT3.NUM(1,i)-1)*idimp1
        DO j=1,NC
          VPOCHA(i,j)=XCOOR(IREF4+j)-XCOOR(IREF3+j)
        ENDDO
      ENDDO
      SEGDES,MPOVA5,ICP1,IPT3
      RETURN

C  Erreur dans le calcul du CHPOINT, incompatibilite entre les maillages
 800  SEGSUP,MPOVA5,MSOUP5,MCHPO4,IPT3
      SEGDES,ICP1
      CALL ERREUR (878)
      RETURN

      END