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