Sources Esope | Cast3M

meldiv
C MELDIV    SOURCE    CB215821  20/11/25    13:34:14     10792          
      SUBROUTINE MELDIV(MTABD,MCHPOI,MCHELM,KPOIND)
      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 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/  MCHPOI : CHPOINT  valeur du coef si chpoint (chpoint vecteur)
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----------------------------------------------------------------------
C KPOIN = 0->SOMMET 1-> FACE     2-> CENTRE  3-> CENTREP0 4-> CENTREP1 5-> MSOMMET
C************************************************************************
 
-INC SIZFFB
      POINTEUR IZF1.IZFFM,IZH2.IZHR,IZFD.IZFFM
      SEGMENT SAJT
      REAL*8 AJT(IDIM,IDIM,NPG)
      ENDSEGMENT
-INC SMCHAML
-INC SMCHPOI
-INC SMELEME
      POINTEUR IGEOM.MELEME
      POINTEUR MELEMD.MELEME,SPGD.MELEME
-INC SMLENTI
-INC SMCOORD
 
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
      CHARACTER*4 NOMD4
      CHARACTER*8 TYPE,NOM0
      DIMENSION XPOI(3)
C*****************************************************************************
CMELDIV
c     write(6,*)' DEBUT MELDIV '
      XPETI=1.D-30
      IAXI=0
      IF(IFOMOD.EQ.0)IAXI=2
C
      CALL ACME(MTABD,'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__CHPOINT
         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)
         IF(NC.NE.IDIM)THEN
         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)
         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
 
      NKD=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)NKD=0
      MP=IPT2.NUM(/1)
 
      NOM0 = NOMS(IPT1.ITYPEL)//NOMD4
      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 '
      write(6,*)' INEFMD=',INEFMD,' NOMD4=',NOMD4
      write(6,*)' MP=',MP,' KPOINC.=',KPOINC,' IZFD.FN(/1)='
     & ,IZFD.FN(/1)
      ENDIF
 
 
      NES=GR(/1)
      NPG=GR(/3)
 
      NBNN  =IPT1.NUM(/1)
      NBELEM=IPT1.NUM(/2)
      SEGINI MCHAML
 
      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     write(6,*)' Avt BCL 192 ',N1EL,nbnn,N1PTEL
      DO 192 K=1,N1EL
 
        DO 109 J=1,NBNN
        J1=IPT1.NUM(J,K)
        DO 109 N=1,IDIM
        XYZ(N,J)=XCOOR((J1-1)*(IDIM+1)+N)
 109    CONTINUE
 
        CALL CALJBR(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,
     &  IDIM,NBNN,NPG,IAXI,AIRE,AJ,SGN)
 
      NKD=NKD+1
 
      DO 194 LG=1,NPG
      U=0.D0
      DO 193 N=1,IDIM
      DO 193 I=1,MP
      I1=LECT(IPT2.NUM(I,NKD))
c     U=U+IZFD.FN(I,LG)*VPOCHA(I1,N)
      U=U+HR(N,I,LG)*VPOCHA(I1,N)
 193  CONTINUE
      VELCHE(LG,K)=U
 194  CONTINUE
 
      IF(IAXI.NE.0)THEN
      DO 196 LG=1,NPG
      U=0.D0
      DO 195 I=1,MP
      I1=LECT(IPT2.NUM(I,NKD))
      U=U+FN(I,LG)*VPOCHA(I1,1)/RPG(LG)
 195  CONTINUE
      VELCHE(LG,K)=VELCHE(LG,K)+U
 196  CONTINUE
      ENDIF
 
 192  CONTINUE
 
 
      SEGDES MELVAL
      SEGDES IPT1,MCHAML
      SEGSUP IZFFM,IZHR,IZF1,IZH2,SAJT
 191  CONTINUE
      SEGDES MCHPOI,MSOUPO,MPOVAL
      SEGDES MCHELM,MELEME
 
      SEGSUP MLENTI
 
 
 
C*************************************************************************
 
c     write(6,*)' FIN MELDIV '
      RETURN
 1001 FORMAT(20(1X,I5))
 1002 FORMAT(10(1X,1PE11.4))
      END