Sources Esope | Cast3M

evmanu
C EVMANU    SOURCE    SP204843  25/06/05    21:15:05     12270          
      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 CCGEOME
-INC SMEVOLL
-INC SMLREEL
-INC SMLMOTS
-INC SMLENTI
C
      PARAMETER (NBOPT=4)
C
      CHARACTER*72 TI,MTIT1
      CHARACTER*12 MOTITR
      CHARACTER*8 ITBLAN,TYPi
      CHARACTER*4 MTYP,LMOT(1)
      CHARACTER*4 MOOPT1(NBOPT)
      DIMENSION MOT(2)
C
      DATA LMOT/'TYPE'/
      DATA MOOPT1/'LEGE','STYL','MARQ','TAIL'/
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)
C OU DES SPECIFICATIONS DE TRACE DES COURBES :
      MTIT1=' '
      ITIT1=0
c Style, marque et taille par defaut (voir SMEVOLL.INC)
      LSTYL1 = 1
      MMARQ1 = 0
      KTAIL1 = 3
 1    CONTINUE
      IOPT1=0
      CALL LIRMOT(MOOPT1,4,IOPT1,0)
      IF (IOPT1.EQ.1) THEN
        CALL LIRCHA(MTIT1,1,IRETOU)
        IF(IERR.NE.0) RETURN
        ITIT1=1
        GOTO 1 
      ELSEIF (IOPT1.EQ.2) THEN
        CALL LIRENT(ISTYL1,0,IRETOU)
        IF (IRETOU.EQ.1) THEN
          ISTYL1 = MAX(ISTYL1,0)
          ISTYL1 = MOD(ISTYL1,NBSTY)
          IF (ISTYL1.EQ.0) ISTYL1 = NBSTY
          LSTYL1 = ISTYL1
        ELSE
          CALL LIRMOT(MOSTYL,NBSTY,LSTYL1,1)
          IF(IERR.NE.0) RETURN
        ENDIF
        GOTO 1 
      ELSEIF (IOPT1.EQ.3) THEN
        CALL LIRENT(IMARQ1,0,IRETOU)
        IF (IRETOU.EQ.1) THEN
          IMARQ1 = MAX(IMARQ1,0)
          IMARQ1 = MOD(IMARQ1,NBMAR)
          IF (IMARQ1.EQ.0) IMARQ1 = NBMAR
          MMARQ1 = IMARQ1
        ELSE
          CALL LIRMOT(MOMARQ,NBMAR,MMARQ1,1)
          IF(IERR.NE.0) RETURN
        ENDIF
        GOTO 1 
      ELSEIF (IOPT1.EQ.4) THEN
        CALL LIRENT(ITAIL1,0,IRETOU)
        IF (IRETOU.EQ.1) THEN
          ITAIL1 = MAX(ITAIL1,1)
          ITAIL1 = MOD(ITAIL1-1,NBTAI)+1
          KTAIL1 = ITAIL1
        ELSE
          CALL LIRMOT(MOTAIL,NBTAI,KTAIL1,1)
          IF(IERR.NE.0) RETURN
        ENDIF
        IF (KTAIL1.EQ.0) KTAIL1 = 3
        GOTO 1 
      ENDIF
C     write(6,*) 'evmanu:MTIT1,LSTYL1,MMARQ1,KTAIL1',
C    &            MTIT1,LSTYL1,MMARQ1,KTAIL1
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
      LSTYL = LSTYL1
      MMARQ = MMARQ1
      KTAIL = KTAIL1
      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