1 : C ADEVOR SOURCE PASCAL 09/02/16 21:15:00 6282 2 : SUBROUTINE ADEVOR(IPO1,IPO2,IRET,IPM) 3 : C 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8(A-H,O-Z) 6 : C 7 : C =================================================================== 8 : C = OPERATEUR : = 9 : C = SOMME (OU DIFFERENCE) DE DEUX OBJETS DE TYPE EVOLUTION = = 10 : C = - X1 ET X2 VARIENT DE FACON STRICTEMENT CROISSANTE = 11 : C = - Y1 ET Y2 SONT DE MEME NATURE = 12 : C = APPELE PAR ADEVOL = 13 : C = = 14 : C = REECRITURE DE L'ADDITION D'OBJETS EVOLUTION DE SOUS-TYPE REELS = = 15 : C = MODIFICATION AOUT 97 ELOI = 16 : C =================================================================== 17 : -INC SMEVOLL 18 : -INC SMLREEL 19 : POINTEUR MLRE1X.MLREEL,MLRE1Y.MLREEL 20 : POINTEUR MLRE2X.MLREEL,MLRE2Y.MLREEL 21 : POINTEUR MLREEX.MLREEL,MLREEY.MLREEL 22 : -INC CCOPTIO 23 : SEGMENT ILIS1(NL1) 24 : SEGMENT ILIS2(NL2) 25 : SEGMENT ITAB1(NP) 26 : SEGMENT ITAB2(NP) 27 : C 28 : PARAMETER (NCR=2,NOA=3) 29 : CHARACTER*72 TI 30 : CHARACTER*4 COMREEL(NCR),OKADI(NOA) 31 : COMREEL(1)='REEL' 32 : COMREEL(2)='HIST' 33 : OKADI(1)='REEL' 34 : OKADI(2)='HIST' 35 : OKADI(3)='MARQ' 36 : C 37 : IRET=0 38 : C 39 : MEVOL1=IPO1 40 : SEGACT MEVOL1 41 : MEVOL2=IPO2 42 : SEGACT MEVOL2 43 : C 44 : C ON TRAITE LE CAS DES OBJETS EVOLUTION DE SOUS-TYPE "REEL" 45 : C 46 : C LES DIFFERENTES COURBES DOIVENT ETRE DE SOIT DE TYPE "REEL", 47 : C SOIT DE TYPE "MARQ", 48 : C SOIT DE TYPE "HIST" 49 : C 50 : N1=MEVOL1.IEVOLL(/1) 51 : NL1=N1 52 : N2=MEVOL2.IEVOLL(/1) 53 : NL2=N2 54 : SEGINI,ILIS1 55 : SEGINI,ILIS2 56 : NRES10=0 57 : NRES20=0 58 : NDIF12=0 59 : C 60 : C ILIS1 : INDICES DES COURBES DE TYPE "REEL" OU "HIST" DE LA 1ERE EVOL 61 : C 62 : DO I0=1,NCR 63 : NRES1=0 64 : DO 1 I1=1,N1 65 : KEVOL1=MEVOL1.IEVOLL(I1) 66 : SEGACT KEVOL1 66 : CALL PLACE(OKADI,3,IPLAC,KEVOL1.NUMEVY) 67 : IF (IPLAC.EQ.0) THEN 68 : SEGDES KEVOL1 69 : SEGDES MEVOL1,MEVOL2 70 : SEGSUP ILIS1 70 : CALL ERREUR(871) 71 : RETURN 72 : ENDIF 73 : IF (KEVOL1.NUMEVY.EQ.COMREEL(I0)) THEN 74 : NRES1=NRES1+1 75 : NRES10=NRES10+1 76 : ILIS1(NRES10)=I1 77 : ENDIF 78 : SEGDES KEVOL1 79 : 1 CONTINUE 80 : C 81 : C ILIS2 : INDICES DES COURBES DE TYPE "REEL" OU "HIST" DE LA 2ND EVOL 82 : C 83 : NRES2=0 84 : DO 2 I2=1,N2 85 : KEVOL2=MEVOL2.IEVOLL(I2) 86 : SEGACT KEVOL2 86 : CALL PLACE(OKADI,3,IPLAC,KEVOL2.NUMEVY) 87 : IF (IPLAC.EQ.0) THEN 88 : SEGDES KEVOL2 89 : SEGDES MEVOL1,MEVOL2 90 : SEGSUP ILIS2 90 : CALL ERREUR(871) 91 : RETURN 92 : ENDIF 93 : IF (KEVOL2.NUMEVY.EQ.COMREEL(I0)) THEN 94 : NRES2=NRES2+1 95 : NRES20=NRES20+1 96 : ILIS2(NRES20)=I2 97 : ENDIF 98 : SEGDES KEVOL2 99 : 2 CONTINUE 100 : IF (NRES1.NE.NRES2) THEN 101 : NDIF12=1 102 : ENDIF 103 : ENDDO 104 : NL1=NRES10 105 : NL2=NRES20 106 : SEGADJ,ILIS1,ILIS2 107 : C 108 : C LES DEUX EVOLUTIONS DOIVENT AVOIR LE MEME NOMBRE DE COURBES DE TYPE 109 : C "REEL" OU "HIST" 110 : C 111 : IF (NDIF12.NE.0) THEN 112 : SEGDES MEVOL1,MEVOL2 113 : SEGSUP ILIS1,ILIS2 114 : IF (NRES10.EQ.NRES20) THEN 114 : CALL ERREUR(871) 115 : ELSE 115 : CALL ERREUR(870) 116 : ENDIF 117 : RETURN 118 : ENDIF 119 : C 120 : C LES DIFFERENTES ABSCISSES DOIVENT ETRE DES PROGRESSIONS STRICTEMENT 121 : C CROISSANTES 122 : C 123 : DO 3 I1=1,N1 124 : KEVOL1=MEVOL1.IEVOLL(I1) 125 : SEGACT KEVOL1 126 : MLREEL=KEVOL1.IPROGX 127 : SEGACT MLREEL 128 : NJG=PROG(/1) 129 : IF (NJG.GT.1) THEN 130 : VAL1=PROG(1) 131 : DO 4 IJG=2,NJG 132 : VAL2=PROG(IJG) 133 : IF (VAL2.LE.VAL1) THEN 134 : SEGDES MLREEL 135 : SEGDES KEVOL1 136 : SEGDES MEVOL1,MEVOL2 137 : SEGSUP ILIS1,ILIS2 137 : CALL ERREUR(872) 138 : RETURN 139 : ENDIF 140 : VAL1=VAL2 141 : 4 CONTINUE 142 : ENDIF 143 : SEGDES MLREEL 144 : SEGDES KEVOL1 145 : 3 CONTINUE 146 : C 147 : DO 5 I2=1,N2 148 : KEVOL2=MEVOL2.IEVOLL(I2) 149 : SEGACT KEVOL2 150 : MLREEL=KEVOL2.IPROGX 151 : SEGACT MLREEL 152 : NJG=PROG(/1) 153 : IF (NJG.GT.1) THEN 154 : VAL1=PROG(1) 155 : DO 6 IJG=2,NJG 156 : VAL2=PROG(IJG) 157 : IF (VAL2.LE.VAL1) THEN 158 : SEGDES MLREEL 159 : SEGDES KEVOL2 160 : SEGDES MEVOL1,MEVOL2 161 : SEGSUP ILIS1,ILIS2 161 : CALL ERREUR(872) 162 : RETURN 163 : ENDIF 164 : VAL1=VAL2 165 : 6 CONTINUE 166 : ENDIF 167 : SEGDES MLREEL 168 : SEGDES KEVOL2 169 : 5 CONTINUE 170 : C DD 171 : EPS=1.D-12 172 : C 173 : N=NRES10 174 : SEGINI MEVOLL 175 : C 176 : DO 7 IN=1,NRES10 177 : IL1=ILIS1(IN) 178 : KEVOL1=MEVOL1.IEVOLL(IL1) 179 : SEGACT KEVOL1 180 : MLRE1X=KEVOL1.IPROGX 181 : SEGACT MLRE1X 182 : NJG1=MLRE1X.PROG(/1) 183 : IL2=ILIS2(IN) 184 : KEVOL2=MEVOL2.IEVOLL(IL2) 185 : SEGACT KEVOL2 186 : MLRE2X=KEVOL2.IPROGX 187 : SEGACT MLRE2X 188 : NJG2=MLRE2X.PROG(/1) 189 : NP=MAX(NJG1,NJG2) 190 : SEGINI ITAB1 191 : SEGINI ITAB2 192 : IDEP=1 193 : NP3=0 194 : DO 8 IJG1=1,NJG1 195 : VAL1=MLRE1X.PROG(IJG1) 196 : DO 9 IJG2=IDEP,NJG2 197 : VAL2=MLRE2X.PROG(IJG2) 198 : IF ((ABS(VAL2 - VAL1)).LT.EPS) THEN 199 : NP3=NP3+1 200 : ITAB1(NP3)=IJG1 201 : ITAB2(NP3)=IJG2 202 : IDEP=IJG2 203 : GOTO 10 204 : ENDIF 205 : 9 CONTINUE 206 : 10 CONTINUE 207 : 8 CONTINUE 208 : IF (NP3.EQ.0) THEN 209 : SEGDES MLRE1X 210 : SEGDES MLRE2X 211 : SEGDES KEVOL1 212 : SEGDES KEVOL2 213 : SEGDES MEVOL1,MEVOL2 214 : SEGSUP ITAB1,ITAB2 215 : SEGSUP ILIS1,ILIS2 216 : IF (IN.GT.1) THEN 217 : DO 11 IIN=1,IN-1 218 : KEVOLL=IEVOLL(IIN) 219 : MLREEX=IPROGX 220 : SEGSUP MLREEX 221 : MLREEY=IPROGY 222 : SEGSUP MLREEY 223 : SEGSUP KEVOLL 224 : 11 CONTINUE 225 : ENDIF 226 : SEGSUP MEVOLL 226 : CALL ERREUR(310) 227 : RETURN 228 : ELSE 229 : NP=NP3 230 : SEGADJ ITAB1 231 : SEGADJ ITAB2 232 : JG=NP 233 : SEGINI MLREEX 234 : SEGINI MLREEY 235 : DO 12 IP=1,NP 236 : MLREEX.PROG(IP)=MLRE1X.PROG(ITAB1(IP)) 237 : 12 CONTINUE 238 : C 239 : C IPM VAUT 1 DANS LE CAS DE L'ADDITION 240 : C IPM VAUT -1 DANS LE CAS DE LA SOUSTRACTION 241 : C 242 : MLRE1Y=KEVOL1.IPROGY 243 : SEGACT MLRE1Y 244 : MLRE2Y=KEVOL2.IPROGY 245 : SEGACT MLRE2Y 246 : IF (IPM.EQ.1) THEN 247 : DO 13 IP=1,NP 248 : MLREEY.PROG(IP)= 249 : # MLRE1Y.PROG(ITAB1(IP)) + MLRE2Y.PROG(ITAB2(IP)) 250 : 13 CONTINUE 251 : ELSEIF (IPM.EQ.-1) THEN 252 : DO 14 IP=1,NP 253 : MLREEY.PROG(IP)= 254 : # MLRE1Y.PROG(ITAB1(IP)) - MLRE2Y.PROG(ITAB2(IP)) 255 : 14 CONTINUE 256 : ENDIF 257 : SEGINI KEVOLL 258 : IPROGX=MLREEX 259 : IPROGY=MLREEY 260 : NUMEVX=KEVOL1.NUMEVX 261 : NUMEVY=KEVOL1.NUMEVY 262 : TYPX=KEVOL1.TYPX 263 : TYPY=KEVOL1.TYPY 264 : NOMEVX=KEVOL1.NOMEVX 265 : NOMEVY=KEVOL1.NOMEVY 266 : KEVTEX=KEVOL1.KEVTEX 267 : IEVOLL(IN)=KEVOLL 268 : SEGDES MLREEX 269 : SEGDES MLREEY 270 : SEGDES KEVOLL 271 : SEGDES MLRE1X 272 : SEGDES MLRE1Y 273 : SEGDES MLRE2X 274 : SEGDES MLRE2Y 275 : SEGDES KEVOL2 276 : ENDIF 277 : SEGDES KEVOL1 278 : SEGSUP ITAB1,ITAB2 279 : 7 CONTINUE 280 : SEGSUP ILIS1,ILIS2 281 : TI(1:72)=TITREE 282 : IEVTEX=TI 283 : ITYEVO=MEVOL1.ITYEVO 284 : IRET=MEVOLL 285 : SEGDES MEVOLL 286 : SEGDES MEVOL1 287 : SEGDES MEVOL2 288 : C 289 : RETURN 290 : END 291 : 292 : 293 : 294 :
© Cast3M 2003 - All rights reserved.
Disclaimer