Télécharger comred.eso

Retour à la liste

Numérotation des lignes :

  1. C COMRED SOURCE PV 19/09/24 21:15:00 10303
  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. melva1 = ich1
  20.  
  21. C Valeurs reelles :
  22. C -----------------
  23. n1ptel = velche(/1)
  24. n1el = velche(/2)
  25. if (n1el.gt.1 .or. n1ptel.gt.1) then
  26. n1pteo=n1ptel
  27. n1elo=n1el
  28. C ymaxe* min et max generaux
  29. ymaxe1 = xgrand
  30. ymaxe2 = -xgrand
  31. C Cas general :
  32. if (n1ptel.gt.1) then
  33. C Est-on constant par element ?
  34. do ipel = 1, n1el
  35. C ymaxd* min et max sur l'element
  36. ymaxd1 = xgrand
  37. ymaxd2 = -xgrand
  38. do igel = 1, n1ptel
  39. valu1 = velche(igel,ipel)
  40. ymaxd1 = min(valu1,ymaxd1)
  41. ymaxd2 = max(valu1,ymaxd2)
  42. enddo
  43. ymaxr=max(max(abs(ymaxd1),abs(ymaxd2))*xzprec,xpetit)
  44. C Est-on constant sur l'element ipel ?
  45. if ((ymaxd2-ymaxd1).gt.ymaxr) return
  46. ymaxe1=min(ymaxe1,ymaxd1)
  47. ymaxe2=max(ymaxe2,ymaxd2)
  48. enddo
  49. C Ici, on est a minima constant par element :
  50. n1ptel = 1
  51. C Est-on uniforme ?
  52. ymaxr=max(max(abs(ymaxe1),abs(ymaxe2))*xzprec,xpetit)
  53. if ((ymaxe2-ymaxe1).le.ymaxr) n1el = 1
  54. C Cas particulier : le champ est deja constant par element (n1ptel=1)
  55. else
  56. do ipel = 1, n1el
  57. valu1 = velche(1,ipel)
  58. ymaxe1=min(ymaxe1,valu1)
  59. ymaxe2=max(ymaxe2,valu1)
  60. enddo
  61. C Est-on uniforme ?
  62. ymaxr=max(max(abs(ymaxe1),abs(ymaxe2))*xzprec,xpetit)
  63. if ((ymaxe2-ymaxe1).gt.ymaxr) return
  64. n1el = 1
  65. endif
  66. n2ptel = 0
  67. n2el = 0
  68. if (n1ptel.ne.n1pteo.or.n1el.ne.n1elo) then
  69. segadj,melval
  70. segact melval
  71. endif
  72. ** segini,melva1
  73. ** DO IEL=1,N1EL
  74. ** DO IPTEL=1,N1PTEL
  75. ** melva1.velche(IPTEL,IEL)=melval.velche(IPTEL,IEL)
  76. ** ENDDO
  77. ** ENDDO
  78. endif
  79.  
  80.  
  81.  
  82. C Valeurs de type pointeur :
  83. C --------------------------
  84. n2ptel = ielche(/1)
  85. n2el = ielche(/2)
  86. if (n2el.gt.1 .or. n2ptel.gt.1) then
  87. n2pteo=n2ptel
  88. n2elo=n2el
  89. jalu1 = ielche(1,1)
  90. maxd1 = 0
  91. C Cas general :
  92. if (n2ptel.gt.1) then
  93. do ipel = 1, n2el
  94. jalu2 = ielche(1,ipel)
  95. C Est-on constant sur l'element ipel ?
  96. maxd2 = 0
  97. do igel = 2, n2ptel
  98. jiff = abs(ielche(igel,ipel) - jalu2)
  99. maxd2 = max(jiff,maxd2)
  100. enddo
  101. if (maxd2.ne.0) return
  102. jiff = abs(jalu2 - jalu1)
  103. maxd1 = max(jiff,maxd1)
  104. enddo
  105. C Ici, on est a minima constant par element :
  106. n2ptel = 1
  107. C Est-on uniforme ?
  108. if (maxd1.eq.0) n2el = 1
  109. C Cas particulier : le champ est deja constant par element (n2ptel=1)
  110. else
  111. do ipel = 2, n2el
  112. jalu2 = ielche(1,ipel)
  113. jiff = abs(jalu2 - jalu1)
  114. maxd1 = max(jiff,maxd1)
  115. enddo
  116. C Est-on uniforme ?
  117. if (maxd1.gt.0) return
  118. n2el = 1
  119. endif
  120. n1ptel = 0
  121. n1el = 0
  122. if (n2ptel.ne.n2pteo.or.n2el.ne.n2elo) then
  123. segadj,melval
  124. segact melval
  125. endif
  126. ** segini,melva1
  127. ** DO IEL=1,N2EL
  128. ** DO IPTEL=1,N2PTEL
  129. ** melva1.ielche(IPTEL,IEL)=melval.ielche(IPTEL,IEL)
  130. ** ENDDO
  131. ** ENDDO
  132. endif
  133.  
  134. ich1 = melva1
  135.  
  136. END
  137.  
  138.  
  139.  
  140.  

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