OpenCPN Partial API docs
Loading...
Searching...
No Matches
georef.cpp
1/******************************************************************************
2 *
3 * Project: OpenCPN
4 * Purpose: OpenCPN Georef utility
5 * Author: David Register
6 *
7 ***************************************************************************
8 * Copyright (C) 2010 by David S. Register *
9 * *
10 * This program is free software; you can redistribute it and/or modify *
11 * it under the terms of the GNU General Public License as published by *
12 * the Free Software Foundation; either version 2 of the License, or *
13 * (at your option) any later version. *
14 * *
15 * This program is distributed in the hope that it will be useful, *
16 * but WITHOUT ANY WARRANTY; without even the implied warranty of *
17 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
18 * GNU General Public License for more details. *
19 * *
20 * You should have received a copy of the GNU General Public License *
21 * along with this program; if not, write to the *
22 * Free Software Foundation, Inc., *
23 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *
24 ***************************************************************************
25
26 ***************************************************************************
27 * Parts of this file were adapted from source code found in *
28 * John F. Waers (jfwaers@csn.net) public domain program MacGPS45 *
29 ***************************************************************************
30 */
31#include <vector>
32#include <utility>
33#include <stdlib.h>
34#include <string.h>
35#include <ctype.h>
36#include <math.h>
37
38#include <wx/debug.h>
39
40#include "georef.h"
41#include "cutil.h"
42
43#ifdef __MSVC__
44#define snprintf mysnprintf
45#endif
46
47#if !defined(NAN)
48static const long long lNaN = 0xfff8000000000000;
49#define NAN (*(double *)&lNaN)
50#endif
51
52// ellipsoid: index into the gEllipsoid[] array, in which
53// a is the ellipsoid semimajor axis
54// invf is the inverse of the ellipsoid flattening f
55// dx, dy, dz: ellipsoid center with respect to WGS84 ellipsoid center
56// x axis is the prime meridian
57// y axis is 90 degrees east longitude
58// z axis is the axis of rotation of the ellipsoid
59
60// The following values for dx, dy and dz were extracted from the output of
61// the GARMIN PCX5 program. The output also includes values for da and df, the
62// difference between the reference ellipsoid and the WGS84 ellipsoid semi-
63// major axis and flattening, respectively. These are replaced by the
64// data contained in the structure array gEllipsoid[], which was obtained from
65// the Defence Mapping Agency document number TR8350.2, "Department of Defense
66// World Geodetic System 1984."
67
68struct DATUM const gDatum[] = {
69 // name ellipsoid dx dy dz
70 {"Adindan", 5, -162, -12, 206}, // 0
71 {"Afgooye", 15, -43, -163, 45}, // 1
72 {"Ain el Abd 1970", 14, -150, -251, -2}, // 2
73 {"Anna 1 Astro 1965", 2, -491, -22, 435}, // 3
74 {"Arc 1950", 5, -143, -90, -294}, // 4
75 {"Arc 1960", 5, -160, -8, -300}, // 5
76 {"Ascension Island 58", 14, -207, 107, 52}, // 6
77 {"Astro B4 Sorol Atoll", 14, 114, -116, -333}, // 7
78 {"Astro Beacon E ", 14, 145, 75, -272}, // 8
79 {"Astro DOS 71/4", 14, -320, 550, -494}, // 9
80 {"Astronomic Stn 52", 14, 124, -234, -25}, // 10
81 {"Australian Geod 66", 2, -133, -48, 148}, // 11
82 {"Australian Geod 84", 2, -134, -48, 149}, // 12
83 {"Bellevue (IGN)", 14, -127, -769, 472}, // 13
84 {"Bermuda 1957", 4, -73, 213, 296}, // 14
85 {"Bogota Observatory", 14, 307, 304, -318}, // 15
86 {"Campo Inchauspe", 14, -148, 136, 90}, // 16
87 {"Canton Astro 1966", 14, 298, -304, -375}, // 17
88 {"Cape", 5, -136, -108, -292}, // 18
89 {"Cape Canaveral", 4, -2, 150, 181}, // 19
90 {"Carthage", 5, -263, 6, 431}, // 20
91 {"CH-1903", 3, 674, 15, 405}, // 21
92 {"Chatham 1971", 14, 175, -38, 113}, // 22
93 {"Chua Astro", 14, -134, 229, -29}, // 23
94 {"Corrego Alegre", 14, -206, 172, -6}, // 24
95 {"Djakarta (Batavia)", 3, -377, 681, -50}, // 25
96 {"DOS 1968", 14, 230, -199, -752}, // 26
97 {"Easter Island 1967", 14, 211, 147, 111}, // 27
98 {"European 1950", 14, -87, -98, -121}, // 28
99 {"European 1979", 14, -86, -98, -119}, // 29
100 {"Finland Hayford", 14, -78, -231, -97}, // 30
101 {"Gandajika Base", 14, -133, -321, 50}, // 31
102 {"Geodetic Datum 49", 14, 84, -22, 209}, // 32
103 {"Guam 1963", 4, -100, -248, 259}, // 33
104 {"GUX 1 Astro", 14, 252, -209, -751}, // 34
105 {"Hermannskogel Datum", 3, 682, -203, 480}, // 35
106 {"Hjorsey 1955", 14, -73, 46, -86}, // 36
107 {"Hong Kong 1963", 14, -156, -271, -189}, // 37
108 {"Indian Bangladesh", 6, 289, 734, 257}, // 38
109 {"Indian Thailand", 6, 214, 836, 303}, // 39
110 {"Ireland 1965", 1, 506, -122, 611}, // 40
111 {"ISTS 073 Astro 69", 14, 208, -435, -229}, // 41
112 {"Johnston Island", 14, 191, -77, -204}, // 42
113 {"Kandawala", 6, -97, 787, 86}, // 43
114 {"Kerguelen Island", 14, 145, -187, 103}, // 44
115 {"Kertau 1948", 7, -11, 851, 5}, // 45
116 {"L.C. 5 Astro", 4, 42, 124, 147}, // 46
117 {"Liberia 1964", 5, -90, 40, 88}, // 47
118 {"Luzon Mindanao", 4, -133, -79, -72}, // 48
119 {"Luzon Philippines", 4, -133, -77, -51}, // 49
120 {"Mahe 1971", 5, 41, -220, -134}, // 50
121 {"Marco Astro", 14, -289, -124, 60}, // 51
122 {"Massawa", 3, 639, 405, 60}, // 52
123 {"Merchich", 5, 31, 146, 47}, // 53
124 {"Midway Astro 1961", 14, 912, -58, 1227}, // 54
125 {"Minna", 5, -92, -93, 122}, // 55
126 {"NAD27 Alaska", 4, -5, 135, 172}, // 56
127 {"NAD27 Bahamas", 4, -4, 154, 178}, // 57
128 {"NAD27 Canada", 4, -10, 158, 187}, // 58
129 {"NAD27 Canal Zone", 4, 0, 125, 201}, // 59
130 {"NAD27 Caribbean", 4, -7, 152, 178}, // 60
131 {"NAD27 Central", 4, 0, 125, 194}, // 61
132 {"NAD27 CONUS", 4, -8, 160, 176}, // 62
133 {"NAD27 Cuba", 4, -9, 152, 178}, // 63
134 {"NAD27 Greenland", 4, 11, 114, 195}, // 64
135 {"NAD27 Mexico", 4, -12, 130, 190}, // 65
136 {"NAD27 San Salvador", 4, 1, 140, 165}, // 66
137 {"NAD83", 11, 0, 0, 0}, // 67
138 {"Nahrwn Masirah Ilnd", 5, -247, -148, 369}, // 68
139 {"Nahrwn Saudi Arbia", 5, -231, -196, 482}, // 69
140 {"Nahrwn United Arab", 5, -249, -156, 381}, // 70
141 {"Naparima BWI", 14, -2, 374, 172}, // 71
142 {"Observatorio 1966", 14, -425, -169, 81}, // 72
143 {"Old Egyptian", 12, -130, 110, -13}, // 73
144 {"Old Hawaiian", 4, 61, -285, -181}, // 74
145 {"Oman", 5, -346, -1, 224}, // 75
146 {"Ord Srvy Grt Britn", 0, 375, -111, 431}, // 76
147 {"Pico De Las Nieves", 14, -307, -92, 127}, // 77
148 {"Pitcairn Astro 1967", 14, 185, 165, 42}, // 78
149 {"Prov So Amrican 56", 14, -288, 175, -376}, // 79
150 {"Prov So Chilean 63", 14, 16, 196, 93}, // 80
151 {"Puerto Rico", 4, 11, 72, -101}, // 81
152 {"Qatar National", 14, -128, -283, 22}, // 82
153 {"Qornoq", 14, 164, 138, -189}, // 83
154 {"Reunion", 14, 94, -948, -1262}, // 84
155 {"Rome 1940", 14, -225, -65, 9}, // 85
156 {"RT 90", 3, 498, -36, 568}, // 86
157 {"Santo (DOS)", 14, 170, 42, 84}, // 87
158 {"Sao Braz", 14, -203, 141, 53}, // 88
159 {"Sapper Hill 1943", 14, -355, 16, 74}, // 89
160 {"Schwarzeck", 21, 616, 97, -251}, // 90
161 {"South American 69", 16, -57, 1, -41}, // 91
162 {"South Asia", 8, 7, -10, -26}, // 92
163 {"Southeast Base", 14, -499, -249, 314}, // 93
164 {"Southwest Base", 14, -104, 167, -38}, // 94
165 {"Timbalai 1948", 6, -689, 691, -46}, // 95
166 {"Tokyo", 3, -128, 481, 664}, // 96
167 {"Tristan Astro 1968", 14, -632, 438, -609}, // 97
168 {"Viti Levu 1916", 5, 51, 391, -36}, // 98
169 {"Wake-Eniwetok 60", 13, 101, 52, -39}, // 99
170 {"WGS 72", 19, 0, 0, 5}, // 100
171 {"WGS 84", 20, 0, 0, 0}, // 101
172 {"Zanderij", 14, -265, 120, -358}, // 102
173 {"WGS_84", 20, 0, 0, 0}, // 103
174 {"WGS-84", 20, 0, 0, 0}, // 104
175 {"EUROPEAN DATUM 1950", 14, -87, -98, -121},
176 {"European 1950 (Norway Finland)", 14, -87, -98, -121},
177 {"ED50", 14, -87, -98, -121},
178 {"RT90 (Sweden)", 3, 498, -36, 568},
179 {"Monte Mario 1940", 14, -104, -49, 10},
180 {"Ord Surv of Gr Britain 1936", 0, 375, -111, 431},
181 {"South American 1969", 16, -57, 1, -41},
182 {"PULKOVO 1942 (2)", 15, 25, -141, -79},
183 {"EUROPEAN DATUM", 14, -87, -98, -121},
184 {"BERMUDA DATUM 1957", 4, -73, 213, 296},
185 {"COA", 14, -206, 172, -6},
186 {"COABR", 14, -206, 172, -6},
187 {"Roma 1940", 14, -225, -65, 9},
188 {"ITALIENISCHES LANDESNETZ", 14, -87, -98, -121},
189 {"HERMANSKOGEL DATUM", 3, 682, -203, 480},
190 {"AGD66", 2, -128, -52, 153},
191 {"ED", 14, -87, -98, -121},
192 {"EUROPEAN 1950 (SPAIN AND PORTUGAL)", 14, -87, -98, -121},
193 {"ED-50", 14, -87, -98, -121},
194 {"EUROPEAN", 14, -87, -98, -121},
195 {"POTSDAM", 14, -87, -98, -121},
196 {"GRACIOSA SW BASE DATUM", 14, -104, 167, -38},
197 {"WGS 1984", 20, 0, 0, 0},
198 {"WGS 1972", 19, 0, 0, 5},
199 {"WGS", 19, 0, 0, 5}
200
201};
202struct ELLIPSOID const gEllipsoid[] = {
203 // name a 1/f
204 {"Airy 1830", 6377563.396, 299.3249646}, // 0
205 {"Modified Airy", 6377340.189, 299.3249646}, // 1
206 {"Australian National", 6378160.0, 298.25}, // 2
207 {"Bessel 1841", 6377397.155, 299.1528128}, // 3
208 {"Clarke 1866", 6378206.4, 294.9786982}, // 4
209 {"Clarke 1880", 6378249.145, 293.465}, // 5
210 {"Everest (India 1830)", 6377276.345, 300.8017}, // 6
211 {"Everest (1948)", 6377304.063, 300.8017}, // 7
212 {"Modified Fischer 1960", 6378155.0, 298.3}, // 8
213 {"Everest (Pakistan)", 6377309.613, 300.8017}, // 9
214 {"Indonesian 1974", 6378160.0, 298.247}, // 10
215 {"GRS 80", 6378137.0, 298.257222101}, // 11
216 {"Helmert 1906", 6378200.0, 298.3}, // 12
217 {"Hough 1960", 6378270.0, 297.0}, // 13
218 {"International 1924", 6378388.0, 297.0}, // 14
219 {"Krassovsky 1940", 6378245.0, 298.3}, // 15
220 {"South American 1969", 6378160.0, 298.25}, // 16
221 {"Everest (Malaysia 1969)", 6377295.664, 300.8017}, // 17
222 {"Everest (Sabah Sarawak)", 6377298.556, 300.8017}, // 18
223 {"WGS 72", 6378135.0, 298.26}, // 19
224 {"WGS 84", 6378137.0, 298.257223563}, // 20
225 {"Bessel 1841 (Namibia)", 6377483.865, 299.1528128}, // 21
226 {"Everest (India 1956)", 6377301.243, 300.8017}, // 22
227 {"Struve 1860", 6378298.3, 294.73} // 23
228
229};
230
231short nDatums = sizeof(gDatum) / sizeof(struct DATUM);
232
233/* define constants */
234
235void datumParams(short datum, double *a, double *es) {
236 extern struct DATUM const gDatum[];
237 extern struct ELLIPSOID const gEllipsoid[];
238
239 if (datum < nDatums) {
240 double f = 1.0 / gEllipsoid[gDatum[datum].ellipsoid].invf; // flattening
241 if (es) *es = 2 * f - f * f; // eccentricity^2
242 if (a) *a = gEllipsoid[gDatum[datum].ellipsoid].a; // semimajor axis
243 } else {
244 double f = 1.0 / 298.257223563; // WGS84
245 if (es) *es = 2 * f - f * f;
246 if (a) *a = 6378137.0;
247 }
248}
249
250static int datumNameCmp(const char *n1, const char *n2) {
251 while (*n1 || *n2) {
252 if (*n1 == ' ')
253 n1++;
254 else if (*n2 == ' ')
255 n2++;
256 else if (toupper(*n1) == toupper(*n2))
257 n1++, n2++;
258 else
259 return 1; // No string match
260 }
261 return 0; // String match
262}
263static int isWGS84(int i) {
264 // DATUM_INDEX_WGS84 is an optimization
265 // but there's more than on in gDatum table
266 if (i == DATUM_INDEX_WGS84) return i;
267
268 if (gDatum[i].ellipsoid != gDatum[DATUM_INDEX_WGS84].ellipsoid) return i;
269
270 if (gDatum[i].dx != gDatum[DATUM_INDEX_WGS84].dx) return i;
271
272 if (gDatum[i].dy != gDatum[DATUM_INDEX_WGS84].dy) return i;
273
274 if (gDatum[i].dz != gDatum[DATUM_INDEX_WGS84].dz) return i;
275
276 return DATUM_INDEX_WGS84;
277
278}
279
280int GetDatumIndex(const char *str) {
281 int i = 0;
282 while (i < (int)nDatums) {
283 if (!datumNameCmp(str, gDatum[i].name)) {
284 return isWGS84(i);
285 }
286 i++;
287 }
288
289 return -1;
290}
291/****************************************************************************/
292/* Convert degrees to dd mm'ss.s" (DMS-Format) */
293/****************************************************************************/
294void toDMS(double a, char *bufp, int bufplen) {
295 bool neg = a < 0.0;
296 a = fabs(a);
297 int n = (int)((a - (int)a) * 36000.0);
298 int m = n / 600;
299 int s = n % 600;
300 sprintf(bufp, "%d%02d'%02d.%01d\"", (int)(neg ? -a : a), m, s / 10, s % 10);
301}
302
303/****************************************************************************/
304/* Convert dd mm'ss.s" (DMS-Format) to degrees. */
305/****************************************************************************/
306
307double fromDMS(char *dms) {
308 int d = 0, m = 0;
309 double s = 0.0;
310 char buf[20] = {'\0'};
311
312 sscanf(dms, "%d%[ ]%d%[ ']%lf%[ \"NSWEnswe]", &d, buf, &m, buf, &s, buf);
313
314 s = (double)(abs(d)) + ((double)m + s / 60.0) / 60.0;
315
316 if (d >= 0 && strpbrk(buf, "SWsw") == NULL) return s;
317
318 return -s;
319}
320
321/****************************************************************************/
322/* Convert degrees to dd mm.mmm' (DMM-Format) */
323/****************************************************************************/
324
325void todmm(int flag, double a, char *bufp, int bufplen) {
326 bool bNeg = a < 0.0;
327 a = fabs(a);
328
329 int m = (int)((a - (int)a) * 60000.0);
330
331 if (!flag)
332 snprintf(bufp, bufplen, "%d %02d.%03d'", (int)a, m / 1000, m % 1000);
333 else {
334 if (flag == 1) {
335 snprintf(bufp, bufplen, "%02d %02d.%03d %c", (int)a, m / 1000, (m % 1000),
336 bNeg ? 'S' : 'N');
337 } else if (flag == 2) {
338 snprintf(bufp, bufplen, "%03d %02d.%03d %c", (int)a, m / 1000, (m % 1000),
339 bNeg ? 'W' : 'E');
340 }
341 }
342}
343
344void toDMM(double a, char *bufp, int bufplen) {
345 todmm(0, a, bufp, bufplen);
346 return;
347}
348
349/* ---------------------------------------------------------------------------------
350 */
351/****************************************************************************/
352/* Convert Lat/Lon <-> Simple Mercator */
353/****************************************************************************/
354void toSM(double lat, double lon, double lat0, double lon0, double *x,
355 double *y) {
356 double xlon = lon;
357
358 /* Make sure lon and lon0 are same phase */
359
360 if ((lon * lon0 < 0.) && (fabs(lon - lon0) > 180.)) {
361 lon < 0.0 ? xlon += 360.0 : xlon -= 360.0;
362 }
363
364 const double z = WGS84_semimajor_axis_meters * mercator_k0;
365
366 *x = (xlon - lon0) * DEGREE * z;
367
368 // y =.5 ln( (1 + sin t) / (1 - sin t) )
369 const double s = sin(lat * DEGREE);
370 const double y3 = (.5 * log((1 + s) / (1 - s))) * z;
371
372 const double s0 = sin(lat0 * DEGREE);
373 const double y30 = (.5 * log((1 + s0) / (1 - s0))) * z;
374 *y = y3 - y30;
375}
376
377double toSMcache_y30(double lat0) {
378 const double z = WGS84_semimajor_axis_meters * mercator_k0;
379 const double s0 = sin(lat0 * DEGREE);
380 const double y30 = (.5 * log((1 + s0) / (1 - s0))) * z;
381 return y30;
382}
383
384void toSMcache(double lat, double lon, double y30, double lon0, double *x,
385 double *y) {
386 double xlon = lon;
387
388 /* Make sure lon and lon0 are same phase */
389
390 if ((lon * lon0 < 0.) && (fabs(lon - lon0) > 180.)) {
391 lon < 0.0 ? xlon += 360.0 : xlon -= 360.0;
392 }
393
394 const double z = WGS84_semimajor_axis_meters * mercator_k0;
395
396 *x = (xlon - lon0) * DEGREE * z;
397
398 // y =.5 ln( (1 + sin t) / (1 - sin t) )
399 const double s = sin(lat * DEGREE);
400 const double y3 = (.5 * log((1 + s) / (1 - s))) * z;
401
402 *y = y3 - y30;
403}
404
405void fromSM(double x, double y, double lat0, double lon0, double *lat,
406 double *lon) {
407 const double z = WGS84_semimajor_axis_meters * mercator_k0;
408
409 // lat = arcsin((e^2(y+y0) - 1)/(e^2(y+y0) + 1))
410 /*
411 double s0 = sin(lat0 * DEGREE);
412 double y0 = (.5 * log((1 + s0) / (1 - s0))) * z;
413
414 double e = exp(2 * (y0 + y) / z);
415 double e11 = (e - 1)/(e + 1);
416 double lat2 =(atan2(e11, sqrt(1 - e11 * e11))) / DEGREE;
417 */
418 // which is the same as....
419
420 const double s0 = sin(lat0 * DEGREE);
421 const double y0 = (.5 * log((1 + s0) / (1 - s0))) * z;
422
423 *lat = (2.0 * atan(exp((y0 + y) / z)) - PI / 2.) / DEGREE;
424
425 // lon = x + lon0
426 *lon = lon0 + (x / (DEGREE * z));
427}
428
429void fromSMR(double x, double y, double lat0, double lon0, double axis_meters,
430 double *lat, double *lon) {
431 const double s0 = sin(lat0 * DEGREE);
432 const double y0 = (.5 * log((1 + s0) / (1 - s0))) * axis_meters;
433
434 *lat = (2.0 * atan(exp((y0 + y) / axis_meters)) - PI / 2.) / DEGREE;
435
436 // lon = x + lon0
437 *lon = lon0 + (x / (DEGREE * axis_meters));
438}
439
440void toSM_ECC(double lat, double lon, double lat0, double lon0, double *x,
441 double *y) {
442 const double f = 1.0 / WGSinvf; // WGS84 ellipsoid flattening parameter
443 const double e2 = 2 * f - f * f; // eccentricity^2 .006700
444 const double e = sqrt(e2);
445
446 const double z = WGS84_semimajor_axis_meters * mercator_k0;
447
448 *x = (lon - lon0) * DEGREE * z;
449
450 // y =.5 ln( (1 + sin t) / (1 - sin t) )
451 const double s = sin(lat * DEGREE);
452 // const double y3 = (.5 * log((1 + s) / (1 - s))) * z;
453
454 const double s0 = sin(lat0 * DEGREE);
455 // const double y30 = (.5 * log((1 + s0) / (1 - s0))) * z;
456
457 // Add eccentricity terms
458
459 const double falsen = z * log(tan(PI / 4 + lat0 * DEGREE / 2) *
460 pow((1. - e * s0) / (1. + e * s0), e / 2.));
461 const double test = z * log(tan(PI / 4 + lat * DEGREE / 2) *
462 pow((1. - e * s) / (1. + e * s), e / 2.));
463 *y = test - falsen;
464}
465
466void fromSM_ECC(double x, double y, double lat0, double lon0, double *lat,
467 double *lon) {
468 const double f = 1.0 / WGSinvf; // WGS84 ellipsoid flattening parameter
469 const double es = 2 * f - f * f; // eccentricity^2 .006700
470 const double e = sqrt(es);
471
472 const double z = WGS84_semimajor_axis_meters * mercator_k0;
473
474 *lon = lon0 + (x / (DEGREE * z));
475
476 const double s0 = sin(lat0 * DEGREE);
477
478 const double falsen = z * log(tan(PI / 4 + lat0 * DEGREE / 2) *
479 pow((1. - e * s0) / (1. + e * s0), e / 2.));
480 const double t = exp((y + falsen) / (z));
481 const double xi = (PI / 2.) - 2.0 * atan(t);
482
483 // Add eccentricity terms
484
485 double esf = (es / 2. + (5 * es * es / 24.) + (es * es * es / 12.) +
486 (13.0 * es * es * es * es / 360.)) *
487 sin(2 * xi);
488 esf += ((7. * es * es / 48.) + (29. * es * es * es / 240.) +
489 (811. * es * es * es * es / 11520.)) *
490 sin(4. * xi);
491 esf += ((7. * es * es * es / 120.) + (81 * es * es * es * es / 1120.) +
492 (4279. * es * es * es * es / 161280.)) *
493 sin(8. * xi);
494
495 *lat = -(xi + esf) / DEGREE;
496}
497
498#define TOL 1e-10
499#define CONV 1e-10
500#define N_ITER 10
501#define I_ITER 20
502#define ITOL 1.e-12
503
504void toPOLY(double lat, double lon, double lat0, double lon0, double *x,
505 double *y) {
506 const double z = WGS84_semimajor_axis_meters * mercator_k0;
507
508 if (fabs((lat - lat0) * DEGREE) <= TOL) {
509 *x = (lon - lon0) * DEGREE * z;
510 *y = 0.;
511
512 } else {
513 const double E = (lon - lon0) * DEGREE * sin(lat * DEGREE);
514 const double cot = 1. / tan(lat * DEGREE);
515 *x = sin(E) * cot;
516 *y = (lat * DEGREE) - (lat0 * DEGREE) + cot * (1. - cos(E));
517
518 *x *= z;
519 *y *= z;
520 }
521
522 /*
523 if (fabs(lp.phi) <= TOL) { xy.x = lp.lam; xy.y = P->ml0; }
524 else {
525 cot = 1. / tan(lp.phi);
526 xy.x = sin(E = lp.lam * sin(lp.phi)) * cot;
527 xy.y = lp.phi - P->phi0 + cot * (1. - cos(E));
528 }
529 */
530}
531
532void fromPOLY(double x, double y, double lat0, double lon0, double *lat,
533 double *lon) {
534 const double z = WGS84_semimajor_axis_meters * mercator_k0;
535
536 double yp = y - (lat0 * DEGREE * z);
537 if (fabs(yp) <= TOL) {
538 *lon = lon0 + (x / (DEGREE * z));
539 *lat = lat0;
540 } else {
541 yp = y / z;
542 const double xp = x / z;
543
544 double lat3 = yp;
545 const double B = (xp * xp) + (yp * yp);
546 int i = N_ITER;
547 double dphi;
548 do {
549 double tp = tan(lat3);
550 dphi = (yp * (lat3 * tp + 1.) - lat3 - .5 * (lat3 * lat3 + B) * tp) /
551 ((lat3 - yp) / tp - 1.);
552 lat3 -= dphi;
553 } while (fabs(dphi) > CONV && --i);
554 if (!i) {
555 *lon = 0.;
556 *lat = 0.;
557 } else {
558 *lon = asin(xp * tan(lat3)) / sin(lat3);
559 *lon /= DEGREE;
560 *lon += lon0;
561
562 *lat = lat3 / DEGREE;
563 }
564 }
565}
566
567/****************************************************************************/
568/* Convert Lat/Lon <-> Transverse Mercator */
569/****************************************************************************/
570
571// converts lat/long to TM coords. Equations from USGS Bulletin 1532
572// East Longitudes are positive, West longitudes are negative.
573// North latitudes are positive, South latitudes are negative
574// Lat and Long are in decimal degrees.
575// Written by Chuck Gantz- chuck.gantz@globalstar.com
576// Adapted for opencpn by David S. Register
577
578void toTM(float lat, float lon, float lat0, float lon0, double *x, double *y) {
579 // constants for WGS-84
580 const double f = 1.0 / WGSinvf; /* WGS84 ellipsoid flattening parameter */
581 const double a = WGS84_semimajor_axis_meters;
582 const double k0 = 1.; /* Scaling factor */
583
584 const double eccSquared = 2 * f - f * f;
585 const double eccPrimeSquared = (eccSquared) / (1 - eccSquared);
586 const double LatRad = lat * DEGREE;
587 const double LongOriginRad = lon0 * DEGREE;
588 const double LongRad = lon * DEGREE;
589
590 const double N = a / sqrt(1 - eccSquared * sin(LatRad) * sin(LatRad));
591 const double T = tan(LatRad) * tan(LatRad);
592 const double C = eccPrimeSquared * cos(LatRad) * cos(LatRad);
593 const double A = cos(LatRad) * (LongRad - LongOriginRad);
594
595 const double MM =
596 a *
597 ((1 - eccSquared / 4 - 3 * eccSquared * eccSquared / 64 -
598 5 * eccSquared * eccSquared * eccSquared / 256) *
599 LatRad -
600 (3 * eccSquared / 8 + 3 * eccSquared * eccSquared / 32 +
601 45 * eccSquared * eccSquared * eccSquared / 1024) *
602 sin(2 * LatRad) +
603 (15 * eccSquared * eccSquared / 256 +
604 45 * eccSquared * eccSquared * eccSquared / 1024) *
605 sin(4 * LatRad) -
606 (35 * eccSquared * eccSquared * eccSquared / 3072) * sin(6 * LatRad));
607
608 *x = (k0 * N *
609 (A + (1 - T + C) * A * A * A / 6 +
610 (5 - 18 * T + T * T + 72 * C - 58 * eccPrimeSquared) * A * A * A * A *
611 A / 120));
612
613 *y =
614 (k0 *
615 (MM + N * tan(LatRad) *
616 (A * A / 2 + (5 - T + 9 * C + 4 * C * C) * A * A * A * A / 24 +
617 (61 - 58 * T + T * T + 600 * C - 330 * eccPrimeSquared) * A *
618 A * A * A * A * A / 720)));
619}
620
621/* ---------------------------------------------------------------------------------
622 */
623
624// converts TM coords to lat/long. Equations from USGS Bulletin 1532
625// East Longitudes are positive, West longitudes are negative.
626// North latitudes are positive, South latitudes are negative
627// Lat and Long are in decimal degrees
628// Written by Chuck Gantz- chuck.gantz@globalstar.com
629// Adapted for opencpn by David S. Register
630
631void fromTM(double x, double y, double lat0, double lon0, double *lat,
632 double *lon) {
633 const double rad2deg = 1. / DEGREE;
634 // constants for WGS-84
635
636 const double f = 1.0 / WGSinvf; /* WGS84 ellipsoid flattening parameter */
637 const double a = WGS84_semimajor_axis_meters;
638 const double k0 = 1.; /* Scaling factor */
639
640 const double eccSquared = 2 * f - f * f;
641
642 const double eccPrimeSquared = (eccSquared) / (1 - eccSquared);
643 const double e1 =
644 (1.0 - sqrt(1.0 - eccSquared)) / (1.0 + sqrt(1.0 - eccSquared));
645
646 const double MM = y / k0;
647 const double mu =
648 MM / (a * (1 - eccSquared / 4 - 3 * eccSquared * eccSquared / 64 -
649 5 * eccSquared * eccSquared * eccSquared / 256));
650
651 const double phi1Rad =
652 mu + (3 * e1 / 2 - 27 * e1 * e1 * e1 / 32) * sin(2 * mu) +
653 (21 * e1 * e1 / 16 - 55 * e1 * e1 * e1 * e1 / 32) * sin(4 * mu) +
654 (151 * e1 * e1 * e1 / 96) * sin(6 * mu);
655
656 const double N1 = a / sqrt(1 - eccSquared * sin(phi1Rad) * sin(phi1Rad));
657 const double T1 = tan(phi1Rad) * tan(phi1Rad);
658 const double C1 = eccPrimeSquared * cos(phi1Rad) * cos(phi1Rad);
659 const double R1 = a * (1 - eccSquared) /
660 pow(1 - eccSquared * sin(phi1Rad) * sin(phi1Rad), 1.5);
661 const double D = x / (N1 * k0);
662
663 *lat = phi1Rad -
664 (N1 * tan(phi1Rad) / R1) *
665 (D * D / 2 -
666 (5 + 3 * T1 + 10 * C1 - 4 * C1 * C1 - 9 * eccPrimeSquared) * D *
667 D * D * D / 24 +
668 (61 + 90 * T1 + 298 * C1 + 45 * T1 * T1 - 252 * eccPrimeSquared -
669 3 * C1 * C1) *
670 D * D * D * D * D * D / 720);
671 *lat = lat0 + (*lat * rad2deg);
672
673 *lon = (D - (1 + 2 * T1 + C1) * D * D * D / 6 +
674 (5 - 2 * C1 + 28 * T1 - 3 * C1 * C1 + 8 * eccPrimeSquared +
675 24 * T1 * T1) *
676 D * D * D * D * D / 120) /
677 cos(phi1Rad);
678 *lon = lon0 + *lon * rad2deg;
679}
680
681/* orthographic, polar, stereographic, gnomonic and equirectangular projection
682 * routines, contributed by Sean D'Epagnier */
683/****************************************************************************/
684/* Convert Lat/Lon <-> Simple Polar */
685/****************************************************************************/
686void cache_phi0(double lat0, double *sin_phi0, double *cos_phi0) {
687 double phi0 = lat0 * DEGREE;
688 *sin_phi0 = sin(phi0);
689 *cos_phi0 = cos(phi0);
690}
691
692void toORTHO(double lat, double lon, double sin_phi0, double cos_phi0,
693 double lon0, double *x, double *y) {
694 const double z = WGS84_semimajor_axis_meters * mercator_k0;
695
696 double xlon = lon;
697 /* Make sure lon and lon0 are same phase */
698 if ((lon * lon0 < 0.) && (fabs(lon - lon0) > 180.))
699 lon < 0.0 ? xlon += 360.0 : xlon -= 360.0;
700
701 double theta = (xlon - lon0) * DEGREE;
702 double phi = lat * DEGREE;
703 double cos_phi = cos(phi);
704
705 double vy = sin(phi), vz = cos(theta) * cos_phi;
706
707 if (vy * sin_phi0 + vz * cos_phi0 < 0) { // on the far side of the earth
708 *x = *y = NAN;
709 return;
710 }
711
712 double vx = sin(theta) * cos_phi;
713 double vw = vy * cos_phi0 - vz * sin_phi0;
714
715 *x = vx * z;
716 *y = vw * z;
717}
718
719void fromORTHO(double x, double y, double lat0, double lon0, double *lat,
720 double *lon) {
721 const double z = WGS84_semimajor_axis_meters * mercator_k0;
722
723 double vx = x / z;
724 double vw = y / z;
725
726 double phi0 = lat0 * DEGREE;
727 double d = 1 - vx * vx - vw * vw;
728
729 if (d < 0) { // position is outside of the earth
730 *lat = *lon = NAN;
731 return;
732 }
733
734 double sin_phi0 = sin(phi0), cos_phi0 = cos(phi0);
735 double vy = vw * cos_phi0 + sqrt(d) * sin_phi0;
736 double phi = asin(vy);
737
738 double vz = (vy * cos_phi0 - vw) / sin_phi0;
739 double theta = atan2(vx, vz);
740
741 *lat = phi / DEGREE;
742 *lon = theta / DEGREE + lon0;
743}
744
745double toPOLARcache_e(double lat0) {
746 double pole = lat0 > 0 ? 90 : -90;
747 return tan((pole - lat0) * DEGREE / 2);
748}
749
750void toPOLAR(double lat, double lon, double e, double lat0, double lon0,
751 double *x, double *y) {
752 const double z = WGS84_semimajor_axis_meters * mercator_k0;
753
754 double xlon = lon;
755 /* Make sure lon and lon0 are same phase */
756 if ((lon * lon0 < 0.) && (fabs(lon - lon0) > 180.))
757 lon < 0.0 ? xlon += 360.0 : xlon -= 360.0;
758
759 double theta = (xlon - lon0) * DEGREE;
760 double pole = lat0 > 0 ? 90 : -90;
761
762 double d = tan((pole - lat) * DEGREE / 2);
763
764 *x = fabs(d) * sin(theta) * z;
765 *y = (e - d * cos(theta)) * z;
766}
767
768void fromPOLAR(double x, double y, double lat0, double lon0, double *lat,
769 double *lon) {
770 const double z = WGS84_semimajor_axis_meters * mercator_k0;
771 double pole = lat0 > 0 ? 90 : -90;
772
773 double e = tan((pole - lat0) * DEGREE / 2);
774
775 double xn = x / z;
776 double yn = e - y / z;
777 double d = sqrt(xn * xn + yn * yn);
778 if (pole < 0) // south polar (negative root and correct branch from cosine)
779 d = -d, yn = -yn;
780
781 *lat = pole - atan(d) * 2 / DEGREE;
782
783 double theta = atan2(xn, yn);
784 *lon = theta / DEGREE + lon0;
785}
786
787static inline void toSTEREO1(double &u, double &v, double &w, double lat,
788 double lon, double sin_phi0, double cos_phi0,
789 double lon0) {
790 double xlon = lon;
791 /* Make sure lon and lon0 are same phase */
792 if ((lon * lon0 < 0.) && (fabs(lon - lon0) > 180.))
793 lon < 0.0 ? xlon += 360.0 : xlon -= 360.0;
794
795 double theta = (xlon - lon0) * DEGREE, phi = lat * DEGREE;
796 double cos_phi = cos(phi), v0 = sin(phi), w0 = cos(theta) * cos_phi;
797
798 u = sin(theta) * cos_phi;
799 v = cos_phi0 * v0 - sin_phi0 * w0;
800 w = sin_phi0 * v0 + cos_phi0 * w0;
801}
802
803static inline void fromSTEREO1(double *lat, double *lon, double lat0,
804 double lon0, double u, double v, double w) {
805 double phi0 = lat0 * DEGREE;
806 double v0 = sin(phi0) * w + cos(phi0) * v;
807 double w0 = cos(phi0) * w - sin(phi0) * v;
808 double phi = asin(v0);
809 double theta = atan2(u, w0);
810
811 *lat = phi / DEGREE;
812 *lon = theta / DEGREE + lon0;
813}
814
815void toSTEREO(double lat, double lon, double sin_phi0, double cos_phi0,
816 double lon0, double *x, double *y) {
817 const double z = WGS84_semimajor_axis_meters * mercator_k0;
818
819 double u, v, w;
820 toSTEREO1(u, v, w, lat, lon, sin_phi0, cos_phi0, lon0);
821
822 double t = 2 / (w + 1);
823 *x = u * t * z;
824 *y = v * t * z;
825}
826
827void fromSTEREO(double x, double y, double lat0, double lon0, double *lat,
828 double *lon) {
829 const double z = WGS84_semimajor_axis_meters * mercator_k0;
830
831 x /= z, y /= z;
832
833 double t = (x * x + y * y) / 4 + 1;
834
835 double u = x / t;
836 double v = y / t;
837 double w = 2 / t - 1;
838
839 fromSTEREO1(lat, lon, lat0, lon0, u, v, w);
840}
841
842void toGNO(double lat, double lon, double sin_phi0, double cos_phi0,
843 double lon0, double *x, double *y) {
844 const double z = WGS84_semimajor_axis_meters * mercator_k0;
845
846 double u, v, w;
847 toSTEREO1(u, v, w, lat, lon, sin_phi0, cos_phi0, lon0);
848
849 if (w <= 0) {
850 *x = *y = NAN; // far side of world
851 return;
852 }
853
854 *x = u / w * z;
855 *y = v / w * z;
856}
857
858void fromGNO(double x, double y, double lat0, double lon0, double *lat,
859 double *lon) {
860 const double z = WGS84_semimajor_axis_meters * mercator_k0;
861
862 x /= z, y /= z;
863
864 double w = 1 / sqrt(x * x + y * y + 1);
865 double u = x * w;
866 double v = y * w;
867
868 fromSTEREO1(lat, lon, lat0, lon0, u, v, w);
869}
870
871void toEQUIRECT(double lat, double lon, double lat0, double lon0, double *x,
872 double *y) {
873 const double z = WGS84_semimajor_axis_meters * mercator_k0;
874 double xlon = lon;
875 /* Make sure lon and lon0 are same phase */
876 if ((lon * lon0 < 0.) && (fabs(lon - lon0) > 180.))
877 lon < 0.0 ? xlon += 360.0 : xlon -= 360.0;
878
879 *x = (xlon - lon0) * DEGREE * z;
880 *y = (lat - lat0) * DEGREE * z;
881}
882
883void fromEQUIRECT(double x, double y, double lat0, double lon0, double *lat,
884 double *lon) {
885 const double z = WGS84_semimajor_axis_meters * mercator_k0;
886
887 *lat = lat0 + (y / (DEGREE * z));
888 // if(fabs(*lat) > 90) *lat = NAN;
889 *lon = lon0 + (x / (DEGREE * z));
890}
891
892/* ---------------------------------------------------------------------------------
893 *
894
895 *Molodensky
896 *In the listing below, the class GeodeticPosition has three members, lon, lat,
897 and h. *They are double-precision values indicating the longitude and latitude
898 in radians,
899 * and height in meters above the ellipsoid.
900
901 * The source code in the listing below may be copied and reused without
902 restriction,
903 * but it is offered AS-IS with NO WARRANTY.
904
905 * Adapted for opencpn by David S. Register
906
907 * --------------------------------------------------------------------------------- */
908
909void MolodenskyTransform(double lat, double lon, double *to_lat, double *to_lon,
910 int from_datum_index, int to_datum_index) {
911 double dlat = 0;
912 double dlon = 0;
913
914 if (from_datum_index < nDatums) {
915 const double from_lat = lat * DEGREE;
916 const double from_lon = lon * DEGREE;
917 const double from_f =
918 1.0 /
919 gEllipsoid[gDatum[from_datum_index].ellipsoid].invf; // flattening
920 const double from_esq = 2 * from_f - from_f * from_f; // eccentricity^2
921 const double from_a =
922 gEllipsoid[gDatum[from_datum_index].ellipsoid].a; // semimajor axis
923 const double dx = gDatum[from_datum_index].dx;
924 const double dy = gDatum[from_datum_index].dy;
925 const double dz = gDatum[from_datum_index].dz;
926 const double to_f =
927 1.0 / gEllipsoid[gDatum[to_datum_index].ellipsoid].invf; // flattening
928 const double to_a =
929 gEllipsoid[gDatum[to_datum_index].ellipsoid].a; // semimajor axis
930 const double da = to_a - from_a;
931 const double df = to_f - from_f;
932 const double from_h = 0;
933
934 const double slat = sin(from_lat);
935 const double clat = cos(from_lat);
936 const double slon = sin(from_lon);
937 const double clon = cos(from_lon);
938 const double ssqlat = slat * slat;
939 const double adb = 1.0 / (1.0 - from_f); // "a divided by b"
940
941 const double rn = from_a / sqrt(1.0 - from_esq * ssqlat);
942 const double rm =
943 from_a * (1. - from_esq) / pow((1.0 - from_esq * ssqlat), 1.5);
944
945 dlat = (((((-dx * slat * clon - dy * slat * slon) + dz * clat) +
946 (da * ((rn * from_esq * slat * clat) / from_a))) +
947 (df * (rm * adb + rn / adb) * slat * clat))) /
948 (rm + from_h);
949
950 dlon = (-dx * slon + dy * clon) / ((rn + from_h) * clat);
951 }
952
953 *to_lon = lon + dlon / DEGREE;
954 *to_lat = lat + dlat / DEGREE;
955 //
956 return;
957}
958
959/* ---------------------------------------------------------------------------------
960 */
961/*
962 Geodesic Forward and Reverse calculation functions
963 Abstracted and adapted from PROJ-4.5.0 by David S.Register
964
965 Original source code contains the following license:
966
967 Copyright (c) 2000, Frank Warmerdam
968
969 Permission is hereby granted, free of charge, to any person obtaining a
970 copy of this software and associated documentation files (the "Software"),
971 to deal in the Software without restriction, including without limitation
972 the rights to use, copy, modify, merge, publish, distribute, sublicense,
973 and/or sell copies of the Software, and to permit persons to whom the
974 Software is furnished to do so, subject to the following conditions:
975
976 The above copyright notice and this permission notice shall be included
977 in all copies or substantial portions of the Software.
978
979 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
980 OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
981 FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
982 THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
983 LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
984 FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
985 DEALINGS IN THE SOFTWARE.
986*/
987/* ---------------------------------------------------------------------------------
988 */
989
990#define DTOL 1e-12
991
992#define HALFPI 1.5707963267948966
993#define SPI 3.14159265359
994#define TWOPI 6.2831853071795864769
995#define ONEPI 3.14159265358979323846
996#define MERI_TOL 1e-9
997
998double adjlon(double lon) {
999 if (fabs(lon) <= SPI) return (lon);
1000 lon += ONEPI; /* adjust to 0..2pi rad */
1001 lon -= TWOPI * floor(lon / TWOPI); /* remove integral # of 'revolutions'*/
1002 lon -= ONEPI; /* adjust back to -pi..pi rad */
1003 return (lon);
1004}
1005
1006/* ---------------------------------------------------------------------------------
1007 */
1008/*
1009// Given the lat/long of starting point, and traveling a specified distance,
1010// at an initial bearing, calculates the lat/long of the resulting location.
1011// using sphere earth model.
1012*/
1013/* ---------------------------------------------------------------------------------
1014 */
1015void ll_gc_ll(double lat, double lon, double brg, double dist, double *dlat,
1016 double *dlon) {
1017 double th1, costh1, sinth1, sina12, cosa12, M, N, c1, c2, D, P, s1;
1018 int merid, signS;
1019
1020 if((brg == 90.) || (brg == 180.)){
1021 brg += 1e-9;
1022 }
1023
1024 /* Input/Output from geodesic functions */
1025 double al12; /* Forward azimuth */
1026 double al21; /* Back azimuth */
1027 double geod_S; /* Distance */
1028 double phi1, lam1, phi2, lam2;
1029
1030 int ellipse;
1031 double geod_f;
1032 double geod_a;
1033 double es, onef, f, f4;
1034
1035 /* Setup the static parameters */
1036 phi1 = lat * DEGREE; /* Initial Position */
1037 lam1 = lon * DEGREE;
1038 al12 = brg * DEGREE; /* Forward azimuth */
1039 geod_S = dist * 1852.0; /* Distance */
1040
1041 // void geod_pre(struct georef_state *state)
1042 {
1043 /* Stuff the WGS84 projection parameters as necessary
1044 * To avoid having to include <geodesic,h>
1045 */
1046 ellipse = 1;
1047 f = 1.0 / WGSinvf; /* WGS84 ellipsoid flattening parameter */
1048 geod_a = WGS84_semimajor_axis_meters;
1049
1050 es = 2 * f - f * f;
1051 onef = sqrt(1. - es);
1052 geod_f = 1 - onef;
1053 f4 = geod_f / 4;
1054
1055 al12 = adjlon(al12); /* reduce to +- 0-PI */
1056 signS = fabs(al12) > HALFPI ? 1 : 0;
1057 th1 = ellipse ? atan(onef * tan(phi1)) : phi1;
1058 costh1 = cos(th1);
1059 sinth1 = sin(th1);
1060 if ((merid = fabs(sina12 = sin(al12)) < MERI_TOL)) {
1061 sina12 = 0.;
1062 cosa12 = fabs(al12) < HALFPI ? 1. : -1.;
1063 M = 0.;
1064 } else {
1065 cosa12 = cos(al12);
1066 M = costh1 * sina12;
1067 }
1068 N = costh1 * cosa12;
1069 if (ellipse) {
1070 if (merid) {
1071 c1 = 0.;
1072 c2 = f4;
1073 D = 1. - c2;
1074 D *= D;
1075 P = c2 / D;
1076 } else {
1077 c1 = geod_f * M;
1078 c2 = f4 * (1. - M * M);
1079 D = (1. - c2) * (1. - c2 - c1 * M);
1080 P = (1. + .5 * c1 * M) * c2 / D;
1081 }
1082 }
1083 if (merid)
1084 s1 = HALFPI - th1;
1085 else {
1086 s1 = (fabs(M) >= 1.) ? 0. : acos(M);
1087 s1 = sinth1 / sin(s1);
1088 s1 = (fabs(s1) >= 1.) ? 0. : acos(s1);
1089 }
1090 }
1091
1092 // void geod_for(struct georef_state *state)
1093 {
1094 double d, sind, u, V, X, ds, cosds, sinds, ss, de;
1095
1096 ss = 0.;
1097
1098 if (ellipse) {
1099 d = geod_S / (D * geod_a);
1100 if (signS) d = -d;
1101 u = 2. * (s1 - d);
1102 V = cos(u + d);
1103 X = c2 * c2 * (sind = sin(d)) * cos(d) * (2. * V * V - 1.);
1104 ds = d + X - 2. * P * V * (1. - 2. * P * cos(u)) * sind;
1105 ss = s1 + s1 - ds;
1106 } else {
1107 ds = geod_S / geod_a;
1108 if (signS) ds = -ds;
1109 }
1110 cosds = cos(ds);
1111 sinds = sin(ds);
1112 if (signS) sinds = -sinds;
1113 al21 = N * cosds - sinth1 * sinds;
1114 if (merid) {
1115 phi2 = atan(tan(HALFPI + s1 - ds) / onef);
1116 if (al21 > 0.) {
1117 al21 = PI;
1118 if (signS)
1119 de = PI;
1120 else {
1121 phi2 = -phi2;
1122 de = 0.;
1123 }
1124 } else {
1125 al21 = 0.;
1126 if (signS) {
1127 phi2 = -phi2;
1128 de = 0;
1129 } else
1130 de = PI;
1131 }
1132 } else {
1133 al21 = atan(M / al21);
1134 if (al21 > 0) al21 += PI;
1135 if (al12 < 0.) al21 -= PI;
1136 al21 = adjlon(al21);
1137 phi2 = atan(-(sinth1 * cosds + N * sinds) * sin(al21) /
1138 (ellipse ? onef * M : M));
1139 de = atan2(sinds * sina12, (costh1 * cosds - sinth1 * sinds * cosa12));
1140 if (ellipse) {
1141 if (signS)
1142 de += c1 * ((1. - c2) * ds + c2 * sinds * cos(ss));
1143 else
1144 de -= c1 * ((1. - c2) * ds - c2 * sinds * cos(ss));
1145 }
1146 }
1147 lam2 = adjlon(lam1 + de);
1148 }
1149
1150 *dlat = phi2 / DEGREE;
1151 *dlon = lam2 / DEGREE;
1152}
1153
1154void ll_gc_ll_reverse(double lat1, double lon1, double lat2, double lon2,
1155 double *bearing, double *dist) {
1156 // For small distances do an ordinary mercator calc. (To prevent return of
1157 // nan's )
1158 if ((fabs(lon2 - lon1) < 0.1) && (fabs(lat2 - lat1) < 0.1)) {
1159 DistanceBearingMercator(lat2, lon2, lat1, lon1, bearing, dist);
1160 return;
1161 } else {
1162 /* Input/Output from geodesic functions */
1163 double al12; /* Forward azimuth */
1164 double al21; /* Back azimuth */
1165 double geod_S; /* Distance */
1166 double phi1, lam1, phi2, lam2;
1167
1168 int ellipse;
1169 double geod_f;
1170 double geod_a;
1171 double es, onef, f, f64, f2, f4;
1172
1173 /* Setup the static parameters */
1174 phi1 = lat1 * DEGREE; /* Initial Position */
1175 lam1 = lon1 * DEGREE;
1176 phi2 = lat2 * DEGREE;
1177 lam2 = lon2 * DEGREE;
1178
1179 // void geod_inv(struct georef_state *state)
1180 {
1181 double th1, th2, thm, dthm, dlamm, dlam, sindlamm, costhm, sinthm,
1182 cosdthm, sindthm, L, E, cosd, d, X, Y, T, sind, tandlammp, u, v, D, A,
1183 B;
1184
1185 /* Stuff the WGS84 projection parameters as necessary
1186 * To avoid having to include <geodesic,h>
1187 */
1188
1189 ellipse = 1;
1190 f = 1.0 / WGSinvf; /* WGS84 ellipsoid flattening parameter */
1191 geod_a = WGS84_semimajor_axis_meters;
1192
1193 es = 2 * f - f * f;
1194 onef = sqrt(1. - es);
1195 geod_f = 1 - onef;
1196 f2 = geod_f / 2;
1197 f4 = geod_f / 4;
1198 f64 = geod_f * geod_f / 64;
1199
1200 if (ellipse) {
1201 th1 = atan(onef * tan(phi1));
1202 th2 = atan(onef * tan(phi2));
1203 } else {
1204 th1 = phi1;
1205 th2 = phi2;
1206 }
1207 thm = .5 * (th1 + th2);
1208 dthm = .5 * (th2 - th1);
1209 dlamm = .5 * (dlam = adjlon(lam2 - lam1));
1210 if (fabs(dlam) < DTOL && fabs(dthm) < DTOL) {
1211 al12 = al21 = geod_S = 0.;
1212 if (bearing) *bearing = 0.;
1213 if (dist) *dist = 0.;
1214 return;
1215 }
1216 sindlamm = sin(dlamm);
1217 costhm = cos(thm);
1218 sinthm = sin(thm);
1219 cosdthm = cos(dthm);
1220 sindthm = sin(dthm);
1221 L = sindthm * sindthm +
1222 (cosdthm * cosdthm - sinthm * sinthm) * sindlamm * sindlamm;
1223 d = acos(cosd = 1 - L - L);
1224 if (ellipse) {
1225 E = cosd + cosd;
1226 sind = sin(d);
1227 Y = sinthm * cosdthm;
1228 Y *= (Y + Y) / (1. - L);
1229 T = sindthm * costhm;
1230 T *= (T + T) / L;
1231 X = Y + T;
1232 Y -= T;
1233 T = d / sind;
1234 D = 4. * T * T;
1235 A = D * E;
1236 B = D + D;
1237 geod_S = geod_a * sind *
1238 (T - f4 * (T * X - Y) +
1239 f64 * (X * (A + (T - .5 * (A - E)) * X) - Y * (B + E * Y) +
1240 D * X * Y));
1241 tandlammp =
1242 tan(.5 * (dlam - .25 * (Y + Y - E * (4. - X)) *
1243 (f2 * T + f64 * (32. * T - (20. * T - A) * X -
1244 (B + 4.) * Y)) *
1245 tan(dlam)));
1246 } else {
1247 geod_S = geod_a * d;
1248 tandlammp = tan(dlamm);
1249 }
1250 u = atan2(sindthm, (tandlammp * costhm));
1251 v = atan2(cosdthm, (tandlammp * sinthm));
1252 al12 = adjlon(TWOPI + v - u);
1253 al21 = adjlon(TWOPI - v - u);
1254 if (al12 < 0) al12 += 2 * PI;
1255 if (bearing) *bearing = al12 / DEGREE;
1256 if (dist) *dist = geod_S / 1852.0;
1257 }
1258 }
1259}
1260
1261void PositionBearingDistanceMercator(double lat, double lon, double brg,
1262 double dist, double *dlat, double *dlon) {
1263 ll_gc_ll(lat, lon, brg, dist, dlat, dlon);
1264}
1265
1266double DistLoxodrome(double slat, double slon, double dlat, double dlon) {
1267 double dist =
1268 60 * sqrt(pow(slat - dlat, 2) +
1269 pow((slon - dlon) * cos((slat + dlat) / 2 * DEGREE), 2));
1270 return dist;
1271}
1272
1273/* ---------------------------------------------------------------------------------
1274 */
1275/*
1276// Given the lat/long of starting point and ending point,
1277// calculates the distance (in Nm) along a geodesic curve, using sphere earth
1278model.
1279*/
1280/* ---------------------------------------------------------------------------------
1281 */
1282
1283double DistGreatCircle(double slat, double slon, double dlat, double dlon) {
1284 double d5;
1285 d5 = DistLoxodrome(slat, slon, dlat, dlon);
1286 if (d5 < 10) // Miles
1287 return d5;
1288
1289 /* Input/Output from geodesic functions */
1290 // double al12; /* Forward azimuth */
1291 // double al21; /* Back azimuth */
1292 double geod_S; /* Distance */
1293 double phi1, lam1, phi2, lam2;
1294
1295 int ellipse;
1296 double geod_f;
1297 double geod_a;
1298 double es, onef, f, f64, f4;
1299
1300 phi1 = slat * DEGREE;
1301 lam1 = slon * DEGREE;
1302 phi2 = dlat * DEGREE;
1303 lam2 = dlon * DEGREE;
1304
1305 // void geod_inv(struct georef_state *state)
1306 {
1307 double th1, th2, thm, dthm, dlamm, dlam, sindlamm, costhm, sinthm, cosdthm,
1308 sindthm, L, E, cosd, d, X, Y, T, sind, D, A, B;
1309 // double tandlammp,u,v;
1310
1311 /* Stuff the WGS84 projection parameters as necessary
1312 * To avoid having to include <geodesic,h>
1313 */
1314
1315 ellipse = 0;
1316 f = 1.0 / WGSinvf; /* WGS84 ellipsoid flattening parameter */
1317 geod_a = WGS84_semimajor_axis_meters;
1318
1319 es = 2 * f - f * f;
1320 onef = sqrt(1. - es);
1321 geod_f = 1 - onef;
1322 // f2 = geod_f/2;
1323 f4 = geod_f / 4;
1324 f64 = geod_f * geod_f / 64;
1325
1326 if (ellipse) {
1327 th1 = atan(onef * tan(phi1));
1328 th2 = atan(onef * tan(phi2));
1329 } else {
1330 th1 = phi1;
1331 th2 = phi2;
1332 }
1333 thm = .5 * (th1 + th2);
1334 dthm = .5 * (th2 - th1);
1335 dlamm = .5 * (dlam = adjlon(lam2 - lam1));
1336 if (fabs(dlam) < DTOL && fabs(dthm) < DTOL) {
1337 return 0.0;
1338 }
1339 sindlamm = sin(dlamm);
1340 costhm = cos(thm);
1341 sinthm = sin(thm);
1342 cosdthm = cos(dthm);
1343 sindthm = sin(dthm);
1344 L = sindthm * sindthm +
1345 (cosdthm * cosdthm - sinthm * sinthm) * sindlamm * sindlamm;
1346 d = acos(cosd = 1 - L - L);
1347
1348 if (ellipse) {
1349 E = cosd + cosd;
1350 sind = sin(d);
1351 Y = sinthm * cosdthm;
1352 Y *= (Y + Y) / (1. - L);
1353 T = sindthm * costhm;
1354 T *= (T + T) / L;
1355 X = Y + T;
1356 Y -= T;
1357 T = d / sind;
1358 D = 4. * T * T;
1359 A = D * E;
1360 B = D + D;
1361 geod_S = geod_a * sind *
1362 (T - f4 * (T * X - Y) +
1363 f64 * (X * (A + (T - .5 * (A - E)) * X) - Y * (B + E * Y) +
1364 D * X * Y));
1365 // tandlammp = tan(.5 * (dlam - .25 * (Y + Y - E * (4. - X))
1366 // *
1367 // (f2 * T + f64 * (32. * T - (20. * T - A)
1368 // * X - (B + 4.) * Y)) * tan(dlam)));
1369 } else {
1370 geod_S = geod_a * d;
1371 // tandlammp = tan(dlamm);
1372 }
1373 // u = atan2(sindthm , (tandlammp * costhm));
1374 // v = atan2(cosdthm , (tandlammp * sinthm));
1375 // al12 = adjlon(TWOPI + v - u);
1376 // al21 = adjlon(TWOPI - v - u);
1377 }
1378
1379 d5 = geod_S / 1852.0;
1380
1381 return d5;
1382}
1383
1384void DistanceBearingMercator(double lat1, double lon1, double lat0, double lon0,
1385 double *brg, double *dist) {
1386 // Calculate bearing and distance between two points
1387 double latm = (lat0 + lat1) / 2 * DEGREE; // median of latitude
1388 double delta_lat = (lat1 - lat0);
1389 double delta_lon = (lon1 - lon0);
1390 double ex_lat0, ex_lat1;
1391 double bearing, distance;
1392 // make sure we calc the shortest route, even if this across the date line.
1393 if (delta_lon < -180) delta_lon += 360;
1394 if (delta_lon > 180) delta_lon -= 360;
1395
1396 if (delta_lon == 0)
1397 bearing = .0; // delta lon = 0 so course is due N or S
1398 else if (fabs(delta_lat) != .0)
1399 bearing = atan(delta_lon * cos(latm) / delta_lat);
1400 else
1401 bearing = PI / 2; // delta lat = 0 so course must be E or W
1402
1403 distance = sqrt(pow(delta_lat, 2) + pow(delta_lon * cos(latm), 2));
1404
1405 if (distance >
1406 0.01745) // > 1 degree we use exaggerated latitude to be more exact
1407 {
1408 if (delta_lat != 0.) {
1409 ex_lat0 = 10800 / PI * log(tan(PI / 4 + lat0 * DEGREE / 2));
1410 ex_lat1 = 10800 / PI * log(tan(PI / 4 + lat1 * DEGREE / 2));
1411 bearing = atan(delta_lon * 60 / (ex_lat1 - ex_lat0));
1412 distance = fabs(delta_lat / cos(bearing));
1413 } else {
1414 bearing = PI / 2;
1415 }
1416 }
1417
1418 bearing = fabs(bearing);
1419 if (lat1 > lat0) {
1420 if (delta_lon < 0) bearing = 2 * PI - bearing;
1421 } // NW
1422 else {
1423 if (delta_lon > 0)
1424 bearing = PI - bearing; // SE
1425 else
1426 bearing = PI + bearing;
1427 } // SW
1428
1429 if (brg) *brg = bearing * RADIAN; // in degrees
1430 if (dist) *dist = distance * 60; // in NM
1431}
1432
1433/* ---------------------------------------------------------------------------------
1434 */
1435/*
1436 * lmfit
1437 *
1438 * Solves or minimizes the sum of squares of m nonlinear
1439 * functions of n variables.
1440 *
1441 * From public domain Fortran version
1442 * of Argonne National Laboratories MINPACK
1443 * argonne national laboratory. minpack project. march 1980.
1444 * burton s. garbow, kenneth e. hillstrom, jorge j. more
1445 * C translation by Steve Moshier
1446 * Joachim Wuttke converted the source into C++ compatible ANSI style
1447 * and provided a simplified interface
1448 */
1449
1450//#include "lmmin.h" // all moved to georef.h
1451#define _LMDIF
1452
1455
1456double my_fit_function(double tx, double ty, int n_par, double *p) {
1457 double ret = p[0] + p[1] * tx;
1458
1459 if (n_par > 2) ret += p[2] * ty;
1460 if (n_par > 3) {
1461 ret += p[3] * tx * tx;
1462 ret += p[4] * tx * ty;
1463 ret += p[5] * ty * ty;
1464 }
1465 if (n_par > 6) {
1466 ret += p[6] * tx * tx * tx;
1467 ret += p[7] * tx * tx * ty;
1468 ret += p[8] * tx * ty * ty;
1469 ret += p[9] * ty * ty * ty;
1470 }
1471
1472 return ret;
1473}
1474
1475int Georef_Calculate_Coefficients_Onedir(int n_points, int n_par, double *tx,
1476 double *ty, double *y, double *p,
1477 double hintp0, double hintp1,
1478 double hintp2)
1479/*
1480n_points : number of sample points
1481n_par : 3, 6, or 10, 6 is probably good
1482tx: sample data independent variable 1
1483ty: sample data independent variable 2
1484y: sample data dependent result
1485p: curve fit result coefficients
1486*/
1487{
1488 int i;
1489 lm_control_type control;
1490 lm_data_type data;
1491
1492 lm_initialize_control(&control);
1493
1494 for (i = 0; i < 12; i++) p[i] = 0.;
1495
1496 // memset(p, 0, 12 * sizeof(double));
1497
1498 // Insert hints
1499 p[0] = hintp0;
1500 p[1] = hintp1;
1501 p[2] = hintp2;
1502
1503 data.user_func = my_fit_function;
1504 data.user_tx = tx;
1505 data.user_ty = ty;
1506 data.user_y = y;
1507 data.n_par = n_par;
1508 data.print_flag = 0;
1509
1510 // perform the fit:
1511
1512 lm_minimize(n_points, n_par, p, lm_evaluate_default, lm_print_default, &data,
1513 &control);
1514
1515 // print results:
1516 // printf( "status: %s after %d evaluations\n",
1517 // lm_infmsg[control.info], control.nfev );
1518
1519 // Control.info results [1,2,3] are success, other failure
1520 return control.info;
1521}
1522
1523int Georef_Calculate_Coefficients(struct GeoRef *cp, int nlin_lon) {
1524 // Zero out the points
1525 for (int i = 0; i < 10; ++i)
1526 cp->pwx[i] = cp->pwy[i] = cp->wpx[i] = cp->wpy[i] = 0.0;
1527
1528 int mp = 3;
1529
1530 switch (cp->order) {
1531 case 1:
1532 mp = 3;
1533 break;
1534 case 2:
1535 mp = 6;
1536 break;
1537 case 3:
1538 mp = 10;
1539 break;
1540 default:
1541 mp = 3;
1542 break;
1543 }
1544
1545 const int mp_lat = mp;
1546
1547 // Force linear fit for longitude if nlin_lon > 0
1548 const int mp_lon = nlin_lon ? 2 : mp;
1549
1550 // Make a dummy double array
1551 std::vector<double> pnull(cp->count, 1.0);
1552
1553 // pixel(tx,ty) to (lat,lon)
1554 // Calculate and use a linear equation for p[0..2] to hint the solver
1555
1556 int r1 = Georef_Calculate_Coefficients_Onedir(
1557 cp->count, mp_lon, cp->tx, cp->ty, cp->lon, cp->pwx,
1558 cp->lonmin -
1559 (cp->txmin * (cp->lonmax - cp->lonmin) / (cp->txmax - cp->txmin)),
1560 (cp->lonmax - cp->lonmin) / (cp->txmax - cp->txmin), 0.);
1561
1562 // if blin_lon > 0, force cross terms in latitude equation coefficients
1563 // to be zero by making lat not dependent on tx,
1564 double *px = nlin_lon ? &pnull[0] : cp->tx;
1565
1566 int r2 = Georef_Calculate_Coefficients_Onedir(
1567 cp->count, mp_lat, px, cp->ty, cp->lat, cp->pwy,
1568 cp->latmin -
1569 (cp->tymin * (cp->latmax - cp->latmin) / (cp->tymax - cp->tymin)),
1570 0., (cp->latmax - cp->latmin) / (cp->tymax - cp->tymin));
1571
1572 // (lat,lon) to pixel(tx,ty)
1573 // Calculate and use a linear equation for p[0..2] to hint the solver
1574
1575 int r3 = Georef_Calculate_Coefficients_Onedir(
1576 cp->count, mp_lon, cp->lon, cp->lat, cp->tx, cp->wpx,
1577 cp->txmin -
1578 ((cp->txmax - cp->txmin) * cp->lonmin / (cp->lonmax - cp->lonmin)),
1579 (cp->txmax - cp->txmin) / (cp->lonmax - cp->lonmin), 0.0);
1580
1581 // if blin_lon > 0, force cross terms in latitude equation coefficients
1582 // to be zero by making ty not dependent on lon,
1583 px = nlin_lon ? &pnull[0] : cp->lon;
1584
1585 int r4 = Georef_Calculate_Coefficients_Onedir(
1586 cp->count, mp_lat, &pnull[0] /*cp->lon*/, cp->lat, cp->ty, cp->wpy,
1587 cp->tymin -
1588 ((cp->tymax - cp->tymin) * cp->latmin / (cp->latmax - cp->latmin)),
1589 0.0, (cp->tymax - cp->tymin) / (cp->latmax - cp->latmin));
1590
1591 if ((r1) && (r1 < 4) && (r2) && (r2 < 4) && (r3) && (r3 < 4) && (r4) &&
1592 (r4 < 4))
1593 return 0;
1594
1595 return 1;
1596}
1597
1598int Georef_Calculate_Coefficients_Proj(struct GeoRef *cp) {
1599 int r1, r2, r3, r4;
1600 int mp;
1601
1602 // Zero out the points
1603 cp->pwx[6] = cp->pwy[6] = cp->wpx[6] = cp->wpy[6] = 0.;
1604 cp->pwx[7] = cp->pwy[7] = cp->wpx[7] = cp->wpy[7] = 0.;
1605 cp->pwx[8] = cp->pwy[8] = cp->wpx[8] = cp->wpy[8] = 0.;
1606 cp->pwx[9] = cp->pwy[9] = cp->wpx[9] = cp->wpy[9] = 0.;
1607 cp->pwx[3] = cp->pwy[3] = cp->wpx[3] = cp->wpy[3] = 0.;
1608 cp->pwx[4] = cp->pwy[4] = cp->wpx[4] = cp->wpy[4] = 0.;
1609 cp->pwx[5] = cp->pwy[5] = cp->wpx[5] = cp->wpy[5] = 0.;
1610 cp->pwx[0] = cp->pwy[0] = cp->wpx[0] = cp->wpy[0] = 0.;
1611 cp->pwx[1] = cp->pwy[1] = cp->wpx[1] = cp->wpy[1] = 0.;
1612 cp->pwx[2] = cp->pwy[2] = cp->wpx[2] = cp->wpy[2] = 0.;
1613
1614 mp = 3;
1615
1616 // pixel(tx,ty) to (northing,easting)
1617 // Calculate and use a linear equation for p[0..2] to hint the solver
1618
1619 r1 = Georef_Calculate_Coefficients_Onedir(
1620 cp->count, mp, cp->tx, cp->ty, cp->lon, cp->pwx,
1621 cp->lonmin -
1622 (cp->txmin * (cp->lonmax - cp->lonmin) / (cp->txmax - cp->txmin)),
1623 (cp->lonmax - cp->lonmin) / (cp->txmax - cp->txmin), 0.);
1624
1625 r2 = Georef_Calculate_Coefficients_Onedir(
1626 cp->count, mp, cp->tx, cp->ty, cp->lat, cp->pwy,
1627 cp->latmin -
1628 (cp->tymin * (cp->latmax - cp->latmin) / (cp->tymax - cp->tymin)),
1629 0., (cp->latmax - cp->latmin) / (cp->tymax - cp->tymin));
1630
1631 // (northing/easting) to pixel(tx,ty)
1632 // Calculate and use a linear equation for p[0..2] to hint the solver
1633
1634 r3 = Georef_Calculate_Coefficients_Onedir(
1635 cp->count, mp, cp->lon, cp->lat, cp->tx, cp->wpx,
1636 cp->txmin -
1637 ((cp->txmax - cp->txmin) * cp->lonmin / (cp->lonmax - cp->lonmin)),
1638 (cp->txmax - cp->txmin) / (cp->lonmax - cp->lonmin), 0.0);
1639
1640 r4 = Georef_Calculate_Coefficients_Onedir(
1641 cp->count, mp, cp->lon, cp->lat, cp->ty, cp->wpy,
1642 cp->tymin -
1643 ((cp->tymax - cp->tymin) * cp->latmin / (cp->latmax - cp->latmin)),
1644 0.0, (cp->tymax - cp->tymin) / (cp->latmax - cp->latmin));
1645
1646 if ((r1) && (r1 < 4) && (r2) && (r2 < 4) && (r3) && (r3 < 4) && (r4) &&
1647 (r4 < 4))
1648 return 0;
1649 else
1650 return 1;
1651}
1652
1653/*
1654 * This file contains default implementation of the evaluate and printout
1655 * routines. In most cases, customization of lmfit can be done by modifying
1656 * these two routines. Either modify them here, or copy and rename them.
1657 */
1658
1659void lm_evaluate_default(double *par, int m_dat, double *fvec, void *data,
1660 int *info)
1661/*
1662 * par is an input array. At the end of the minimization, it contains
1663 * the approximate solution vector.
1664 *
1665 * m_dat is a positive integer input variable set to the number
1666 * of functions.
1667 *
1668 * fvec is an output array of length m_dat which contains the function
1669 * values the square sum of which ought to be minimized.
1670 *
1671 * data is a read-only pointer to lm_data_type, as specified by lmuse.h.
1672 *
1673 * info is an integer output variable. If set to a negative value, the
1674 * minimization procedure will stop.
1675 */
1676{
1677 lm_data_type *mydata = (lm_data_type *)data;
1678
1679 for (int i = 0; i < m_dat; i++) {
1680 fvec[i] = mydata->user_y[i] - mydata->user_func(mydata->user_tx[i],
1681 mydata->user_ty[i],
1682 mydata->n_par, par);
1683 }
1684 *info = *info; /* to prevent a 'unused variable' warning */
1685 /* if <parameters drifted away> { *info = -1; } */
1686}
1687
1688void lm_print_default(int n_par, double *par, int m_dat, double *fvec,
1689 void *data, int iflag, int iter, int nfev)
1690/*
1691 * data : for soft control of printout behaviour, add control
1692 * variables to the data struct
1693 * iflag : 0 (init) 1 (outer loop) 2(inner loop) -1(terminated)
1694 * iter : outer loop counter
1695 * nfev : number of calls to *evaluate
1696 */
1697{
1698 lm_data_type *mydata = (lm_data_type *)data;
1699
1700 if (mydata->print_flag) {
1701 if (iflag == 2) {
1702 printf("trying step in gradient direction\n");
1703 } else if (iflag == 1) {
1704 printf("determining gradient (iteration %d)\n", iter);
1705 } else if (iflag == 0) {
1706 printf("starting minimization\n");
1707 } else if (iflag == -1) {
1708 printf("terminated after %d evaluations\n", nfev);
1709 }
1710
1711 printf(" par: ");
1712 for (int i = 0; i < n_par; ++i) printf(" %12g", par[i]);
1713 printf(" => norm: %12g\n", lm_enorm(m_dat, fvec));
1714
1715 if (iflag == -1) {
1716 printf(" fitting data as follows:\n");
1717 for (int i = 0; i < m_dat; ++i) {
1718 const double tx = (mydata->user_tx)[i];
1719 const double ty = (mydata->user_ty)[i];
1720 const double y = (mydata->user_y)[i];
1721 const double f = mydata->user_func(tx, ty, mydata->n_par, par);
1722 printf(
1723 " tx[%2d]=%8g ty[%2d]=%8g y=%12g fit=%12g "
1724 "residue=%12g\n",
1725 i, tx, i, ty, y, f, y - f);
1726 }
1727 }
1728 } // if print_flag
1729}
1730
1732
1733/* *********************** high-level interface **************************** */
1734
1735void lm_initialize_control(lm_control_type *control) {
1736 control->maxcall = 100;
1737 control->epsilon = 1.e-10; // 1.e-14;
1738 control->stepbound = 100; // 100.;
1739 control->ftol = 1.e-14;
1740 control->xtol = 1.e-14;
1741 control->gtol = 1.e-14;
1742}
1743
1744void lm_minimize(int m_dat, int n_par, double *par, lm_evaluate_ftype *evaluate,
1745 lm_print_ftype *printout, void *data,
1746 lm_control_type *control) {
1747 std::vector<double> fvec(m_dat);
1748 std::vector<double> diag(n_par);
1749 std::vector<double> qtf(n_par);
1750 std::vector<double> fjac(n_par * m_dat);
1751 std::vector<double> wa1(n_par);
1752 std::vector<double> wa2(n_par);
1753 std::vector<double> wa3(n_par);
1754 std::vector<double> wa4(m_dat);
1755 std::vector<int> ipvt(n_par);
1756
1757 // *** perform fit.
1758
1759 control->info = 0;
1760 control->nfev = 0;
1761
1762 // this goes through the modified legacy interface:
1763 lm_lmdif(m_dat, n_par, par, &fvec[0], control->ftol, control->xtol,
1764 control->gtol, control->maxcall * (n_par + 1), control->epsilon,
1765 &diag[0], 1, control->stepbound, &(control->info), &(control->nfev),
1766 &fjac[0], &ipvt[0], &qtf[0], &wa1[0], &wa2[0], &wa3[0], &wa4[0],
1767 evaluate, printout, data);
1768
1769 (*printout)(n_par, par, m_dat, &fvec[0], data, -1, 0, control->nfev);
1770 control->fnorm = lm_enorm(m_dat, &fvec[0]);
1771 if (control->info < 0) control->info = 10;
1772}
1773
1774// ***** the following messages are referenced by the variable info.
1775
1776const char *lm_infmsg[] = {
1777 "improper input parameters",
1778 "the relative error in the sum of squares is at most tol",
1779 "the relative error between x and the solution is at most tol",
1780 "both errors are at most tol",
1781 "fvec is orthogonal to the columns of the jacobian to machine precision",
1782 "number of calls to fcn has reached or exceeded 200*(n+1)",
1783 "ftol is too small. no further reduction in the sum of squares is possible",
1784 "xtol too small. no further improvement in approximate solution x possible",
1785 "gtol too small. no further improvement in approximate solution x possible",
1786 "not enough memory",
1787 "break requested within function evaluation"};
1788
1789const char *lm_shortmsg[] = {"invalid input", "success (f)", "success (p)",
1790 "success (f,p)", "degenerate", "call limit",
1791 "failed (f)", "failed (p)", "failed (o)",
1792 "no memory", "user break"};
1793
1794/* ************************** implementation ******************************* */
1795
1796#define BUG 0
1797#if BUG
1798#include <stdio.h>
1799#endif
1800
1801// the following values seem good for an x86:
1802//#define LM_MACHEP .555e-16 /* resolution of arithmetic */
1803//#define LM_DWARF 9.9e-324 /* smallest nonzero number */
1804// the follwoing values should work on any machine:
1805#define LM_MACHEP 1.2e-16
1806#define LM_DWARF 1.0e-38
1807
1808// the squares of the following constants shall not under/overflow:
1809// these values seem good for an x86:
1810//#define LM_SQRT_DWARF 1.e-160
1811//#define LM_SQRT_GIANT 1.e150
1812// the following values should work on any machine:
1813#define LM_SQRT_DWARF 3.834e-20
1814#define LM_SQRT_GIANT 1.304e19
1815
1816void lm_qrfac(int m, int n, double *a, int pivot, int *ipvt, double *rdiag,
1817 double *acnorm, double *wa);
1818void lm_qrsolv(int n, double *r, int ldr, int *ipvt, double *diag, double *qtb,
1819 double *x, double *sdiag, double *wa);
1820void lm_lmpar(int n, double *r, int ldr, int *ipvt, double *diag, double *qtb,
1821 double delta, double *par, double *x, double *sdiag, double *wa1,
1822 double *wa2);
1823
1824#define MIN(a, b) (((a) <= (b)) ? (a) : (b))
1825#define MAX(a, b) (((a) >= (b)) ? (a) : (b))
1826#define SQR(x) (x) * (x)
1827
1828// ***** the low-level legacy interface for full control.
1829
1830void lm_lmdif(int m, int n, double *x, double *fvec, double ftol, double xtol,
1831 double gtol, int maxfev, double epsfcn, double *diag, int mode,
1832 double factor, int *info, int *nfev, double *fjac, int *ipvt,
1833 double *qtf, double *wa1, double *wa2, double *wa3, double *wa4,
1834 lm_evaluate_ftype *evaluate, lm_print_ftype *printout,
1835 void *data) {
1836 /*
1837 * the purpose of lmdif is to minimize the sum of the squares of
1838 * m nonlinear functions in n variables by a modification of
1839 * the levenberg-marquardt algorithm. the user must provide a
1840 * subroutine evaluate which calculates the functions. the jacobian
1841 * is then calculated by a forward-difference approximation.
1842 *
1843 * the multi-parameter interface lm_lmdif is for users who want
1844 * full control and flexibility. most users will be better off using
1845 * the simpler interface lmfit provided above.
1846 *
1847 * the parameters are the same as in the legacy FORTRAN implementation,
1848 * with the following exceptions:
1849 * the old parameter ldfjac which gave leading dimension of fjac has
1850 * been deleted because this C translation makes no use of two-
1851 * dimensional arrays;
1852 * the old parameter nprint has been deleted; printout is now controlled
1853 * by the user-supplied routine *printout;
1854 * the parameter field *data and the function parameters *evaluate and
1855 * *printout have been added; they help avoiding global variables.
1856 *
1857 * parameters:
1858 *
1859 * m is a positive integer input variable set to the number
1860 * of functions.
1861 *
1862 * n is a positive integer input variable set to the number
1863 * of variables. n must not exceed m.
1864 *
1865 * x is an array of length n. on input x must contain
1866 * an initial estimate of the solution vector. on output x
1867 * contains the final estimate of the solution vector.
1868 *
1869 * fvec is an output array of length m which contains
1870 * the functions evaluated at the output x.
1871 *
1872 * ftol is a nonnegative input variable. termination
1873 * occurs when both the actual and predicted relative
1874 * reductions in the sum of squares are at most ftol.
1875 * therefore, ftol measures the relative error desired
1876 * in the sum of squares.
1877 *
1878 * xtol is a nonnegative input variable. termination
1879 * occurs when the relative error between two consecutive
1880 * iterates is at most xtol. therefore, xtol measures the
1881 * relative error desired in the approximate solution.
1882 *
1883 * gtol is a nonnegative input variable. termination
1884 * occurs when the cosine of the angle between fvec and
1885 * any column of the jacobian is at most gtol in absolute
1886 * value. therefore, gtol measures the orthogonality
1887 * desired between the function vector and the columns
1888 * of the jacobian.
1889 *
1890 * maxfev is a positive integer input variable. termination
1891 * occurs when the number of calls to lm_fcn is at least
1892 * maxfev by the end of an iteration.
1893 *
1894 * epsfcn is an input variable used in determining a suitable
1895 * step length for the forward-difference approximation. this
1896 * approximation assumes that the relative errors in the
1897 * functions are of the order of epsfcn. if epsfcn is less
1898 * than the machine precision, it is assumed that the relative
1899 * errors in the functions are of the order of the machine
1900 * precision.
1901 *
1902 * diag is an array of length n. if mode = 1 (see below), diag is
1903 * internally set. if mode = 2, diag must contain positive entries
1904 * that serve as multiplicative scale factors for the variables.
1905 *
1906 * mode is an integer input variable. if mode = 1, the
1907 * variables will be scaled internally. if mode = 2,
1908 * the scaling is specified by the input diag. other
1909 * values of mode are equivalent to mode = 1.
1910 *
1911 * factor is a positive input variable used in determining the
1912 * initial step bound. this bound is set to the product of
1913 * factor and the euclidean norm of diag*x if nonzero, or else
1914 * to factor itself. in most cases factor should lie in the
1915 * interval (.1,100.). 100. is a generally recommended value.
1916 *
1917 * info is an integer output variable that indicates the termination
1918 * status of lm_lmdif as follows:
1919 *
1920 * info < 0 termination requested by user-supplied routine *evaluate;
1921 *
1922 * info = 0 improper input parameters;
1923 *
1924 * info = 1 both actual and predicted relative reductions
1925 * in the sum of squares are at most ftol;
1926 *
1927 * info = 2 relative error between two consecutive iterates
1928 * is at most xtol;
1929 *
1930 * info = 3 conditions for info = 1 and info = 2 both hold;
1931 *
1932 * info = 4 the cosine of the angle between fvec and any
1933 * column of the jacobian is at most gtol in
1934 * absolute value;
1935 *
1936 * info = 5 number of calls to lm_fcn has reached or
1937 * exceeded maxfev;
1938 *
1939 * info = 6 ftol is too small. no further reduction in
1940 * the sum of squares is possible;
1941 *
1942 * info = 7 xtol is too small. no further improvement in
1943 * the approximate solution x is possible;
1944 *
1945 * info = 8 gtol is too small. fvec is orthogonal to the
1946 * columns of the jacobian to machine precision;
1947 *
1948 * nfev is an output variable set to the number of calls to the
1949 * user-supplied routine *evaluate.
1950 *
1951 * fjac is an output m by n array. the upper n by n submatrix
1952 * of fjac contains an upper triangular matrix r with
1953 * diagonal elements of nonincreasing magnitude such that
1954 *
1955 * t t t
1956 * p *(jac *jac)*p = r *r,
1957 *
1958 * where p is a permutation matrix and jac is the final
1959 * calculated jacobian. column j of p is column ipvt(j)
1960 * (see below) of the identity matrix. the lower trapezoidal
1961 * part of fjac contains information generated during
1962 * the computation of r.
1963 *
1964 * ipvt is an integer output array of length n. ipvt
1965 * defines a permutation matrix p such that jac*p = q*r,
1966 * where jac is the final calculated jacobian, q is
1967 * orthogonal (not stored), and r is upper triangular
1968 * with diagonal elements of nonincreasing magnitude.
1969 * column j of p is column ipvt(j) of the identity matrix.
1970 *
1971 * qtf is an output array of length n which contains
1972 * the first n elements of the vector (q transpose)*fvec.
1973 *
1974 * wa1, wa2, and wa3 are work arrays of length n.
1975 *
1976 * wa4 is a work array of length m.
1977 *
1978 * the following parameters are newly introduced in this C translation:
1979 *
1980 * evaluate is the name of the subroutine which calculates the functions.
1981 * a default implementation lm_evaluate_default is provided in
1982 * lm_eval.c; alternatively, evaluate can be provided by a user calling
1983 * program. it should be written as follows:
1984 *
1985 * void evaluate ( double* par, int m_dat, double* fvec,
1986 * void *data, int *info )
1987 * {
1988 * // for ( i=0; i<m_dat; ++i )
1989 * // calculate fvec[i] for given parameters par;
1990 * // to stop the minimization,
1991 * // set *info to a negative integer.
1992 * }
1993 *
1994 * printout is the name of the subroutine which nforms about fit
1995 * progress. a default implementation lm_print_default is provided in
1996 * lm_eval.c; alternatively, printout can be provided by a user calling
1997 * program. it should be written as follows:
1998 *
1999 * void printout ( int n_par, double* par, int m_dat, double* fvec,
2000 * void *data, int iflag, int iter, int nfev )
2001 * {
2002 * // iflag : 0 (init) 1 (outer loop) 2(inner loop) -1(terminated)
2003 * // iter : outer loop counter
2004 * // nfev : number of calls to *evaluate
2005 * }
2006 *
2007 * data is an input pointer to an arbitrary structure that is passed to
2008 * evaluate. typically, it contains experimental data to be fitted.
2009 *
2010 */
2011
2012 *nfev = 0; // function evaluation counter
2013
2014 // *** check the input parameters for errors.
2015
2016 if ((n <= 0) || (m < n) || (ftol < 0.) || (xtol < 0.) || (gtol < 0.) ||
2017 (maxfev <= 0) || (factor <= 0.)) {
2018 *info = 0; // invalid parameter
2019 return;
2020 }
2021
2022 if (mode == 2) /* scaling by diag[] */
2023 {
2024 for (int j = 0; j < n; j++) /* check for non positive elements */
2025 {
2026 if (diag[j] <= 0.0) {
2027 *info = 0; // invalid parameter
2028 return;
2029 }
2030 }
2031 }
2032#if BUG
2033 printf("lmdif\n");
2034#endif
2035
2036 // *** evaluate the function at the starting point and calculate its norm.
2037
2038 *info = 0;
2039 (*evaluate)(x, m, fvec, data, info);
2040 (*printout)(n, x, m, fvec, data, 0, 0, ++(*nfev));
2041 if (*info < 0) return;
2042
2043 // *** the outer loop.
2044 int iter = 1; // outer loop counter
2045 double delta =
2046 0.0; // just to prevent a warning (initialization within if-clause)
2047 double xnorm = 0.0;
2048 double fnorm = lm_enorm(m, fvec);
2049 const double eps = sqrt(MAX(
2050 epsfcn,
2051 LM_MACHEP)); // used in calculating the Jacobian by forward differences
2052
2053 do {
2054#if BUG
2055 printf("lmdif/ outer loop iter=%d nfev=%d fnorm=%.10e\n", iter, *nfev,
2056 fnorm);
2057#endif
2058
2059 // O** calculate the jacobian matrix.
2060
2061 for (int j = 0; j < n; j++) {
2062 const double temp = x[j];
2063 const double step = eps * fabs(temp) == 0.0 ? eps : eps * fabs(temp);
2064
2065 x[j] = temp + step;
2066 *info = 0;
2067 (*evaluate)(x, m, wa4, data, info);
2068 (*printout)(n, x, m, wa4, data, 1, iter, ++(*nfev));
2069 if (*info < 0) return; // user requested break
2070 x[j] = temp;
2071 for (int i = 0; i < m; i++) fjac[j * m + i] = (wa4[i] - fvec[i]) / step;
2072 }
2073#if BUG > 1
2074 // DEBUG: print the entire matrix
2075 for (i = 0; i < m; i++) {
2076 for (j = 0; j < n; j++) printf("%.5e ", y[j * m + i]);
2077 printf("\n");
2078 }
2079#endif
2080
2081 // O** compute the qr factorization of the jacobian.
2082
2083 lm_qrfac(m, n, fjac, 1, ipvt, wa1, wa2, wa3);
2084
2085 // O** on the first iteration ...
2086
2087 if (iter == 1) {
2088 if (mode != 2)
2089 // ... scale according to the norms of the columns of the initial
2090 // jacobian.
2091 {
2092 for (int j = 0; j < n; j++) {
2093 diag[j] = wa2[j];
2094 if (wa2[j] == 0.) diag[j] = 1.;
2095 }
2096 }
2097
2098 // ... calculate the norm of the scaled x and
2099 // initialize the step bound delta.
2100
2101 for (int j = 0; j < n; j++) wa3[j] = diag[j] * x[j];
2102
2103 xnorm = lm_enorm(n, wa3);
2104 delta = factor * xnorm;
2105 if (delta == 0.) delta = factor;
2106 }
2107
2108 // O** form (q transpose)*fvec and store the first n components in qtf.
2109
2110 for (int i = 0; i < m; i++) wa4[i] = fvec[i];
2111
2112 for (int j = 0; j < n; j++) {
2113 double temp3 = fjac[j * m + j];
2114 if (temp3 != 0.) {
2115 double sum = 0.0;
2116 for (int i = j; i < m; i++) sum += fjac[j * m + i] * wa4[i];
2117 double temp = -sum / temp3;
2118 for (int i = j; i < m; i++) wa4[i] += fjac[j * m + i] * temp;
2119 }
2120 fjac[j * m + j] = wa1[j];
2121 qtf[j] = wa4[j];
2122 }
2123
2124 // O** compute the norm of the scaled gradient and test for convergence.
2125
2126 double gnorm = 0;
2127 if (fnorm != 0) {
2128 for (int j = 0; j < n; j++) {
2129 if (wa2[ipvt[j]] == 0) continue;
2130
2131 double sum = 0.0;
2132 for (int i = 0; i <= j; i++) sum += fjac[j * m + i] * qtf[i] / fnorm;
2133 gnorm = MAX(gnorm, fabs(sum / wa2[ipvt[j]]));
2134 }
2135 }
2136
2137 if (gnorm <= gtol) {
2138 *info = 4;
2139 return;
2140 }
2141
2142 // O** rescale if necessary.
2143
2144 if (mode != 2) {
2145 for (int j = 0; j < n; j++) diag[j] = MAX(diag[j], wa2[j]);
2146 }
2147
2148 // O** the inner loop.
2149 const double kP0001 = 1.0e-4;
2150 double ratio = 0.0;
2151 do {
2152#if BUG
2153 printf("lmdif/ inner loop iter=%d nfev=%d\n", iter, *nfev);
2154#endif
2155
2156 // OI* determine the levenberg-marquardt parameter.
2157 double par = 0; // levenberg-marquardt parameter
2158 lm_lmpar(n, fjac, m, ipvt, diag, qtf, delta, &par, wa1, wa2, wa3, wa4);
2159
2160 // OI* store the direction p and x + p. calculate the norm of p.
2161
2162 for (int j = 0; j < n; j++) {
2163 wa1[j] = -wa1[j];
2164 wa2[j] = x[j] + wa1[j];
2165 wa3[j] = diag[j] * wa1[j];
2166 }
2167 double pnorm = lm_enorm(n, wa3);
2168
2169 // OI* on the first iteration, adjust the initial step bound.
2170
2171 if (*nfev <= 1 + n) // bug corrected by J. Wuttke in 2004
2172 delta = MIN(delta, pnorm);
2173
2174 // OI* evaluate the function at x + p and calculate its norm.
2175
2176 *info = 0;
2177 (*evaluate)(wa2, m, wa4, data, info);
2178 (*printout)(n, x, m, wa4, data, 2, iter, ++(*nfev));
2179 if (*info < 0) return; // user requested break
2180
2181 double fnorm1 = lm_enorm(m, wa4);
2182#if BUG
2183 printf(
2184 "lmdif/ pnorm %.10e fnorm1 %.10e fnorm %.10e"
2185 " delta=%.10e par=%.10e\n",
2186 pnorm, fnorm1, fnorm, delta, par);
2187#endif
2188
2189 // OI* compute the scaled actual reduction.
2190 const double kP1 = 0.1;
2191 const double actred = kP1 * fnorm1 < fnorm ? 1 - SQR(fnorm1 / fnorm) : -1;
2192
2193 // OI* compute the scaled predicted reduction and
2194 // the scaled directional derivative.
2195
2196 for (int j = 0; j < n; j++) {
2197 wa3[j] = 0;
2198 for (int i = 0; i <= j; i++) wa3[i] += fjac[j * m + i] * wa1[ipvt[j]];
2199 }
2200 const double temp1 = lm_enorm(n, wa3) / fnorm;
2201 const double temp2 = sqrt(par) * pnorm / fnorm;
2202 const double prered = SQR(temp1) + 2 * SQR(temp2);
2203 const double dirder = -(SQR(temp1) + SQR(temp2));
2204
2205 // OI* compute the ratio of the actual to the predicted reduction.
2206
2207 ratio = prered != 0 ? actred / prered : 0.0;
2208#if BUG
2209 printf(
2210 "lmdif/ actred=%.10e prered=%.10e ratio=%.10e"
2211 " sq(1)=%.10e sq(2)=%.10e dd=%.10e\n",
2212 actred, prered, prered != 0 ? ratio : 0., SQR(temp1), SQR(temp2),
2213 dirder);
2214#endif
2215
2216 // OI* update the step bound.
2217 const double kP5 = 0.5;
2218 const double kP25 = 0.25;
2219 const double kP75 = 0.75;
2220
2221 if (ratio <= kP25) {
2222 double temp =
2223 actred >= 0.0 ? kP5 : kP5 * dirder / (dirder + kP5 * actred);
2224 if (kP1 * fnorm1 >= fnorm || temp < kP1) temp = kP1;
2225 delta = temp * MIN(delta, pnorm / kP1);
2226 par /= temp;
2227 } else if (par == 0. || ratio >= kP75) {
2228 delta = pnorm / kP5;
2229 par *= kP5;
2230 }
2231
2232 // OI* test for successful iteration...
2233 if (ratio >= kP0001) {
2234 // ... successful iteration. update x, fvec, and their norms.
2235
2236 for (int j = 0; j < n; j++) {
2237 x[j] = wa2[j];
2238 wa2[j] = diag[j] * x[j];
2239 }
2240 for (int i = 0; i < m; i++) fvec[i] = wa4[i];
2241 xnorm = lm_enorm(n, wa2);
2242 fnorm = fnorm1;
2243 iter++;
2244 }
2245#if BUG
2246 else {
2247 printf("ATTN: iteration considered unsuccessful\n");
2248 }
2249#endif
2250
2251 // OI* tests for convergence ( otherwise *info = 1, 2, or 3 )
2252
2253 *info = 0; // do not terminate (unless overwritten by nonzero value)
2254 if (fabs(actred) <= ftol && prered <= ftol && kP5 * ratio <= 1) *info = 1;
2255 if (delta <= xtol * xnorm) *info += 2;
2256 if (*info != 0) return;
2257
2258 // OI* tests for termination and stringent tolerances.
2259
2260 if (*nfev >= maxfev) *info = 5;
2261 if (fabs(actred) <= LM_MACHEP && prered <= LM_MACHEP && kP5 * ratio <= 1)
2262 *info = 6;
2263 if (delta <= LM_MACHEP * xnorm) *info = 7;
2264 if (gnorm <= LM_MACHEP) *info = 8;
2265 if (*info != 0) return;
2266
2267 // OI* end of the inner loop. repeat if iteration unsuccessful.
2268
2269 } while (ratio < kP0001);
2270
2271 // O** end of the outer loop.
2272
2273 } while (1);
2274}
2275
2276void lm_lmpar(int n, double *r, int ldr, int *ipvt, double *diag, double *qtb,
2277 double delta, double *par, double *x, double *sdiag, double *wa1,
2278 double *wa2) {
2279 /* given an m by n matrix a, an n by n nonsingular diagonal
2280 * matrix d, an m-vector b, and a positive number delta,
2281 * the problem is to determine a value for the parameter
2282 * par such that if x solves the system
2283 *
2284 * a*x = b , sqrt(par)*d*x = 0 ,
2285 *
2286 * in the least squares sense, and dxnorm is the euclidean
2287 * norm of d*x, then either par is 0. and
2288 *
2289 * (dxnorm-delta) .le. 0.1*delta ,
2290 *
2291 * or par is positive and
2292 *
2293 * abs(dxnorm-delta) .le. 0.1*delta .
2294 *
2295 * this subroutine completes the solution of the problem
2296 * if it is provided with the necessary information from the
2297 * qr factorization, with column pivoting, of a. that is, if
2298 * a*p = q*r, where p is a permutation matrix, q has orthogonal
2299 * columns, and r is an upper triangular matrix with diagonal
2300 * elements of nonincreasing magnitude, then lmpar expects
2301 * the full upper triangle of r, the permutation matrix p,
2302 * and the first n components of (q transpose)*b. on output
2303 * lmpar also provides an upper triangular matrix s such that
2304 *
2305 * t t t
2306 * p *(a *a + par*d*d)*p = s *s .
2307 *
2308 * s is employed within lmpar and may be of separate interest.
2309 *
2310 * only a few iterations are generally needed for convergence
2311 * of the algorithm. if, however, the limit of 10 iterations
2312 * is reached, then the output par will contain the best
2313 * value obtained so far.
2314 *
2315 * parameters:
2316 *
2317 * n is a positive integer input variable set to the order of r.
2318 *
2319 * r is an n by n array. on input the full upper triangle
2320 * must contain the full upper triangle of the matrix r.
2321 * on output the full upper triangle is unaltered, and the
2322 * strict lower triangle contains the strict upper triangle
2323 * (transposed) of the upper triangular matrix s.
2324 *
2325 * ldr is a positive integer input variable not less than n
2326 * which specifies the leading dimension of the array r.
2327 *
2328 * ipvt is an integer input array of length n which defines the
2329 * permutation matrix p such that a*p = q*r. column j of p
2330 * is column ipvt(j) of the identity matrix.
2331 *
2332 * diag is an input array of length n which must contain the
2333 * diagonal elements of the matrix d.
2334 *
2335 * qtb is an input array of length n which must contain the first
2336 * n elements of the vector (q transpose)*b.
2337 *
2338 * delta is a positive input variable which specifies an upper
2339 * bound on the euclidean norm of d*x.
2340 *
2341 * par is a nonnegative variable. on input par contains an
2342 * initial estimate of the levenberg-marquardt parameter.
2343 * on output par contains the final estimate.
2344 *
2345 * x is an output array of length n which contains the least
2346 * squares solution of the system a*x = b, sqrt(par)*d*x = 0,
2347 * for the output par.
2348 *
2349 * sdiag is an output array of length n which contains the
2350 * diagonal elements of the upper triangular matrix s.
2351 *
2352 * wa1 and wa2 are work arrays of length n.
2353 *
2354 */
2355
2356#if BUG
2357 printf("lmpar\n");
2358#endif
2359
2360 // *** compute and store in x the gauss-newton direction. if the
2361 // jacobian is rank-deficient, obtain a least squares solution.
2362
2363 int nsing = n;
2364 for (int j = 0; j < n; j++) {
2365 wa1[j] = qtb[j];
2366 if (r[j * ldr + j] == 0 && nsing == n) nsing = j;
2367 if (nsing < n) wa1[j] = 0;
2368 }
2369#if BUG
2370 printf("nsing %d ", nsing);
2371#endif
2372 for (int j = nsing - 1; j >= 0; j--) {
2373 wa1[j] = wa1[j] / r[j + ldr * j];
2374 const double temp = wa1[j];
2375 for (int i = 0; i < j; i++) wa1[i] -= r[j * ldr + i] * temp;
2376 }
2377
2378 for (int j = 0; j < n; j++) x[ipvt[j]] = wa1[j];
2379
2380 // *** initialize the iteration counter.
2381 // evaluate the function at the origin, and test
2382 // for acceptance of the gauss-newton direction.
2383
2384 int iter = 0;
2385 for (int j = 0; j < n; j++) wa2[j] = diag[j] * x[j];
2386
2387 double dxnorm = lm_enorm(n, wa2);
2388 double fp = dxnorm - delta;
2389 const double kP1 = 0.1;
2390 if (fp <= kP1 * delta) {
2391#if BUG
2392 printf("lmpar/ terminate (fp<delta/10\n");
2393#endif
2394 *par = 0;
2395 return;
2396 }
2397
2398 // *** if the jacobian is not rank deficient, the newton
2399 // step provides a lower bound, parl, for the 0. of
2400 // the function. otherwise set this bound to 0..
2401
2402 double parl = 0.0;
2403 if (nsing >= n) {
2404 for (int j = 0; j < n; j++) wa1[j] = diag[ipvt[j]] * wa2[ipvt[j]] / dxnorm;
2405
2406 for (int j = 0; j < n; j++) {
2407 double sum = 0.0;
2408 for (int i = 0; i < j; i++) sum += r[j * ldr + i] * wa1[i];
2409 wa1[j] = (wa1[j] - sum) / r[j + ldr * j];
2410 }
2411 const double temp = lm_enorm(n, wa1);
2412 parl = fp / delta / temp / temp;
2413 }
2414
2415 // *** calculate an upper bound, paru, for the 0. of the function.
2416
2417 for (int j = 0; j < n; j++) {
2418 double sum = 0;
2419 for (int i = 0; i <= j; i++) sum += r[j * ldr + i] * qtb[i];
2420 wa1[j] = sum / diag[ipvt[j]];
2421 }
2422 const double gnorm = lm_enorm(n, wa1);
2423 double paru =
2424 gnorm / delta == 0.0 ? LM_DWARF / MIN(delta, kP1) : gnorm / delta;
2425
2426 // *** if the input par lies outside of the interval (parl,paru),
2427 // set par to the closer endpoint.
2428
2429 *par = MAX(*par, parl);
2430 *par = MIN(*par, paru);
2431 if (*par == 0.) *par = gnorm / dxnorm;
2432#if BUG
2433 printf("lmpar/ parl %.4e par %.4e paru %.4e\n", parl, *par, paru);
2434#endif
2435
2436 // *** iterate.
2437
2438 for (;; iter++) {
2439 // *** evaluate the function at the current value of par.
2440 const double kP001 = 0.001;
2441 if (*par == 0.) *par = MAX(LM_DWARF, kP001 * paru);
2442 double temp = sqrt(*par);
2443 for (int j = 0; j < n; j++) wa1[j] = temp * diag[j];
2444 lm_qrsolv(n, r, ldr, ipvt, wa1, qtb, x, sdiag, wa2);
2445 for (int j = 0; j < n; j++) wa2[j] = diag[j] * x[j];
2446 dxnorm = lm_enorm(n, wa2);
2447 const double fp_old = fp;
2448 fp = dxnorm - delta;
2449
2450 // *** if the function is small enough, accept the current value
2451 // of par. also test for the exceptional cases where parl
2452 // is 0. or the number of iterations has reached 10.
2453
2454 if (fabs(fp) <= kP1 * delta ||
2455 (parl == 0. && fp <= fp_old && fp_old < 0.) || iter == 10)
2456 break; // the only exit from this loop
2457
2458 // *** compute the Newton correction.
2459
2460 for (int j = 0; j < n; j++) wa1[j] = diag[ipvt[j]] * wa2[ipvt[j]] / dxnorm;
2461
2462 for (int j = 0; j < n; j++) {
2463 wa1[j] = wa1[j] / sdiag[j];
2464 for (int i = j + 1; i < n; i++) wa1[i] -= r[j * ldr + i] * wa1[j];
2465 }
2466 temp = lm_enorm(n, wa1);
2467 double parc = fp / delta / temp / temp;
2468
2469 // *** depending on the sign of the function, update parl or paru.
2470
2471 if (fp > 0)
2472 parl = MAX(parl, *par);
2473 else if (fp < 0)
2474 paru = MIN(paru, *par);
2475 // the case fp==0 is precluded by the break condition
2476
2477 // *** compute an improved estimate for par.
2478
2479 *par = MAX(parl, *par + parc);
2480 }
2481}
2482
2483void lm_qrfac(int m, int n, double *a, int pivot, int *ipvt, double *rdiag,
2484 double *acnorm, double *wa) {
2485 /*
2486 * this subroutine uses householder transformations with column
2487 * pivoting (optional) to compute a qr factorization of the
2488 * m by n matrix a. that is, qrfac determines an orthogonal
2489 * matrix q, a permutation matrix p, and an upper trapezoidal
2490 * matrix r with diagonal elements of nonincreasing magnitude,
2491 * such that a*p = q*r. the householder transformation for
2492 * column k, k = 1,2,...,min(m,n), is of the form
2493 *
2494 * t
2495 * i - (1/u(k))*u*u
2496 *
2497 * where u has 0.s in the first k-1 positions. the form of
2498 * this transformation and the method of pivoting first
2499 * appeared in the corresponding linpack subroutine.
2500 *
2501 * parameters:
2502 *
2503 * m is a positive integer input variable set to the number
2504 * of rows of a.
2505 *
2506 * n is a positive integer input variable set to the number
2507 * of columns of a.
2508 *
2509 * a is an m by n array. on input a contains the matrix for
2510 * which the qr factorization is to be computed. on output
2511 * the strict upper trapezoidal part of a contains the strict
2512 * upper trapezoidal part of r, and the lower trapezoidal
2513 * part of a contains a factored form of q (the non-trivial
2514 * elements of the u vectors described above).
2515 *
2516 * pivot is a logical input variable. if pivot is set true,
2517 * then column pivoting is enforced. if pivot is set false,
2518 * then no column pivoting is done.
2519 *
2520 * ipvt is an integer output array of length lipvt. ipvt
2521 * defines the permutation matrix p such that a*p = q*r.
2522 * column j of p is column ipvt(j) of the identity matrix.
2523 * if pivot is false, ipvt is not referenced.
2524 *
2525 * rdiag is an output array of length n which contains the
2526 * diagonal elements of r.
2527 *
2528 * acnorm is an output array of length n which contains the
2529 * norms of the corresponding columns of the input matrix a.
2530 * if this information is not needed, then acnorm can coincide
2531 * with rdiag.
2532 *
2533 * wa is a work array of length n. if pivot is false, then wa
2534 * can coincide with rdiag.
2535 *
2536 */
2537
2538 // *** compute the initial column norms and initialize several arrays.
2539
2540 for (int j = 0; j < n; j++) {
2541 acnorm[j] = lm_enorm(m, &a[j * m]);
2542 rdiag[j] = acnorm[j];
2543 wa[j] = rdiag[j];
2544 if (pivot) ipvt[j] = j;
2545 }
2546#if BUG
2547 printf("qrfac\n");
2548#endif
2549
2550 // *** reduce a to r with householder transformations.
2551
2552 const int minmn = MIN(m, n);
2553 for (int j = 0; j < minmn; j++) {
2554 int kmax = j, k;
2555 if (!pivot) goto pivot_ok;
2556
2557 // *** bring the column of largest norm into the pivot position.
2558
2559 for (k = j + 1; k < n; k++)
2560 if (rdiag[k] > rdiag[kmax]) kmax = k;
2561 if (kmax == j) goto pivot_ok; // bug fixed in rel 2.1
2562
2563 for (int i = 0; i < m; i++) {
2564 std::swap(a[j * m + i], a[kmax * m + i]);
2565 // const double temp = a[j*m+i];
2566 // a[j*m+i] = a[kmax*m+i];
2567 // a[kmax*m+i] = temp;
2568 }
2569 rdiag[kmax] = rdiag[j];
2570 wa[kmax] = wa[j];
2571 std::swap(ipvt[j], ipvt[kmax]);
2572 // k = ipvt[j];
2573 // ipvt[j] = ipvt[kmax];
2574 // ipvt[kmax] = k;
2575
2576 pivot_ok:
2577
2578 // *** compute the Householder transformation to reduce the
2579 // j-th column of a to a multiple of the j-th unit vector.
2580
2581 double ajnorm = lm_enorm(m - j, &a[j * m + j]);
2582 if (ajnorm == 0.) {
2583 rdiag[j] = 0;
2584 continue;
2585 }
2586
2587 if (a[j * m + j] < 0.) ajnorm = -ajnorm;
2588 for (int i = j; i < m; i++) a[j * m + i] /= ajnorm;
2589 a[j * m + j] += 1;
2590
2591 // *** apply the transformation to the remaining columns
2592 // and update the norms.
2593
2594 for (k = j + 1; k < n; k++) {
2595 double sum = 0;
2596
2597 for (int i = j; i < m; i++) sum += a[j * m + i] * a[k * m + i];
2598
2599 double temp = sum / a[j + m * j];
2600
2601 for (int i = j; i < m; i++) a[k * m + i] -= temp * a[j * m + i];
2602
2603 if (pivot && rdiag[k] != 0.) {
2604 temp = a[m * k + j] / rdiag[k];
2605 temp = MAX(0., 1 - temp * temp);
2606 rdiag[k] *= sqrt(temp);
2607 temp = rdiag[k] / wa[k];
2608 const double kP05 = 0.05;
2609 if (kP05 * SQR(temp) <= LM_MACHEP) {
2610 rdiag[k] = lm_enorm(m - j - 1, &a[m * k + j + 1]);
2611 wa[k] = rdiag[k];
2612 }
2613 }
2614 }
2615
2616 rdiag[j] = -ajnorm;
2617 }
2618}
2619
2620void lm_qrsolv(int n, double *r, int ldr, int *ipvt, double *diag, double *qtb,
2621 double *x, double *sdiag, double *wa) {
2622 /*
2623 * given an m by n matrix a, an n by n diagonal matrix d,
2624 * and an m-vector b, the problem is to determine an x which
2625 * solves the system
2626 *
2627 * a*x = b , d*x = 0 ,
2628 *
2629 * in the least squares sense.
2630 *
2631 * this subroutine completes the solution of the problem
2632 * if it is provided with the necessary information from the
2633 * qr factorization, with column pivoting, of a. that is, if
2634 * a*p = q*r, where p is a permutation matrix, q has orthogonal
2635 * columns, and r is an upper triangular matrix with diagonal
2636 * elements of nonincreasing magnitude, then qrsolv expects
2637 * the full upper triangle of r, the permutation matrix p,
2638 * and the first n components of (q transpose)*b. the system
2639 * a*x = b, d*x = 0, is then equivalent to
2640 *
2641 * t t
2642 * r*z = q *b , p *d*p*z = 0 ,
2643 *
2644 * where x = p*z. if this system does not have full rank,
2645 * then a least squares solution is obtained. on output qrsolv
2646 * also provides an upper triangular matrix s such that
2647 *
2648 * t t t
2649 * p *(a *a + d*d)*p = s *s .
2650 *
2651 * s is computed within qrsolv and may be of separate interest.
2652 *
2653 * parameters
2654 *
2655 * n is a positive integer input variable set to the order of r.
2656 *
2657 * r is an n by n array. on input the full upper triangle
2658 * must contain the full upper triangle of the matrix r.
2659 * on output the full upper triangle is unaltered, and the
2660 * strict lower triangle contains the strict upper triangle
2661 * (transposed) of the upper triangular matrix s.
2662 *
2663 * ldr is a positive integer input variable not less than n
2664 * which specifies the leading dimension of the array r.
2665 *
2666 * ipvt is an integer input array of length n which defines the
2667 * permutation matrix p such that a*p = q*r. column j of p
2668 * is column ipvt(j) of the identity matrix.
2669 *
2670 * diag is an input array of length n which must contain the
2671 * diagonal elements of the matrix d.
2672 *
2673 * qtb is an input array of length n which must contain the first
2674 * n elements of the vector (q transpose)*b.
2675 *
2676 * x is an output array of length n which contains the least
2677 * squares solution of the system a*x = b, d*x = 0.
2678 *
2679 * sdiag is an output array of length n which contains the
2680 * diagonal elements of the upper triangular matrix s.
2681 *
2682 * wa is a work array of length n.
2683 *
2684 */
2685
2686 // *** copy r and (q transpose)*b to preserve input and initialize s.
2687 // in particular, save the diagonal elements of r in x.
2688
2689 for (int j = 0; j < n; j++) {
2690 for (int i = j; i < n; i++) r[j * ldr + i] = r[i * ldr + j];
2691 x[j] = r[j * ldr + j];
2692 wa[j] = qtb[j];
2693 }
2694#if BUG
2695 printf("qrsolv\n");
2696#endif
2697
2698 // *** eliminate the diagonal matrix d using a givens rotation.
2699
2700 for (int j = 0; j < n; j++) {
2701 // *** prepare the row of d to be eliminated, locating the
2702 // diagonal element using p from the qr factorization.
2703
2704 double qtbpj = 0.0;
2705
2706 if (diag[ipvt[j]] == 0.) goto L90;
2707 for (int k = j; k < n; k++) sdiag[k] = 0.;
2708 sdiag[j] = diag[ipvt[j]];
2709
2710 // *** the transformations to eliminate the row of d
2711 // modify only a single element of (q transpose)*b
2712 // beyond the first n, which is initially 0..
2713
2714 for (int k = j; k < n; k++) {
2715 const double p25 = 0.25;
2716 const double p5 = 0.5;
2717
2718 // determine a givens rotation which eliminates the
2719 // appropriate element in the current row of d.
2720
2721 if (sdiag[k] == 0.) continue;
2722 const int kk = k + ldr * k; // <! keep this shorthand !>
2723 double sin, cos; // these are local variables, not functions
2724
2725 if (fabs(r[kk]) < fabs(sdiag[k])) {
2726 const double cotan = r[kk] / sdiag[k];
2727 sin = p5 / sqrt(p25 + p25 * SQR(cotan));
2728 cos = sin * cotan;
2729 } else {
2730 const double tan = sdiag[k] / r[kk];
2731 cos = p5 / sqrt(p25 + p25 * SQR(tan));
2732 sin = cos * tan;
2733 }
2734
2735 // *** compute the modified diagonal element of r and
2736 // the modified element of ((q transpose)*b,0).
2737
2738 r[kk] = cos * r[kk] + sin * sdiag[k];
2739 double temp = cos * wa[k] + sin * qtbpj;
2740 qtbpj = -sin * wa[k] + cos * qtbpj;
2741 wa[k] = temp;
2742
2743 // *** accumulate the transformation in the row of s.
2744
2745 for (int i = k + 1; i < n; i++) {
2746 temp = cos * r[k * ldr + i] + sin * sdiag[i];
2747 sdiag[i] = -sin * r[k * ldr + i] + cos * sdiag[i];
2748 r[k * ldr + i] = temp;
2749 }
2750 }
2751 L90:
2752
2753 // *** store the diagonal element of s and restore
2754 // the corresponding diagonal element of r.
2755
2756 sdiag[j] = r[j * ldr + j];
2757 r[j * ldr + j] = x[j];
2758 }
2759
2760 // *** solve the triangular system for z. if the system is
2761 // singular, then obtain a least squares solution.
2762
2763 int nsing = n;
2764 for (int j = 0; j < n; j++) {
2765 if (sdiag[j] == 0. && nsing == n) nsing = j;
2766 if (nsing < n) wa[j] = 0;
2767 }
2768
2769 for (int j = nsing - 1; j >= 0; j--) {
2770 double sum = 0.0;
2771 for (int i = j + 1; i < nsing; i++) sum += r[j * ldr + i] * wa[i];
2772 wa[j] = (wa[j] - sum) / sdiag[j];
2773 }
2774
2775 // *** permute the components of z back to components of x.
2776
2777 for (int j = 0; j < n; j++) x[ipvt[j]] = wa[j];
2778}
2779
2780double lm_enorm(int n, double *x) {
2781 /* given an n-vector x, this function calculates the
2782 * euclidean norm of x.
2783 *
2784 * the euclidean norm is computed by accumulating the sum of
2785 * squares in three different sums. the sums of squares for the
2786 * small and large components are scaled so that no overflows
2787 * occur. non-destructive underflows are permitted. underflows
2788 * and overflows do not occur in the computation of the unscaled
2789 * sum of squares for the intermediate components.
2790 * the definitions of small, intermediate and large components
2791 * depend on two constants, LM_SQRT_DWARF and LM_SQRT_GIANT. the main
2792 * restrictions on these constants are that LM_SQRT_DWARF**2 not
2793 * underflow and LM_SQRT_GIANT**2 not overflow.
2794 *
2795 * parameters
2796 *
2797 * n is a positive integer input variable.
2798 *
2799 * x is an input array of length n.
2800 */
2801
2802 double s1 = 0.0, s2 = 0.0, s3 = 0.0;
2803 double x1max = 0.0, x3max = 0.0;
2804 const double agiant = LM_SQRT_GIANT / ((double)n);
2805
2806 for (int i = 0; i < n; i++) {
2807 double xabs = fabs(x[i]);
2808 if (xabs > LM_SQRT_DWARF && xabs < agiant) {
2809 // ** sum for intermediate components.
2810 s2 += xabs * xabs;
2811 continue;
2812 }
2813
2814 if (xabs > LM_SQRT_DWARF) {
2815 // ** sum for large components.
2816 if (xabs > x1max) {
2817 s1 = 1 + s1 * SQR(x1max / xabs);
2818 x1max = xabs;
2819 } else {
2820 s1 += SQR(xabs / x1max);
2821 }
2822 continue;
2823 }
2824 // ** sum for small components.
2825 if (xabs > x3max) {
2826 s3 = 1 + s3 * SQR(x3max / xabs);
2827 x3max = xabs;
2828 } else {
2829 if (xabs != 0.) {
2830 s3 += SQR(xabs / x3max);
2831 }
2832 }
2833 }
2834
2835 // *** calculation of norm.
2836
2837 if (s1 != 0) return x1max * sqrt(s1 + (s2 / x1max) / x1max);
2838 if (s2 != 0) {
2839 if (s2 >= x3max) return sqrt(s2 * (1 + (x3max / s2) * (x3max * s3)));
2840 return sqrt(x3max * ((s2 / x3max) + (x3max * s3)));
2841 }
2842
2843 return x3max * sqrt(s3);
2844}
2845
2846double lat_gc_crosses_meridian(double lat1, double lon1, double lat2,
2847 double lon2, double lon) {
2848 /*
2849 Calculates a latitude at which a GC route between two points crosses a given
2850 meridian
2851 */
2852
2853 double dlon = lon * DEGREE;
2854 double dlat1 = lat1 * DEGREE;
2855 double dlat2 = lat2 * DEGREE;
2856 double dlon1 = lon1 * DEGREE;
2857 double dlon2 = lon2 * DEGREE;
2858
2859 return RADIAN * atan((sin(dlat1) * cos(dlat2) * sin(dlon - dlon2) -
2860 sin(dlat2) * cos(dlat1) * sin(dlon - dlon1)) /
2861 (cos(dlat1) * cos(dlat2) * sin(dlon1 - dlon2)));
2862}
2863
2864double lat_rl_crosses_meridian(double lat1, double lon1, double lat2,
2865 double lon2, double lon) {
2866 /*
2867 Calculates a latitude at which a loxodromic route between two points crosses a
2868 given meridian
2869 */
2870
2871 double brg;
2872
2873 DistanceBearingMercator(lat2, lon2, lat1, lon1, &brg, NULL);
2874
2875 double x1, y1, x;
2876 toSM(lat1, lon1, 0., lon, &x1, &y1);
2877 toSM(lat1, lon, 0., lon, &x, &y1);
2878
2879 double dir = 1.0;
2880 if (brg >= 270.0) {
2881 brg -= 270.0;
2882 } else if (brg >= 180.) {
2883 brg = 270.0 - brg;
2884 dir = -1.0;
2885 } else if (brg >= 90.) {
2886 brg -= 90.0;
2887 dir = -1.0;
2888 } else {
2889 brg = 90.0 - brg;
2890 }
2891
2892 double ydelta = fabs(x1) * tan(brg * DEGREE);
2893
2894 double crosslat, crosslon;
2895 fromSM(x, y1 + dir * ydelta, 0., lon, &crosslat, &crosslon);
2896
2897 return crosslat;
2898}
Definition: georef.h:41
Definition: georef.h:55