Sources Esope | Cast3M

lumpin
C LUMPIN    SOURCE    PASCAL    22/09/19    21:15:01     11457          
      SUBROUTINE LUMPIN(IRIG,LMOT,ILUM)
************************************************************************
*
*     LUMPING D'UNE MATRICE
*             ENTREE : IRIG POINTEUR SUR LA MATRICE A LUMPER
*                      LMOT POINTEUR SUR LISTMOTS, 0 SI PAS DONNE
*
*             SORTIE : ILUM POINTEUR SUR LA MATRICE LUMPEE
*
*     M. PETIT DECEMBRE 89
*
************************************************************************
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
-INC PPARAM
-INC SMRIGID
-INC SMLMOTS
*
*    NE PAS ENLEVER LA CARTE DEBILE QUI SUIT
*
      MLMOTS=IRIG
*
      NMOT=0
      IF (LMOT.NE.0) THEN
        MLMOTS=LMOT
        SEGACT MLMOTS
        NMOT=MOTS(/2)
      ENDIF
*
      RI1=IRIG
      SEGACT RI1
      NRIGE=RI1.IRIGEL(/1)
      NRIGEL=RI1.IRIGEL(/2)
      SEGINI MRIGID
      ILUM=MRIGID
      DO 100 I=1,NRIGEL
      DESCR=RI1.IRIGEL(3,I)
      SEGACT DESCR
      NLIGRP=LISINC(/2)
      NLIGRD=LISDUA(/2)
*
*  TEST DE MATRICE CARREE
*
      IF(NLIGRP.NE.NLIGRD) THEN
        CALL ERREUR(26)
        SEGDES DESCR,RI1
        SEGSUP MRIGID
        IF(LMOT.NE.0) SEGDES MLMOTS
        RETURN
      ENDIF
*
      xMATR1=RI1.IRIGEL(4,I)
      SEGACT xMATR1
      NELRIG=xMATR1.re(/3)
      SEGINI xMATRI
      IRIGEL(4,I)=xMATRI
      DO 200 J=1,NELRIG
*      XMATR1=IMATR1.IMATTT(J)
*      SEGACT XMATR1
*      SEGINI XMATRI
*      IMATTT(J)=XMATRI
*
         DO 300 K=1,NLIGRP
         SOMM=0.D0
         IF (LMOT.EQ.0) THEN
           DO 40 JJ=1,NLIGRP
             RE(K,JJ,J)=0.D0
            SOMM=SOMM+XMATR1.RE(K,JJ,j)
40         CONTINUE
           RE(K,K,j)=SOMM
         ELSE
           KDIAG=0
           DO 21 KK=1,NMOT
             IF (MOTS(KK).EQ.LISINC(K)) THEN
                KDIAG=1
                GO TO 20
             ENDIF
 21        CONTINUE
 20        CONTINUE
*
           IF(KDIAG.EQ.0) THEN
             DO 50 JJ=1,NLIGRP
             RE(K,JJ,J)=0.D0
             DO 51 JJJ=1,NMOT
               IF (MOTS(JJJ).EQ.LISINC(JJ)) GOTO 50
51           CONTINUE
             SOMM=SOMM+XMATR1.RE(K,JJ,j)
50           CONTINUE
             RE(K,K,j)=SOMM
           ELSE
             DO 52 JJ=1,NLIGRP
             RE(K,JJ,j)=0.D0
 52          CONTINUE
             RE(K,K,j)=XMATR1.RE(K,K,j)
           ENDIF
         ENDIF
300      CONTINUE
*      SEGDES XMATR1,XMATRI
200   CONTINUE
      SEGDES xMATR1,xMATRI
      SEGINI,DES1=DESCR
      IRIGEL(3,I)=DES1
      SEGDES DESCR,DES1
      IRIGEL(1,I)=RI1.IRIGEL(1,I)
      IRIGEL(2,I)=RI1.IRIGEL(2,I)
      IRIGEL(5,I)=RI1.IRIGEL(5,I)
      IRIGEL(6,I)=RI1.IRIGEL(6,I)
      COERIG(I)=RI1.COERIG(I)
100   CONTINUE
      MTYMAT=RI1.MTYMAT
      IFORIG=RI1.IFORIG
      ISUPEQ=RI1.ISUPEQ
      SEGDES RI1
      IMGEO1=0
      IMGEO2=0
      ICHOLE=0
      SEGDES MRIGID
      IF (LMOT.NE.0) SEGDES MLMOTS
      RETURN
      END