Télécharger comred.eso

Retour à la liste

Numérotation des lignes :

comred
  1. C COMRED SOURCE PV090527 23/01/27 21:15:16 11574
  2.  
  3. SUBROUTINE COMRED(ich1)
  4.  
  5. C---------------------------------------------------------------
  6. C reduit la taille d'un melval s'il est constant
  7. C
  8. C ich1 segment de type MELVAL (ACTIF en E/S)
  9. C nouveau segment si necessaire
  10. C---------------------------------------------------------------
  11.  
  12. IMPLICIT INTEGER(I-N)
  13. IMPLICIT REAL*8(A-H,O-Z)
  14.  
  15. -INC SMCHAML
  16. -INC CCREEL
  17.  
  18. melval = ich1
  19.  
  20. C Valeurs reelles :
  21. C -----------------
  22. n1ptel = velche(/1)
  23. n1el = velche(/2)
  24. if (n1el.gt.1 .or. n1ptel.gt.1) then
  25. n1pteo=n1ptel
  26. n1elo =n1el
  27.  
  28. C ymaxe* : min et max generaux
  29. ymaxe1 = xgrand
  30. ymaxe2 = -xgrand
  31.  
  32. C Cas general :
  33. if (n1ptel .gt. 1) then
  34. C Est-on constant par element ?
  35. do ipel = 1, n1el
  36. C ymaxd* : min et max sur l'element
  37. ymaxd1 = xgrand
  38. ymaxd2 = -xgrand
  39. do igel = 1, n1ptel
  40. valu1 = velche(igel,ipel)
  41. ymaxd1 = min(valu1,ymaxd1)
  42. ymaxd2 = max(valu1,ymaxd2)
  43. enddo
  44. C Est-on constant sur l'element ipel ?
  45. C Utilisation de la MACRO A_EGALE_B pour uniformiser le test d'egalite de flottants (CCREEL)
  46. if (.NOT. A_EGALE_B(ymaxd2,ymaxd1)) return
  47. ymaxe1=min(ymaxe1,ymaxd1)
  48. ymaxe2=max(ymaxe2,ymaxd2)
  49. enddo
  50. C Ici, on est a minima constant par element :
  51. n1ptel = 1
  52. C Est-on uniforme ?
  53. C Utilisation de la MACRO A_EGALE_B pour uniformiser le test d'egalite de flottants (CCREEL)
  54. if (A_EGALE_B(ymaxe2,ymaxe1)) n1el = 1
  55. C Cas particulier : le champ est deja constant par element (n1ptel=1)
  56.  
  57. else
  58. do ipel = 1, n1el
  59. valu1 = velche(1,ipel)
  60. ymaxe1=min(ymaxe1,valu1)
  61. ymaxe2=max(ymaxe2,valu1)
  62. enddo
  63.  
  64. C Est-on uniforme ?
  65. ymaxr=max(max(abs(ymaxe1),abs(ymaxe2))*xzprec,xpetit)
  66. if (.NOT. A_EGALE_B(ymaxe2,ymaxe1)) return
  67. n1el = 1
  68. endif
  69.  
  70. n2ptel = 0
  71. n2el = 0
  72. if (n1ptel.ne.n1pteo.or.n1el.ne.n1elo) then
  73. segadj,melval
  74. endif
  75. endif
  76.  
  77.  
  78. C Valeurs de type pointeur :
  79. C --------------------------
  80. n2ptel = ielche(/1)
  81. n2el = ielche(/2)
  82. if (n2el.gt.1 .or. n2ptel.gt.1) then
  83. n2pteo=n2ptel
  84. n2elo=n2el
  85. jalu1 = ielche(1,1)
  86. maxd1 = 0
  87. C Cas general :
  88. if (n2ptel.gt.1) then
  89. do ipel = 1, n2el
  90. jalu2 = ielche(1,ipel)
  91. C Est-on constant sur l'element ipel ?
  92. maxd2 = 0
  93. do igel = 2, n2ptel
  94. jiff = abs(ielche(igel,ipel) - jalu2)
  95. maxd2 = max(jiff,maxd2)
  96. enddo
  97. if (maxd2.ne.0) return
  98. jiff = abs(jalu2 - jalu1)
  99. maxd1 = max(jiff,maxd1)
  100. enddo
  101. C Ici, on est a minima constant par element :
  102. n2ptel = 1
  103. C Est-on uniforme ?
  104. if (maxd1.eq.0) n2el = 1
  105. C Cas particulier : le champ est deja constant par element (n2ptel=1)
  106. else
  107. do ipel = 2, n2el
  108. jalu2 = ielche(1,ipel)
  109. jiff = abs(jalu2 - jalu1)
  110. maxd1 = max(jiff,maxd1)
  111. enddo
  112. C Est-on uniforme ?
  113. if (maxd1.gt.0) return
  114. n2el = 1
  115. endif
  116. n1ptel = 0
  117. n1el = 0
  118. if (n2ptel.ne.n2pteo.or.n2el.ne.n2elo) then
  119. segadj,melval
  120. segact melval
  121. endif
  122. endif
  123.  
  124. END
  125.  
  126.  
  127.  

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