C MELMOF    SOURCE    CB215821  20/11/25    13:34:17     10792          
      SUBROUTINE MELMOF(IMDL,MTABD,IHV,TYPE,COEF,XPOI,MCHPOI,MCHELM,
     &KPOIND,MUG,MCHELG)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C
C  Ce Sp crée un MCHAML a partir d'un FLOTTANT ou d'un CHPOIN
C Le MCHAML en retour est jetable et est calcule aux pts d'integrations
C Le support géométrique du MCHELM (MCHELN) est compatible avec le schema
C d'intégration de l'opérateur
C c'est le MELEME sauf pour les MACRO (INEFMD=2) avec CENTREP0
C CENTREP1 et MSOMMET où MELEME=MACRO1
C----------------------------------------------------------------------
C HISTORIQUE : 20/10/01 : Création
C
C HISTORIQUE :
C
C
C---------------------------
C Paramètres Entrée/Sortie :
C---------------------------
C
C E/  MTABD  : Objet model de la zone
C E/  IHV    : 0 ou 1 Scalaire ou Vecteur
C E/  TYPE   : MOT  type du coefficient FLOTTANT VECTEUR CHPOINT
C E/  COEF   : FLOTTANT valeur du coef si flottant
C E/  XPOI   : POINT    valeur du coef si vecteur
C E/  MCHPOI : CHPOINT  valeur du coef si chpoint
C  /S MCHELM : Chamelem pts d'intégration pour le COEF
C E/  KPOIND : ENTIER type du support GÉométrique DUAL du shéma
C              d'intégration différent de KPOINC celui du coef
C              cette info sert à la construction du Chamelem
C E/  MUG=0 On rend le coefficient tel quel
C E/  MUG=1 Si le coefficient est un CHPOINT On retourne en plus le gradient
C  /S MCHELG : Chamelem pts d'intégration pour le Gradient du coef (=0 sinon)
C----------------------------------------------------------------------
C KPOIN = 0->SOMMET 1-> FACE     2-> CENTRE  3-> CENTREP0 4-> CENTREP1 5-> MSOMMET
C INEFMD : Type formulation INEFMD=1 LINE,=2 MACRO,=3 QUADRATIQUE, INEFMD=4 LINB
C************************************************************************

-INC SIZFFB
      POINTEUR IZF1.IZFFM,IZH2.IZHR,IZFD.IZFFM
      SEGMENT SAJT
      REAL*8 AJT(IDIM,IDIM,NPG)
      ENDSEGMENT
-INC SMCHAML
      POINTEUR MCHELG.MCHELM
-INC SMCHPOI
-INC SMELEME
      POINTEUR IGEOM.MELEME
      POINTEUR MELEMD.MELEME,SPGD.MELEME,MELEM1.MELEME,MELEMC.MELEME
-INC SMLENTI
-INC SMCOORD
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
      CHARACTER*4 NOMD4
      CHARACTER*8 TYPE,NOM0
      DIMENSION XPOI(3)
C*****************************************************************************
CMELMOF
c     write(6,*)' DEBUT MELMOF MUG=',MUG

      MCHELG=0

      XPETI=1.D-30
      IAXI=0
      IF(IFOMOD.EQ.0)IAXI=2
C
      CALL ACME(MTABD,'INEFMD',INEFMD)
c     write(6,*)'INEFMD=',INEFMD

      CALL LEKTAB(MTABD,'MAILLAGE',MELEME)
      IF(INEFMD.EQ.2.AND.
     & (KPOIND.EQ.3.OR.KPOIND.EQ.4.OR.KPOIND.EQ.5))THEN
      CALL LEKTAB(MTABD,'MACRO1',MELEME)
      ENDIF

      SEGACT MELEME

      L1=72
      N1=MAX(1,LISOUS(/1))
      N2=1
      N3=6
      SEGINI MCHELM

C-------------------------------------------------------------------------
C__MCHAML
c     write(6,*)' MELMOF TYPE=',TYPE
      IF(TYPE.EQ.'MCHAML'.AND.IMDL.EQ.0)THEN
