C AVISO     SOURCE    FANDEUR   13/01/29    21:15:08     7683           
C
      SUBROUTINE AVISO(MELEME,MCHPOI,MCHAM,IPMO1,
     >    VCPCHA,VCHC,NISO,NCOUMA,VCHMIN,VCHMAX,MLREEL,MCARA,
     >    NCOMP,LCOMP,COMPCH,choico)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   Préparation du tracé des isovaleurs d un objet
c   de type CHPOINT ou CHAMELEM
C
C   Création
C     AOUT 85
C
C   Modifications :
C      PM 09/11/2007 :
C        . ne conserve que le nb d'isovaleurs admissibles
C          si liste d'isovaleurs imposées
C        . accepte une liste d'isovaleurs non croissante
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT INTEGER(I-N)
      SEGMENT VCPCHA(XCOOR(/1)/(IDIM+1))
-INC CCOPTIO
-INC SMELEME
-INC SMMODEL
-INC SMCHPOI
-INC SMCOORD
-INC SMLREEL
-INC SMCHAML
-INC SMLMOTS
      REAL VCHC
      DIMENSION VCHC(*)
c BP : indesou doit etre capable d'accueillir tous les nbsous modeles
      SEGMENT indesou(nbinde)
*     tableau des noms de composantes (chamelem)
      CHARACTER*(*) COMPCH(*)
      CHARACTER*8 CHOISI
      CHARACTER*4 CHOICO
C
* kich : modif ncomp etait deja initialise dans prtrac
*      NCOMP=0

      DO I=1,VCPCHA(/1)
         VCPCHA(I)=0
      ENDDO

*     Cas du MCHAML
*     =============
      IF (MCHAM.NE.0) THEN
*        Si ce sont des contraintes, on rajoute le Von Mises
         MCHELM=MCHAM
         SEGACT MCHELM
         IUN=1
         DO IU=1,ICHAML(/1)
            MCHAML=ICHAML(IU)
            SEGACT MCHAML
            IF(IELVAL(/1).NE.1) IUN=0
         ENDDO
         IF (TITCHE.EQ.'CONTRAINTES'.AND.IUN.NE.1) THEN
C Petit traitement pour retirer JOI1 du calcul de VMIS
            MMODEL=IPMO1
            SEGACT,MMODEL
            N1=KMODEL(/1)
            SEGINI,MMODE1
            NN1=0
            DO 3 IMO=1,N1
              IMODEL=KMODEL(IMO)
              SEGACT,IMODEL
              IF(INFELE(13).EQ.75) GOTO 3
              NN1=NN1+1
              MMODE1.KMODEL(NN1)=IMODEL
              SEGDES,IMODEL
 3          CONTINUE
            IF(NN1.EQ.0) THEN
              SEGSUP,MMODE1
              SEGDES,MMODEL
            ELSE
              N1=NN1
              SEGADJ,MMODE1
              SEGDES,MMODEL,MMODE1
              IPMO1=MMODE1
              CALL VMISPO(IPMO1,MCHELM,MCARA,ICONV,MCHEL1,IRET)
              IF (IERR.NE.0) RETURN
              SEGACT MCHEL1
              DO 5 ISOUS=1,MCHEL1.IMACHE(/1)
                 MCHAML=MCHEL1.ICHAML(ISOUS)
                 SEGACT MCHAML*MOD
                 NOMCHE(1)='VONMISES'
 5            CONTINUE
              CALL FUSCHL(MCHEL1,MCHELM,MCHELO)
              MCHELM=MCHELO
            ENDIF
         ENDIF

*        On cree le MELEME a tracer
*        On stocke les MELVAL dans LISREF (très astucieux)
         SEGACT MCHELM
         NBSOUS=IMACHE(/1)
         NBREF=NBSOUS
         NBNN=0
         NBELEM=0
         SEGINI MELEME
         ITYPEL=0
         DO ISOUS=1,NBSOUS
            LISOUS(ISOUS)=IMACHE(ISOUS)
         ENDDO
         nbinde=NBSOUS
         segini,indesou
* kich : pour des modeles heterogenes (ex massif + poutre) pb de trace
         ksou = 0
         DO ISOUS=1,NBSOUS
            IF (INFCHE(ISOUS,2).EQ.1.AND.INFCHE(ISOUS,6).NE.1) THEN
