Sources Esope | Cast3M

kres10
C KRES10    SOURCE    GOUNAND   25/04/30    21:15:10     12258          
      SUBROUTINE KRES10(MRIGID,KMORS,KIZA)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : KRES10
C DESCRIPTION : - Conversion au format Morse de la matrice
C                 assemblée (MMATRI)
C
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C VERSION    : v1, 24/08/2011, version initiale
C HISTORIQUE : v1, 24/08/2011, création
C HISTORIQUE :
C HISTORIQUE :
C***********************************************************************
      REAL*8 XKT,PREC
-INC SMRIGID
-INC SMMATRI
 
-INC PPARAM
-INC CCOPTIO
      SEGMENT PMORS
      INTEGER IA (NTT+1)
      INTEGER JA (NJA)
      ENDSEGMENT
      SEGMENT IZA
      REAL*8  A(NBVA)
      ENDSEGMENT
      POINTEUR KMORU.PMORS,KMORUT.PMORS,KMORL.PMORS,KMORS.PMORS
      POINTEUR KIZAU.IZA,KIZAUT.IZA,KIZAL.IZA,KIZA.IZA
*
      SEGACT MRIGID
      MMATRI=ICHOLE
      SEGDES MRIGID
      SEGACT MMATRI
*
*      WRITE(IOIMP,*) 'COUCOU KRES10'
*
* Transformation au format Morse du triangle inférieur IPASS=1
* et supérieur IPASS=2
*
      DO IPASS=1,2
         IF (IPASS.EQ.1) THEN
            MILIGN=IILIGN
         ELSE
            MILIGN=IILIGS
         ENDIF
*         WRITE(IOIMP,*) 'MILIGN=',MILIGN
         SEGACT MILIGN
         NNOE=ILIGN(/1)
         INC=IPNO(/1)
* On active toutes les lignes et on compte le nombre
* total de termes non nuls
         NJA=0
         DO INOE=1,NNOE
            LLIGN=ILIGN(INOE)
            SEGACT LLIGN
            LLVVA=XXVA(/1)
            NJA=NJA+LLVVA
         ENDDO
*
*dbg         WRITE(IOIMP,*) ' KRES10 INC=',INC
         NTT=INC
         NBVA=NJA
         SEGINI PMORS
         SEGINI IZA
         ITT=0
         IJA=0
         IA(ITT+1)=1
         DO INOE=1,NNOE
            LLIGN=ILIGN(INOE)
            NA=LDEB(/1)
            DO INA=1,NA
               IVVD=IPPO(INA)
               IVVL=IPPO(INA+1)-IPPO(INA)
               ITT=ITT+1
               IA(ITT+1)=IA(ITT)+IVVL
               DO ICOP=1,IVVL
                  IJA=IJA+1
                  JA(IJA)=LINC(IVVD+ICOP)
                  A(IJA)=XXVA(IVVD+ICOP)
               ENDDO
            ENDDO
         ENDDO
         SEGDES PMORS
         SEGDES IZA
         DO INOE=1,NNOE
            LLIGN=ILIGN(INOE)
            SEGDES LLIGN
         ENDDO
*         WRITE(IOIMP,*) 'MILIGN2=',MILIGN
         SEGDES MILIGN
         IF (IPASS.EQ.1) THEN
            KMORL=PMORS
            KIZAL=IZA
C            WRITE(IOIMP,*) 'Triangle inferieur'
C            CALL ECMORS(PMORS,IZA,4)
         ELSE
            KMORUT=PMORS
            KIZAUT=IZA
C            WRITE(IOIMP,*) 'Triangle superieur'
C            CALL ECMORS(PMORS,IZA,4)
         ENDIF
      ENDDO
* On transpose le triangle supérieur
      SEGACT KMORUT
      SEGACT KIZAUT
      NTT=KMORUT.IA(/1)-1
      NJA=KMORUT.JA(/1)
      NBVA=NJA
      SEGINI KMORU
      SEGINI KIZAU
      CALL TRMORS(NTT,NJA,KIZAUT.A,KMORUT.JA,KMORUT.IA,
     $     KIZAU.A,KMORU.JA,KMORU.IA)
      SEGSUP KMORUT
      SEGSUP KIZAUT
      SEGDES KMORU
      SEGDES KIZAU
C      WRITE(IOIMP,*) 'Triangle superieur transpose'
C      CALL ECMORS(KMORU,KIZAU,4)
*
* Maintenant, on peut créer la matrice Morse total
*
      MDIAG=IDIAG
      SEGACT MDIAG
      SEGACT KMORL
      SEGACT KMORU
      SEGACT KIZAL
      SEGACT KIZAU
      NTT=KMORU.IA(/1)-1
      NJAL=KMORL.JA(/1)
      NJAU=KMORU.JA(/1)
      NJA=NJAL+NTT+NJAU
      NBVA=NJA
      SEGINI PMORS
      SEGINI IZA
      NJA=0
      IA(1)=1
      DO ITT=1,NTT
         IAL=KMORL.IA(ITT)
         IALP=KMORL.IA(ITT+1)-1
         DO IJA=IAL,IALP
            IF (KMORL.JA(IJA).LT.ITT) THEN
               NJA=NJA+1
               JA(NJA)=KMORL.JA(IJA)
               A(NJA)=KIZAL.A(IJA)
            ENDIF
         ENDDO
         NJA=NJA+1
         JA(NJA)=ITT
         A(NJA)=DIAG(ITT)
         IAU=KMORU.IA(ITT)
         IAUP=KMORU.IA(ITT+1)-1
         DO IJA=IAU,IAUP
            IF (KMORU.JA(IJA).GT.ITT) THEN
               NJA=NJA+1
               JA(NJA)=KMORU.JA(IJA)
               A(NJA)=KIZAU.A(IJA)
            ENDIF
         ENDDO
         IA(ITT+1)=NJA+1
      ENDDO
      NBVA=NJA
      SEGADJ IZA
      SEGADJ PMORS
      KMORS=PMORS
      KIZA=IZA
C      WRITE(IOIMP,*) 'Matrice Morse non ordonnée'
C      CALL ECMORS(KMORS,KIZA,4)
      SEGSUP KIZAU
      SEGSUP KMORU
      SEGSUP KIZAL
      SEGSUP KMORL
      SEGDES MDIAG
*
* On ne reordonne pas tout de suite car on va renumeroter
*
      IF (.FALSE.) THEN
         CALL KRES15(KMORS,KIZA)
         IF (IERR.NE.0) RETURN
      ENDIF
C
      RETURN
      END