C% Le type d'inconnue %m1:8 ne convient pas.
      CALL ERREUR(927)
      RETURN
      ENDIF
      IF(TYPE.EQ.'MCHAML')THEN

      ITEST=0
      IREDU=0
      MCHEL1=MCHPOI
 452  CONTINUE
      SEGACT MCHEL1
      NN1=MCHEL1.IMACHE(/1)
        IF(NN1.NE.N1)THEN
c        write(6,*)' NN1 différent de N1',N1,NN1,MCHEL1,ITEST
         ITEST=ITEST+1
          IF(ITEST.GT.1)THEN
C% Le nombre de sous-zones du chamelem est supérieur au nombre de
C% sous-zones du modèle
           CALL ERREUR(553)
           RETURN
          ENDIF
        ENDIF

      SEGACT MELEME
      DO 455 L=1,MAX(1,LISOUS(/1))
       IPT1=MELEME
       IF(LISOUS(/1).NE.0)IPT1=LISOUS(L)
       IPT2=MCHEL1.IMACHE(L)
c       write(6,*)' IPT1=',IPT1,' IPT2=',IPT2
        IF(IPT1.NE.IPT2)THEN
         ITEST=1
         GO TO 456
        ENDIF
 455  CONTINUE
 456  CONTINUE

        IF(ITEST.EQ.1.AND.IREDU.EQ.0)THEN
        IREDU=1
c       write(6,*)' On reduiiit'
         CALL ECROBJ('MMODEL',IMDL)
         CALL ECROBJ('MCHAML',MCHEL1)
         CALL REDU
         CALL LIROBJ('MCHAML',MCHEL1,1,IRETOU)
          IF(IRETOU.EQ.0)THEN
           CALL ERREUR(920)
           RETURN
          ENDIF
         GO TO 452
        ENDIF

      SEGACT MCHEL1
      MCHAM1=MCHEL1.ICHAML(1)
      SEGACT MCHAM1
      MELVA1=MCHAM1.IELVAL(1)
      SEGACT MELVA1


      SEGACT MELEME

      DO 371 L=1,MAX(1,LISOUS(/1))
      IPT1=MELEME
      IF(LISOUS(/1).NE.0)IPT1=LISOUS(L)
      SEGACT IPT1

      NOM0 = NOMS(IPT1.ITYPEL)//'    '
      CALL KALPBG(NOM0,'FONFORM ',IZFFM)
      SEGACT IZFFM
      IZHR=KZHR(1)
      SEGACT IZHR*MOD
      IZF1=KTP(1)
      IZH2=KZHR(2)

      NES=GR(/1)
      NPG=GR(/3)

      NBNN  =IPT1.NUM(/1)
      NBELEM=IPT1.NUM(/2)
      SEGINI MCHAML
      IDU=1
      IF(IHV.EQ.1)IDU=IDIM
      SEGINI SAJT
      N1PTEL=NPG*IDU
      N1EL  =NBELEM
      N2PTEL=0
      N2EL=0

      IMACHE(L)=IPT1
      ICHAML(L)=MCHAML

      MCHAM1=MCHEL1.ICHAML(L)
      SEGACT MCHAM1
      MELVA1=MCHAM1.IELVAL(1)
      SEGACT MELVA1

      SEGINI MELVAL
      IELVAL(1)=MELVAL

      DO 375 K=1,NBELEM
      COEF=MELVA1.VELCHE(1,K)

      IF(IHV.EQ.0)THEN
      DO 372 LG=1,NPG
      VELCHE(LG,K)=COEF
 372  CONTINUE
      ELSEIF(IHV.EQ.1)THEN
      DO 374 N =1,IDIM
      DO 374 LG=1,NPG
      VELCHE(LG+(N-1)*NPG,1)=XPOI(N)
 374  CONTINUE
      ENDIF
 375  CONTINUE

      SEGSUP IZFFM,IZHR,IZF1,IZH2,SAJT
      SEGDES IPT1,MCHAML,MELVAL
 371  CONTINUE
      SEGDES MCHELM,MELEME


C__FLOTTANT ENTIER ou POINT
      ELSEIF(TYPE.EQ.'FLOTTANT'.OR.TYPE.EQ.'ENTIER'.OR.
     &   TYPE.EQ.'POINT' )THEN