*              pas un chamelem aux noeuds
               CALL ERREUR(609)
               RETURN
            ENDIF
            MCHAML=ICHAML(ISOUS)
            SEGACT MCHAML

*           Constitution de la liste des noms de composantes COMPCH
* kich : modif on crée une liste pour l ensemble du MCHELM
*           NCOMP=0
            CHOISI=' '
            IF (LCOMP.NE.0) CHOISI=COMPCH(LCOMP)
            IF (LCOMP.EQ.0) LCOMP=1
            DO 25 ICOMP=1,TYPCHE(/2)
               IF (TYPCHE(1).NE.'REAL*8') GOTO 25
               DO JCOMP=1,NCOMP
                  IF (COMPCH(JCOMP).EQ.NOMCHE(ICOMP)) GOTO 25
               ENDDO
*              COMPCH dimensionné à 10 dans PRTRAC
               IF (NCOMP.EQ.10) GOTO 25
               NCOMP=NCOMP+1
               COMPCH(NCOMP)=NOMCHE(ICOMP)
               IF (CHOISI.EQ.' ') CHOISI=NOMCHE(ICOMP)
 25         CONTINUE
            IF (NCOMP.EQ.0) THEN
*           Il faut spécifier un champ par élément avec une seule composante
               CALL ERREUR(320)
               RETURN
            ENDIF
*           provisoirement
*            DO JCOMP=1,NCOMP
* kich : c est nomche qu il faut tester
            DO  ICOMP=1,TYPCHE(/2)
*               IF (COMPCH(JCOMP).EQ.CHOISI) LISREF(ISOUS)=IELVAL(JCOMP)
                  IF (CHOISI.EQ.NOMCHE(ICOMP)) THEN
                     LISREF(ISOUS)=IELVAL(ICOMP)
                     ksou = ksou + 1
                     indesou(ksou ) = isous
                  ENDIF
            ENDDO
            IF (IERR.NE.0) RETURN
            SEGDES MCHAML
         ENDDO
         SEGDES MCHELM

* verifie le meleme
         do jso = 1 ,ksou
          jsous = indesou(jso)
          lisous(jso) = lisous(jsous)
          lisref(jso) = lisref(jsous)
          if (lisref(jso).eq.0) call erreur(5)
c          write(6,*) 'verif', jso, lisous(jso),lisref(jso),lcomp
         enddo
         NBSOUS = ksou
         NBREF = NBSOUS
         segadj MELEME
         segsup,indesou

*        Calcul des extrema
         DO ISOUS=1,NBSOUS
            MELVAL=LISREF(ISOUS)
            IF (MELVAL.NE.0) THEN
               SEGACT MELVAL
               DO INN=1,VELCHE(/1)
                  DO IEL=1,VELCHE(/2)
                     VCHMIN=MIN(VCHMIN,REAL(VELCHE(INN,IEL)))
                     VCHMAX=MAX(VCHMAX,REAL(VELCHE(INN,IEL)))
                  ENDDO
               ENDDO
            ENDIF
         ENDDO
      ENDIF

*     Cas du CHPOINT
*     ==============
      IF (MCHAM.EQ.0) THEN
*        Récupération des valeurs du champ à tracer
         SEGACT MELEME
         SEGACT MCHPOI
         NSOUPO=IPCHP(/1)
         if(lcomp.eq.0) then
           nomp=0
           do isoupo=1,nsoupo
             msoupo=ipchp(isoupo)
             segact msoupo
             do nbpp=1,nocomp(/2)
               do ncbb=1,ncomp
                 if( compch(ncbb).eq.nocomp(nbpp)) go to 43
               enddo
*              COMPCH dimensionné à 10 dans PRTRAC
               IF (NCOMP.EQ.10) GOTO 43
               ncomp=ncomp+1
               compch(ncomp)=nocomp(nbpp)
   43          continue
             enddo
           enddo
           lcomp=1
           if( (compch(1).eq.'LX  '. or . compch (1).eq.'FLX ' )
     $     .and. ncomp.ge.2) lcomp=2
         endif
         choisi=compch(lcomp)
         DO ISOUPO=1,NSOUPO
            MSOUPO=IPCHP(ISOUPO)
            SEGACT MSOUPO
            MPOVAL=IPOVAL
            SEGACT MPOVAL
            IPT2=IGEOC
            SEGACT IPT2
            ncomp=0
            NCC=NOCOMP(/2)
            do ic=1,ncc
               if( choisi.eq.nocomp(ic)) go to 44
            enddo
            go to 45
   44       continue
            DO IEL=1,IPT2.NUM(/2)
               IFOI=IPT2.NUM(1,IEL)
               VCPCHA(IFOI)=VPOCHA(IEL,IC)
            ENDDO
   45       continue
            SEGDES IPT2,MPOVAL,MSOUPO
         ENDDO

