C KMF       SOURCE    CHAT      05/01/13    00:57:24     5004           
      SUBROUTINE KMF
C ***********************************************************************       
C                                                                               
C    Objet   :  Cet operateur calcule soit C*U
C                                      soit C*1/D * U
C                                                                               
C    Syntaxe :
C               CAS 1 /
C                                                                               
C               B = KMF MATRAK MCHPOI ;
C                                                                               
C                                                                               
C               CAS 2 /
C
C               B = KMF  MATRAK MCHPOI 'MDM1' CHPOIMDM1 ;
C      ou
C               KMF  MATRAK MCHPOI 'MDM1' CHPOIMDM1 B ;
C                                                                               
C    Dans ce dernier cas KMF agit comme foncteur sur B
C                                                                               
C                                                                               
C                                                                               
C                                                                               
C     POINTEURS :                                                               
C                                                                               
C     MATRAK  MATRICES ELEMENTAIRES DE LA DIVERGENCE (ALIAS "C")
C     IZTUN   CHPOINT CONTENANT U
C                                                                               
C     EN SORTIE :                                                               
C                                                                               
C     IZB     CONTIENT C*U                                                      
C                                                                               
C ***********************************************************************       
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
      CHARACTER*8 TYPE,TYPC
-INC CCOPTIO
-INC SMELEME                                                                    
-INC SMLENTI
      POINTEUR IZIPAD.MLENTI
C-INC SMMATRAK
C*************************************************************************
C                                                                               
C    REPERAGE ET STOKAGE DES MATRICES ELEMENTAIRES  puis assemblees
C                                                                               

* LGEOC SPG de la pression et/ou des multiplicateurs de Lagrange
* (points CENTRE ) pour chaque operateur de contrainte
* KGEOC SPG pour la totalite des points CENTRE.
* KGEOS SPG pour la totalite des points SOMMET (Diagonale vitesse)
* KLEMC Connectivites de l'ensemble des contraintes
* LIZAFM(NBSOUS) contient les pointeurs IZAFM des sous-zones

      SEGMENT MATRAK
      INTEGER LGEOC(NBOP),IDEBS(NBOP),IFINS(NBOP)
      INTEGER LIZAFM(NBSOUS)
      INTEGER IKAM0 (NBSOUS)
      INTEGER IMEM  (NBELC)
      INTEGER KLEMC,KGEOS,KGEOC,KDIAG,KCAC,KIZCL,KIZGC
      ENDSEGMENT

      SEGMENT IZAFM                                                             
      REAL*8  AM(NNELP,NP,IESP),RPGI(NELAX)
      ENDSEGMENT                                                                

      POINTEUR IPMJ.IZAFM,IPMK.IZAFM

C*******************************************************************            
-INC SMCHPOI
      POINTEUR IZB.MCHPOI,IZBB.MPOVAL
      POINTEUR IZD.MCHPOI,IZDD.MPOVAL
      CHARACTER*4 LISMOT(1)
      DATA LISMOT/'MDM1'/
C****
                                                                                
C     LECTURE DES ARGUMENTS                                                     

      CALL QUETYP(TYPE,1,IRET)
      IF(IRET.EQ.0) RETURN

      IF(TYPE.EQ.'MATRIK')THEN
      CALL KMFN
      RETURN
      ELSEIF(TYPE.EQ.'MATRAK')THEN
      CALL LIROBJ('MATRAK',MATRAK,1,IRET)

      CALL LIROBJ('CHPOINT',MCHPOI,1,IRET)
      IF(IRET.EQ.0) RETURN

      CALL LIRMOT(LISMOT,1,IMDM1,0)

      IF(IMDM1.NE.0)THEN
      CALL LIROBJ('CHPOINT',IZD,1,IRET)
      IF(IRET.EQ.0) RETURN
      CALL LICHT(IZD,IZDD,TYPC,IGEOM)
      ENDIF

      SEGACT MATRAK
      MELEME=KLEMC
      MELEM1=KGEOS
      CALL KRIPAD(MELEM1,IZIPAD)
      IGEOMC=KGEOC
      TYPE='CENTRE'


      IF(IMDM1.EQ.0)THEN
      CALL CRCHPT(TYPE,IGEOMC,1,IZB)
      CALL LICHT(IZB,IZBB,TYPC,IGEOM)
        
      ELSE
      CALL LIROBJ('CHPOINT',IZB,0,IRET)

      IEB=1
      IF(IRET.EQ.0) THEN
      IEB=0
      CALL CRCHPT(TYPE,IGEOMC,1,IZB)
      ENDIF

      CALL LICHT(IZB,IZBB,TYPC,IGEOM)
      IF(IGEOM.NE.IGEOMC)THEN
      WRITE(6,*)' Le champ de contraintes n a pas le meme support'
     &,' geometrique que les matrices de contrainte '
      RETURN
      ENDIF
      ENDIF


      CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOU)
      N=VPOCHA(/1)

      SEGACT MELEME 
      NBSOUS=LISOUS(/1)                                                         
      IF(NBSOUS.EQ.0)NBSOUS=1                                                   
      KK=0                                                                      
      DO 15 KS=1,NBSOUS                                                         
      IF(NBSOUS.EQ.1)IPT1=MELEME                                                
      IF(NBSOUS.NE.1)IPT1=LISOUS(KS)                                            
      IZAFM=LIZAFM(KS)                                                          
      SEGACT IPT1,IZAFM                                                         
                                                                                
      NP=IPT1.NUM(/1)                                                           
      NEL=IPT1.NUM(/2)                                                          
      IF(IDIM.EQ.3)GO TO 5
C
C                                2D                                             
C                                                                               

      K0=KK
      IF(IMDM1.NE.0)THEN
      CALL KRA002(AM,VPOCHA,IZDD.VPOCHA,IZBB.VPOCHA(K0+1,1),
     & IPT1.NUM,IZIPAD.LECT,NP,NEL,N)
      ELSE
      CALL KMF2(AM,VPOCHA,IZBB.VPOCHA(K0+1,1),
     & IPT1.NUM,IZIPAD.LECT,NP,NEL,N)
      ENDIF
      KK=K0+NEL

      GO TO 10                                                                  
                                                                                
    5 CONTINUE                                                                  
C
C                                3D                                             
C                                                                               
      K0=KK
      IF(IMDM1.NE.0)THEN
      CALL KRA003(AM,VPOCHA,IZDD.VPOCHA,IZBB.VPOCHA(K0+1,1),
     & IPT1.NUM,IZIPAD.LECT,NP,NEL,N)
      ELSE
      CALL KMF3(AM,VPOCHA,IZBB.VPOCHA(K0+1,1),
     & IPT1.NUM,IZIPAD.LECT,NP,NEL,N)
      ENDIF
      KK=K0+NEL

 10   CONTINUE                                                                  
      IF(MELEME.NE.IPT1)SEGDES IPT1
      SEGDES IZAFM
 15   CONTINUE                                                                  
                                                                                
      SEGSUP IZIPAD
      SEGDES MELEME
      SEGDES MATRAK
      SEGACT MCHPOI
      MSOUPO=IPCHP(1)
      SEGDES MPOVAL
      SEGDES MSOUPO
      SEGDES MCHPOI
      SEGDES IZB,IZBB
      IF(IMDM1.NE.0)THEN
      SEGDES IZD,IZDD
      ENDIF

      IF(IMDM1.EQ.0.OR.IEB.EQ.0)CALL ECROBJ('CHPOINT ',IZB)
      ELSE
      RETURN
      ENDIF
                                                                                
      RETURN                                                                    
      END