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