1 : C TEVOLU SOURCE MAUGIS 07/10/26 21:16:21 5856 2 : SUBROUTINE TEVOLU(IEVO,TI) 3 : C 4 : C ===================================================================== 5 : C 6 : C Options (PAS) AVANT et APRES à l'opération EXTR EVOL1 7 : C (aggiunta opzione ENTI per mots AVAN, APRE; arede 14.09.94)--- 8 : C 9 : C ===================================================================== 10 : C 11 : C CREATION : 14.09.94 12 : C PROGRAMMEUR : ? 13 : C Modification : PM 12/09/2007, 14 : C définition de la couleur et du type de l'évolution 15 : C extraite 16 : C 17 : C ===================================================================== 18 : IMPLICIT INTEGER(I-N) 19 : -INC CCOPTIO 20 : -INC SMEVOLL 21 : -INC SMLREEL 22 : CHARACTER*12 TI 23 : SEGMENT WEVOX(0) 24 : SEGMENT WEVOY(0) 25 : C 26 : PARAMETER (IOPZ=3) 27 : CHARACTER*4 MOPZ(IOPZ) 28 : DATA MOPZ /'PAS ','AVAN','APRE'/ 29 : 30 : MEVOL1=IEVO 31 : SEGACT MEVOL1 32 : DO IMOT=1,IOPZ 33 : IF(TI(1:4).EQ.MOPZ(IMOT)) GOTO (10,20,20),IMOT 34 : ENDDO 34 : CALL ERREUR(5) 35 : GOTO 900 36 : C 37 : C option 'PAS' 38 : * Extraction d'une valeur toutes les J 39 : * 40 : 10 CONTINUE 41 : * Lecture du pas 41 : CALL LIRENT(J,1,IRETOU) 42 : IF(IERR.NE.0) GOTO 900 43 : 44 : NW=0 45 : N =0 46 : SEGINI MEVOLL 47 : JMEVO=MEVOLL 48 : IEVTEX=MEVOL1.IEVTEX 49 : ITYEVO=MEVOL1.ITYEVO 50 : DO 11 KE=1,MEVOL1.IEVOLL(/1) 51 : SEGINI WEVOX,WEVOY 52 : KEVOL1=MEVOL1.IEVOLL(KE) 53 : SEGACT KEVOL1 54 : MLREE1=KEVOL1.IPROGX 55 : MLREE2=KEVOL1.IPROGY 56 : SEGACT MLREE1,MLREE2 57 : DO KN=1,MLREE1.PROG(/1),J 58 : WEVOX(**)=MLREE1.PROG(KN) 59 : WEVOY(**)=MLREE2.PROG(KN) 60 : ENDDO 61 : SEGDES MLREE1,MLREE2 62 : 63 : * création évolution résultat 64 : SEGINI KEVOLL 65 : IEVOLL(**)=KEVOLL 66 : TYPX='LISTREEL' 67 : TYPY='LISTREEL' 68 : NOMEVX=KEVOL1.NOMEVX 69 : NOMEVY=KEVOL1.NOMEVY 70 : KEVTEX=KEVOL1.KEVTEX 71 : NUMEVX=KEVOL1.NUMEVX 72 : LPROG=WEVOX(/1) 73 : JG=LPROG 74 : SEGINI MLREE1 75 : SEGINI MLREE2 76 : IPROGX=MLREE1 77 : IPROGY=MLREE2 78 : DO KN=1,LPROG 79 : MLREE1.PROG(KN)=WEVOX(KN) 80 : MLREE2.PROG(KN)=WEVOY(KN) 81 : ENDDO 82 : SEGSUP WEVOX,WEVOY 83 : SEGDES KEVOL1,KEVOLL 84 : 11 CONTINUE 85 : GOTO 777 86 : C 87 : C Options AVANT / APRES [ENTI] ['ZERO'] 88 : 20 CONTINUE 88 : CALL LIRMOT('ENTI',1,IENTI,0) 89 : IF(IENTI.NE.0) THEN 89 : CALL LIRENT(KKK,1,IRETOU) 90 : IF(IERR.NE.0) GOTO 900 91 : ELSE 91 : CALL LIRFLO(FLT,0,IRETOU) 92 : IF(IERR.NE.0) GOTO 900 93 : ENDIF 94 : NW =0 95 : N =0 96 : IZE=0 97 : SEGINI MEVOLL 98 : JMEVO=MEVOLL 99 : IEVTEX=MEVOL1.IEVTEX 100 : ITYEVO=MEVOL1.ITYEVO 101 : DO 21 KE=1,MEVOL1.IEVOLL(/1) 102 : SEGINI WEVOX,WEVOY 103 : KEVOL1=MEVOL1.IEVOLL(KE) 104 : SEGACT KEVOL1 105 : MLREE1=KEVOL1.IPROGX 106 : MLREE2=KEVOL1.IPROGY 107 : SEGACT MLREE1,MLREE2 108 : C 109 : IF(IENTI.EQ.0) THEN 110 : * comparaison de la valeur avec le seuil 111 : DO KN=1,MLREE1.PROG(/1) 112 : IF(TI(:4).EQ.'AVAN') THEN 113 : IF(FLT.GE.MLREE1.PROG(KN)) THEN 114 : WEVOX(**)=MLREE1.PROG(KN) 115 : WEVOY(**)=MLREE2.PROG(KN) 116 : ENDIF 117 : ELSEIF(TI(:4).EQ.'APRE') THEN 118 : IF(FLT.LE.MLREE1.PROG(KN)) THEN 119 : WEVOX(**)=MLREE1.PROG(KN) 120 : WEVOY(**)=MLREE2.PROG(KN) 121 : ENDIF 122 : ENDIF 123 : ENDDO 124 : ELSE 125 : * comparaison de l'indice avec le seuil 126 : DO KN=1,MLREE1.PROG(/1) 127 : IF(TI(:4).EQ.'AVAN') THEN 128 : IF(KKK.GE.KN) THEN 129 : WEVOX(**)=MLREE1.PROG(KN) 130 : WEVOY(**)=MLREE2.PROG(KN) 131 : ENDIF 132 : ELSEIF(TI(:4).EQ.'APRE') THEN 133 : IF(KKK.LE.KN) THEN 134 : WEVOX(**)=MLREE1.PROG(KN) 135 : WEVOY(**)=MLREE2.PROG(KN) 136 : ENDIF 137 : ENDIF 138 : ENDDO 139 : IF(TI(:4).EQ.'APRE') FLT=WEVOX(1) 140 : ENDIF 141 : SEGDES MLREE1,MLREE2 142 : 143 : C changement de l'origine des abscisses à zéro ? 144 : LPROG=WEVOX(/1) 145 : IF(IZE.EQ.0) THEN 145 : CALL LIRMOT('ZERO',1,IVAL,0) 146 : IF(IVAL.NE.0) THEN 147 : IF(IERR.NE.0) THEN 148 : * On ne comprend pas le mot %m1:4 148 : CALL ERREUR(7) 149 : SEGSUP WEVOX,WEVOY 150 : GOTO 900 151 : ENDIF 152 : IZE=1 153 : ENDIF 154 : ENDIF 155 : IF(IZE.EQ.0) FLT0=0.E0 156 : IF(IZE.EQ.1) FLT0=FLT 157 : 158 : * création évolution résultat 159 : SEGINI KEVOLL 160 : IEVOLL(**)=KEVOLL 161 : TYPX='LISTREEL' 162 : TYPY='LISTREEL' 163 : NOMEVX=KEVOL1.NOMEVX 164 : NOMEVY=KEVOL1.NOMEVY 165 : KEVTEX=KEVOL1.KEVTEX 166 : NUMEVX=KEVOL1.NUMEVX 167 : JG=LPROG 168 : SEGINI MLREE1 169 : SEGINI MLREE2 170 : IPROGX=MLREE1 171 : IPROGY=MLREE2 172 : DO KN=1,LPROG 173 : MLREE1.PROG(KN)=WEVOX(KN)-FLT0 174 : MLREE2.PROG(KN)=WEVOY(KN) 175 : ENDDO 176 : SEGSUP WEVOX,WEVOY 177 : SEGDES KEVOL1,KEVOLL 178 : 21 CONTINUE 179 : C 180 : 777 SEGDES MEVOLL 180 : CALL ECROBJ('EVOLUTIO',JMEVO) 181 : 182 : 900 CONTINUE 183 : SEGDES MEVOL1 184 : 185 : RETURN 186 : END 187 : 188 :
© Cast3M 2003 - All rights reserved.
Disclaimer