c     write(6,*)' MELMOF CAS ENTIER OU POINT : TYPE=',TYPE


      DO 171 L=1,MAX(1,LISOUS(/1))
      IPT1=MELEME
      IF(LISOUS(/1).NE.0)IPT1=LISOUS(L)
      SEGACT IPT1

      NOM0 = NOMS(IPT1.ITYPEL)//'    '
      CALL KALPBG(NOM0,'FONFORM ',IZFFM)
      SEGACT IZFFM
      IZHR=KZHR(1)
      SEGACT IZHR*MOD
      IZF1=KTP(1)
      IZH2=KZHR(2)

      NES=GR(/1)
      NPG=GR(/3)

      NBNN  =IPT1.NUM(/1)
      NBELEM=IPT1.NUM(/2)
      SEGINI MCHAML
      IDU=1
      IF(IHV.EQ.1)IDU=IDIM
      SEGINI SAJT
      N1PTEL=NPG*IDU
      N1EL  =1
      N2PTEL=0
      N2EL=0

      IMACHE(L)=IPT1
      ICHAML(L)=MCHAML

      SEGINI MELVAL
      IELVAL(1)=MELVAL

      IF(IHV.EQ.0)THEN
      DO 172 LG=1,NPG
      VELCHE(LG,1)=COEF
 172  CONTINUE
      ELSEIF(IHV.EQ.1)THEN
      DO 174 N =1,IDIM
      DO 174 LG=1,NPG
      VELCHE(LG+(N-1)*NPG,1)=XPOI(N)
 174  CONTINUE
      ENDIF

      SEGSUP IZFFM,IZHR,IZF1,IZH2,SAJT
      SEGDES IPT1,MCHAML,MELVAL
 171  CONTINUE
      SEGDES MCHELM,MELEME

C__CHPOINT
      ELSEIF(TYPE.EQ.'CHPOINT')THEN
c        write(6,*)' MELMOF CAS CHPOINT'

         IF(IHV.EQ.0.AND.MUG.EQ.1)THEN
C ON SORT LE GRADIENT DU COEFFICIENT EN PLUS
         MUVARI=1
      L1=72
      N1=MAX(1,LISOUS(/1))
      N2=1
      N3=6
      SEGINI MCHELG
         ELSE
         MUVARI=0
         ENDIF

         SEGACT MCHPOI
         NSOUPO=IPCHP(/1)

         IF(NSOUPO.EQ.1) THEN
         MSOUPO=IPCHP(1)
         SEGACT MSOUPO
         IGEOM=IGEOC
         MPOVAL=IPOVAL
         SEGDES MSOUPO
         SEGACT MPOVAL
         NC=VPOCHA(/2)
C On ne traite que les coefficients scalaires
         IF(IHV.EQ.0.AND.NC.NE.1)THEN
c        write(6,*)' MELMOF IHV=',IHV,' NC=',NC
         CALL ERREUR(788)
         RETURN
         ENDIF
         IF(IHV.EQ.1.AND.NC.NE.IDIM)THEN
c        write(6,*)' MELMOF IHV=',IHV,' NC=',NC
         CALL ERREUR(788)
         RETURN
         ENDIF
         ELSE
         CALL ERREUR(788)
         RETURN
         ENDIF

c        write(6,*)' IGEOM=',IGEOM
      CALL KRIPAD(IGEOM,MLENTI)

         KPOINC=0
         NOMD4= '    '
         CALL LEKTAB(MTABD,'MAILLAGE',MELEMD)

         IF(INEFMD.EQ.2.AND.
     &   (KPOIND.EQ.3.OR.KPOIND.EQ.4.OR.KPOIND.EQ.5))THEN
         CALL LEKTAB(MTABD,'MACRO1',MELEMD)
         ENDIF

         CALL LEKTAB(MTABD,'SOMMET',SPGD)
         CALL VERPAD(MLENTI,SPGD,IRET)
c        write(6,*)' SOMMET (0 OK) ',SPGD,iret
         SEGDES SPGD
        IF(IRET.EQ.0)GO TO 180
         KPOINC=2
         NOMD4= '    '
         CALL LEKTAB(MTABD,'CENTRE',MELEMD)
         CALL LEKTAB(MTABD,'CENTRE',SPGD)
         CALL VERPAD(MLENTI,SPGD,IRET)
