Esope source files

   1 : C CLMORS    SOURCE    MAGN      09/07/30    21:16:28     6458           
   2 :       SUBROUTINE CLMORS(KMORS,KISA,IMPR,IRET)
   3 :       IMPLICIT INTEGER(I-N)
   4 :       IMPLICIT REAL*8 (A-H,O-Z)
   5 : C***********************************************************************
   6 : C NOM         : CLMORS
   7 : C DESCRIPTION :
   8 : C     Nettoyage d'un objet de type Matrice Morse :
   9 : C     on supprime les ZERO stockées.
  10 : C     ATTENTION, on ne nettoie pas les valeurs "proches" de zero,
  11 : C     on nettoie celle qui y ont été mises explicitement
  12 : C     (i.e. qui ne sont pas le résultat d'un calcul)
  13 : C
  14 : C
  15 : C LANGAGE     : ESOPE
  16 : C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF)
  17 : C               mél : gounand@semt2.smts.cea.fr
  18 : C***********************************************************************
  19 : C APPELES (E/S) : ECMORS
  20 : C***********************************************************************
  21 : C ENTREES            : IMPR
  22 : C ENTREES/SORTIES    : KMORS, KISA
  23 : C SORTIES            : -
  24 : C CODE RETOUR (IRET) : -
  25 : C     PMORS  : pointeurs sur segment PMORS de l'include SMMATRIK
  26 : C              profil de la matrice Morse à traiter
  27 : C     IZA    : pointeurs sur segment IZA de l'include SMMATRIK
  28 : C              valeurs de la matrice Morse.
  29 : C***********************************************************************
  30 : C VERSION    : v1, 01/04/98, version initiale
  31 : C HISTORIQUE : v1, 01/04/98, création
  32 : C HISTORIQUE :     15/06/98, modif : non-suppression des zéros
  33 : C                                    sur la diagonale.
  34 : C HISTORIQUE :
  35 : C
  36 : C***********************************************************************
  37 : C Prière de PRENDRE LE TEMPS de compléter les commentaires
  38 : C en cas de modification de ce sous-programme afin de faciliter
  39 : C la maintenance !
  40 : C***********************************************************************
  41 : *     
  42 : * Nettoyage d'un objet de type Matrice Morse
  43 : * i.e. on supprimme les ZERO stockées
  44 : * ATTENTION, on ne nettoie pas les valeurs "proches" de zero,
  45 : * on nettoie celle qui y ont été mises explicitement
  46 : * (i.e. qui ne sont pas le résultat d'un calcul)
  47 : *     
  48 : -INC CCOPTIO
  49 :       INTEGER IMPR,IRET
  50 : -INC SMMATRIK
  51 :       INTEGER NBVA
  52 :       INTEGER NJA,NTT
  53 :       POINTEUR KMORS.PMORS
  54 :       POINTEUR KISA.IZA
  55 : *     
  56 : *
  57 : *     .. Variables locales
  58 : *     .. Parameters ..
  59 :       REAL*8             ZERO
  60 :       PARAMETER        ( ZERO = 0.0D+0 )
  61 : *     ..
  62 :       INTEGER ICOL,INTT
  63 :       INTEGER NBZER
  64 :       INTEGER NBZER2
  65 :       IF (IMPR.GT.5) THEN
  66 :          WRITE(IOIMP,*) 'clmors : nettoyage de la matrice morse',
  67 :      $        ' de pointeurs',KMORS,KISA
  68 :          IF (IMPR.GT.7) THEN
  69 :             WRITE(IOIMP,*) 'Avant :'
  69 :             CALL ECMORS(KMORS,KISA,(IMPR-1))
  70 :          ENDIF
  71 :       ENDIF
  72 :       SEGACT KMORS*MOD
  73 :       SEGACT KISA*MOD
  74 :       NTT=KMORS.IA(/1)-1
  75 :       NJA=KMORS.JA(/1)
  76 :       NBZER=0
  77 :       DO 1 INTT=1,NTT
  78 :          NBZER2=NBZER
  79 :          DO 11 ICOL=KMORS.IA(INTT),(KMORS.IA(INTT+1)-1)
  80 :             IF (KISA.A(ICOL).EQ.ZERO.AND.KMORS.JA(ICOL).NE.INTT) THEN
  81 :                NBZER=NBZER+1
  82 :             ELSE
  83 :                KMORS.JA(ICOL-NBZER)=KMORS.JA(ICOL)
  84 :                KISA.A(ICOL-NBZER)= KISA.A(ICOL)
  85 :             ENDIF
  86 :  11      CONTINUE
  87 :          KMORS.IA(INTT)=KMORS.IA(INTT)-NBZER2
  88 :  1    CONTINUE
  89 :       KMORS.IA(NTT+1)=KMORS.IA(NTT+1)-NBZER
  90 :       NJA=NJA-NBZER
  91 :       SEGADJ KMORS
  92 :       NBVA=NJA
  93 :       SEGADJ KISA
  94 :       SEGDES KMORS
  95 :       SEGDES KISA
  96 :       IF (IMPR.GT.5) THEN
  97 :          IF (IMPR.GT.7) THEN
  98 :             WRITE(IOIMP,*) 'Après :'
  98 :             CALL ECMORS(KMORS,KISA,(IMPR-1))
  99 :          ENDIF
 100 :          WRITE(IOIMP,*) 'Nombre de zéros éliminés  :',NBZER
 101 :       ENDIF
 102 : *
 103 : *     Terminaison normale
 104 : *
 105 :       IRET=0
 106 :       RETURN
 107 : *
 108 : *     End of CLMORS
 109 : *
 110 :       END
 111 : 
 112 :  
 113 :  
 114 :  
 115 :  
 116 :  
 117 :  
 118 :  
 119 :