1 : C LUMPIN SOURCE CHAT 09/10/09 21:20:30 6519 2 : SUBROUTINE LUMPIN(IRIG,LMOT,ILUM) 3 : ************************************************************************ 4 : * 5 : * LUMPING D'UNE MATRICE 6 : * ENTREE : IRIG POINTEUR SUR LA MATRICE A LUMPER 7 : * LMOT POINTEUR SUR LISTMOTS, 0 SI PAS DONNE 8 : * 9 : * SORTIE : ILUM POINTEUR SUR LA MATRICE LUMPEE 10 : * 11 : * M. PETIT DECEMBRE 89 12 : * 13 : ************************************************************************ 14 : IMPLICIT INTEGER(I-N) 15 : IMPLICIT REAL*8 (A-H,O-Z) 16 : -INC SMRIGID 17 : -INC SMLMOTS 18 : * 19 : * NE PAS ENLEVER LA CARTE DEBILE QUI SUIT 20 : * 21 : MLMOTS=IRIG 22 : * 23 : NMOT=0 24 : IF (LMOT.NE.0) THEN 25 : MLMOTS=LMOT 26 : SEGACT MLMOTS 27 : NMOT=MOTS(/2) 28 : ENDIF 29 : * 30 : RI1=IRIG 31 : SEGACT RI1 32 : NRIGE=RI1.IRIGEL(/1) 33 : NRIGEL=RI1.IRIGEL(/2) 34 : SEGINI MRIGID 35 : ILUM=MRIGID 36 : DO 100 I=1,NRIGEL 37 : DESCR=RI1.IRIGEL(3,I) 38 : SEGACT DESCR 39 : NLIGRP=LISINC(/2) 40 : NLIGRD=LISDUA(/2) 41 : * 42 : * TEST DE MATRICE CARREE 43 : * 44 : IF(NLIGRP.NE.NLIGRD) THEN 44 : CALL ERREUR(26) 45 : SEGDES DESCR,RI1 46 : SEGSUP MRIGID 47 : IF(LMOT.NE.0) SEGDES MLMOTS 48 : RETURN 49 : ENDIF 50 : * 51 : xMATR1=RI1.IRIGEL(4,I) 52 : SEGACT xMATR1 53 : NELRIG=xMATR1.re(/3) 54 : SEGINI xMATRI 55 : IRIGEL(4,I)=xMATRI 56 : DO 200 J=1,NELRIG 57 : * XMATR1=IMATR1.IMATTT(J) 58 : * SEGACT XMATR1 59 : * SEGINI XMATRI 60 : * IMATTT(J)=XMATRI 61 : * 62 : DO 300 K=1,NLIGRP 63 : SOMM=0.D0 64 : IF (LMOT.EQ.0) THEN 65 : DO 40 JJ=1,NLIGRP 66 : RE(K,JJ)=0.D0 67 : SOMM=SOMM+XMATR1.RE(K,JJ,j) 68 : 40 CONTINUE 69 : RE(K,K,j)=SOMM 70 : ELSE 71 : KDIAG=0 72 : DO 21 KK=1,NMOT 73 : IF (MOTS(KK).EQ.LISINC(K)) THEN 74 : KDIAG=1 75 : GO TO 20 76 : ENDIF 77 : 21 CONTINUE 78 : 20 CONTINUE 79 : * 80 : IF(KDIAG.EQ.0) THEN 81 : DO 50 JJ=1,NLIGRP 82 : RE(K,JJ)=0.D0 83 : DO 51 JJJ=1,NMOT 84 : IF (MOTS(JJJ).EQ.LISINC(JJ)) GOTO 50 85 : 51 CONTINUE 86 : SOMM=SOMM+XMATR1.RE(K,JJ,j) 87 : 50 CONTINUE 88 : RE(K,K,j)=SOMM 89 : ELSE 90 : DO 52 JJ=1,NLIGRP 91 : RE(K,JJ,j)=0.D0 92 : 52 CONTINUE 93 : RE(K,K,j)=XMATR1.RE(K,K,j) 94 : ENDIF 95 : ENDIF 96 : 300 CONTINUE 97 : * SEGDES XMATR1,XMATRI 98 : 200 CONTINUE 99 : SEGDES xMATR1,xMATRI 100 : SEGINI,DES1=DESCR 101 : IRIGEL(3,I)=DES1 102 : SEGDES DESCR,DES1 103 : IRIGEL(1,I)=RI1.IRIGEL(1,I) 104 : IRIGEL(2,I)=RI1.IRIGEL(2,I) 105 : IRIGEL(5,I)=RI1.IRIGEL(5,I) 106 : IRIGEL(6,I)=RI1.IRIGEL(6,I) 107 : COERIG(I)=RI1.COERIG(I) 108 : 100 CONTINUE 109 : MTYMAT=RI1.MTYMAT 110 : IFORIG=RI1.IFORIG 111 : ISUPEQ=RI1.ISUPEQ 112 : SEGDES RI1 113 : IMGEO1=0 114 : IMGEO2=0 115 : ICHOLE=0 116 : SEGDES MRIGID 117 : IF (LMOT.NE.0) SEGDES MLMOTS 118 : RETURN 119 : END 120 : 121 :
© Cast3M 2003 - All rights reserved.
Disclaimer