*        Calcul des extrema
         IPT1=MELEME
         DO I=1,MAX(1,LISOUS(/1))
            IF (LISOUS(/1).NE.0) IPT1=LISOUS(I)
            SEGACT IPT1
            DO J=1,IPT1.NUM(/1)
               DO K=1,IPT1.NUM(/2)
                  IPOIT=IPT1.NUM(J,K)
                  VCHMIN=MIN(VCHMIN,REAL(VCPCHA(IPOIT)))
                  VCHMAX=MAX(VCHMAX,REAL(VCPCHA(IPOIT)))
               ENDDO
            ENDDO
            IF (LISOUS(/1).NE.0) SEGDES IPT1
         ENDDO
         SEGDES MELEME
         SEGDES MCHPOI
      ENDIF
C
*     Détermination de la liste d'isovaleurs
*     ======================================
**--   par défaut
      NISO=NCOUMA
      IF (ISOTYP.GT.0) NISO=NISO-1
*--   d'après un LISTREEL en entrée
      IF (MLREEL.EQ.0) CALL LIROBJ ('LISTREEL',MLREEL,0,IRETOU)
      IF (MLREEL.EQ.0) GOTO 9800

*PM   On s'assure d'avoir une liste croissante
      SEGINI,MLREE1=MLREEL
      CALL ORDO01(MLREE1.PROG,MLREE1.PROG(/1),.TRUE.)
      SEGACT MLREEL
*
      NISO=PROG(/1)
      IF (ISOTYP.GT.0) NISO=NISO+1
*PM   Limitation du nb d'isovaleurs au nombre de couleurs admissibles
      IF(NISO.GT.NCOUMA) THEN
*         write(IOIMP,*) 'ajustement à ',ncouma,' réels'
         JG=NCOUMA
         SEGADJ, MLREE1
*        on picore les valeurs parmi la liste entrée
         IDI = PROG(/1) / JG
         DO I=1,JG
            MLREE1.PROG(I)=PROG(1+((I-1)*IDI))
         ENDDO
         NISO=NCOUMA
*         CALL ERREUR(201)
*         GOTO 9099
      ENDIF
      SEGDES, MLREEL

*PM   PET=-1E30
      DO I=1,MLREE1.PROG(/1)
         VCHC(I)=MLREE1.PROG(I)
*PM         IF (VCHC(I).LE.PET) THEN
*PM*           Valeurs non croissantes dans la table
*PM            CALL ERREUR(211)
*PM            RETURN
*PM         ELSE
*PM            PET=MAX(PET,VCHC(I))
*PM         ENDIF
      ENDDO
* Pas nécessaire ?
*goo      IF (ISOTYP.GT.0) VCHC(NISO)=VCHMAX
      SEGSUP MLREE1
      GOTO 9099

*--   d'après un ENTIER en entrée
9800  CALL LIRENT(NIZO,0,IRETOU)
      IF (IRETOU.NE.0) NISO=MIN(NIZO,NISO)
      NISO=MAX(1,NISO)

*--   Progression arithmétique entre les extrêmes
9900  CONTINUE
C     Si la valeur max est egal au min on ne prend qu'une couleur
      IF (VCHMIN.EQ.VCHMAX) NISO=1
C
      DO I=1,NISO+1
         VCHC(I)=VCHMIN+(I-1)*(VCHMAX-VCHMIN)/NISO
      ENDDO
C     On essaie de repérer s'il y a des NaNQ
      IF (.NOT.(VCHC(1).EQ.VCHC(1))) THEN
         NISO=1
         DO I=1,NISO+1
            VCHC(I)=VCHMIN+(I-1)*(VCHMAX-VCHMIN)/NISO
         ENDDO
      ENDIF

      IT=0
      DO II=1,NISO
         IT=IT+1
         VCHC(IT)=(VCHC(II)+VCHC(II+1))/2
      ENDDO
*gounand
      IF (ISOTYP.GT.0) NISO=NISO+1
*     Sortie
*     ======
 9099 CONTINUE
      SEGDES MELEME

      RETURN
      END