C KSPRJS SOURCE CB215821 20/11/25 13:33:11 10792 SUBROUTINE KSPRJS &(MELEME,IPM1,IPM2,IPM3,IAXI,IKAS,INEFMD,KPRE,IZTGG1,IPAD,IK1) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C***************************************************************************** C C Ce SP calcule les matrices elementaires de divergence alias C C C IKAS=1 KMCT calcul de Ct (Div U) C IKAS=2 KMAC calcul de C uniquement (Grad p) C IKAS=3 KCCT calcul de C assemblage pour C et Ct C C***************************************************************************** CHARACTER*8 NOM0 -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC SMCOORD -INC SIZFFB POINTEUR IZF1.IZFFM -INC SMMATRIK -INC SMELEME -INC SMLENTI -INC SMCHPOI POINTEUR IZTGG1.MPOVAL -INC CCREEL DIMENSION KIPM(3),XYZ1(24),UA(3),UB(3) C OPERATEUR PRESSION C MLENTI=IPAD DEUPI=1.D0 IF(IAXI.NE.0)DEUPI=2.D0*XPI IF(IKAS.EQ.3)DEUPI=-DEUPI IF(IDIM.EQ.2)IPM3=IPM1 KIPM(1)=IPM1 KIPM(2)=IPM2 KIPM(3)=IPM3 SEGACT MELEME,IPM1*MOD,IPM2*MOD,IPM3*MOD NP=NUM(/1) NEL=NUM(/2) C write(6,*)' INEFMD=',inefmd,'KPRE=',kpre IF(KPRE.NE.2)THEN IF(INEFMD.EQ.3)THEN IF(KPRE.EQ.3)NOM0=NOMS(ITYPEL)//'PRP0' IF(KPRE.EQ.4)NOM0=NOMS(ITYPEL)//'PRP1' IF(KPRE.EQ.5)NOM0=NOMS(ITYPEL)//'PRF1' ELSEIF(INEFMD.EQ.2)THEN IF(KPRE.EQ.3)NOM0=NOMS(ITYPEL)//'MCP0' IF(KPRE.EQ.4)NOM0=NOMS(ITYPEL)//'MCP1' IF(KPRE.EQ.5)NOM0=NOMS(ITYPEL)//'MCF1' ELSEIF(INEFMD.EQ.4)THEN NOM0=NOMS(ITYPEL)//' ' ENDIF C write(6,*)' NOM0=',nom0,' ikas=',ikas,' nel=',nel CALL KALPBG(NOM0,'FONFORM ',IZFFM) SEGACT IZFFM*MOD IZHR=KZHR(1) SEGACT IZHR*MOD NES=GR(/1) NPG=GR(/3) IZF1=KTP(1) SEGACT IZF1*MOD MP1=FN(/1) DO 30 KE=1,NEL DO I=1,NP J=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) C write(6,*)' Retour caljbr ',mp1,np,npg DO 324 K=1,IDIM IPM4=KIPM(K) KG=(IK1-4)*(K-1)+1 DO M=1,MP1 DO I=1,NP U=0.D0 DO 333 L=1,NPG CALL INITD(UA,3,0.D0) CALL INITD(UB,3,0.D0) DO 533 J=1,NP J1=LECT(NUM(J,KE)) UA(KG)=UA(KG)+FN(J,L)*IZTGG1.VPOCHA(J1,KG) UB(K)=UB(K)+HR(K,J,L)*IZTGG1.VPOCHA(J1,KG) 533 CONTINUE U=U+FN(M,L)* &(HR(K,I,L)*UA(KG) + FN(I,L)*UB(KG))*PGSQ(L)*DEUPI*RPG(L) IF(IAXI.NE.0.AND.K.EQ.1)THEN U=U+FN(M,L)*FN(I,L)*UA(KG)*PGSQ(L)*DEUPI ENDIF 333 CONTINUE if(ikas.ne.2)then IPM4.AM(KE,I,M)=IPM4.AM(KE,I,M)+U else IPM4.AM(KE,M,I)=IPM4.AM(KE,M,I)+U endif ENDDO ENDDO 324 CONTINUE 37 CONTINUE 30 CONTINUE SEGSUP IZHR,IZFFM C CAS MACRO CENTRE ELSEIF(KPRE.EQ.2)THEN NOM0=NOMS(ITYPEL)//' ' CALL KALPBG(NOM0,'FONFORM ',IZFFM) SEGACT IZFFM*MOD IZHR=KZHR(1) SEGACT IZHR*MOD NES=GR(/1) NPG=GR(/3) IZF1=KTP(1) SEGACT IZF1*MOD MPG=IZF1.FN(/2) c modif tc initialisation de M à 1 ??? (izf1.fn(/1)) M=1 NP=GR(/2) DO 40 KE=1,NEL IX=0 DO I=1,NP J=NUM(I,KE) DO N=1,IDIM IX=IX+1 XYZ1(IX)=XCOOR((J-1)*(IDIM+1) +N) ENDDO ENDDO CALL CALJBR(FN,GR,PG,XYZ1,HR,PGSQ,RPG,NES, & IDIM,NP,NPG,IAXI,AIRE,AJ,SGN) DO 424 K=1,IDIM IPM4=KIPM(K) KG=(IK1-4)*(K-1)+1 DO 423 I=1,NP U=0.D0 DO 433 L=1,NPG CALL INITD(UA,3,0.D0) CALL INITD(UB,3,0.D0) DO 633 J=1,NP J1=LECT(NUM(J,KE)) UA(KG)=UA(KG)+FN(J,L)*IZTGG1.VPOCHA(J1,KG) UB(K)=UB(K)+HR(K,J,L)*IZTGG1.VPOCHA(J1,KG) 633 CONTINUE U=U+IZF1.FN(M,L)* &(HR(K,I,L)*UA(KG) + FN(I,L)*UB(KG))*PGSQ(L)*DEUPI*RPG(L) IF(IAXI.NE.0.AND.K.EQ.1)THEN U=U+IZF1.FN(M,L)*FN(I,L)*UA(KG)*PGSQ(L)*DEUPI ENDIF 433 CONTINUE if(ikas.ne.2)then IPM4.AM(KE,I,1)=IPM4.AM(KE,I,1)+U else IPM4.AM(KE,1,I)=IPM4.AM(KE,1,I)+U endif 423 CONTINUE 424 CONTINUE 40 CONTINUE SEGSUP IZHR,IZFFM ENDIF RETURN 1002 FORMAT(10(1X,1PE11.4)) 1040 FORMAT(1X,'CALCUL MATRICE AM ',I4/10(1X,1PE11.4)) END