1 : C EVOLIN SOURCE CHAT 05/01/12 23:47:22 5004 2 : SUBROUTINE EVOLIN (IEV1,XX1,IEV2,XX2,IEV3) 3 : *____________________________________________________________________ 4 : * 5 : * Interpolation d'une courbe (type EVOLUTION) 6 : * en fouction de deux autres courbes (type EVOLUTION) 7 : * 8 : * ENTREES : 9 : * --------- 10 : * 11 : * IEV1 Pointeur sur un objet de type EVOLUTION 12 : * IEV2 Pointeur sur le deuxieme objet de type EVOLUTION 13 : * XX1 Flottant donnant le rapport entre la courbe 14 : * a calculer et la courbe designee par IEV2 15 : * XX2 Flottant donnant le rapport entre la courbe 16 : * a calculer et la courbe designee par IEV1. 17 : * Il existe la relation (XX1 + XX2)=1 18 : * 19 : * 20 : * SORTIE : 21 : * -------- 22 : * 23 : * IEV3 Pointeur sur l'objet EVOLUTION resultat 24 : * =0 si operation impossible 25 : * 26 : *____________________________________________________________________ 27 : * 28 : IMPLICIT INTEGER(I-N) 29 : IMPLICIT REAL*8(A-H,O-Z) 30 : -INC CCOPTIO 31 : -INC SMEVOLL 32 : -INC SMLREEL 33 : -INC SMLENTI 34 : POINTEUR MREX.MLREEL,MREY.MLREEL,MREY2.MLREEL 35 : MEVOL1=IEV1 36 : MEVOL2=IEV2 37 : IF(MEVOL1.EQ.0.OR.MEVOL2.EQ.0) THEN 38 : MOTERR(1:8)='EVOLUTIO' 38 : CALL ERREUR(37) 39 : IEV3=0 40 : RETURN 41 : ENDIF 42 : C 43 : C ACTIVATION DES EVOLUTIONS 44 : C 45 : SEGACT MEVOL1,MEVOL2 46 : N1=MEVOL1.IEVOLL(/1) 47 : N2=MEVOL2.IEVOLL(/1) 48 : C 49 : C ON TETSTE LES OBJETS EVOLUTION 50 : C 51 : IF(N1.NE.1) THEN 52 : MOTERR(1:8)='EVOLUTIO' 53 : INTERR(1)=MEVOL1 53 : CALL ERREUR(110) 54 : SEGDES MEVOL1,MEVOL2 55 : IEV3=0 56 : RETURN 57 : ENDIF 58 : IF(N2.NE.1) THEN 59 : MOTERR(1:8)='EVOLUTIO' 60 : INTERR(1)=MEVOL2 60 : CALL ERREUR(110) 61 : SEGDES MEVOL1,MEVOL2 62 : IEV3=0 63 : RETURN 64 : ENDIF 65 : IF(MEVOL1.ITYEVO.NE.'REEL '.OR. 66 : $ MEVOL2.ITYEVO.NE.'REEL ') THEN 67 : MOTERR(1:8)='EVOLUTIO' 68 : MOTERR(9:16)='REEL ' 68 : CALL ERREUR(79) 69 : SEGDES MEVOL1,MEVOL2 70 : IEV3=0 71 : RETURN 72 : ENDIF 73 : KEVOL1=MEVOL1.IEVOLL(1) 74 : KEVOL2=MEVOL2.IEVOLL(1) 75 : SEGACT KEVOL1,KEVOL2 76 : IF(KEVOL1.TYPX.NE.'LISTREEL'.OR.KEVOL1.TYPY.NE.'LISTREEL')THEN 77 : MOTERR(1:8)='EVOLUTIO' 78 : MOTERR(9:16)='LISTREEL' 79 : INTERR(1)=MEVOL1 79 : CALL ERREUR(630) 80 : SEGDES MEVOL1,MEVOL2,KEVOL1,KEVOL2 81 : IEV3=0 82 : RETURN 83 : ENDIF 84 : IF(KEVOL2.TYPX.NE.'LISTREEL'.OR.KEVOL2.TYPY.NE.'LISTREEL')THEN 85 : MOTERR(1:8)='EVOLUTIO' 86 : MOTERR(9:16)='LISTREEL' 87 : INTERR(1)=MEVOL2 87 : CALL ERREUR(630) 88 : SEGDES MEVOL1,MEVOL2,KEVOL1,KEVOL2 89 : IEV3=0 90 : RETURN 91 : ENDIF 92 : IF(KEVOL1.NOMEVX.NE.KEVOL2.NOMEVX) THEN 93 : MOTERR(1:9)='abscisses' 94 : MOTERR(10:17)='EVOLUTIO' 95 : INTERR(1)=MEVOL1 96 : INTERR(2)=MEVOL2 96 : CALL ERREUR(631) 97 : SEGDES MEVOL1,MEVOL2,KEVOL1,KEVOL2 98 : IEV3=0 99 : RETURN 100 : ENDIF 101 : IF(KEVOL1.NOMEVY.NE.KEVOL2.NOMEVY) THEN 102 : MOTERR(1:9)='ordonnees' 103 : MOTERR(10:17)='EVOLUTIO' 104 : INTERR(1)=MEVOL1 105 : INTERR(2)=MEVOL2 105 : CALL ERREUR(631) 106 : SEGDES MEVOL1,MEVOL2,KEVOL1,KEVOL2 107 : IEV3=0 108 : RETURN 109 : ENDIF 110 : C 111 : C ON ACTIVE LES 4 LISTREEL DE DEUX COURBES 112 : C 113 : SEGDES MEVOL1,MEVOL2 114 : MLREEL=KEVOL1.IPROGX 115 : MLREE1=KEVOL1.IPROGY 116 : MLREE2=KEVOL2.IPROGX 117 : MLREE3=KEVOL2.IPROGY 118 : SEGDES KEVOL1,KEVOL2 119 : SEGACT MLREEL,MLREE1,MLREE2,MLREE3 120 : JG=PROG(/1)+MLREE2.PROG(/1) 121 : C 122 : C ON DETERNIME LA VARIATION EN X DE DEUX COURBES 123 : C 124 : XMIN=1.E32 125 : XMAX=-1.E32 126 : DO 1 I=1,PROG(/1) 127 : IF(PROG(I).LT.XMIN) XMIN=PROG(I) 128 : IF(PROG(I).GT.XMAX) XMAX=PROG(I) 129 : 1 CONTINUE 130 : DO 2 I=1,MLREE2.PROG(/1) 131 : IF(MLREE2.PROG(I).LT.XMIN) XMIN=MLREE2.PROG(I) 132 : IF(MLREE2.PROG(I).GT.XMAX) XMAX=MLREE2.PROG(I) 133 : 2 CONTINUE 134 : C 135 : C ON CALCULE LA PRECISION 136 : C 137 : XPRE=(XMAX-XMIN)/1.D12 138 : SEGINI MREX 139 : IJ=0 140 : I1=1 141 : I2=1 142 : 3 CONTINUE 143 : IF(PROG(I1).LE.MLREE2.PROG(I2)) THEN 144 : IJ=IJ+1 145 : MREX.PROG(IJ)=PROG(I1) 146 : I1=I1+1 147 : IF(MLREE2.PROG(I2)-XPRE.LT.MREX.PROG(IJ)) I2=I2+1 148 : ELSE 149 : IJ=IJ+1 150 : MREX.PROG(IJ)=MLREE2.PROG(I2) 151 : I2=I2+1 152 : IF(PROG(I1)-XPRE.LT.MREX.PROG(IJ)) I1=I1+1 153 : ENDIF 154 : IF(I1.LE.PROG(/1).AND.I2.LE.MLREE2.PROG(/1)) GO TO 3 155 : IF(I1.GT.PROG(/1)) THEN 156 : IF(I2.GT.MLREE2.PROG(/1)) GOTO 6 157 : DO 4 I=I2,MLREE2.PROG(/1) 158 : IJ=IJ+1 159 : MREX.PROG(IJ)=MLREE2.PROG(I) 160 : 4 CONTINUE 161 : ELSE 162 : DO 5 I=I1,PROG(/1) 163 : IJ=IJ+1 164 : MREX.PROG(IJ)=PROG(I) 165 : 5 CONTINUE 166 : ENDIF 167 : 6 CONTINUE 168 : JG=IJ 169 : SEGADJ MREX 170 : SEGINI MREY,MLENTI,MREY2 171 : JDEB=1 172 : DO 7 I=1,PROG(/1) 173 : DO 8 J=JDEB,MREX.PROG(/1) 174 : XX=MREX.PROG(J) 175 : IF(XX.GT.PROG(I)-XPRE.AND.XX.LT.PROG(I)+XPRE) THEN 176 : LECT(J)=1 177 : MREY.PROG(J)=MLREE1.PROG(I)*XX1 178 : JDEB=J 179 : GO TO 7 180 : ENDIF 181 : 8 CONTINUE 182 : 7 CONTINUE 183 : DO 9 J=1,MREX.PROG(/1) 184 : IF(LECT(J).EQ.1) GO TO 10 185 : MREY.PROG(J)=MLREE1.PROG(1)*XX1 186 : LECT(J)=1 187 : 9 CONTINUE 188 : 10 CONTINUE 189 : DO 11 J=MREX.PROG(/1),1,-1 190 : IF(LECT(J).EQ.1) GO TO 12 191 : MREY.PROG(J)=MLREE1.PROG(MLREE1.PROG(/1))*XX1 192 : LECT(J)=1 193 : 11 CONTINUE 194 : 12 CONTINUE 195 : DO 13 J=1,MREX.PROG(/1) 196 : IF(LECT(J).EQ.1) GO TO 13 197 : DO 14 K=J+1,MREX.PROG(/1) 198 : J1=K 199 : IF(LECT(K).EQ.1) GO TO 15 200 : 14 CONTINUE 201 : 15 CONTINUE 202 : MREY.PROG(J)=MREY.PROG(J-1)+((MREY.PROG(J1)-MREY.PROG(J-1))* 203 : $(MREX.PROG(J)-MREX.PROG(J-1))/(MREX.PROG(J1)-MREX.PROG(J-1))) 204 : 13 CONTINUE 205 : DO 16 I=1,LECT(/1) 206 : LECT(I)=0 207 : 16 CONTINUE 208 : SEGDES MLREEL,MLREE1 209 : SEGDES MLREE2,MLREE3 210 : MLREEL=MLREE2 211 : MLREE1=MLREE3 212 : SEGACT MLREEL,MLREE1 213 : JDEB=1 214 : DO 17 I=1,PROG(/1) 215 : DO 18 J=JDEB,MREX.PROG(/1) 216 : XX=MREX.PROG(J) 217 : IF(XX.GT.PROG(I)-XPRE.AND.XX.LT.PROG(I)+XPRE) THEN 218 : LECT(J)=1 219 : MREY2.PROG(J)=MLREE1.PROG(I)*XX2 220 : JDEB=J 221 : GO TO 17 222 : ENDIF 223 : 18 CONTINUE 224 : 17 CONTINUE 225 : DO 19 J=1,MREX.PROG(/1) 226 : IF(LECT(J).EQ.1) GO TO 20 227 : MREY2.PROG(J)=MLREE1.PROG(1)*XX2 228 : LECT(J)=1 229 : 19 CONTINUE 230 : 20 CONTINUE 231 : DO 21 J=MREX.PROG(/1),1,-1 232 : IF(LECT(J).EQ.1) GO TO 22 233 : MREY2.PROG(J)=MLREE1.PROG(MLREE1.PROG(/1))*XX2 234 : LECT(J)=1 235 : 21 CONTINUE 236 : 22 CONTINUE 237 : DO 23 J=1,MREX.PROG(/1) 238 : IF(LECT(J).EQ.1) GO TO 23 239 : DO 24 K=J+1,MREX.PROG(/1) 240 : J1=K 241 : IF(LECT(K).EQ.1) GO TO 25 242 : 24 CONTINUE 243 : 25 CONTINUE 244 : MREY2.PROG(J)=MREY2.PROG(J-1)+((MREY2.PROG(J1)-MREY2.PROG(J-1))* 245 : $ (MREX.PROG(J)-MREX.PROG(J-1))/(MREX.PROG(J1)-MREX.PROG(J-1))) 246 : 23 CONTINUE 247 : DO 26 I=1,LECT(/1) 248 : MREY.PROG(I)=MREY.PROG(I)+MREY2.PROG(I) 249 : 26 CONTINUE 250 : SEGDES MLREEL,MLREE1,MREY,MREX 251 : SEGSUP MLENTI,MREY2 252 : SEGINI,MEVOLL=MEVOL1 253 : SEGINI,KEVOLL=KEVOL1 254 : IEVOLL(1)=KEVOLL 255 : NUMEVX=2 256 : IPROGX=MREX 257 : IPROGY=MREY 258 : SEGDES MEVOLL,KEVOLL 259 : IEV3=MEVOLL 260 : RETURN 261 : END 262 : 263 :
© Cast3M 2003 - All rights reserved.
Disclaimer