Sources Esope | Cast3M

clmors
C CLMORS    SOURCE    PV        20/09/26    21:16:13     10724          
      SUBROUTINE CLMORS(KMORS,KISA,IMPR,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C NOM         : CLMORS
C DESCRIPTION :
C     Nettoyage d'un objet de type Matrice Morse :
C     on supprime les ZERO stockées.
C     ATTENTION, on ne nettoie pas les valeurs "proches" de zero,
C     on nettoie celle qui y ont été mises explicitement
C     (i.e. qui ne sont pas le résultat d'un calcul)
C
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES (E/S) : ECMORS
C***********************************************************************
C ENTREES            : IMPR
C ENTREES/SORTIES    : KMORS, KISA
C SORTIES            : -
C CODE RETOUR (IRET) : -
C     PMORS  : pointeurs sur segment PMORS de l'include SMMATRIK
C              profil de la matrice Morse à traiter
C     IZA    : pointeurs sur segment IZA de l'include SMMATRIK
C              valeurs de la matrice Morse.
C***********************************************************************
C VERSION    : v1, 01/04/98, version initiale
C HISTORIQUE : v1, 01/04/98, création
C HISTORIQUE :     15/06/98, modif : non-suppression des zéros
C                                    sur la diagonale.
C HISTORIQUE :
C
C***********************************************************************
C Prière de PRENDRE LE TEMPS de compléter les commentaires
C en cas de modification de ce sous-programme afin de faciliter
C la maintenance !
C***********************************************************************
*
* Nettoyage d'un objet de type Matrice Morse
* i.e. on supprimme les ZERO stockées
* ATTENTION, on ne nettoie pas les valeurs "proches" de zero,
* on nettoie celle qui y ont été mises explicitement
* (i.e. qui ne sont pas le résultat d'un calcul)
*
 
-INC PPARAM
-INC CCOPTIO
      INTEGER IMPR,IRET
-INC SMMATRIK
      INTEGER NBVA
      INTEGER NJA,NTT
      POINTEUR KMORS.PMORS
      POINTEUR KISA.IZA
*
*
*     .. Variables locales
*     .. Parameters ..
      REAL*8             ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
*     ..
      INTEGER ICOL,INTT
      INTEGER NBZER
      INTEGER NBZER2
      IF (IMPR.GT.5) THEN
         WRITE(IOIMP,*) 'clmors : nettoyage de la matrice morse',
     $        ' de pointeurs',KMORS,KISA
         IF (IMPR.GT.7) THEN
            WRITE(IOIMP,*) 'Avant :'
            CALL ECMORS(KMORS,KISA,(IMPR-1))
         ENDIF
      ENDIF
      SEGACT KMORS*MOD
      SEGACT KISA*MOD
      NTT=KMORS.IA(/1)-1
      NJA=KMORS.JA(/1)
      NBZER=0
      DO 1 INTT=1,NTT
         NBZER2=NBZER
         DO 11 ICOL=KMORS.IA(INTT),(KMORS.IA(INTT+1)-1)
            IF (KISA.A(ICOL).EQ.ZERO.AND.KMORS.JA(ICOL).NE.INTT) THEN
               NBZER=NBZER+1
            ELSE
               KMORS.JA(ICOL-NBZER)=KMORS.JA(ICOL)
               KISA.A(ICOL-NBZER)= KISA.A(ICOL)
            ENDIF
 11      CONTINUE
         KMORS.IA(INTT)=KMORS.IA(INTT)-NBZER2
 1    CONTINUE
      KMORS.IA(NTT+1)=KMORS.IA(NTT+1)-NBZER
      NJA=NJA-NBZER
      SEGADJ KMORS
      NBVA=NJA
      SEGADJ KISA
      SEGDES KMORS
      SEGDES KISA
      IF (IMPR.GT.5) THEN
         IF (IMPR.GT.7) THEN
            WRITE(IOIMP,*) 'Après :'
            CALL ECMORS(KMORS,KISA,(IMPR-1))
         ENDIF
         WRITE(IOIMP,*) 'Nombre de zéros éliminés  :',NBZER
      ENDIF
*
*     Terminaison normale
*
      IRET=0
      RETURN
*
*     End of CLMORS
*
      END