C XXSOUR SOURCE CB215821 20/11/25 13:43:37 10792 SUBROUTINE XXSOUR(KPOIND,NOMD4,MCHPO1,XPG,MELEME,MELEMD,SPGD, & MCHEL4,INEFMD) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C*********************************************************************** C C SYNTAXE : C C / / C On calcule | W S do = | Ma NbSb do C / / C EN 2D C elements SEG2 -> Flux C elements TRI3 -> Source volumique C elements QUA4 -> Source volumique C EN 3D C elements SEG2 -> Pas de sens !! C elements TRI3 -> Flux C elements QUA4 -> Flux C elements CUB8 -> Source volumique C elements PRI6 -> Source volumique C elements TET4 -> Source volumique C C*********************************************************************** -INC PPARAM -INC CCOPTIO -INC CCREEL -INC CCGEOME -INC SMCHAML -INC SMCOORD -INC SMLENTI -INC SMELEME POINTEUR MELEMD.MELEME,SPGD.MELEME -INC SMCHPOI -INC SMMATRIK -INC SIZFFB POINTEUR IZF1.IZFFM,IZH2.IZHR,IZW.IZFFM,IZWH.IZHR SEGMENT SAJT REAL*8 AJT(IDIM,IDIM,NPG),RF1(NP,MP,IDIM),SM1(NP,IDIM) REAL*8 TN1(NP,IDIM),TN2(NP,IDIM) ENDSEGMENT -INC SMLMOTS CHARACTER*8 TYPE,NOM0,TYPC,MTERR CHARACTER*4 NOMD4 LOGICAL XPG C***************************************************************************** CXXSOUR C write(6,*)' Debut XXSOUR' C***************************************************************************** C OPTIONS C KFORM = 0 -> SI 1 -> EF 2 -> VF 3 -> EFMC C IDCEN = 0->rien 1-> CENTREE 2-> SUPGDC 3-> SUPG 4-> TVISQUEU 5-> CNG C KPOIN = 0->SOMMET 1-> FACE 2-> CENTRE 3-> CENTREP0 4-> CENTREP1 5-> MSOMMET C E/ MMODEL : Pointeur de la table contenant l'information cherchée C /S IPOINT : Pointeur sur la table DOMAINE C /S INEFMD : Type formulation INEFMD=1 LINE,=2 MACRO,=3 QUADRATIQUE C INEFMD=4 LINB IF(XPG)THEN CALL ARRET(0) ENDIF c IK3=0 IAXI=0 IF(IFOMOD.EQ.0)IAXI=2 DEUPI=1.D0 IF(IAXI.NE.0)DEUPI=2.D0*XPI CALL LICHTM(MCHPO1,MPOVA1,TYPC,IGEOM) NC=MPOVA1.VPOCHA(/2) CALL KRIPAD(SPGD,MLENTI) SEGACT MELEME SEGACT MCHEL4 NKD=0 DO 101 L=1,MAX(1,LISOUS(/1)) SEGACT MELEMD IPT1=MELEME IPT2=MELEMD IF(LISOUS(/1).NE.0)IPT1=LISOUS(L) SEGACT IPT1 IF(MELEMD.LISOUS(/1).NE.0)THEN IPT2=MELEMD.LISOUS(L) NKD=0 ENDIF SEGACT IPT2 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----------------------------------------------------------------------- c write(6,*)' XXSOUR 1er KALPBG NOM0=',NOM0,IPT1 CALL KALPBG(NOM0,'FONFORM ',IZFFM) IF(IZFFM.EQ.0)RETURN SEGACT IZFFM*MOD IZHR=KZHR(1) SEGACT IZHR*MOD IZF1 = KTP(1) IZH2 = KZHR(2) IZW = IZF1 IF(KPOIND.EQ.0)IZW=IZFFM SEGACT IZW*MOD IF(MP.NE.IZW.FN(/1))THEN c write(6,*)' Gross problem XXSOUR ' c write(6,*)' NOM0=',NOM0 ,' NOMD4=',NOMD4 c write(6,*)' MP=',MP,' KPOIND.=',KPOIND,' IZW.FN(/1)=' c & ,IZW.FN(/1) ENDIF NES=GR(/1) NPG=GR(/3) NP = IPT1.NUM(/1) NBEL=IPT1.NUM(/2) SEGINI SAJT MCHAM4=MCHEL4.ICHAML(L) SEGACT MCHAM4 MELVA4=MCHAM4.IELVAL(1) SEGACT MELVA4 N1PTEL=MELVA4.VELCHE(/1) N1EL=MELVA4.VELCHE(/2) c write(6,*)' N1PTEL=',N1PTEL,'N1EL=',N1EL IF(N1EL.EQ.1)THEN IK4=1 ELSEIF(N1EL.EQ.NBEL)THEN IK4=0 ENDIF c write(6,*)' AVANT 108 NC=',NC,' NBEL=',NBEL,MP,NP,NC c write(6,*)' AVANT 108 IK4=',IK4,'N1PTEL=',N1PTEL,'N1EL=',N1EL c write(6,*)' ' c write(6,*)' XXSOUR ---------------------------------------' c nche1=MELVA4.VELCHE(/1) c nche2=MELVA4.VELCHE(/2) c write(6,*)' MELVA4=',MELVA4 c write(6,*)' MCHEL4=',MCHEL4,' nche1=',nche1,' nche2=',nche2 c write(6,*)' NC=',NC,' MP=',MP,' NP=',NP,' NPG=',NPG c write(6,*)' IDIM=',IDIM,' NBEL=',nbel c write(6,*)' XXSOUR ---------------------------------------' c write(6,*)' ' DO 108 KE=1,NBEL NKD=NKD+1 c NK1=KE + IK1*(1 - KE) c NK2=KE + IK2*(1 - KE) c NK3=KE + IK3*(1 - KE) NK4=KE + IK4*(1 - KE) DO I=1,NP J=IPT1.NUM(I,KE) DO N=1,IDIM XYZ(N,I)=XCOOR((J-1)*(IDIM+1)+N) ENDDO ENDDO CALL CALJBR(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES, * IDIM,NP,NPG,IAXI,AIRE,AJ,SGN) CALL INITD(SM1,(MP*IDIM),0.D0) C======================================================================= C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: C...... Source DO 710 I=1,MP U4=0.D0 C1=1.D0 DO 717 N=1,NC DO 715 LG=1,NPG WT=IZW.FN(I,LG) c IF(XPG)THEN c WT=MELVA3.VELCHE((IDIM+I-1)*NPG+LG,NK3)+IZW.FN(I,LG) c ENDIF C4=MELVA4.VELCHE((N-1)*NPG+LG,NK4) U4=U4+WT*PGSQ(LG)*C4*DEUPI*RPG(LG) 715 CONTINUE SM1(I,N)=SM1(I,N)+ U4 717 CONTINUE 710 CONTINUE C...... Source Fin C======================================================================= C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> C ...... Chargement Second membre DO 911 I=1,MP I1=LECT(IPT2.NUM(I,KE)) DO 910 N=1,NC MPOVA1.VPOCHA(I1,N)=MPOVA1.VPOCHA(I1,N)+SM1(I,N) 910 CONTINUE 911 CONTINUE C<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 108 CONTINUE SEGDES IPT1,IPT2 SEGSUP MCHAM4,MELVA4 SEGSUP IZFFM,IZHR,IZF1,IZH2 SEGSUP SAJT 101 CONTINUE SEGDES MPOVA1 SEGSUP MLENTI SEGSUP MCHEL4 c write(6,*)' FIN XXSOUR' RETURN 1002 FORMAT(10(1X,1PE11.4)) 1001 FORMAT(10(1X,I7)) END