Télécharger comred.eso

Retour à la liste

Numérotation des lignes :

  1. C COMRED SOURCE PV 17/07/11 21:15:01 9491
  2.  
  3. SUBROUTINE COMRED(ich1)
  4.  
  5. *---------------------------------------------------------------
  6. * reduit la taille d'un melval s'il est constant
  7. *
  8. * ich1 segment de type MELVAL (ACTIF en E/S)
  9. * segment modifie par ajustement si necessaire
  10. *---------------------------------------------------------------
  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. ** segact,melval
  20.  
  21. * Valeurs reelles :
  22. * -----------------
  23. n1ptel = velche(/1)
  24. n1el = velche(/2)
  25. if (n1el.gt.1.or.n1ptel.gt.1) then
  26. * ymaxe* min et max generaux
  27. ymaxe1 = xgrand
  28. ymaxe2 = -xgrand
  29. * Cas general :
  30. if (n1ptel.gt.1) then
  31. * Est-on constant par element ?
  32. do ipel = 1, n1el
  33. * ymaxd* min et max sur l'element
  34. ymaxd1 = xgrand
  35. ymaxd2 = -xgrand
  36. do igel = 1, n1ptel
  37. valu1 = velche(igel,ipel)
  38. ymaxd1 = min(valu1,ymaxd1)
  39. ymaxd2 = max(valu1,ymaxd2)
  40. enddo
  41. ymaxr=max(max(abs(ymaxd1),abs(ymaxd2))*xzprec,xpetit)
  42. * Est-on constant sur l'element ipel ?
  43. if ((ymaxd2-ymaxd1).gt.ymaxr) goto 10
  44. ymaxe1=min(ymaxe1,ymaxd1)
  45. ymaxe2=max(ymaxe2,ymaxd2)
  46. enddo
  47. * Ici, on est a minima constant par element :
  48. n1ptel = 1
  49. * Est-on uniforme ?
  50. ymaxr=max(max(abs(ymaxe1),abs(ymaxe2))*xzprec,xpetit)
  51. if ((ymaxe2-ymaxe1).le.ymaxr) n1el = 1
  52. * Cas particulier : le champ est deja constant par element (n1ptel=1)
  53. else
  54. do ipel = 1, n1el
  55. valu1 = velche(1,ipel)
  56. ymaxe1=min(ymaxe1,valu1)
  57. ymaxe2=max(ymaxe2,valu1)
  58. enddo
  59. * Est-on uniforme ?
  60. ymaxr=max(max(abs(ymaxe1),abs(ymaxe2))*xzprec,xpetit)
  61. if ((ymaxe2-ymaxe1).gt.ymaxr) goto 10
  62. n1el = 1
  63. endif
  64. n2ptel = 0
  65. n2el = 0
  66. segadj,melval
  67. * On reactive le segment pour enlever le statut *mod suite au segadj
  68. ** segact,melval
  69. 10 continue
  70. endif
  71.  
  72. * Valeurs de type pointeur :
  73. * --------------------------
  74. n2ptel = ielche(/1)
  75. n2el = ielche(/2)
  76. if (n2el.gt.1.or.n2ptel.gt.1) then
  77. jalu1 = ielche(1,1)
  78. maxd1 = 0
  79. * Cas general :
  80. if (n2ptel.gt.1) then
  81. do ipel = 1, n2el
  82. jalu2 = ielche(1,ipel)
  83. * Est-on constant sur l'element ipel ?
  84. maxd2 = 0
  85. do igel = 2, n2ptel
  86. jiff = abs(ielche(igel,ipel) - jalu2)
  87. maxd2 = max(jiff,maxd2)
  88. enddo
  89. if (maxd2.ne.0) goto 20
  90. jiff = abs(jalu2 - jalu1)
  91. maxd1 = max(jiff,maxd1)
  92. enddo
  93. * Ici, on est a minima constant par element :
  94. n2ptel = 1
  95. * Est-on uniforme ?
  96. if (maxd1.eq.0) n2el = 1
  97. * Cas particulier : le champ est deja constant par element (n2ptel=1)
  98. else
  99. do ipel = 2, n2el
  100. jalu2 = ielche(1,ipel)
  101. jiff = abs(jalu2 - jalu1)
  102. maxd1 = max(jiff,maxd1)
  103. enddo
  104. * Est-on uniforme ?
  105. if (maxd1.gt.0) goto 20
  106. n2el = 1
  107. endif
  108. n1ptel = 0
  109. n1el = 0
  110. segadj,melval
  111. * On reactive le segment pour enlever le statut *mod suite au segadj
  112. ** segact,melval
  113. 20 continue
  114. endif
  115.  
  116. ich1 = melval
  117.  
  118. RETURN
  119. END
  120.  
  121.  
  122.  
  123.  
  124.  
  125.  

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