C PROSCA    SOURCE    GOUNAND   26/01/09    21:15:50     12445          
      SUBROUTINE PROSCA(MCHPO1,MCHPO2,MLMOTX,MLMOTY,IRET)
C-----------------------------------------------------------------------
C                 PRODUIT SCALAIRE DE 2 CHPOINTS
C-----------------------------------------------------------------------
C    EN STANDARD LE CHPOINT RESULTAT A POUR NUMERO D'HARMONIQUE 0
C    EN SERIE DE FOURIER , IL EST TYPE NOHARM
C-----------------------------------------------------------------------
C  ENTREE
C     IPOI1   CHPOINT
C     IPOI2   CHPOINT
C     MLMOTX  LISTMOTS DE COMPOSANTES ASSOCIEES AU 1-ER  CHPOINT
C     MLMOTY  LISTMOTS DE COMPOSANTES ASSOCIEES AU 2-EME CHPOINT
C  SORTIE
C     IRET    POINTEUR SUR LE CHPOINT RESULTAT
C-----------------------------------------------------------------------

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

-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMLMOTS
-INC SMELEME
-INC SMCOORD
-INC TMTRAV

      CHARACTER*(LOCOMP) NOIN

      CHARACTER*4 NOMIL
      integer*4   iomil
      equivalence (nomil,iomil)
      DATA NOMIL/'NOHA'/

      SEGMENT ITRAV
        REAL*8 IVAA(NINC,NPOI),IVAB(NINC,NPOI)
        INTEGER IPOS(NINC),ICPRA(NPOI),ICPRB(NPOI)
        CHARACTER*(LOCOMP) INCA(NINC),INCB(NINC)
      ENDSEGMENT

      NPOI=nbpts
      MLMOTS=MLMOTX
      SEGACT MLMOTS
      NINC= MOTS(/2)
      SEGINI ITRAV
      DO 1 I = 1, NINC
         INCA(I)=MOTS(I)
  1   CONTINUE
      MLMOTS=MLMOTY
      SEGACT MLMOTS
      IF(MOTS(/2).NE.NINC) THEN
      SEGSUP ITRAV
      MOTERR(1:4)='PSCA'
      MOTERR(5:12)='LISTMOTS'
      CALL ERREUR(125)
      RETURN
      ENDIF
      DO 21 I = 1, NINC
         INCB(I)=MOTS(I)
 21   CONTINUE
C
C *********  IVAA CONTIENDRA LES VALEURS A MULTIPLIER PAR IVAB
C *********  CREATION D'ABORD DE IVAA PUIS DE IVAB
C
      MCHPOI=MCHPO1
      SEGACT MCHPOI
      NSOUPO = IPCHP(/1)
      DO 2 M = 1,NSOUPO
         MSOUPO = IPCHP(M)
         SEGACT MSOUPO
         NC=NOCOMP(/2)
         DO 10 I = 1,NINC
            IPOS(I)=0
 10      CONTINUE
         DO 4 K = 1, NINC
            DO 3 J = 1, NC
               NOIN= NOCOMP (J)
               IF(INCA(K). EQ . NOIN) THEN
                  IPOS(K)=J
                  GO TO 4
               ENDIF
 3          CONTINUE
 4       CONTINUE
         DO 5 I = 1,NINC
            IF(IPOS(I). NE . 0) GO TO 6
 5       CONTINUE
         GO TO 8
 6       CONTINUE
         MELEME=IGEOC
         SEGACT MELEME
         NBELEM=NUM(/2)
         MPOVAL=IPOVAL
         SEGACT MPOVAL
         DO 9 LI = 1,NINC
            KL = IPOS(LI)
            IF(KL.EQ.0) GO TO 9
            DO 7 I = 1,NBELEM
               I1 = NUM(1,I)
               IVAA(LI,I1)=VPOCHA(I,KL)
               ICPRA(I1)=1
 7          CONTINUE
 9       CONTINUE
 8       CONTINUE
    2 CONTINUE