c        write(6,*)' CENTRE (0 OK) ',SPGD,iret
         SEGDES SPGD
         IF(INEFMD.EQ.3)THEN
         KPOINC=3
         NOMD4= 'PRP0'
         ENDIF
        IF(IRET.EQ.0)GO TO 180
         KPOINC=5
         NOMD4= 'P1P1'
         IF(INEFMD.EQ.2)NOMD4= 'MCF1'
         IF(INEFMD.EQ.3)NOMD4= 'PFP1'
         CALL LEKTAB(MTABD,'MMAIL  ',MELEMD)
         CALL LEKTAB(MTABD,'MSOMMET',SPGD)
         CALL VERPAD(MLENTI,SPGD,IRET)
c        write(6,*)'MSOMMET (0 OK) ',SPGD,iret
         SEGDES SPGD
        IF(IRET.EQ.0)GO TO 180
         IF(INEFMD.EQ.2.OR.INEFMD.EQ.3)THEN
           KPOINC=4
           NOMD4= '    '
           IF(INEFMD.EQ.2)NOMD4= 'MCP1'
           IF(INEFMD.EQ.3)NOMD4= 'PRP1'
           CALL LEKTAB(MTABD,'ELTP1NC ',MELEMD)
           CALL LEKTAB(MTABD,'CENTREP1',SPGD)
           CALL VERPAD(MLENTI,SPGD,IRET)
c          write(6,*)'CENTREP1 (0 OK) ',SPGD,iret
           SEGDES SPGD
          IF(IRET.EQ.0)GO TO 180
           KPOINC=3
           NOMD4= '    '
           IF(INEFMD.EQ.2)NOMD4= 'MCP0'
           IF(INEFMD.EQ.3)NOMD4= 'PRP0'
           CALL LEKTAB(MTABD,'CENTREP0',MELEMD)
           CALL LEKTAB(MTABD,'CENTREP0',SPGD)
           CALL VERPAD(MLENTI,SPGD,IRET)
           SEGDES SPGD
          IF(IRET.EQ.0)GO TO 180
         ENDIF

C__CHPOINT_SUPPORT_INCONU
C     Indice %m1:8 : L'objet %m9:16 n'a pas le bon support géométrique
          MOTERR(1: 8) = 'CHPOINT '
          MOTERR(9:16) = ' COEF   '
          CALL ERREUR(788)
          RETURN
 180  CONTINUE
      SEGDES IGEOM
C__CHPOINT
c      write(6,*)' CAs CHPOIN '

      SEGACT MELEMD

      NKD0=0
      DO 191 L=1,MAX(1,LISOUS(/1))
      IPT1=MELEME
      IPT2=MELEMD
      IF(LISOUS(/1).NE.0)IPT1=LISOUS(L)
      SEGACT IPT1
      IF(MELEMD.LISOUS(/1).NE.0)IPT2=MELEMD.LISOUS(L)
      SEGACT IPT2
      IF(MELEMD.LISOUS(/1).NE.0)NKD0=0
      MP=IPT2.NUM(/1)

C-----------------------------------------------------------------------
      IF(KPOIND.NE.2)THEN
       IF(INEFMD.EQ.3)THEN
       IF(KPOIND.EQ.3)NOM0=NOMS(IPT1.ITYPEL)//'PRP0'
       IF(KPOIND.EQ.4)NOM0=NOMS(IPT1.ITYPEL)//'PRP1'
       IF(KPOIND.EQ.5)NOM0=NOMS(IPT1.ITYPEL)//'PFP1'
       ELSEIF(INEFMD.EQ.2)THEN
       IF(KPOIND.EQ.3)NOM0=NOMS(IPT1.ITYPEL)//'MCP0'
       IF(KPOIND.EQ.4)NOM0=NOMS(IPT1.ITYPEL)//'MCP1'
       IF(KPOIND.EQ.5)NOM0=NOMS(IPT1.ITYPEL)//'MCF1'
       ELSEIF(INEFMD.EQ.1)THEN
       IF(KPOIND.EQ.5)NOM0=NOMS(IPT1.ITYPEL)//'P1P1'
       ELSEIF(INEFMD.EQ.4)THEN
       NOM0=NOMS(IPT1.ITYPEL)//'    '
       ENDIF
      ENDIF

      IF(KPOIND.EQ.2)THEN
      NOM0 = NOMS(IPT1.ITYPEL)//NOMD4
      ENDIF

      IF(KPOIND.EQ.0)THEN
      NOM0 = NOMS(IPT1.ITYPEL)
      NOM0 = NOMS(IPT1.ITYPEL)//NOMD4
      ENDIF

