C EXTRA6    SOURCE    BP208322  13/09/12    21:15:01     7823           
      SUBROUTINE EXTRA6(IBOLL)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C
C  =====================================================================
C
C   EXTRAIT UNE LISTE DE REELS ou autre D'UN OBJET EVOL
C        OU UNE COURBE (EVOL ELEMENTAIRE) 
C        OU CERTAINS COUPLES
C
C   APPELE PAR EXTRAI 
C
C  =====================================================================
C
C   CREATION     : 12/05/87
C   PROGRAMMEUR  : GUILBAUD
C   Modification : PM 12/09/2007, 
C                  définition de la couleur et du type  de l'évolution
C                  extraite 
c                  bp 12/09/2013: erreur 1027 pour les EVOLUTIOns vides
C
C  =====================================================================
C
-INC CCOPTIO
-INC SMEVOLL
-INC SMTEXTE
      CHARACTER*12 TI,ITEX,CHAR1,CHAR2
      CHARACTER*8 ITBLA,TYPRES

C
C     VERIF QUE L'EVOLUTION N'EST PAS VIDE
C
      MEVOLL=IBOLL
      SEGACT MEVOLL
      NBEV = IEVOLL(/1)
      if(NBEV.le.0) then
       MOTERR(1:8)='EVOLUTIO'
C      Une donnée de type %m1:8 est vide
       CALL ERREUR(1027)
       GOTO 80
      endif
C
C     LECTURE DU TITRE DE LA PROGRESSION
C
      TYPRES='LISTREEL'
      ITBLA=' '
      CALL QUETYP(ITBLA,0,IRETOU)
      IF(ITBLA.EQ.'MOT     ') THEN
C
C         ON VA LIRE UN MOT
C
          CALL LIRCHA(TI,1,IRETOU)

C         On extrait la légende en X
          IF(TI(:4).EQ.'LEGX')THEN
           CALL LIRENT(K,1,IRETOU)
            if(K.LE.0)THEN
             CALL ERREUR(352)
             RETURN
            ENDIF
c            MEVOLL=IBOLL
c            SEGACT MEVOLL
            if(K.GT.IEVOLL(/1))THEN
c            Il n'y a pas %i1 courbes dans l'objet évolution
             INTERR(1)=K
             CALL ERREUR(351)
             SEGDES MEVOLL
             RETURN
            ENDIF

           KEVOLL = IEVOLL(K)
           SEGACT KEVOLL
           ITEX=NOMEVX
           SEGDES KEVOLL,MEVOLL
           CALL ECRCHA(ITEX)
           RETURN
          ENDIF

C         On extrait la légende en Y
          IF(TI(:4).EQ.'LEGY')THEN
           CALL LIRENT(K,1,IRETOU)
            if(K.LE.0)THEN
             CALL ERREUR(352)
             RETURN
            ENDIF
c            MEVOLL=IBOLL
c            SEGACT MEVOLL
            if(K.GT.IEVOLL(/1))THEN
             CALL ERREUR(351)
             RETURN
            ENDIF

           KEVOLL = IEVOLL(K)
           SEGACT KEVOLL
           ITEX=NOMEVY
           SEGDES KEVOLL,MEVOLL
           CALL ECRCHA(ITEX)
           RETURN
          ENDIF

          IF (TI(:4).EQ.'ABSC'.OR.TI(:4).EQ.'ORDO'.OR.TI(:4).EQ.'COUR')
     &       GOTO 25
*
          IF (TI(:4).EQ.'PAS '.OR.TI(:4).EQ.'APRE'.OR.TI(:4).EQ.'AVAN')
     &       GOTO 26
*
      ELSE
C
C         ON LIT AUTRE CHOSE
C
          CALL LIROBJ(ITBLA,MOT1,1,IRETOU)
C         On ne veut pas d'objet de type %m1:8
          MOTERR(1:8)=ITBLA
          CALL ERREUR(39)
          RETURN
      ENDIF
