C XTY       SOURCE    KICH      06/03/17    21:17:51     5342
      SUBROUTINE XTY
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C=======================================================================
C   OPERATEUR YTX : EFFECTUE LE PRODUIT Y * X
C     ON RETIRE DU CHPOINT LES MULT. DE LAGRANGE .
C   SYNTAXE :  Z = XTY X Y LISMOTX LISMOTY
C         Z : FLOTTANT
C         X : OBJET DE TYPE CHPOINT
C         Y : OBJET DE TYPE CHPOINT
C   LISMOTX : OBJET DE TYPE LISTE MOTS QUI PRECISE LES INCONNUES
C             DE X A PRENDRE EN COMPTE
C   LISMOTY : OBJET DE TYPE LISTE MOTS QUI PRECISE LES INCONNUES
C             DE Y CORRESPONDANTES
C      EX : UX UY UZ  ET FX FY FZ POUR FAIRE LE PRODUIT U * F
C
C=======================================================================

-INC PPARAM
-INC CCOPTIO
-INC SMLCHPO
-INC SMLREEL
C
C     LECTURE D UN CHPOINT
C
      CALL LIROBJ('CHPOINT ',MCHPOI,0,IRETOU)
      IF(IERR.NE.0) GO TO 5000
      if (iretou.ne.0) then
        CALL LIROBJ('CHPOINT ',ICH1,1,IRETOU)
        IF(IERR.NE.0) GO TO 5000
        CALL LIROBJ('LISTMOTS',MLMOTX,1,IRETOU)
        IF(IERR.NE.0) GO TO 5000
        CALL LIROBJ('LISTMOTS',MLMOTY,1,IRETOU)
        IF(IERR.NE.0) GO TO 5000
        CALL XTY1(MCHPOI,ICH1,MLMOTX,MLMOTY,XDRET)
        IF(IERR.NE.0) GO TO 5000
        CALL ECRREE(XDRET)
      endif

      CALL LIROBJ('LISTCHPO',LMCHPO,0,IRETOU)
      IF(IERR.NE.0) GO TO 5000
      if (iretou.ne.0) then
        CALL LIROBJ('LISTCHPOI',LICH1,1,IRETOU)
        IF(IERR.NE.0) GO TO 5000
        CALL LIROBJ('LISTMOTS',MLMOTX,1,IRETOU)
        IF(IERR.NE.0) GO TO 5000
        CALL LIROBJ('LISTMOTS',MLMOTY,1,IRETOU)
        IF(IERR.NE.0) GO TO 5000

      MLCHP1 = lmchpo
      segact mlchp1
      n1 = mlchp1.ichpoi(/1)

      if (n1.le.0) call erreur(3)
      if (ierr.ne.0) return
      MLCHP2 = lich1
      segact mlchp2

      jg = n1
      segini mlreel

      do ic = 1,n1
        mchpo1 = mlchp1.ichpoi(ic)
        mchpo2 = mlchp2.ichpoi(ic)
        CALL XTY1(MCHPO1,mchpo2,MLMOTX,MLMOTY,XDRET)
      if (ierr.ne.0) return

        prog(ic) = xdret
      enddo

        segdes mlchp1, mlchp2,mlreel
        CALL ECROBJ('LISTREEL',mlreel)
      endif

 5000 CONTINUE
      RETURN
      END