Sources Esope | Cast3M

evmanu
C EVMANU    SOURCE    CB215821  22/05/12    15:08:13     11362          
      SUBROUTINE EVMANU(ICOUL)
C=======================================================================
C   OPTION MANU DE L'OPERATEUR EVOL
C
C   POUR RENTRER A LA MAIN UN OBJET DE TYPE EVOLUTION
C   (IL N Y AURA QU UNE SEULE  EVOLUTION)
C   SYNTAXE :
C
C   EV1= EVOL (COUL) MANU  ('TYPE' MTYP)  ('LEGE' MTIT1)
C             ('CHAINE CARAC') PRGX   ('CHAINE CARAC') PRGY  ;
C
C
C   COUL   : COULEUR DE LA COURBE (FACULTATIVE)
C   MOTXI  : OBJET DE TYPE MOT
C   PRGX   : LISTE DE REELS (ABSCISSES)
C   MOTYI  : OBJET DE TYPE MOT
C   PRGY   : LISTE DE REELS (ORDONNEES)
C
C   CREATION : 01/10/86, GUILBAUD
C   MODIFS   : 2015-05-07 BP, ajout du titre de la LEGEnde
C
C======================================================================
      IMPLICIT INTEGER(I-N)
 
-INC PPARAM
-INC CCOPTIO
-INC SMEVOLL
-INC SMLREEL
-INC SMLMOTS
-INC SMLENTI
C
      CHARACTER*72 TI,MTIT1
      CHARACTER*12 MOTITR
      CHARACTER*8 ITBLAN,TYPi
      CHARACTER*4 MTYP,LMOT(1)
      CHARACTER*4 MOTIT1(1)
      DIMENSION MOT(2)
C
      DATA LMOT/'TYPE'/
      DATA MOTIT1/'LEGE'/
C
C  CREATION DE LA SOUS-EVOLUTION
      SEGINI KEVOLL
      NOMEVX=' '
      NOMEVY=' '
      TYPX='LISTREEL'
      TYPY='LISTREEL'
C
C LECTURE OPTIONNELLE DU TYPE DE LA COURBE
C (NUMEVY = MTYP = {REEL, MODU, PHAS, PREE, PIMA ...} ) :
      IPLAC=0
      IMOT=0
      CALL LIRMOT(LMOT,1,IPLAC,0)
      IF (IPLAC.EQ.1) THEN
        CALL LIRCHA(MTYP,1,IMOT)
        IF (IMOT.EQ.0) RETURN
      ENDIF
 
C  LECTURE OPTIONNELLE DU TITRE DE LA SOUS EVOLUTION DE LA COURBE (LEGE) :
      MTIT1=' '
      ITIT1=0
      CALL LIRMOT(MOTIT1,1,ITIT1,0)
      IF(ITIT1.EQ.1) THEN
         CALL LIRCHA(MTIT1,1,IRETOU)
         IF(IERR.NE.0) RETURN
      ENDIF
C
C  LECTURE DES TITRES ET LISTREELS DE L'ABSCISSE + ORDONNEE
      DO 20 J=1,2
 
C   *** TITRE ABSCISSES / ORDONNEES  SOUS FORME DE MOT
        MOTITR=' '
        CALL LIRCHA(MOTITR,0,IRETOU)
        IF(IRETOU.EQ.0) GOTO 12
        IF(J.EQ.1) NOMEVX=MOTITR
        IF(J.EQ.2) NOMEVY=MOTITR
 
C   *** LECTURE DE LA LISTREEL (ou autre...)
  12    CONTINUE
        CALL QUETYP (TYPi,1,IRETOU)
        IF (IRETOU .EQ. 0 .OR. (.NOT. (    Typi .EQ. 'LISTREEL'
     &                                .OR. Typi .EQ. 'LISTMOTS'
     &                                .OR. Typi .EQ. 'LISTENTI'))) THEN
          MOTERR(1 :8 ) = 'LISTREEL'
          MOTERR(9 :16) = 'LISTMOTS'
          MOTERR(17:24) = 'LISTENTI'
          CALL ERREUR(471)
          GOTO 1000
        ENDIF
 
        CALL LIROBJ(Typi,MOT(J),0,IRET)
        IF( J.EQ.1) TYPX=Typi
        IF( J.EQ.2) TYPY=Typi
  20  CONTINUE
C
      IF    (TYPX.EQ.'LISTREEL') THEN
        MLREEL=MOT(1)
        SEGACT MLREEL
        LX = PROG(/1)
      ELSEIF(TYPX.EQ.'LISTMOTS') THEN
        MLMOTS=MOT(1)
        SEGACT MLMOTS
        LX= MOTS(/2)
      ELSEIF(TYPX.EQ.'LISTENTI') THEN
        MLENTI=MOT(1)
        SEGACT MLENTI
        LX=LECT(/1)
      ENDIF
 
      IF    (TYPY.EQ.'LISTREEL') THEN
        MLREEL=MOT(2)
        SEGACT MLREEL
        LY = PROG(/1)
        IF (IPLAC .EQ. 0) MTYP  ='REEL'
      ELSEIF(TYPY.EQ.'LISTMOTS') THEN
        MLMOTS=MOT(2)
        SEGACT MLMOTS
        LY= MOTS(/2)
        IF (IPLAC .EQ. 0) MTYP  ='MOTS'
      ELSEIF(TYPY.EQ.'LISTENTI') THEN
        MLENTI=MOT(2)
        SEGACT MLENTI
        LY=LECT(/1)
        IF (IPLAC .EQ. 0) MTYP  ='ENTI'
      ENDIF
 
      IF(LX.NE.LY) THEN
          CALL ERREUR(263)
C     LES 2 PROGRESSIONS DOIVENT ETRE DE MEME LONGUEUR
          GOTO 1000
      ENDIF
 
C  CREATION DE L'EVOLUTION AVEC 1 SEULE SOUS EVOLUTION
      N=1
      SEGINI MEVOLL
      IPVO=MEVOLL
      TI(1:72)=TITREE
      IEVTEX=TI
      ITYEVO='REEL'
c       KEVTEX=TI
      IF(ITIT1.EQ.0) MTIT1=NOMEVY
      KEVTEX=MTIT1
      IEVOLL(1)=KEVOLL
      IPROGX=MOT(1)
      IPROGY=MOT(2)
      NUMEVX=ICOUL
      NUMEVY=MTYP
      CALL ACTOBJ('EVOLUTIO',IPVO,1)
      CALL ECROBJ('EVOLUTIO',IPVO)
      RETURN
 
 1000 CONTINUE
      SEGSUP KEVOLL
      RETURN
      END