C
C     RECHERCHE DE LA PROGRESSION
C
c       MEVOLL=IBOLL
c       SEGACT MEVOLL
      NBEV=IEVOLL(/1)
      DO J=1,NBEV
        KEVOLL=IEVOLL(J)
        SEGACT KEVOLL
        ITEX=NOMEVX
        IRET=IPROGX
        SEGDES KEVOLL
        IF(TI.EQ.ITEX) GOTO 30
        SEGACT KEVOLL
        ITEX=NOMEVY
        IRET=IPROGY
        SEGDES KEVOLL
        IF(TI.EQ.ITEX) GOTO 30
      ENDDO 

C     Il n'existe pas de liste ayant ce titre dans l'objet évolution
      CALL ERREUR(353)
      GOTO 80
*
*     EXTRACTION DE CERTAINS COUPLES
*
   26 CONTINUE
      CALL TEVOLU(IBOLL,TI)
      RETURN
*
*     AUTRE OPERATION
*
   25 CONTINUE
c       MEVOLL=IBOLL
c       SEGACT MEVOLL
C
C     ON A LU UN MOT-CLE
C
C
C     EXTRAIRE LES COURBES DE NOMS D'ABSCISSES OU D'ORDONNEES DONNES
C
      CALL LIRCHA(ITEX,0,IRETOU)
      IF (IRETOU.NE.0.AND.TI(:4).EQ.'COUR') THEN
         NBEV=IEVOLL(/1)
         N=NBEV
         SEGINI,MEVOL1
         MEVOL1.ITYEVO=ITYEVO
         MEVOL1.IEVTEX=IEVTEX
         N=0
         DO IK=1,NBEV
            KEVOLL=MEVOLL.IEVOLL(IK)
            SEGACT,KEVOLL
            CHAR1=NOMEVX
            CHAR2=NOMEVY
*      write(6,*) 'CHAR1 =',CHAR1
*      write(6,*) 'CHAR2 =',CHAR2
            IF (ITEX(1:12).EQ.CHAR1.OR.ITEX(1:12).EQ.CHAR2) THEN
              N=N+1
              MEVOL1.IEVOLL(N)=KEVOLL
            ENDIF
            SEGDES,KEVOLL
         ENDDO
*      write(6,*) 'N =',N
         IF (N.NE.0) THEN
            SEGADJ,MEVOL1
            IRET=MEVOL1
            SEGDES,MEVOL1
            CALL ECROBJ('EVOLUTIO',IRET)
         ELSE
            SEGSUP,MEVOL1
            CALL ERREUR(353)
         ENDIF
         GOTO 80
      ENDIF
C
C     EXTRAIRE LA COURBE J
C
      CALL LIRENT(J,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
          J=1
      ELSE
          IF(J.GT.IEVOLL(/1)) THEN
*             Il n'y a pas %i1 courbes dans l'objet évolution
              INTERR(1)=J
              CALL ERREUR(351)
              GOTO 80
          ENDIF
          IF(J.LE.0) THEN
C             Numéro de la courbe négatif ou nul
              CALL ERREUR(352)
              GOTO 80
          ENDIF
      ENDIF

      KEVOLL=IEVOLL(J)
      SEGACT KEVOLL
      IF(TI(:4).EQ.'COUR') THEN
          N=1
          SEGINI MEVOL1
          MEVOL1.IEVTEX   = KEVTEX
          MEVOL1.ITYEVO   = 'REEL'
          MEVOL1.IEVOLL(1)= KEVOLL
          IRET=MEVOL1
          SEGDES MEVOL1
          SEGDES KEVOLL
          CALL ECROBJ('EVOLUTIO',IRET)
          GOTO 80
      ENDIF

C
C     EXTRAIRE LES LISTES D'ABSCISSES (DEFAUT) OU D'ORDONNEES
C
      IRET=IPROGX
      TYPRES=TYPX
      IF(TI(:4).EQ.'ORDO') THEN
         IRET  = IPROGY
         TYPRES= TYPY
      ENDIF
      SEGDES KEVOLL

   30 CONTINUE
      CALL ECROBJ(TYPRES,IRET)

   80 CONTINUE
      SEGDES MEVOLL
      RETURN

      END