Sources Esope | Cast3M

addmat
C ADDMAT    SOURCE    PV        20/09/26    21:15:03     10724          
      SUBROUTINE ADDMAT(M1,M2,M3,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
-INC SMMATRIK
      POINTEUR M1.MATRIK,M2.MATRIK,M3.MATRIK
      POINTEUR PMS3.PMORS, IZA3.IZA
      POINTEUR IMAT1.IMATRI,IMAT2.IMATRI,IMAT3.IMATRI
 
      SEGMENT ASSTAB
      INTEGER ITAB(NBCOMP,NTA)
      ENDSEGMENT
 
      INTEGER NBCOMP,NTA,PRI,DUA,NTTP,NTTD,IRET
 
C     =========================================
      IRET=0
 
      SEGACT M1
 
C     Si les matrices ne sont pas morse, on les crees
C     en morse
      IF (M1.IRIGEL(7,1).NE.6) THEN
        CALL ELMORS(M1,1)
      END IF
 
      SEGACT M2
 
      IF (M2.IRIGEL(7,1).NE.6) THEN
        CALL ELMORS(M2,1)
      END IF
 
      SEGACT M1,M2
 
      PMS1=M1.IRIGEL(5,1)
      PMS2=M2.IRIGEL(5,1)
 
      IZA1=M1.IRIGEL(6,1)
      IZA2=M2.IRIGEL(6,1)
 
      IMAT1=M1.IRIGEL(4,1)
      IMAT2=M2.IRIGEL(4,1)
 
      SEGACT IMAT1,IMAT2
 
      NBSOUS=IMAT1.LIZAFM(/1)
      NBME1=IMAT1.LIZAFM(/2)
      NBME2=IMAT2.LIZAFM(/2)
 
      IF (NBME1.NE.NBME2) THEN
        WRITE(6,*) 'ADDMAT: Les 2 MATRIK n ont pas'
        WRITE(6,*) 'le meme support, impossible de les'
        WRITE(6,*) 'additionner.'
        IRET=1
        RETURN
      ELSE
        IFLAG=0
        NBME=NBME1
        DO I=1,NBME
           IF ((IMAT1.LISPRI(I).NE.IMAT2.LISPRI(I)).OR.
     &        (IMAT1.LISDUA(I).NE.IMAT2.LISDUA(I))) THEN
              IFLAG=1
           END IF
        END DO
        IF (IFLAG.NE.0) THEN
        WRITE(6,*) 'ADDMAT: Les 2 MATRIK n ont pas'
        WRITE(6,*) 'le meme support, impossible de les'
        WRITE(6,*) 'additionner.'
        IRET=1
        RETURN
        END IF
      END IF
 
      SEGINI IMAT3
 
C     On recopie le segact IMATRI de la matrice 1 dans le IMATRI
C     pour la matrice 3
 
      DO I=1,NBME
         IMAT3.LISPRI(I)=IMAT1.LISPRI(I)
         IMAT3.LISDUA(I)=IMAT1.LISDUA(I)
      END DO
      IMAT3.KSPGP=IMAT1.KSPGP
      IMAT3.KSPGD=IMAT1.KSPGD
 
C     On initialise M3
      NMATRI=1
      NRIGE=7
      NKID=9
      NKMT=7
      SEGINI M3
 
      M3.KMINCP=M1.KMINCP
      M3.KMINCD=M1.KMINCD
c      WRITE(6,*) 'ADDMAT',M1.KMINCP,M1.KMINCD
 
      CALL RSETI(M3.IRIGEL(1,1),M1.IRIGEL(1,1),7)
 
      SEGACT PMS1,PMS2
      SEGACT IZA1,IZA2
 
      NTT=PMS1.IA(/1)-1
 
      NBCOMP=10
      NTA=NTT
      SEGINI ASSTAB
 
      DO I=1,NTT
         LI1=PMS1.IA(I)
         NB1=PMS1.IA(I+1)-PMS1.IA(I)
 
         LI2=PMS2.IA(I)
         NB2=PMS2.IA(I+1)-PMS2.IA(I)
 
         DO J=1,NB1
            NB=ITAB(1,I)
            PRI=PMS1.JA(LI1+J-1)
 
 10         IF (NB+1.GE.NBCOMP) THEN
               NBCOMP=NBCOMP+10
               SEGADJ ASSTAB
               GO TO 10
            END IF
 
C     On regarde sur la ligne DUA si la colonne PRI est
C     deja inserer dans le profil ITAB
            DO II=1,NB
               IF (ITAB(II+1,I).EQ.PRI) GO TO 30
            END DO
            ITAB(1,I)=NB+1
            ITAB(NB+2,I)=PRI
 
 30         CONTINUE
         END DO
 
         DO J=1,NB2
            NB=ITAB(1,I)
            PRI=PMS2.JA(LI2+J-1)
 
 35         IF (NB+1.GE.NBCOMP) THEN
               NBCOMP=NBCOMP+10
               SEGADJ ASSTAB
               GO TO 35
            END IF
 
C     On regarde sur la ligne DUA si la colonne PRI est
C     deja inserer dans le profil ITAB
            DO II=1,NB
               IF (ITAB(II+1,I).EQ.PRI) GO TO 40
            END DO
            ITAB(1,I)=NB+1
            ITAB(NB+2,I)=PRI
 
 40         CONTINUE
         END DO
      END DO
 
      DO I=1,NTT
         CALL ORDOTA(ITAB(2,I),ITAB(1,I))
      END DO
 
c      write(6,*)' KTAB ************** NPTD=',NTT
c      DO II=1,NTT
c         nb=ITAB(1,II)
c         write(6,*)' II=',ii,'  NB=',nb
c         write(6,*)(ITAB(ji+1,ii),ji=1,nb)
c      END DO
 
c      SEGDES ASSTAB
      M3.KNTTD=NTT
c      CALL PFMORS(ASSTAB,M3,1)
 
      NJA=PMS1.JA(/1)
      SEGINI PMS3
 
      M=0
      DO I=1,NTT
         NB=ITAB(1,I)
 
         PMS3.IA(I)=M+1
         DO J=1,NB
            M=M+1
 110        CONTINUE
            IF (M.GT.NJA) THEN
               NJA=NJA+100
               SEGADJ PMS3
               GOTO 110
            END IF
 
            PMS3.JA(M)=ITAB(J+1,I)
         END DO
      END DO
 
      PMS3.IA(NTT+1)=M+1
      NJA=M
      SEGADJ PMS3
 
c      SEGACT M3*MOD
c      PMS3=M3.IRIGEL(5,1)
c      SEGACT PMS3
      NBVA=PMS3.JA(/1)
      SEGINI IZA3
 
      N=PMS3.IA(/1)
c      WRITE(6,*) 'N=',N
c      DO I=1,N
c         WRITE(6,*) I,'IA',PMS3.IA(I)
c      END DO
c      WRITE(6,*) 'NBVA=',NBVA
c      DO I=1,NBVA
c         WRITE(6,*) I,'JA',PMS3.JA(I)
c      END DO
 
      NTT=PMS3.IA(/1)-1
      DO I=1,NTT
 
         LI1=PMS1.IA(I)
         NB1=PMS1.IA(I+1)-PMS1.IA(I)
 
         LI2=PMS2.IA(I)
         NB2=PMS2.IA(I+1)-PMS2.IA(I)
 
         DO J=1,NB1
            PRI=PMS1.JA(LI1+J-1)
 
            MA=IMORSE(PMS1.IA,PMS1.JA,I,PRI)
            MM=IMORSE(PMS3.IA,PMS3.JA,I,PRI)
 
            IZA3.A(MM)=IZA3.A(MM)+IZA1.A(MA)
         END DO
 
         DO J=1,NB2
            PRI=PMS2.JA(LI2+J-1)
 
            MA=IMORSE(PMS2.IA,PMS2.JA,I,PRI)
            MM=IMORSE(PMS3.IA,PMS3.JA,I,PRI)
 
            IZA3.A(MM)=IZA3.A(MM)+IZA2.A(MA)
         END DO
      END DO
 
      SEGDES PMS1,PMS2,PMS3
      SEGDES IZA1,IZA2,PMS3
C      SEGSUP ASSTAB
 
C     On remplit les pointeurs de M3
 
      M3.IRIGEL(4,1)=IMAT3
      M3.IRIGEL(5,1)=PMS3
      M3.IRIGEL(6,1)=IZA3
      M3.IRIGEL(7,1)=6
 
      M3.KSYM=2
      M3.KNTTP=M2.KNTTP
      M3.KNTTD=M1.KNTTD
 
      SEGDES IMAT1,IMAT2,IMAT3
      SEGDES M1,M2,M3
 
      CALL OPTIM(M3,1)
      RETURN
      END