C-----------------------------------------------------------------------
cc      write(6,*)' MELMOF 2 KPOIND=',KPOIND,' NOMS=',NOMS(IPT1.ITYPEL),
cc     & ' NOMD4=',NOMD4,' NOM0=',NOM0
      CALL KALPBG(NOM0,'FONFORM ',IZFFM)
      SEGACT IZFFM
      IZHR=KZHR(1)
      IZF1=KTP(1)
      IZH2=KZHR(2)
      SEGACT IZHR*MOD

      IZFD=IZF1
      IF(KPOINC.EQ.0)IZFD=IZFFM
      SEGACT IZFD*MOD
      IF(MP.NE.IZFD.FN(/1))THEN
      write(6,*)' Gross problem dans MELMOF'
      write(6,*)' INEFMD=',INEFMD,' NOMD4=',NOMD4
      write(6,*)' MP=',MP,' KPOINC.=',KPOINC,' IZFD.FN(/1)='
     & ,IZFD.FN(/1)
      ENDIF


      NES=GR(/1)
      NP =GR(/2)
      NPG=GR(/3)

      NBNN  =IPT1.NUM(/1)
      NBELEM=IPT1.NUM(/2)
      SEGINI MCHAML

      IDU=1
      IF(IHV.EQ.1)IDU=IDIM
      SEGINI SAJT
      N1PTEL=NPG*IDU
      N1EL  =NBELEM
      N2PTEL=0
      N2EL=0
      IMACHE(L)=IPT1
      ICHAML(L)=MCHAML

      SEGINI MELVAL
      IELVAL(1)=MELVAL

C......................................MUVARI..DEBUT
      IF(MUVARI.EQ.1)THEN
      N2=IDIM
      SEGINI MCHAM1
      N1PTEL=NBNN
      N1EL  =NBELEM
      N2PTEL=0
      N2EL=0
      MCHELG.IMACHE(L)=IPT1
      MCHELG.ICHAML(L)=MCHAM1

      SEGINI MELVA1
      MCHAM1.IELVAL(1)=MELVA1

      ENDIF
C......................................MUVARI..FIN

      ID1=1
      IF(IHV.EQ.1)ID1=IDIM

      NKD=NKD0
      DO 192 K=1,N1EL
      NKD=NKD+1
      DO 194 N=1,ID1
      DO 194 LG=1,NPG
      U=0.D0
      DO 193 I=1,MP
      I1=LECT(IPT2.NUM(I,NKD))
      U=U+IZFD.FN(I,LG)*VPOCHA(I1,N)
 193  CONTINUE
      VELCHE(LG+(N-1)*NPG,K)=U
 194  CONTINUE
 192  CONTINUE

      SEGDES MELVAL,MCHAML

C......................................MUVARI..DEBUT
      IF(MUVARI.EQ.1)THEN

      NKD=NKD0
      DO 292 K=1,N1EL
      NKD=NKD+1
      DO 293 I=1,MP
      I1=LECT(IPT2.NUM(I,NKD))
      MELVA1.VELCHE(I,K)=VPOCHA(I1,1)
 293  CONTINUE
 292  CONTINUE

      SEGDES MELVA1,MCHAM1

      ENDIF
C......................................MUVARI..FIN

      NKD0=NKD
      SEGDES IPT1
      SEGSUP IZFFM,IZHR,IZF1,IZH2,SAJT

 191  CONTINUE
      SEGDES MCHELM
      IF(MUVARI.EQ.1)SEGDES MCHELG

      SEGDES MCHPOI,MSOUPO,MPOVAL
      SEGDES MELEME
      SEGSUP MLENTI


      ENDIF

C*************************************************************************

c     write(6,*)' FIN MELMOF '
      RETURN
 1001 FORMAT(20(1X,I5))
 1002 FORMAT(10(1X,1PE11.4))
      END