C
C     TRAITEMENT DU 2-EME CHPOINT
C
      IA=0
      MCHPOI=MCHPO2
      SEGACT MCHPOI
      NSOUPO = IPCHP(/1)
      DO 12 M = 1,NSOUPO
         MSOUPO = IPCHP(M)
         SEGACT MSOUPO
         NC=NOCOMP(/2)
         DO 11 I = 1,NINC
            IPOS(I)=0
 11      CONTINUE
         DO 14  K= 1,NINC
            DO 13  J = 1, NC
               NOIN= NOCOMP (J)
               IF(INCB(K). EQ . NOIN) THEN
                  IPOS(K)=J
                  GO TO 14
               ENDIF
 13         CONTINUE
 14      CONTINUE
         DO 15 I = 1,NINC
            IF(IPOS(I). NE . 0) GO TO 16
 15      CONTINUE
         GO TO 18
 16      CONTINUE
         MELEME=IGEOC
         SEGACT MELEME
         NBELEM=NUM(/2)
         MPOVAL=IPOVAL
         SEGACT MPOVAL
         DO 19 LI = 1,NINC
            KL = IPOS(LI)
            IF(KL.EQ.0) GO TO 19
            DO 17 I = 1,NBELEM
               I1 = NUM(1,I)
               IVAB(LI,I1)=VPOCHA(I,KL)
               IF(ICPRA(I1).NE.0) THEN
                  IA=IA+1
                  ICPRB(I1)=IA
               ENDIF
 17         CONTINUE
 19      CONTINUE
 18      CONTINUE
 12   CONTINUE
*
      CALL COMBNA(MCHPO1,MCHPO2,INAT,IATTR)
*     Si IATTR1 = DIFFUS et IATTR2 = DISCRET ou vice-versa, on veut bien
*     mettre IATTR = DISCRET pour le produit scalaire
      IF (IATTR.NE.2) THEN
         NAT1 = MCHPO1.JATTRI(/1)
         IATTR1=0
         IF (NAT1.GE.1) IATTR1=MCHPO1.JATTRI(1)
         NAT2 = MCHPO2.JATTRI(/1)
         IATTR2=0
         IF (NAT2.GE.1) IATTR2=MCHPO2.JATTRI(1)
         IF ((IATTR1.EQ.1.AND.IATTR2.EQ.2)
     $        .OR.(IATTR1.EQ.2.AND.IATTR2.EQ.1)) IATTR=2
      ENDIF

      IF(IA.EQ.0) THEN
C
C     CHPOINT VIDE
C
      SEGSUP ITRAV
      NSOUPO=0
      NAT=1
      SEGINI MCHPOI
      IFOPOI=IFOUR
      IF (INAT.GE.1) JATTRI(1)=IATTR
      IRET=MCHPOI
      RETURN
      ENDIF
C
C     ON EFFECTUE LE CALCUL
C
      NNIN=1
      NNNOE=IA
      SEGINI MTRAV
      INCO(1)='SCAL'
*
*  MODIF  MILL LE 18 / 7 / 90
*  REMPLISSAGE DE L'HARMONIQUE : NOHARM SI FOURIER , 0 SINON
*
      NHMIL=iomil
      IF(IFOPOI.EQ.1) THEN
      NHAR(1)=NHMIL
      ELSE
      NHAR(1)=0
      ENDIF
*
      MCHPOI=MCHPO1
      SEGACT MCHPOI
      NSOUPO=IPCHP(/1)
      DO 22 M=1,NSOUPO
        MSOUPO=IPCHP(M)
        SEGACT MSOUPO
        MELEME=IGEOC
        SEGACT MELEME
        DO 27 J=1,NUM(/2)
          I1=NUM(1,J)
          IB=ICPRB(I1)
          IF(IB.EQ.0) GO TO 27
          IF(IGEO(IB).NE.0) GO TO 27
          IGEO(IB)=I1
          IBIN(1,IB)=1
          DO 28 LI=1,NINC
            BB(1,IB)=BB(1,IB)+IVAA(LI,I1)*IVAB(LI,I1)
  28      CONTINUE
  27    CONTINUE
  22  CONTINUE
      SEGSUP ITRAV
      CALL CRECHP(MTRAV,IRET)
      SEGSUP MTRAV
      MCHPOI=IRET
      SEGACT MCHPOI*MOD
      NAT=INAT
      NSOUPO=IPCHP(/1)
      SEGADJ,MCHPOI
      JATTRI(1)=IATTR
      RETURN
      END