Télécharger clmors.eso

Retour à la liste

Numérotation des lignes :

  1. C CLMORS SOURCE PV 16/11/17 21:58:54 9180
  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. INTEGER NBVA
  51. INTEGER NJA,NTT
  52. POINTEUR KMORS.PMORS
  53. POINTEUR KISA.IZA
  54. *
  55. *
  56. * .. Variables locales
  57. * .. Parameters ..
  58. REAL*8 ZERO
  59. PARAMETER ( ZERO = 0.0D+0 )
  60. * ..
  61. INTEGER ICOL,INTT
  62. INTEGER NBZER
  63. INTEGER NBZER2
  64. IF (IMPR.GT.5) THEN
  65. WRITE(IOIMP,*) 'clmors : nettoyage de la matrice morse',
  66. $ ' de pointeurs',KMORS,KISA
  67. IF (IMPR.GT.7) THEN
  68. 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 :'
  99. CALL ECMORS(KMORS,KISA,(IMPR-1))
  100. ENDIF
  101. WRITE(IOIMP,*) 'Nombre de zéros éliminés :',NBZER
  102. ENDIF
  103. *
  104. * Terminaison normale
  105. *
  106. IRET=0
  107. RETURN
  108. *
  109. * End of CLMORS
  110. *
  111. END
  112.  
  113.  
  114.  
  115.  
  116.  
  117.  
  118.  
  119.  
  120.  
  121.  
  122.  
  123.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales