Télécharger extra6.eso

Retour à la liste

extra6
C EXTRA6    SOURCE    CB215821  21/10/14    21:15:16     11122          
      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                  BP 09/07/2014: ajout EXTR evol1 listent1
C
C  =====================================================================
C
 
-INC PPARAM
-INC CCOPTIO
-INC SMEVOLL
-INC SMTEXTE
-INC SMLENTI
-INC SMLMOTS
-INC CCGEOME
      CHARACTER*12 TI,ITEX,CHAR1,CHAR2
      CHARACTER*8 ITBLA,TYPRES
      CHARACTER*4 ICOUL
 
C
C     VERIF QUE L'EVOLUTION N'EST PAS VIDE
C
      MEVOLL=IBOLL
      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 couleur (ajout BP, 2015-03-12)
          IF(TI(:4).EQ.'COUL')THEN
           CALL LIRENT(K,0,IRETOU)
*          cas ou on precise la k^ieme courbe --> mot
           if (IRETOU.NE.0) then
            if(K.LE.0)THEN
             CALL ERREUR(352)
             RETURN
            ENDIF
            if(K.GT.IEVOLL(/1))THEN
c            Il n'y a pas %i1 courbes dans l'objet évolution
             INTERR(1)=K
             CALL ERREUR(351)
             RETURN
            ENDIF
            KEVOLL = IEVOLL(K)
            ICOUL=NCOUL(NUMEVX)
            CALL ECRCHA(ICOUL)
            RETURN
*          cas ou on ne precise pas la k^ieme courbe --> listmots
           else
            JGN=4
            JGM=IEVOLL(/1)
            segini,MLMOTS
            ILMOTS=MLMOTS
            DO 1 K=1,JGM
              KEVOLL = IEVOLL(K)
              ICOUL=NCOUL(NUMEVX)
              MOTS(K)=ICOUL
 1          CONTINUE
            SEGDES MLMOTS
            CALL ECROBJ('LISTMOTS',ILMOTS)
            RETURN
           endif
          ENDIF
 
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
            if(K.GT.IEVOLL(/1))THEN
c            Il n'y a pas %i1 courbes dans l'objet évolution
             INTERR(1)=K
             CALL ERREUR(351)
             RETURN
            ENDIF
 
           KEVOLL = IEVOLL(K)
           ITEX=NOMEVX
           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
            if(K.GT.IEVOLL(/1))THEN
             CALL ERREUR(351)
             RETURN
            ENDIF
 
           KEVOLL = IEVOLL(K)
           ITEX=NOMEVY
           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'
     &       .OR.TI(:4).EQ.'COMP') 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
      NBEV=IEVOLL(/1)
      DO J=1,NBEV
        KEVOLL=IEVOLL(J)
        ITEX=NOMEVX
        IRET=IPROGX
        IF(TI.EQ.ITEX) GOTO 30
        ITEX=NOMEVY
        IRET=IPROGY
        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
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)
            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
         ENDDO
*      write(6,*) 'N =',N
         IF (N.NE.0) THEN
            SEGADJ,MEVOL1
            IRET=MEVOL1
            CALL ACTOBJ('EVOLUTIO',IRET,1)
            CALL ECROBJ('EVOLUTIO',IRET)
         ELSE
            CALL ERREUR(353)
         ENDIF
         GOTO 80
      ENDIF
C
C     EXTRAIRE LES COURBES DEPUIS UN LISTENTI
C
      CALL LIROBJ('LISTENTI',MLENTI,0,IRETOU)
      IF (IRETOU.NE.0.AND.TI(:4).EQ.'COUR') THEN
         NBEV=IEVOLL(/1)
         SEGACT,MLENTI
         JG=LECT(/1)
         N=JG
         SEGINI,MEVOL1
         MEVOL1.ITYEVO=ITYEVO
         MEVOL1.IEVTEX=IEVTEX
         N=0
         DO J=1,JG
            IK=LECT(J)
            IF(IK.GT.NBEV) THEN
              INTERR(1)=IK
              CALL ERREUR(351)
              GOTO 80
            ELSEIF(IK.LE.0) THEN
              CALL ERREUR(352)
              GOTO 80
            ENDIF
            N=N+1
            MEVOL1.IEVOLL(N)= IEVOLL(IK)
         ENDDO
         IRET=MEVOL1
         CALL ACTOBJ('EVOLUTIO',IRET,1)
         CALL ECROBJ('EVOLUTIO',IRET)
         GOTO 80
      ENDIF
C
C     EXTRAIRE LA COURBE(S) 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)
      IF(TI(:4).EQ.'COUR') THEN
          N=1
          SEGINI MEVOL1
          MEVOL1.IEVTEX   = KEVTEX
          MEVOL1.ITYEVO   = 'REEL'
          MEVOL1.IEVOLL(1)= KEVOLL
          IRET=MEVOL1
          CALL ACTOBJ('EVOLUTIO',IRET,1)
          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
 
   30 CONTINUE
      CALL ACTOBJ(TYPRES,IRET,1)
      CALL ECROBJ(TYPRES,IRET)
 
   80 CONTINUE
      RETURN
 
      END
 
 

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