C KMFN SOURCE MAGN 09/07/30 21:17:32 6458 SUBROUTINE KMFN C *********************************************************************** C C Objet : Cet operateur calcule soit A * U C t C soit A U C Syntaxe : C CAS 1 / C C B = KMF MATRIK MCHPOI ; C C C CAS 2 / C C B = KMF MATRIK MCHPOI 'TRAN' ; C C MATRIK MATRICES ELEMENTAIRES C MCHPOI CHPOINT CONTENANT U C C *********************************************************************** IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC CCOPTIO -INC SMELEME POINTEUR MELEMP.MELEME,MELEMD.MELEME,MELEM1.MELEME POINTEUR ISPGD.MELEME -INC SMLENTI -INC SMMATRIK -INC SMCHPOI POINTEUR MCHINI.MCHPOI LOGICAL LNEW,LFIRST CHARACTER*8 NOMP,NOMD,NOMD0,LDLP,NOMDX CHARACTER*4 LISMOT(1) DATA LISMOT/'TRAN'/ C**** MPOVA1=0 C write(6,*)' SUBROUTINE KMFN' C LECTURE DES ARGUMENTS CALL LIROBJ('MATRIK',MATRIK,1,IRET) IF(IRET.EQ.0) RETURN CALL LIROBJ('CHPOINT',MCHPOI,1,IRET) IF(IRET.EQ.0) RETURN CALL LIRMOT(LISMOT,1,ITRAN,0) ITRAN0=ITRAN SEGACT MATRIK SEGACT MCHPOI SEGINI,MCHINI=MCHPOI NSOUPO=0 NAT=MCHINI.JATTRI(/1) SEGADJ MCHINI SEGDES MCHINI CALL ECROBJ('CHPOINT',MCHINI) NOMD0=' ' MLENT2=0 ISPGD0=0 MCHPO1=0 IT=0 NMATRI=IRIGEL(/2) NSP2 =IPCHP(/1) LFIRST=.TRUE. DO 5000 IM=1,NMATRI IKT=1 IMATRI=IRIGEL(4,IM) SEGACT IMATRI NBME =LIZAFM(/2) ITYM=IRIGEL(7,IM) IF(ITYM.EQ.4)ITRAN=0 777 CONTINUE DO 5001 LP=NBME,1,-1 IF(ITRAN.EQ.0)THEN NOMP=LISPRI(LP) ELSE NOMP=LISDUA(LP) ENDIF C write(6,*)' LP,NBME,ITRAN,LISPRI(LP),LISDUA(LP)=', C &LP,NBME,ITRAN,LISPRI(LP),LISDUA(LP) DO 4000 KS=1,NSP2 MSOUPO=IPCHP(KS) SEGACT MSOUPO NC=NOCOMP(/2) DO 4001 KC=1,NC C WRITE(IOIMP,*)'KMFN : NOCOMP=',NOCOMP(KC),' NOMP=',NOMP(1:4) IF (NOCOMP(KC).EQ.NOMP(1:4)) THEN IT=1 MELEM1=IGEOC C In KRIPAD : SEGACT MELEM1 C In KRIPAD : SEGINI MLENTI CALL KRIPAD(MELEM1,MLENTI) C segact melem1 C nk1=melem1.num(/1) C nk2=melem1.num(/2) C write(6,*)'Controle MELEM1=IGEOC',MELEM1,NK1,NK2 C write(6,1101)(melem1.num(1,kk),kk=1,nk2) SEGDES MELEM1 MPOVAL=IPOVAL SEGACT MPOVAL IF (ITRAN.EQ.0) THEN MELEMP=IRIGEL(1,IM) MELEMD=IRIGEL(2,IM) IKSPGD=KSPGD LDLP=LISDUA(LP) ELSE MELEMP=IRIGEL(2,IM) MELEMD=IRIGEL(1,IM) IKSPGD=KSPGP LDLP=LISPRI(LP) ENDIF ISPGD=ISPGD0 NOMD=NOMD0 LNEW=((ISPGD0.NE.IKSPGD).OR.(NOMD0.NE.LDLP)) IF (LNEW) THEN IF (.NOT.LFIRST) THEN SEGSUP MLENT2 SEGDES MPOVA1 SEGDES MSOUP1 SEGDES MCHPO1 ELSE LFIRST=.FALSE. ENDIF IF (ITRAN.EQ.0) THEN NOMD=LISDUA(LP) NOMD0=LISDUA(LP) ISPGD=KSPGD ISPGD0=KSPGD ELSE NOMD=LISPRI(LP) NOMD0=LISPRI(LP) ISPGD=KSPGP ISPGD0=KSPGP ENDIF SEGACT ISPGD N=ISPGD.NUM(/2) NC=1 C WRITE(IOIMP,*)' Creation MPOVA1 N,NC=',n,nc IF (MCHPO1.NE.0)THEN CALL ECROBJ('CHPOINT',MCHPO1) CALL PRFUSE CALL DTCHPO(MCHPO1) ENDIF SEGINI,MCHPO1=MCHPOI NSOUPO=1 NAT=MCHPO1.JATTRI(/1) SEGADJ MCHPO1 C WRITE(IOIMP,*)' On cree MPOVA1 -> ',NOMD(1:4) SEGINI MSOUP1 SEGINI MPOVA1 MCHPO1.IPCHP(NSOUPO)=MSOUP1 MSOUP1.NOCOMP(1)=NOMD(1:4) MSOUP1.IGEOC=ISPGD MSOUP1.IPOVAL=MPOVA1 C In KRIPAD : SEGINI MLENT2 CALL KRIPAD(ISPGD,MLENT2) C segact ISPGD C nk1=ISPGD.num(/1) C nk2=ISPGD.num(/2) C write(6,*)'Controle ISPGD',ISPGD,NK1,NK2 C write(6,1101)(ISPGD.num(1,kk),kk=1,nk2) SEGDES ISPGD ENDIF C WRITE(IOIMP,*)' On charge dans ',MSOUP1.NOCOMP(1) C CALL VERPAD(MLENTI,MELEMP,IRET) C IRET=0 C IF(IRET.NE.0)THEN C write(6,*)' VERPAD Pb MELEMP ' C write(6,*)' MELEMP=',MELEMP,'ITRAN=',ITRAN C segact melemp C nk1= melemp.num(/1) C nk2= melemp.num(/2) C do 6317 kkk=1,nk2 C write(6,1101)(melemp.num(kk,kkk),kk=1,nk1) C6317 continue C C C MOTERR(1:40)=' ' C MOTERR(1:8) ='MATRIK ' C MOTERR(9:16)='CHPOINT ' C Incompatibilité entre l'objet %m1:8 et l'objet %m9:16 C CALL ERREUR(135) C RETURN C ENDIF CALL VERPAD(MLENT2,MELEMD,IRET) C IRET=0 IF(IRET.NE.0)THEN C write(6,*)' VERPAD Pb MELEMD ' C write(6,*)' MELEMD=',MELEMD,'ITRAN=',ITRAN C segact melemd C nk1= melemd.num(/1) C nk2= melemd.num(/2) C do 6318 kkk=1,nk2 C write(6,1101)(melemd.num(kk,kkk),kk=1,nk1) C6318 continue MOTERR(1:40)=' ' MOTERR(1:8) ='MATRIK ' MOTERR(9:16)='CHPOINT ' C Incompatibilité entre l'objet %m1:8 et l'objet %m9:16 CALL ERREUR(135) RETURN ENDIF SEGACT MELEMP SEGACT MELEMD NBSOUM=LIZAFM(/1) NBSP=MELEMP.LISOUS(/1) NBSD=MELEMD.LISOUS(/1) IPT1=MELEMP IPT2=MELEMD IF(NBSP.NE.0)IPT1=MELEMP.LISOUS(1) IF(NBSD.NE.0)IPT2=MELEMD.LISOUS(1) SEGACT IPT1,IPT2 NBELP=IPT1.NUM(/2) NBELD=IPT2.NUM(/2) KKP=0 KKD=0 NSP=1 NSD=1 DO 4002 LS=1,NBSOUM IZAFM=LIZAFM(LS,LP) SEGACT IZAFM NBEL=AM(/1) NP=AM(/2) MP=AM(/3) C WRITE(IOIMP,*)' BCL 4002 LS=',ls,nbel,np,mp IF(ITRAN.EQ.0)THEN DO 4033 K=1,NBEL KKP=KKP+1 KKD=KKD+1 DO 4034 J=1,MP U=0.D0 DO 4035 I=1,NP I1=LECT(IPT1 .NUM(I,KKP)) IF(I1.EQ.0)GO TO 4035 U=U+AM(K,I,J)*VPOCHA(I1,KC) 4035 CONTINUE III=IPT2 .NUM(J,KKD) I2=MLENT2.LECT(III) MPOVA1.VPOCHA(I2,1)=MPOVA1.VPOCHA(I2,1) $ +U 4034 CONTINUE 4033 CONTINUE IF(KKP.EQ.NBELP.AND.NSP.LT.NBSP)THEN NSP=NSP+1 SEGDES IPT1 IPT1=MELEMP.LISOUS(NSP) SEGACT IPT1 NBELP=IPT1.NUM(/2) KKP=0 ENDIF IF(KKD.EQ.NBELD.AND.NSD.LT.NBSD)THEN NSD=NSD+1 SEGDES IPT2 IPT2=MELEMD.LISOUS(NSD) SEGACT IPT2 NBELD=IPT2.NUM(/2) KKD=0 ENDIF ELSE DO 3033 K=1,NBEL KKP=KKP+1 KKD=KKD+1 DO 3034 J=1,NP U=0.D0 DO 3035 I=1,MP I1=LECT(IPT1 .NUM(I,KKP)) IF(I1.EQ.0)GO TO 3035 U=U+AM(K,J,I)*VPOCHA(I1,KC) 3035 CONTINUE I2=MLENT2.LECT(IPT2 .NUM(J,KKD)) MPOVA1.VPOCHA(I2,1)=MPOVA1.VPOCHA(I2,1) $ +U 3034 CONTINUE 3033 CONTINUE IF(KKP.EQ.NBELP.AND.NSP.LT.NBSP)THEN NSP=NSP+1 SEGDES IPT1 IPT1=MELEMP.LISOUS(NSP) SEGACT IPT1 NBELP=IPT1.NUM(/2) KKP=0 ENDIF IF(KKD.EQ.NBELD.AND.NSD.LT.NBSD)THEN NSD=NSD+1 SEGDES IPT2 IPT2=MELEMD.LISOUS(NSD) SEGACT IPT2 NBELD=IPT2.NUM(/2) KKD=0 ENDIF ENDIF SEGDES IZAFM 4002 CONTINUE SEGDES MELEMP SEGDES MELEMD SEGDES MPOVAL SEGSUP MLENTI ENDIF 4001 CONTINUE SEGDES MSOUPO 4000 CONTINUE 5001 CONTINUE C write(6,*)' ITYM,IKT,ITRAN=',ITYM,IKT,ITRAN IF(ITYM.EQ.4)THEN IF(IKT.EQ.1)THEN IKT=2 ITRAN=1 GO TO 777 ELSE ITRAN=ITRAN0 IKT=1 ENDIF ENDIF SEGDES IMATRI 5000 CONTINUE SEGSUP MLENT2 C write(6,*)' MPOVA1=',MPOVA1 C write(6,*)' FIN SUBROUTINE KMFN' IF(MPOVA1.EQ.0)THEN MOTERR(1:40)=' ' MOTERR(1:8) ='MATRIK ' MOTERR(9:16)='CHPOINT ' C Incompatibilité entre l'objet %m1:8 et l'objet %m9:16 CALL ERREUR(135) RETURN ENDIF c SEGDES MPOVA1 SEGDES MSOUP1 SEGDES MCHPO1 C CALL DTCHPO(MCHINI) SEGDES MCHPOI SEGDES MATRIK IF(IT.EQ.1)THEN CALL ECROBJ('CHPOINT',MCHPO1) CALL PRFUSE CALL DTCHPO(MCHPO1) ELSE MOTERR(1:40)=' ' MOTERR(1:8) ='MATRIK ' MOTERR(9:16)='CHPOINT ' C Incompatibilité entre l'objet %m1:8 et l'objet %m9:16 CALL ERREUR(135) ENDIF RETURN 1101 FORMAT(20(1X,I5)) END