C PRMCP5    SOURCE    MAGN      09/07/30    21:20:41     6458           
      SUBROUTINE PRMCP5(MMLPRI,MMLDUA,MMATEL,ICMPRI,ICMDUA,LNBME,
     $     MPOPRI,KICPRI,KMCPRI,
     $            KICDUA,KMCDUA,
     $     MPODUA,
     $     IMPR,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C NOM         : PRMCP5
C DESCRIPTION : Produit matrices élémentaires * mpoval primal 
C                       -> mpoval dual.
C
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES          : REGMAI, INIRPM, RPELEM
C APPELE PAR       : PRMCP2
C***********************************************************************
C ENTREES            : MLPRI, MMLDUA, MMATEL, ICMPRI, ICMDUA, LNBME,
C                      MPOPRI, KICPRI, KMCPRI, KICDUA, KMCDUA
C ENTREES/SORTIES    : -
C SORTIES            : MPODUA
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 18/04/2000, version initiale
C HISTORIQUE : v1, 18/04/2000, création
C HISTORIQUE :
C HISTORIQUE :
C***********************************************************************
C Prière de PRENDRE LE TEMPS de compléter les commentaires
C en cas de modification de ce sous-programme afin de faciliter
C la maintenance !
C***********************************************************************
-INC CCOPTIO
-INC SMELEME
      POINTEUR MMLPRI.MELEME
      POINTEUR MMLDUA.MELEME
      POINTEUR ML2PRI.MELEME
      POINTEUR ML2DUA.MELEME
      POINTEUR SMLPRI.MELEME
      POINTEUR SMLDUA.MELEME
-INC SMMATRIK
      POINTEUR MMATEL.IMATRI
      POINTEUR VMATEL.IZAFM
-INC SMLENTI
      POINTEUR RPMAT.MLENTI
      POINTEUR ICMPRI.MLENTI
      POINTEUR ICMDUA.MLENTI
      POINTEUR LNBME.MLENTI
      POINTEUR KICPRI.MLENTI
      POINTEUR KICDUA.MLENTI
      POINTEUR KMCPRI.MLENTI
      POINTEUR KMCDUA.MLENTI
-INC SMCHPOI
      POINTEUR MPOPRI.MPOVAL
      POINTEUR MPODUA.MPOVAL
*
      INTEGER IMPR,IRET
*
      INTEGER ICCPRI,ICCDUA,ILMAT,NUELG,NUELOC,ITPOPR,ITPODU
      INTEGER IELEM ,IMATL ,IPMAT,JDMAT, ISOUM,ISOUMA,OLDISM
      INTEGER NELPRI,NMATL ,NPMAT,NDMAT,NBSOUM,NBSOUP,NBSOUD
      LOGICAL LPARTP,LPARTD
*     
* Executable statements
*
      IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans prmcp5.eso' 
* On régularise les maillage pour plus se faire chier si LISOUS(/1).EQ.0 
* In REGMAI : IF (.NOT.LPARTD) SEGINI ML2DUA
      CALL REGMAI(MMLDUA,ML2DUA,LPARTD,IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
* In REGMAI : IF (.NOT.LPARTP) SEGINI ML2PRI
      CALL REGMAI(MMLPRI,ML2PRI,LPARTP,IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
*
* Activons les chapeaux (Matrices et supports)
*
      SEGACT ML2DUA
      NBSOUD=ML2DUA.LISOUS(/1)
      SEGACT ML2PRI
      NBSOUP=ML2PRI.LISOUS(/1)
      SEGACT MMATEL
      NBSOUM=NBSOUP
      IF (NBSOUD.NE.NBSOUP) THEN
         WRITE(IOIMP,*) 'Maillage primal, dual :'
         WRITE(IOIMP,*) 'partitionnment différent...'
         WRITE(IOIMP,*) 'NBSOUD=',NBSOUD
         WRITE(IOIMP,*) 'NBSOUP=',NBSOUP
         GOTO 9999
      ENDIF
*
* Tableau de repérage dans la matrice
*
* In INIRPM : SEGINI RPMAT
      CALL INIRPM(MMATEL,RPMAT,IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
*
* Activons les tableaux de repérage
*
* Matrices
*  Inconnues
      SEGACT ICMPRI
      SEGACT ICMDUA
*  Matrices élémentaires à parcourir
      SEGACT LNBME
* Chpoints
      SEGACT MPOPRI
      SEGACT MPODUA*MOD
*  Inconnues
      SEGACT KICPRI
      SEGACT KICDUA
*  Maillages
      SEGACT KMCPRI
      SEGACT KMCDUA
*
* Parcourons les matrices élémentaires par sous-domaine et
* remplissons les valeurs de MPODUA.
*
      NMATL=LNBME.LECT(/1)
      DO 1 IMATL=1,NMATL
* Numéros d'inconnues dans les chpo. primaux et duaux 
* pour la LNBME.LECT(IMATL)ième matrice
         ICCPRI=KICPRI.LECT(ICMPRI.LECT(LNBME.LECT(IMATL)))
         ICCDUA=KICDUA.LECT(ICMDUA.LECT(LNBME.LECT(IMATL)))
         NUELG=0
         OLDISM=1
         VMATEL=MMATEL.LIZAFM(OLDISM,LNBME.LECT(IMATL))
         SEGACT VMATEL
         DO 12 ISOUM=1,NBSOUM
            SMLDUA=ML2DUA.LISOUS(ISOUM)
            SEGACT SMLDUA
            SMLPRI=ML2PRI.LISOUS(ISOUM)
            SEGACT SMLPRI
            NELPRI=SMLPRI.NUM(/2)
            DO 122 IELEM=1,NELPRI
               NUELG=NUELG+1
               CALL RPELEM(NUELG,RPMAT,ISOUMA,NUELOC,IMPR,IRET)
               IF (IRET.NE.0) GOTO 9999
               ISOUMA=MAX(ISOUMA,1)
               IF (ISOUMA.NE.OLDISM) THEN
                  SEGDES VMATEL
                  VMATEL=MMATEL.LIZAFM(ISOUMA,LNBME.LECT(IMATL))
                  SEGACT VMATEL
                  OLDISM=ISOUMA
               ENDIF
               ILMAT=NUELOC
               NPMAT=VMATEL.AM(/2)
               NDMAT=VMATEL.AM(/3)
               DO 1222 JDMAT=1,NDMAT
                  ITPODU=KMCDUA.LECT(SMLDUA.NUM(JDMAT,IELEM))
                  IF (ITPODU.EQ.0) THEN
                     WRITE(IOIMP,*) 'Point dual ????'
                     GOTO 9999
                  ENDIF
                  DO 12222 IPMAT=1,NPMAT
                     ITPOPR=KMCPRI.LECT(SMLPRI.NUM(IPMAT,IELEM))
*                     IF (ITPOPR.EQ.0) THEN
*                        WRITE(IOIMP,*) 'Un point du chpo. primal ',
*     $                       'n''est pas dans le spg primal de la  ',
*     $                       'matrice..'
*                        GOTO 9999
*                     ENDIF
                     IF (ITPOPR.NE.0) THEN
                        MPODUA.VPOCHA(ITPODU,ICCDUA)=
     $                       MPODUA.VPOCHA(ITPODU,ICCDUA)+
     $                       (VMATEL.AM(ILMAT,IPMAT,JDMAT)
     $                       *MPOPRI.VPOCHA(ITPOPR,ICCPRI))
                     ENDIF
12222             CONTINUE
 1222          CONTINUE
 122        CONTINUE
            SEGDES SMLPRI
            SEGDES SMLDUA
  12      CONTINUE
          SEGDES VMATEL
 1    CONTINUE
*
* Désactivons les tableaux de repérage
*
      SEGDES KMCDUA
      SEGDES KMCPRI
      SEGDES KICDUA
      SEGDES KICPRI
      SEGDES MPODUA
      SEGDES MPOPRI
      SEGDES LNBME
      SEGDES ICMDUA
      SEGDES ICMPRI
      SEGDES RPMAT
      SEGDES MMATEL
      SEGDES ML2PRI
      SEGDES ML2DUA
      IF (.NOT.LPARTP) SEGSUP ML2PRI
      IF (.NOT.LPARTD) SEGSUP ML2DUA
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine prmcp5'
      RETURN
*
* End of subroutine PRMCP5
*
      END