1 : C EVCOMP SOURCE CHAT 05/01/12 23:46:49 5004
2 : SUBROUTINE EVCOMP(ICOUL)
3 : C=======================================================================
4 : C OPTION COMP DE L'OPERATEUR EVOL
5 : C
6 : C POUR RENTRER UN OBJET DE TYPE EVOLUTION DE SOUS TYPE COMPLEXE
7 : C SYNTAXE :
8 : C
9 : C EV1= EVOL (COUL) COMP /(REIM)/ /('CHAINE CARAC')/ PRGX
10 : C ---- ---- /(MOPH)/
11 : C /('CHAINE CARAC')/ PRGY1 ;
12 : C
13 : C /('CHAINE CARAC')/ PRGY2 ;
14 : C
15 : C
16 : C COUL : COULEUR DE LA COURBE (FACULTATIVE)
17 : C
18 : C PRGX : LISTE DE REELS (ABSCISSES)
19 : C
20 : C PRGY1 : LISTE DE REELS (PARTIE REELLE OU MODULE)
21 : C
22 : C PRGY2 : LISTE DE REELS (PARTIE IMAGINAIRE OU PHASE)
23 : C
24 : C CREATION : 04/12/87
25 : C F. ROULLIER
26 : C======================================================================
27 : IMPLICIT INTEGER(I-N)
28 : -INC CCOPTIO
29 : -INC SMEVOLL
30 : -INC SMLREEL
31 : C
32 : CHARACTER *72 TI
33 : CHARACTER*12 MOTITR
34 : CHARACTER*8 ITBLAN
35 : CHARACTER*4 MOTCMP(2,2),MOTOPT(2)
36 : DATA MOTCMP/'MODU','PHAS','PREE','PIMA'/
37 : DATA MOTOPT/'MOPH','REIM'/
38 : LOPT=2
39 : C
39 : CALL LIRMOT (MOTOPT,LOPT,IOPT,0)
40 : IF (IOPT.EQ.0) IOPT=2
41 : N=2
42 : SEGINI MEVOLL
43 : IPVO=MEVOLL
44 : TI(1:72)=TITREE
45 : IEVTEX=TI
46 : ITYEVO='COMPLEXE'
47 : C
48 : SEGINI KEVOL1,KEVOL2
49 : IEVOLL(1)=KEVOL1
50 : IEVOLL(2)=KEVOL2
51 : KEVOL1.NUMEVX=ICOUL
52 : KEVOL2.NUMEVX=ICOUL
53 : KEVOL1.KEVTEX=TI
54 : KEVOL2.KEVTEX=TI
55 : KEVOL1.TYPX='LISTREEL'
56 : KEVOL1.TYPY='LISTREEL'
57 : KEVOL2.TYPX='LISTREEL'
58 : KEVOL2.TYPY='LISTREEL'
59 : C
60 : DO 110 K=1,2
61 : DO 20 J=1,K
62 : C *** TITRE SOUS FORME DE CHAINE DE CARACTERES
63 : MOTITR=' '
63 : CALL LIRCHA(MOTITR,0,IRETOU)
64 : IF(IRETOU.EQ.0) GOTO 12
65 : IF (K.EQ.1) THEN
66 : KEVOL1.NOMEVX=MOTITR
67 : KEVOL2.NOMEVX=MOTITR
68 : ELSE
69 : IF(J.EQ.1) KEVOL1.NOMEVY=MOTITR
70 : IF(J.EQ.2) KEVOL2.NOMEVY=MOTITR
71 : ENDIF
72 : C *** LECTURE DE LISTREEL
73 : 12 CONTINUE
73 : CALL LIROBJ('LISTREEL',IMOT,1,IRET)
74 : IF(IERR.NE.0) RETURN
75 : IF (K.EQ.1) THEN
76 : C ABSCISSES DES 2 COURBES
77 : KEVOL1.IPROGX=IMOT
78 : KEVOL2.IPROGX=IMOT
79 : MLREEL=IMOT
80 : SEGACT MLREEL
81 : LX = MLREEL.PROG(/1)
82 : SEGDES MLREEL
83 : ELSE
84 : IF (J.EQ.1) THEN
85 : C PREMIERE COURBE
86 : KEVOL1.IPROGY=IMOT
87 : KEVOL1.NUMEVY=MOTCMP(1,IOPT)
88 : MLREEL=IMOT
89 : SEGACT MLREEL
90 : LY1 = MLREEL.PROG(/1)
91 : SEGDES MLREEL
92 : ELSE
93 : C DEUXIEME COURBE
94 : KEVOL2.IPROGY=IMOT
95 : KEVOL2.NUMEVY=MOTCMP(2,IOPT)
96 : MLREEL=IMOT
97 : SEGACT MLREEL
98 : LY2 = MLREEL.PROG(/1)
99 : SEGDES MLREEL
100 : ENDIF
101 : ENDIF
102 : 20 CONTINUE
103 : 110 CONTINUE
104 : SEGDES KEVOL1,KEVOL2
105 : C
106 : IF((LX.NE.LY1).OR.(LY1.NE.LY2)) THEN
106 : CALL ERREUR(263)
107 : C LES 3 PROGRESSIONS DOIVENT ETRE DE MEME LONGUEUR
108 : GO TO 1000
109 : ENDIF
110 : C
111 : SEGDES MEVOLL
111 : CALL ECROBJ('EVOLUTIO',IPVO)
112 : RETURN
113 : 1000 CONTINUE
114 : RETURN
115 : END
116 :
© Cast3M 2003 - All rights reserved.
Disclaimer