[69] | 1 | ;------------------------------------------------------------ |
---|
| 2 | ;------------------------------------------------------------ |
---|
| 3 | ;------------------------------------------------------------ |
---|
| 4 | ;+ |
---|
| 5 | ; |
---|
[101] | 6 | ; @file_comments |
---|
[69] | 7 | ; |
---|
| 8 | ; Given the arrays X and Y, which tabulate a function (with the X[i] |
---|
| 9 | ; AND Y[i] in ascending order), and given an input value X2, the |
---|
| 10 | ; SPL_INCR function returns an interpolated value for the given values |
---|
| 11 | ; of X2. The interpolation method is based on cubic spline, corrected |
---|
| 12 | ; in a way that interpolated values are also monotonically increasing. |
---|
| 13 | ; |
---|
[125] | 14 | ; @param x1 {in}{required} |
---|
| 15 | ; An n-element (at least 2) input vector that specifies the tabulate points in |
---|
[118] | 16 | ; a strict ascending order. |
---|
[69] | 17 | ; |
---|
[125] | 18 | ; @param y1 {in}{required} |
---|
[118] | 19 | ; f(x) = y. An n-element input vector that specifies the values |
---|
[69] | 20 | ; of the tabulated function F(Xi) corresponding to Xi. As f is |
---|
| 21 | ; supposed to be monotonically increasing, y values must be |
---|
| 22 | ; monotonically increasing. y can have equal consecutive values. |
---|
| 23 | ; |
---|
[125] | 24 | ; @param x2 {in}{required} |
---|
[118] | 25 | ; The input values for which the interpolated values are |
---|
[125] | 26 | ; desired. Its values must be strictly monotonically increasing. |
---|
[69] | 27 | ; |
---|
[118] | 28 | ; @param der2 |
---|
[125] | 29 | ; @param x |
---|
[69] | 30 | ; |
---|
[125] | 31 | ; @returns |
---|
[69] | 32 | ; |
---|
| 33 | ; y2: f(x2) = y2. Double precision array |
---|
| 34 | ; |
---|
[101] | 35 | ; @restrictions |
---|
[69] | 36 | ; It might be possible that y2[i+1]-y2[i] has very small negative |
---|
| 37 | ; values (amplitude smaller than 1.e-6)... |
---|
| 38 | ; |
---|
[125] | 39 | ; @examples |
---|
[69] | 40 | ; |
---|
[118] | 41 | ; IDL> n = 100L |
---|
[125] | 42 | ; IDL> x = (dindgen(n))^2 |
---|
[118] | 43 | ; IDL> y = abs(randomn(0, n)) |
---|
| 44 | ; IDL> y[n/2:n/2+1] = 0. |
---|
| 45 | ; IDL> y[n-n/3] = 0. |
---|
| 46 | ; IDL> y[n-n/6:n-n/6+5] = 0. |
---|
| 47 | ; IDL> y = total(y, /cumulative, /double) |
---|
| 48 | ; IDL> x2 = dindgen((n-1)^2) |
---|
| 49 | ; IDL> n2 = n_elements(x2) |
---|
| 50 | ; IDL> print, min(y[1:n-1]-y[0:n-2]) LT 0 |
---|
| 51 | ; IDL> y2 = spl_incr( x, y, x2) |
---|
| 52 | ; IDL> splot, x, y, xstyle = 1, ystyle = 1, ysurx=.25, petit = [1, 2, 1], /land |
---|
| 53 | ; IDL> oplot, x2, y2, color = 100 |
---|
| 54 | ; IDL> c = y2[1:n2-1] - y2[0:n2-2] |
---|
[125] | 55 | ; IDL> print, min(c) LT 0 |
---|
[118] | 56 | ; IDL> print, min(c, max = ma), ma |
---|
| 57 | ; IDL> splot,c,xstyle=1,ystyle=1, yrange=[-.01,.05], ysurx=.25, petit = [1, 2, 2], /noerase |
---|
| 58 | ; IDL> oplot,[0, n_elements(c)], [0, 0], linestyle = 1 |
---|
[69] | 59 | ; |
---|
[101] | 60 | ; @history |
---|
| 61 | ; Sebastien Masson (smasson\@lodyc.jussieu.fr): May-Dec 2005 |
---|
[118] | 62 | ; |
---|
| 63 | ; @version $Id$ |
---|
| 64 | ; |
---|
[69] | 65 | ;- |
---|
| 66 | ;------------------------------------------------------------ |
---|
| 67 | ;------------------------------------------------------------ |
---|
| 68 | ;------------------------------------------------------------ |
---|
| 69 | FUNCTION pure_concave, x1, x2, y1, y2, der2, x |
---|
| 70 | ; X^n type |
---|
[114] | 71 | ; |
---|
| 72 | compile_opt idl2, strictarrsubs |
---|
| 73 | ; |
---|
[69] | 74 | xx = (double(x)-double(x1))/(double(x2)-double(x1)) |
---|
| 75 | f = (double(x2)-double(x1))/(double(y2)-double(y1)) |
---|
| 76 | n = der2*temporary(f) |
---|
| 77 | res = xx^(n) |
---|
| 78 | ; IF check_math() GT 0 THEN BEGIN |
---|
| 79 | ; zero = where(abs(res) LT 1.e-10) |
---|
| 80 | ; IF zero[0] NE -1 THEN res[zero] = 0.0d |
---|
| 81 | ; END |
---|
| 82 | res = temporary(res)*(double(y2)-double(y1))+y1 |
---|
| 83 | ; |
---|
| 84 | ; IF array_equal(sort(res), lindgen(n_elements(res)) ) NE 1 THEN stop |
---|
| 85 | RETURN, res |
---|
| 86 | END |
---|
| 87 | |
---|
[118] | 88 | ;+ |
---|
[125] | 89 | ; @param x1 {in}{required} |
---|
| 90 | ; An n-element (at least 2) input vector that specifies the tabulate points in |
---|
[118] | 91 | ; a strict ascending order. |
---|
| 92 | ; |
---|
[125] | 93 | ; @param y1 {in}{required} |
---|
[118] | 94 | ; f(x) = y. An n-element input vector that specifies the values |
---|
| 95 | ; of the tabulated function F(Xi) corresponding to Xi. As f is |
---|
| 96 | ; supposed to be monotonically increasing, y values must be |
---|
| 97 | ; monotonically increasing. y can have equal consecutive values. |
---|
| 98 | ; |
---|
[125] | 99 | ; @param x2 {in}{required} |
---|
[118] | 100 | ; The input values for which the interpolated values are |
---|
[125] | 101 | ; desired. Its values must be strictly monotonically increasing. |
---|
[118] | 102 | ; |
---|
| 103 | ; @param der2 |
---|
[125] | 104 | ; @param x |
---|
[118] | 105 | ; |
---|
| 106 | ;- |
---|
[69] | 107 | FUNCTION pure_convex, x1, x2, y1, y2, der2, x |
---|
| 108 | ; 1-(1-X)^n type |
---|
[114] | 109 | ; |
---|
| 110 | compile_opt idl2, strictarrsubs |
---|
| 111 | ; |
---|
[69] | 112 | xx = 1.0d - (double(x)-double(x1))/(double(x2)-double(x1)) |
---|
| 113 | f = (double(x2)-double(x1))/(double(y2)-double(y1)) |
---|
| 114 | n = der2*temporary(f) |
---|
| 115 | res = xx^(n) |
---|
| 116 | ; IF check_math() GT 0 THEN BEGIN |
---|
| 117 | ; zero = where(abs(res) LT 1.e-10) |
---|
| 118 | ; IF zero[0] NE -1 THEN res[zero] = 0.0d |
---|
| 119 | ; END |
---|
| 120 | res = 1.0d - temporary(res) |
---|
| 121 | res = temporary(res)*(y2-y1)+y1 |
---|
| 122 | ; |
---|
| 123 | ; IF array_equal(sort(res), lindgen(n_elements(res)) ) NE 1 THEN stop |
---|
| 124 | RETURN, res |
---|
| 125 | END |
---|
| 126 | |
---|
[101] | 127 | ;+ |
---|
[118] | 128 | ; @param x |
---|
| 129 | ; @param y |
---|
| 130 | ; @param x2 |
---|
| 131 | ; @keyword YP0 The first derivative of the interpolating function at the |
---|
[101] | 132 | ; point X0. If YP0 is omitted, the second derivative at the |
---|
| 133 | ; boundary is set to zero, resulting in a "natural spline." |
---|
[118] | 134 | ; @keyword YPN_1 The first derivative of the interpolating function at the |
---|
[101] | 135 | ; point Xn-1. If YPN_1 is omitted, the second derivative at the |
---|
[125] | 136 | ; boundary is set to zero, resulting in a "natural spline." |
---|
[101] | 137 | ;- |
---|
[69] | 138 | FUNCTION spl_incr, x, y, x2, YP0 = yp0, YPN_1 = ypn_1 |
---|
| 139 | ; |
---|
[114] | 140 | compile_opt idl2, strictarrsubs |
---|
| 141 | ; |
---|
[69] | 142 | ;--------------------------------- |
---|
| 143 | ; check and initialisation ... |
---|
| 144 | ;--------------------------------- |
---|
[114] | 145 | ; |
---|
[69] | 146 | nx = n_elements(x) |
---|
| 147 | ny = n_elements(y) |
---|
| 148 | nx2 = n_elements(x2) |
---|
| 149 | ; x must have at least 2 elements |
---|
[125] | 150 | IF nx LT 2 THEN stop |
---|
[69] | 151 | ; y must have the same number of elements than x |
---|
| 152 | IF nx NE ny THEN stop |
---|
| 153 | ; x be monotonically increasing |
---|
[125] | 154 | IF min(x[1:nx-1]-x[0:nx-2]) LE 0 THEN stop |
---|
[69] | 155 | ; x2 be monotonically increasing |
---|
| 156 | IF N_ELEMENTS(X2) GE 2 THEN $ |
---|
[125] | 157 | IF min(x2[1:nx2-1]-x2[0:nx2-2]) LE 0 THEN stop |
---|
[69] | 158 | ; y be monotonically increasing |
---|
[125] | 159 | IF min(y[1:ny-1]-y[0:ny-2]) LT 0 THEN stop |
---|
[69] | 160 | ;--------------------------------- |
---|
| 161 | ; first check: check if two consecutive values are equal |
---|
| 162 | ;--------------------------------- |
---|
| 163 | bad = where(y[1:ny-1]-y[0:ny-2] EQ 0, cntbad) |
---|
| 164 | IF cntbad NE 0 THEN BEGIN |
---|
| 165 | ; define the results: y2 |
---|
| 166 | y2 = dblarr(nx2) |
---|
| 167 | ; define xinx2: see help of value_locate |
---|
| 168 | ; if xinx2[i] eq -1 : x[bad[i]] < x2[0] |
---|
| 169 | ; if xinx2[i] eq nx2-1: x[bad[i]] >= x2[nx2-1] |
---|
| 170 | ; else : x2[xinx2[i]] <= x[bad[i]] < x2[xinx2[i]+1] |
---|
| 171 | xinx2 = value_locate(x2, x[bad]) |
---|
| 172 | xinx2_1 = value_locate(x2, x[bad+1]) |
---|
| 173 | ; |
---|
[125] | 174 | ; left side ... if there is x2 values smaller that x[bad[0]]. |
---|
[69] | 175 | ; we force ypn_1 = 0.0d |
---|
| 176 | IF xinx2[0] NE -1 THEN BEGIN |
---|
| 177 | IF bad[0] EQ 0 THEN BEGIN |
---|
| 178 | IF xinx2[0] NE 0 THEN stop |
---|
| 179 | y2[0] = y[0] |
---|
[125] | 180 | ENDIF ELSE BEGIN |
---|
[69] | 181 | y2[0:xinx2[0]] $ |
---|
| 182 | = spl_incr(x[0:bad[0]], y[0:bad[0]], x2[0:xinx2[0]] $ |
---|
| 183 | , yp0 = yp0, ypn_1 = 0.0d) |
---|
[125] | 184 | ENDELSE |
---|
| 185 | ENDIF |
---|
[69] | 186 | ; flat section |
---|
| 187 | IF xinx2_1[0] NE -1 THEN $ |
---|
| 188 | y2[(xinx2[0]+1) < xinx2_1[0] : xinx2_1[0]] = y[bad[0]] |
---|
| 189 | ; middle pieces ... if cntbad gt 1 then we have to cut spl_incr in |
---|
| 190 | ; more than 2 pieces... |
---|
| 191 | IF cntbad GT 1 THEN BEGIN |
---|
| 192 | ; we take care of the piece located wetween bad[ib-1]+1 and bad[ib] |
---|
| 193 | FOR ib = 1, cntbad-1 DO BEGIN |
---|
| 194 | ; if there is x2 values smaller that x[bad[ib]], then the x2 values |
---|
| 195 | ; located between bad[ib-1]+1 and bad[ib] are (xinx2_1[ib-1]+1:xinx2[ib] |
---|
| 196 | ; and if we don't have two consecutive flat sections |
---|
| 197 | IF xinx2[ib] NE -1 AND (bad[ib-1] NE bad[ib]-1) THEN begin |
---|
| 198 | y2[(xinx2_1[ib-1]+1) < xinx2[ib]:xinx2[ib]] $ |
---|
| 199 | = spl_incr(x[bad[ib-1]+1:bad[ib]], y[bad[ib-1]+1:bad[ib]] $ |
---|
| 200 | , x2[(xinx2_1[ib-1]+1) < xinx2[ib]:xinx2[ib]] $ |
---|
| 201 | , yp0 = 0.0d, ypn_1 = 0.0d) |
---|
| 202 | ENDIF |
---|
| 203 | ; flat section |
---|
| 204 | IF xinx2_1[ib] NE -1 THEN $ |
---|
| 205 | y2[(xinx2[ib]+1) < xinx2_1[ib] : xinx2_1[ib]] = y[bad[ib]] |
---|
| 206 | ENDFOR |
---|
| 207 | ENDIF |
---|
[125] | 208 | ; right side ... if there is x2 values larger that x[bad[cntbad-1]+1]. |
---|
[69] | 209 | ; we force yp0 = 0.0d |
---|
| 210 | IF xinx2_1[cntbad-1] NE nx2-1 THEN $ |
---|
| 211 | y2[xinx2_1[cntbad-1]+1:nx2-1] $ |
---|
| 212 | = spl_incr(x[bad[cntbad-1]+1:nx-1], y[bad[cntbad-1]+1:nx-1] $ |
---|
| 213 | , x2[xinx2_1[cntbad-1]+1:nx2-1] $ |
---|
| 214 | , yp0 = 0.0d, ypn_1 = ypn_1new) |
---|
| 215 | |
---|
| 216 | RETURN, y2 |
---|
| 217 | |
---|
| 218 | ENDIF |
---|
| 219 | ;----------- |
---|
| 220 | ; compute the second derivative of the cubic spline on each x. |
---|
| 221 | ;----------- |
---|
| 222 | yscd = spl_init(x, y, yp0 = yp0, ypn_1 = ypn_1, /double) |
---|
| 223 | ;--------------------------------- |
---|
| 224 | ; second check: none of the first derivative on x values must be negative. |
---|
| 225 | ;--------------------------------- |
---|
| 226 | ; |
---|
| 227 | ; compute the first derivative on x |
---|
| 228 | ; |
---|
| 229 | yifrst = spl_fstdrv(x, y, yscd, x) |
---|
| 230 | ; |
---|
| 231 | ; we force the negative first derivative to 0 by calling again |
---|
| 232 | ; spl_incr with the keywords yp0 and ypn_1 to specify the |
---|
| 233 | ; first derivative equal to 0 |
---|
| 234 | ; |
---|
| 235 | bad = where(yifrst LT 0.0d, cntbad) |
---|
| 236 | IF cntbad NE 0 THEN BEGIN |
---|
| 237 | ; |
---|
| 238 | ; we define the new values of the keyword ypn_1: |
---|
[125] | 239 | ; if the first derivative of the last value of x is negative |
---|
[69] | 240 | ; we define the new values of the keyword ypn_1 to 0.0d0 |
---|
[125] | 241 | IF bad[cntbad-1] EQ nx-1 THEN BEGIN |
---|
[69] | 242 | ypn_1new = 0.0d |
---|
| 243 | ; we remove this case from the list |
---|
| 244 | IF cntbad GE 2 THEN bad = bad[0:cntbad-2] |
---|
| 245 | cntbad = cntbad-1 |
---|
| 246 | ; else we take the value of ypn_1 if it was already defined |
---|
| 247 | ENDIF ELSE IF n_elements(ypn_1) NE 0 THEN ypn_1new = ypn_1 |
---|
| 248 | ; |
---|
| 249 | ; we define the new values of the keyword yp0: |
---|
[125] | 250 | ; if the first derivative of the first value of x is negative |
---|
[69] | 251 | ; we define the new values of the keyword yp0 to 0.0 |
---|
| 252 | IF bad[0] EQ 0 THEN BEGIN |
---|
| 253 | yp0new = 0.0d |
---|
| 254 | ; we remove this case from the list |
---|
| 255 | IF cntbad GE 2 THEN bad = bad[1:cntbad-1] |
---|
| 256 | cntbad = cntbad-1 |
---|
| 257 | ; else we take the value of yp0 if it was already defined |
---|
| 258 | ENDIF ELSE IF n_elements(yp0) NE 0 THEN yp0new = yp0 |
---|
| 259 | ; |
---|
| 260 | ; if all the negative derivative corresponded to one of the cases above, |
---|
| 261 | ; then we can directly call spl_incr with the new yp0new and ypn_1new |
---|
| 262 | IF cntbad LE 0 THEN BEGIN |
---|
| 263 | y2 = spl_incr(x, y, x2, yp0 = yp0new, ypn_1 = ypn_1new) |
---|
| 264 | ; |
---|
| 265 | ; else: there is still cases with negative derivative ... |
---|
| 266 | ; we will cut spl_incr in n spl_incr and specify yp0, ypn_1 |
---|
[125] | 267 | ; for each of this n spl_incr |
---|
[69] | 268 | ENDIF ELSE BEGIN |
---|
| 269 | ; define xinx2: see help of value_locate |
---|
| 270 | ; if xinx2[i] eq -1 : x[bad[i]] < x2[0] |
---|
| 271 | ; if xinx2[i] eq nx2-1: x[bad[i]] >= x2[nx2-1] |
---|
| 272 | ; else : x2[xinx2[i]] <= x[bad[i]] < x2[xinx2[i]+1] |
---|
| 273 | xinx2 = value_locate(x2, x[bad]) |
---|
| 274 | y2 = dblarr(nx2) |
---|
[125] | 275 | ; left side ... if there is x2 values smaller that x[bad[0]]. |
---|
[69] | 276 | ; we force ypn_1 = 0.0d |
---|
| 277 | IF xinx2[0] NE -1 THEN $ |
---|
| 278 | y2[0:xinx2[0]] $ |
---|
| 279 | = spl_incr(x[0:bad[0]], y[0:bad[0]], x2[0:xinx2[0]] $ |
---|
| 280 | , yp0 = yp0new, ypn_1 = 0.0d) |
---|
| 281 | ; middle pieces ... if cntbad gt 1 then we have to cut spl_incr in |
---|
[125] | 282 | ; more than 2 pieces -> we have middle pieces for which |
---|
[69] | 283 | ; we force yp0 = 0.0d and ypn_1 = 0.0d |
---|
| 284 | IF cntbad GT 1 THEN BEGIN |
---|
| 285 | ; we take care of the piece located wetween bad[ib-1] and bad[ib] |
---|
| 286 | FOR ib = 1, cntbad-1 DO BEGIN |
---|
| 287 | ; if there is x2 values smaller that x[bad[ib]], then the x2 values |
---|
| 288 | ; located between bad[ib-1] and bad[ib] are (xinx2[ib-1]+1:xinx2[ib] |
---|
| 289 | IF xinx2[ib] NE -1 THEN begin |
---|
| 290 | y2[(xinx2[ib-1]+1) < xinx2[ib]:xinx2[ib]] $ |
---|
| 291 | = spl_incr(x[bad[ib-1]:bad[ib]], y[bad[ib-1]:bad[ib]] $ |
---|
| 292 | , x2[(xinx2[ib-1]+1) < xinx2[ib]:xinx2[ib]] $ |
---|
| 293 | , yp0 = 0.0d, ypn_1 = 0.0d) |
---|
| 294 | endif |
---|
| 295 | ENDFOR |
---|
| 296 | ENDIF |
---|
[125] | 297 | ; right side ... if there is x2 values larger that x[bad[cntbad-1]]. |
---|
[69] | 298 | ; we force yp0 = 0.0d |
---|
| 299 | IF xinx2[cntbad-1] NE nx2-1 THEN $ |
---|
| 300 | y2[xinx2[cntbad-1]+1:nx2-1] $ |
---|
| 301 | = spl_incr(x[bad[cntbad-1]:nx-1], y[bad[cntbad-1]:nx-1] $ |
---|
| 302 | , x2[xinx2[cntbad-1]+1:nx2-1] $ |
---|
| 303 | , yp0 = 0.0d, ypn_1 = ypn_1new) |
---|
[125] | 304 | ENDELSE |
---|
[69] | 305 | ; we return the checked and corrected value of yfrst |
---|
| 306 | ; FOR i = 0, nx-1 DO BEGIN |
---|
| 307 | ; same = where(abs(x2- x[i]) LT 1.e-10, cnt) |
---|
[125] | 308 | ; ; IF cnt NE 0 THEN y2[same] = y[i] |
---|
[69] | 309 | ; ENDFOR |
---|
| 310 | RETURN, y2 |
---|
| 311 | ENDIF |
---|
| 312 | ; |
---|
| 313 | ; we can be in this part of the code only if: |
---|
| 314 | ; (1) spl_incr is called by itself |
---|
[125] | 315 | ; (2) none are the first derivative in x are negative (because they have been |
---|
| 316 | ; checked and corrected by the previous call to spl_incr, see above) |
---|
[69] | 317 | ;--------------------------------- |
---|
| 318 | ; third check: we have to make sure that the first derivative cannot |
---|
| 319 | ; have negative values between on x[0] and x[nx-1] |
---|
| 320 | ;--------------------------------- |
---|
| 321 | ; |
---|
| 322 | ; first we compute the first derivative, next we correct the values |
---|
[125] | 323 | ; where we know that the first derivative can be negative. |
---|
[69] | 324 | ; |
---|
| 325 | y2 = spl_interp(x, y, yscd, x2, /double) |
---|
| 326 | ; |
---|
| 327 | ; between x[i] and x[i+1], the cubic spline is a cubic function: |
---|
| 328 | ; y = a*X^3 + b*X^2 + c*X + d |
---|
| 329 | ; y' = 3a*X^2 + 2b*X + c |
---|
| 330 | ; y''= 6a*X + 2b |
---|
| 331 | ; if we take X = x[i+1]-x[i] then |
---|
[125] | 332 | ; d = y[i]; c = y'[i]; b = 0.5 * y''[i], |
---|
[69] | 333 | ; a = 1/6 * (y''[i+1]-y''[i])/(x[i+1]-x[i]) |
---|
[125] | 334 | ; |
---|
[69] | 335 | ; y'[i] and y'[i+1] are positive so y' can be negative |
---|
[125] | 336 | ; between x[i] and x[i+1] only if |
---|
[69] | 337 | ; 1) a > 0 |
---|
| 338 | ; ==> y''[i+1] > y''[i] |
---|
[125] | 339 | ; 2) y' reach its minimum value between x[i] and x[i+1] |
---|
| 340 | ; -> 0 < - b/(3a) < x[i+1]-x[i] |
---|
[69] | 341 | ; ==> y''[i+1] > 0 > y''[i] |
---|
| 342 | ; |
---|
| 343 | ; we do a first selection by looking for those points... |
---|
| 344 | ; |
---|
| 345 | loc = lindgen(nx-1) |
---|
| 346 | maybebad = where(yscd[loc] LE 0.0d AND yscd[loc+1] GE 0.0d, cntbad) |
---|
| 347 | ; |
---|
| 348 | IF cntbad NE 0 THEN BEGIN |
---|
| 349 | |
---|
| 350 | mbbloc = loc[maybebad] |
---|
| 351 | |
---|
| 352 | aaa = (yscd[mbbloc+1]-yscd[mbbloc])/(6.0d*(x[mbbloc+1]-x[mbbloc])) |
---|
| 353 | bbb = 0.5d * yscd[mbbloc] |
---|
| 354 | ccc = yifrst[mbbloc] |
---|
| 355 | ddd = y[mbbloc] |
---|
| 356 | ; |
---|
| 357 | ; definitive selection: |
---|
| 358 | ; y' can become negative if and only if (2b)^2 - 4(3a)c > 0 |
---|
| 359 | ; y' can become negative if and only if b^2 - (3a)c > 0 |
---|
| 360 | ; |
---|
| 361 | delta = bbb*bbb - 3.0d*aaa*ccc |
---|
| 362 | ; |
---|
| 363 | bad = where(delta GT 0, cntbad) |
---|
| 364 | ; |
---|
| 365 | IF cntbad NE 0 THEN BEGIN |
---|
| 366 | delta = delta[bad] |
---|
| 367 | aaa = aaa[bad] |
---|
| 368 | bbb = bbb[bad] |
---|
| 369 | ccc = ccc[bad] |
---|
| 370 | ddd = ddd[bad] |
---|
| 371 | bad = maybebad[bad] |
---|
| 372 | ; define xinx2_1: see help of value_locate |
---|
| 373 | ; if xinx2_1[i] eq -1 : x[bad[i]] < x2[0] |
---|
| 374 | ; if xinx2_1[i] eq nx2-1: x[bad[i]] >= x2[nx2-1] |
---|
| 375 | ; else : x2[xinx2_1[i]] <= x[bad[i]] < x2[xinx2_1[i]+1] |
---|
| 376 | xinx2_1 = value_locate(x2, x[bad]) |
---|
| 377 | ; define xinx2_2: see help of value_locate |
---|
| 378 | ; if xinx2_2[i] eq -1 : x[bad[i]+1] < x2[0] |
---|
| 379 | ; if xinx2_2[i] eq nx2-1: x[bad[i]+1] >= x2[nx2-1] |
---|
| 380 | ; else : x2[xinx2_2[i]] <= x[bad[i]+1] < x2[xinx2_2[i]+1] |
---|
| 381 | xinx2_2 = value_locate(x2, x[bad+1]) |
---|
| 382 | ; to avoid the particular case when x2 = x[bad[i]] |
---|
| 383 | ; and there is no other x2 point until x[bad[i]+1] |
---|
| 384 | xinx2_1 = xinx2_1 < (xinx2_2-1) |
---|
| 385 | ; |
---|
| 386 | FOR ib = 0, cntbad-1 DO BEGIN |
---|
| 387 | ; |
---|
| 388 | ; at least one of the x2 points must be located between |
---|
| 389 | ; x[bad[ib]] and x[bad[ib]+1] |
---|
| 390 | IF x2[0] LE x[bad[ib]+1] AND x2[nx2-1] GE x[bad[ib]] THEN BEGIN |
---|
| 391 | ; |
---|
| 392 | CASE 1 OF |
---|
| 393 | yifrst[bad[ib]+1] EQ 0.0d:BEGIN |
---|
| 394 | ; case pur convex: we use the first derivative of 1-(1-x)^n |
---|
| 395 | ; and ajust n to get the good value: yifrst[bad[ib]] in x[bad[ib]] |
---|
| 396 | y2[xinx2_1[ib]+1:xinx2_2[ib]] $ |
---|
| 397 | = pure_convex(x[bad[ib]], x[bad[ib]+1] $ |
---|
| 398 | , y[bad[ib]], y[bad[ib]+1] $ |
---|
| 399 | , yifrst[bad[ib]] $ |
---|
| 400 | , x2[xinx2_1[ib]+1:xinx2_2[ib]]) |
---|
| 401 | END |
---|
| 402 | yifrst[bad[ib]] EQ 0.0d:BEGIN |
---|
| 403 | ; case pur concave: we use the first derivative of x^n |
---|
| 404 | ; and ajust n to get the good value: yifrst[bad[ib]+1] in x[bad[ib]+1] |
---|
| 405 | y2[xinx2_1[ib]+1:xinx2_2[ib]] $ |
---|
| 406 | = pure_concave(x[bad[ib]], x[bad[ib]+1] $ |
---|
| 407 | , y[bad[ib]], y[bad[ib]+1] $ |
---|
| 408 | , yifrst[bad[ib]+1] $ |
---|
| 409 | , x2[xinx2_1[ib]+1:xinx2_2[ib]]) |
---|
| 410 | END |
---|
| 411 | ELSE:BEGIN |
---|
| 412 | ; in those cases, the first derivative has 2 zero between |
---|
| 413 | ; x[bad[ib]] and x[bad[ib]+1]. We look for the minimum value of the |
---|
[125] | 414 | ; first derivative that correspond to the inflection point of y |
---|
[69] | 415 | xinfl = -bbb[ib]/(3.0d*aaa[ib]) |
---|
| 416 | ; we compute the y value for xinfl |
---|
| 417 | yinfl = aaa[ib]*xinfl*xinfl*xinfl + bbb[ib]*xinfl*xinfl $ |
---|
| 418 | + ccc[ib]*xinfl + ddd[ib] |
---|
[125] | 419 | ; |
---|
[69] | 420 | CASE 1 OF |
---|
| 421 | ; if y[xinfl] smaller than y[bad[ib]] then we conserve y2 until |
---|
| 422 | ; the first zero of y2 and from this point we use x^n and ajust n to |
---|
| 423 | ; get the good value: yifrst[bad[ib]+1] in x[bad[ib]+1] |
---|
| 424 | yinfl LT y[bad[ib]]:BEGIN |
---|
| 425 | ; value of the first zero (y'[xzero]=0) |
---|
| 426 | xzero = (-bbb[ib]-sqrt(delta[ib]))/(3.0d*aaa[ib]) |
---|
| 427 | ; value of y[xzero]... |
---|
| 428 | yzero = aaa[ib]*xzero*xzero*xzero + bbb[ib]*xzero*xzero $ |
---|
| 429 | + ccc[ib]*xzero + ddd[ib] |
---|
| 430 | ; if yzero > y[bad[ib]+1] then we cannot applay the method we want to |
---|
| 431 | ; apply => we use then convex-concave case by changing by hand the |
---|
| 432 | ; value of yinfl and xinfl |
---|
| 433 | IF yzero GT y[bad[ib]+1] THEN BEGIN |
---|
| 434 | yinfl = 0.5d*(y[bad[ib]+1]+y[bad[ib]]) |
---|
| 435 | xinfl = 0.5d*(x[bad[ib]+1]-x[bad[ib]]) |
---|
| 436 | GOTO, convexconcave |
---|
| 437 | ENDIF |
---|
| 438 | ; define xinx2_3: see help of value_locate |
---|
| 439 | ; if xinx2_3[ib] eq -1 : x[bad[ib]]+xzero < x2[0] |
---|
| 440 | ; if xinx2_3[ib] eq nx2-1: x[bad[ib]]+xzero >= x2[nx2-1] |
---|
| 441 | ; else : x2[xinx2_3] <= x[bad[ib]]+xzero < x2[xinx3_2+1] |
---|
| 442 | xinx2_3 = value_locate(x2, x[bad[ib]]+xzero) |
---|
| 443 | ; to avoid the particular case when x2 = x[bad[ib]]+xzero |
---|
| 444 | ; and there is no other x2 point until x[bad[ib]+1] |
---|
| 445 | xinx2_3 = xinx2_3 < (xinx2_2[ib]-1) |
---|
| 446 | IF xinx2_2[ib] GE xinx2_3+1 THEN BEGIN |
---|
| 447 | y2[xinx2_3+1:xinx2_2[ib]] $ |
---|
| 448 | = pure_concave(x[bad[ib]]+xzero, x[bad[ib]+1] $ |
---|
| 449 | , yzero, y[bad[ib]+1] $ |
---|
| 450 | , yifrst[bad[ib]+1] $ |
---|
| 451 | , x2[xinx2_3+1:xinx2_2[ib]]) |
---|
[125] | 452 | ENDIF |
---|
[69] | 453 | END |
---|
| 454 | ; if y[xinfl] bigger than y[bad[ib]+1] then we conserve y2 from |
---|
| 455 | ; the second zero of y2 and before this point we use 1-(1-x)^n and |
---|
| 456 | ; ajust n to get the good value: yifrst[bad[ib]] in x[bad[ib]] |
---|
| 457 | yinfl GT y[bad[ib]+1]:BEGIN |
---|
| 458 | ; value of the second zero (y'[xzero]=0) |
---|
| 459 | xzero = (-bbb[ib]+sqrt(delta[ib]))/(3.0d*aaa[ib]) |
---|
| 460 | ; value of y[xzero]... |
---|
| 461 | yzero = aaa[ib]*xzero*xzero*xzero + bbb[ib]*xzero*xzero $ |
---|
| 462 | + ccc[ib]*xzero + ddd[ib] |
---|
| 463 | ; if yzero < y[bad[ib]] then we cannot applay the method we want to |
---|
| 464 | ; apply => we use then convex-concave case by changing by hand the |
---|
| 465 | ; value of yinfl and xinfl |
---|
| 466 | IF yzero lt y[bad[ib]] THEN BEGIN |
---|
| 467 | yinfl = 0.5d*(y[bad[ib]+1]+y[bad[ib]]) |
---|
| 468 | xinfl = 0.5d*(x[bad[ib]+1]-x[bad[ib]]) |
---|
| 469 | GOTO, convexconcave |
---|
| 470 | ENDIF |
---|
| 471 | ; define xinx2_3: see help of value_locate |
---|
| 472 | ; if xinx2_3[ib] eq -1 : x[bad[ib]]+xzero < x2[0] |
---|
| 473 | ; if xinx2_3[ib] eq nx2-1: x[bad[ib]]+xzero >= x2[nx2-1] |
---|
| 474 | ; else : x2[xinx2_3] <= x[bad[ib]]+xzero < x2[xinx3_2+1] |
---|
| 475 | xinx2_3 = value_locate(x2, x[bad[ib]]+xzero) |
---|
| 476 | IF xinx2_3 ge xinx2_1[ib]+1 THEN BEGIN |
---|
| 477 | y2[xinx2_1[ib]+1:xinx2_3] $ |
---|
| 478 | = pure_convex(x[bad[ib]], x[bad[ib]]+xzero $ |
---|
| 479 | , y[bad[ib]], yzero $ |
---|
| 480 | , yifrst[bad[ib]] $ |
---|
| 481 | , x2[xinx2_1[ib]+1:xinx2_3]) |
---|
[125] | 482 | ENDIF |
---|
[69] | 483 | END |
---|
| 484 | ELSE:BEGIN |
---|
| 485 | convexconcave: |
---|
| 486 | ; define xinx2_3: see help of value_locate |
---|
| 487 | ; if xinx2_3[ib] eq -1 : x[bad[ib]]+xzero < x2[0] |
---|
| 488 | ; if xinx2_3[ib] eq nx2-1: x[bad[ib]]+xzero >= x2[nx2-1] |
---|
| 489 | ; else : x2[xinx2_3] <= x[bad[ib]]+xzero < x2[xinx3_2+1] |
---|
| 490 | xinx2_3 = value_locate(x2, x[bad[ib]]+xinfl) |
---|
| 491 | |
---|
| 492 | IF xinx2_3 ge xinx2_1[ib]+1 THEN BEGIN |
---|
| 493 | y2[xinx2_1[ib]+1:xinx2_3] $ |
---|
| 494 | = pure_convex(x[bad[ib]], x[bad[ib]]+xinfl $ |
---|
| 495 | , y[bad[ib]], yinfl $ |
---|
| 496 | , yifrst[bad[ib]] $ |
---|
| 497 | , x2[xinx2_1[ib]+1:xinx2_3]) |
---|
[125] | 498 | |
---|
| 499 | ENDIF |
---|
[69] | 500 | IF xinx2_2[ib] GE xinx2_3+1 THEN BEGIN |
---|
| 501 | y2[xinx2_3+1:xinx2_2[ib]] $ |
---|
| 502 | = pure_concave(x[bad[ib]]+xinfl, x[bad[ib]+1] $ |
---|
| 503 | , yinfl, y[bad[ib]+1] $ |
---|
| 504 | , yifrst[bad[ib]+1] $ |
---|
| 505 | , x2[xinx2_3+1:xinx2_2[ib]]) |
---|
[125] | 506 | ENDIF |
---|
[69] | 507 | END |
---|
| 508 | ENDCASE |
---|
| 509 | |
---|
[125] | 510 | END |
---|
[69] | 511 | ENDCASE |
---|
| 512 | ENDIF |
---|
| 513 | ENDFOR |
---|
| 514 | |
---|
| 515 | ENDIF |
---|
| 516 | ENDIF |
---|
| 517 | ; |
---|
| 518 | RETURN, y2 |
---|
| 519 | ; |
---|
| 520 | ;------------------------------------------------------------------ |
---|
| 521 | ;------------------------------------------------------------------ |
---|
| 522 | ; |
---|
| 523 | END |
---|