C PRMCP5    SOURCE    GOUNAND   24/11/06    21:15:16     12073          
      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 PPARAM
-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
*
* 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 : SEGINI ML2DUA
      CALL REGMAI(MMLDUA,ML2DUA)
* In REGMAI : SEGINI ML2PRI
      CALL REGMAI(MMLPRI,ML2PRI)
*
* 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 LNBME
      SEGDES ICMDUA
      SEGDES ICMPRI
      SEGDES RPMAT
      SEGDES MMATEL
      SEGDES ML2PRI
      SEGDES ML2DUA
      SEGSUP ML2PRI
      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