C COMRED    SOURCE    FANDEUR   11/09/26    21:16:20     7141           

      SUBROUTINE COMRED(ich1) 

*---------------------------------------------------------------
*  reduit la taille d'un melval s'il est constant
*
*  ich1  segment de type MELVAL (ACTIF en E/S)
*        segment modifie par ajustement si necessaire
*---------------------------------------------------------------

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)

-INC SMCHAML

      melval = ich1
      segact,melval

* Valeurs reelles :
* -----------------
      n1ptel = velche(/1)
      n1el   = velche(/2)
      if (n1el.gt.1.or.n1ptel.gt.1) then
        vale1 = velche(1,1)
        ymaxe1 = 0.
* Cas general :
        if (n1ptel.gt.1) then
          ymaxe2 = 0.
*   Est-on constant par element ?
          do ipel = 1, n1el
            valu1 = velche(1,ipel)
            ymaxd1 = 0.
            ymaxd2 = abs(valu1)
            do igel = 2, n1ptel
              diff1  = abs(velche(igel,ipel) - valu1)
              ymaxd1 = max(diff1,ymaxd1)
              ymaxd2 = max(abs(velche(igel,ipel)),ymaxd2)
            enddo 
*   Est-on constant sur l'element ipel ?
            if (ymaxd1.gt.ymaxd2*1.d-14) goto 10
            diff1  = abs(valu1 - vale1)
            ymaxe1 = max(diff1,ymaxe1)
            ymaxe2 = max(abs(valu1),ymaxe2)
          enddo
*   Ici, on est a minima constant par element :
          n1ptel = 1
*   Est-on uniforme ?
          if (ymaxe1.le.ymaxe2*1.d-14) n1el = 1
* Cas particulier : le champ est deja constant par element (n1ptel=1)
        else
          ymaxe2 = abs(vale1)
          do ipel = 2, n1el
            valu1 = velche(1,ipel)
            diff1  = abs(valu1 - vale1)
            ymaxe1 = max(diff1,ymaxe1)
            ymaxe2 = max(abs(valu1),ymaxe2)
          enddo
*   Est-on uniforme ?
          if (ymaxe1.gt.ymaxe2*1.d-14) goto 10
          n1el = 1
        endif
        n2ptel = 0
        n2el   = 0
        segadj,melval
* On reactive le segment pour enlever le statut *mod suite au segadj
        segact,melval
  10    continue
      endif

* Valeurs de type pointeur :
* --------------------------
      n2ptel = ielche(/1)
      n2el   = ielche(/2)
      if (n2el.gt.1.or.n2ptel.gt.1) then
        jalu1 = ielche(1,1)
        maxd1 = 0
* Cas general :
        if (n2ptel.gt.1) then
          do ipel = 1, n2el
            jalu2 = ielche(1,ipel)
*   Est-on constant sur l'element ipel ?
            maxd2 = 0
            do igel = 2, n2ptel
              jiff  = abs(ielche(igel,ipel) - jalu2)
              maxd2 = max(jiff,maxd2)
            enddo 
            if (maxd2.ne.0) goto 20
            jiff  = abs(jalu2 - jalu1)
            maxd1 = max(jiff,maxd1)
          enddo
*   Ici, on est a minima constant par element :
          n2ptel = 1
*   Est-on uniforme ?
          if (maxd1.eq.0) n2el = 1
* Cas particulier : le champ est deja constant par element (n2ptel=1)
        else
          do ipel = 2, n2el
            jalu2 = ielche(1,ipel)
            jiff  = abs(jalu2 - jalu1)
            maxd1 = max(jiff,maxd1)
          enddo
*   Est-on uniforme ?
          if (maxd1.gt.0) goto 20
          n2el = 1
        endif
        n1ptel = 0
        n1el   = 0
        segadj,melval
* On reactive le segment pour enlever le statut *mod suite au segadj
        segact,melval
 20     continue
      endif

      ich1 = melval

      RETURN
      END