Télécharger comred.eso

Retour à la liste

Numérotation des lignes :

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

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