184 subroutine direct(a, f, lat1, lon1, azi1, s12a12, flags,
185 + lat2, lon2, azi2, omask, a12s12, m12, MM12, MM21, SS12)
187 double precision a, f, lat1, lon1, azi1, s12a12
190 double precision lat2, lon2, azi2
192 double precision a12s12, m12, MM12, MM21, SS12
194 integer ord, nC1, nC1p, nC2, nA3, nA3x, nC3, nC3x, nC4, nC4x
195 parameter(ord = 6, nc1 = ord, nc1p = ord,
196 + nc2 = ord, na3 = ord, na3x = na3,
197 + nc3 = ord, nc3x = (nc3 * (nc3 - 1)) / 2,
198 + nc4 = ord, nc4x = (nc4 * (nc4 + 1)) / 2)
199 double precision A3x(0:nA3x-1), C3x(0:nC3x-1), C4x(0:nC4x-1),
200 + c1a(nc1), c1pa(nc1p), c2a(nc2), c3a(nc3-1), c4a(0:nc4-1)
202 double precision atanhx, hypotx,
203 + angnm, angrnd, trgsum, a1m1f, a2m1f, a3f, atn2dx, latfix
204 logical arcmod, unroll, arcp, redlp, scalp, areap
205 double precision e2, f1, ep2, n, b, c2,
206 + salp0, calp0, k2, eps,
207 + salp1, calp1, ssig1, csig1, cbet1, sbet1, dn1, somg1, comg1,
208 + salp2, calp2, ssig2, csig2, sbet2, cbet2, dn2, somg2, comg2,
209 + ssig12, csig12, salp12, calp12, omg12, lam12, lon12,
210 + sig12, stau1, ctau1, tau12, t, s, c, serr, e,
211 + a1m1, a2m1, a3c, a4, ab1, ab2,
212 + b11, b12, b21, b22, b31, b41, b42, j12
214 double precision dblmin, dbleps, pi, degree, tiny,
215 + tol0, tol1, tol2, tolb, xthrsh
216 integer digits, maxit1, maxit2
218 common /geocom/ dblmin, dbleps, pi, degree, tiny,
219 + tol0, tol1, tol2, tolb, xthrsh, digits, maxit1, maxit2, init
221 if (.not.init)
call geoini
230 arcmod = mod(flags/1, 2) .eq. 1
231 unroll = mod(flags/2, 2) .eq. 1
233 arcp = mod(omask/1, 2) .eq. 1
234 redlp = mod(omask/2, 2) .eq. 1
235 scalp = mod(omask/4, 2) .eq. 1
236 areap = mod(omask/8, 2) .eq. 1
241 else if (e2 .gt. 0)
then
242 c2 = (a**2 + b**2 * atanhx(sqrt(e2)) / sqrt(e2)) / 2
244 c2 = (a**2 + b**2 * atan(sqrt(abs(e2))) / sqrt(abs(e2))) / 2
250 if (areap)
call c4cof(n, c4x)
253 call sncsdx(angrnd(azi1), salp1, calp1)
255 call sncsdx(angrnd(latfix(lat1)), sbet1, cbet1)
257 call norm2x(sbet1, cbet1)
259 cbet1 = max(tiny, cbet1)
260 dn1 = sqrt(1 + ep2 * sbet1**2)
264 salp0 = salp1 * cbet1
267 calp0 = hypotx(calp1, salp1 * sbet1)
278 somg1 = salp0 * sbet1
279 if (sbet1 .ne. 0 .or. calp1 .ne. 0)
then
280 csig1 = cbet1 * calp1
286 call norm2x(ssig1, csig1)
290 eps = k2 / (2 * (1 + sqrt(1 + k2)) + k2)
294 b11 = trgsum(.true., ssig1, csig1, c1a, nc1)
298 stau1 = ssig1 * c + csig1 * s
299 ctau1 = csig1 * c - ssig1 * s
303 if (.not. arcmod)
call c1pf(eps, c1pa)
305 if (redlp .or. scalp)
then
308 b21 = trgsum(.true., ssig1, csig1, c2a, nc2)
315 call c3f(eps, c3x, c3a)
316 a3c = -f * salp0 * a3f(eps, a3x)
317 b31 = trgsum(.true., ssig1, csig1, c3a, nc3-1)
320 call c4f(eps, c4x, c4a)
322 a4 = a**2 * calp0 * salp0 * e2
323 b41 = trgsum(.false., ssig1, csig1, c4a, nc4)
332 sig12 = s12a12 * degree
333 call sncsdx(s12a12, ssig12, csig12)
338 tau12 = s12a12 / (b * (1 + a1m1))
342 b12 = - trgsum(.true.,
343 + stau1 * c + ctau1 * s, ctau1 * c - stau1 * s, c1pa, nc1p)
344 sig12 = tau12 - (b12 - b11)
347 if (abs(f) .gt. 0.01d0)
then
369 ssig2 = ssig1 * csig12 + csig1 * ssig12
370 csig2 = csig1 * csig12 - ssig1 * ssig12
371 b12 = trgsum(.true., ssig2, csig2, c1a, nc1)
372 serr = (1 + a1m1) * (sig12 + (b12 - b11)) - s12a12 / b
373 sig12 = sig12 - serr / sqrt(1 + k2 * ssig2**2)
381 ssig2 = ssig1 * csig12 + csig1 * ssig12
382 csig2 = csig1 * csig12 - ssig1 * ssig12
383 dn2 = sqrt(1 + k2 * ssig2**2)
384 if (arcmod .or. abs(f) .gt. 0.01d0)
385 + b12 = trgsum(.true., ssig2, csig2, c1a, nc1)
386 ab1 = (1 + a1m1) * (b12 - b11)
389 sbet2 = calp0 * ssig2
391 cbet2 = hypotx(salp0, calp0 * csig2)
392 if (cbet2 .eq. 0)
then
399 somg2 = salp0 * ssig2
404 calp2 = calp0 * csig2
410 + - (atan2( ssig2, csig2) - atan2( ssig1, csig1))
411 + + (atan2(e * somg2, comg2) - atan2(e * somg1, comg1)))
413 omg12 = atan2(somg2 * comg1 - comg2 * somg1,
414 + comg2 * comg1 + somg2 * somg1)
417 lam12 = omg12 + a3c *
418 + ( sig12 + (trgsum(.true., ssig2, csig2, c3a, nc3-1)
420 lon12 = lam12 / degree
424 lon2 = angnm(angnm(lon1) + angnm(lon12))
426 lat2 = atn2dx(sbet2, f1 * cbet2)
427 azi2 = atn2dx(salp2, calp2)
429 if (redlp .or. scalp)
then
430 b22 = trgsum(.true., ssig2, csig2, c2a, nc2)
431 ab2 = (1 + a2m1) * (b22 - b21)
432 j12 = (a1m1 - a2m1) * sig12 + (ab1 - ab2)
436 if (redlp) m12 = b * ((dn2 * (csig1 * ssig2) -
437 + dn1 * (ssig1 * csig2)) - csig1 * csig2 * j12)
439 t = k2 * (ssig2 - ssig1) * (ssig2 + ssig1) / (dn1 + dn2)
440 mm12 = csig12 + (t * ssig2 - csig2 * j12) * ssig1 / dn1
441 mm21 = csig12 - (t * ssig1 - csig1 * j12) * ssig2 / dn2
445 b42 = trgsum(.false., ssig2, csig2, c4a, nc4)
446 if (calp0 .eq. 0 .or. salp0 .eq. 0)
then
448 salp12 = salp2 * calp1 - calp2 * salp1
449 calp12 = calp2 * calp1 + salp2 * salp1
459 if (csig12 .le. 0)
then
460 salp12 = csig1 * (1 - csig12) + ssig12 * ssig1
462 salp12 = ssig12 * (csig1 * ssig12 / (1 + csig12) + ssig1)
464 salp12 = calp0 * salp0 * salp12
465 calp12 = salp0**2 + calp0**2 * csig1 * csig2
467 ss12 = c2 * atan2(salp12, calp12) + a4 * (b42 - b41)
472 a12s12 = b * ((1 + a1m1) * sig12 + ab1)
474 a12s12 = sig12 / degree
526 subroutine invers(a, f, lat1, lon1, lat2, lon2,
527 + s12, azi1, azi2, omask, a12, m12, MM12, MM21, SS12)
529 double precision a, f, lat1, lon1, lat2, lon2
532 double precision s12, azi1, azi2
534 double precision a12, m12, MM12, MM21, SS12
536 integer ord, nA3, nA3x, nC3, nC3x, nC4, nC4x, nC
537 parameter (ord = 6, na3 = ord, na3x = na3,
538 + nc3 = ord, nc3x = (nc3 * (nc3 - 1)) / 2,
539 + nc4 = ord, nc4x = (nc4 * (nc4 + 1)) / 2,
541 double precision A3x(0:nA3x-1), C3x(0:nC3x-1), C4x(0:nC4x-1),
544 double precision atanhx, hypotx,
545 + AngDif, AngRnd, TrgSum, Lam12f, InvSta, atn2dx, LatFix
546 integer latsgn, lonsgn, swapp, numit
547 logical arcp, redlp, scalp, areap, merid, tripn, tripb
549 double precision e2, f1, ep2, n, b, c2,
550 + lat1x, lat2x, salp0, calp0, k2, eps,
551 + salp1, calp1, ssig1, csig1, cbet1, sbet1, dbet1, dn1,
552 + salp2, calp2, ssig2, csig2, sbet2, cbet2, dbet2, dn2,
553 + slam12, clam12, salp12, calp12, omg12, lam12, lon12, lon12s,
554 + salp1a, calp1a, salp1b, calp1b,
555 + dalp1, sdalp1, cdalp1, nsalp1, alp12, somg12, comg12, domg12,
556 + sig12, v, dv, dnm, dummy,
557 + a4, b41, b42, s12x, m12x, a12x, sdomg12, cdomg12
559 double precision dblmin, dbleps, pi, degree, tiny,
560 + tol0, tol1, tol2, tolb, xthrsh
561 integer digits, maxit1, maxit2, lmask
563 common /geocom/ dblmin, dbleps, pi, degree, tiny,
564 + tol0, tol1, tol2, tolb, xthrsh, digits, maxit1, maxit2, init
566 if (.not.init)
call geoini
575 arcp = mod(omask/1, 2) .eq. 1
576 redlp = mod(omask/2, 2) .eq. 1
577 scalp = mod(omask/4, 2) .eq. 1
578 areap = mod(omask/8, 2) .eq. 1
588 else if (e2 .gt. 0)
then
589 c2 = (a**2 + b**2 * atanhx(sqrt(e2)) / sqrt(e2)) / 2
591 c2 = (a**2 + b**2 * atan(sqrt(abs(e2))) / sqrt(abs(e2))) / 2
597 if (areap)
call c4cof(n, c4x)
603 lon12 = angdif(lon1, lon2, lon12s)
605 if (lon12 .ge. 0)
then
610 lon12 = lonsgn * angrnd(lon12)
611 lon12s = angrnd((180 - lon12) - lonsgn * lon12s)
612 lam12 = lon12 * degree
613 if (lon12 .gt. 90)
then
614 call sncsdx(lon12s, slam12, clam12)
617 call sncsdx(lon12, slam12, clam12)
621 lat1x = angrnd(latfix(lat1))
622 lat2x = angrnd(latfix(lat2))
625 if (abs(lat1x) .lt. abs(lat2x))
then
630 if (swapp .lt. 0)
then
632 call swap(lat1x, lat2x)
635 if (lat1x .lt. 0)
then
640 lat1x = lat1x * latsgn
641 lat2x = lat2x * latsgn
654 call sncsdx(lat1x, sbet1, cbet1)
656 call norm2x(sbet1, cbet1)
658 cbet1 = max(tiny, cbet1)
660 call sncsdx(lat2x, sbet2, cbet2)
662 call norm2x(sbet2, cbet2)
664 cbet2 = max(tiny, cbet2)
675 if (cbet1 .lt. -sbet1)
then
676 if (cbet2 .eq. cbet1) sbet2 = sign(sbet1, sbet2)
678 if (abs(sbet2) .eq. -sbet1) cbet2 = cbet1
681 dn1 = sqrt(1 + ep2 * sbet1**2)
682 dn2 = sqrt(1 + ep2 * sbet2**2)
686 merid = lat1x .eq. -90 .or. slam12 .eq. 0
702 csig1 = calp1 * cbet1
704 csig2 = calp2 * cbet2
707 sig12 = atan2(0d0 + max(0d0, csig1 * ssig2 - ssig1 * csig2),
708 + csig1 * csig2 + ssig1 * ssig2)
709 call lengs(n, sig12, ssig1, csig1, dn1, ssig2, csig2, dn2,
710 + cbet1, cbet2, lmask,
711 + s12x, m12x, dummy, mm12, mm21, ep2, ca)
720 if (sig12 .lt. 1 .or. m12x .ge. 0)
then
721 if (sig12 .lt. 3 * tiny .or.
722 + (sig12 .lt. tol0 .and.
723 + (s12x .lt. 0 .or. m12x .lt. 0)))
then
731 a12x = sig12 / degree
742 if (.not. merid .and. sbet1 .eq. 0 .and.
743 + (f .le. 0 .or. lon12s .ge. f * 180))
then
753 m12x = b * sin(sig12)
759 else if (.not. merid)
then
764 sig12 = invsta(sbet1, cbet1, dn1, sbet2, cbet2, dn2, lam12,
765 + slam12, clam12, f, a3x, salp1, calp1, salp2, calp2, dnm, ca)
767 if (sig12 .ge. 0)
then
769 s12x = sig12 * b * dnm
770 m12x = dnm**2 * b * sin(sig12 / dnm)
772 mm12 = cos(sig12 / dnm)
775 a12x = sig12 / degree
776 omg12 = lam12 / (f1 * dnm)
798 do 10 numit = 0, maxit2-1
801 v = lam12f(sbet1, cbet1, dn1, sbet2, cbet2, dn2,
802 + salp1, calp1, slam12, clam12, f, a3x, c3x, salp2, calp2,
803 + sig12, ssig1, csig1, ssig2, csig2,
804 + eps, domg12, numit .lt. maxit1, dv, ca)
811 if (tripb .or. .not. (abs(v) .ge. dummy * tol0))
814 if (v .gt. 0 .and. (numit .gt. maxit1 .or.
815 + calp1/salp1 .gt. calp1b/salp1b))
then
818 else if (v .lt. 0 .and. (numit .gt. maxit1 .or.
819 + calp1/salp1 .lt. calp1a/salp1a))
then
823 if (numit .lt. maxit1 .and. dv .gt. 0)
then
827 nsalp1 = salp1 * cdalp1 + calp1 * sdalp1
828 if (nsalp1 .gt. 0 .and. abs(dalp1) .lt. pi)
then
829 calp1 = calp1 * cdalp1 - salp1 * sdalp1
831 call norm2x(salp1, calp1)
835 tripn = abs(v) .le. 16 * tol0
847 salp1 = (salp1a + salp1b)/2
848 calp1 = (calp1a + calp1b)/2
849 call norm2x(salp1, calp1)
851 tripb = abs(salp1a - salp1) + (calp1a - calp1) .lt. tolb
852 + .or. abs(salp1 - salp1b) + (calp1 - calp1b) .lt. tolb
855 call lengs(eps, sig12, ssig1, csig1, dn1, ssig2, csig2, dn2,
856 + cbet1, cbet2, lmask,
857 + s12x, m12x, dummy, mm12, mm21, ep2, ca)
860 a12x = sig12 / degree
862 sdomg12 = sin(domg12)
863 cdomg12 = cos(domg12)
864 somg12 = slam12 * cdomg12 - clam12 * sdomg12
865 comg12 = clam12 * cdomg12 + slam12 * sdomg12
872 if (redlp) m12 = 0 + m12x
876 salp0 = salp1 * cbet1
877 calp0 = hypotx(calp1, salp1 * sbet1)
878 if (calp0 .ne. 0 .and. salp0 .ne. 0)
then
881 csig1 = calp1 * cbet1
883 csig2 = calp2 * cbet2
885 eps = k2 / (2 * (1 + sqrt(1 + k2)) + k2)
887 a4 = a**2 * calp0 * salp0 * e2
888 call norm2x(ssig1, csig1)
889 call norm2x(ssig2, csig2)
890 call c4f(eps, c4x, ca)
891 b41 = trgsum(.false., ssig1, csig1, ca, nc4)
892 b42 = trgsum(.false., ssig2, csig2, ca, nc4)
893 ss12 = a4 * (b42 - b41)
899 if (.not. merid .and. somg12 .gt. 1)
then
904 if (.not. merid .and. comg12 .ge. 0.7071d0
905 + .and. sbet2 - sbet1 .lt. 1.75d0)
then
912 alp12 = 2 * atan2(somg12 * (sbet1 * dbet2 + sbet2 * dbet1),
913 + domg12 * ( sbet1 * sbet2 + dbet1 * dbet2 ) )
916 salp12 = salp2 * calp1 - calp2 * salp1
917 calp12 = calp2 * calp1 + salp2 * salp1
922 if (salp12 .eq. 0 .and. calp12 .lt. 0)
then
923 salp12 = tiny * calp1
926 alp12 = atan2(salp12, calp12)
928 ss12 = ss12 + c2 * alp12
929 ss12 = ss12 * swapp * lonsgn * latsgn
935 if (swapp .lt. 0)
then
936 call swap(salp1, salp2)
937 call swap(calp1, calp2)
938 if (scalp)
call swap(mm12, mm21)
941 salp1 = salp1 * swapp * lonsgn
942 calp1 = calp1 * swapp * latsgn
943 salp2 = salp2 * swapp * lonsgn
944 calp2 = calp2 * swapp * latsgn
946 azi1 = atn2dx(salp1, calp1)
947 azi2 = atn2dx(salp2, calp2)
974 subroutine area(a, f, lats, lons, n, AA, PP)
977 double precision a, f, lats(n), lons(n)
979 double precision AA, PP
981 integer i, omask, cross, trnsit
982 double precision s12, azi1, azi2, dummy, SS12, b, e2, c2, area0,
983 + atanhx, aacc(2), pacc(2)
985 double precision dblmin, dbleps, pi, degree, tiny,
986 + tol0, tol1, tol2, tolb, xthrsh
987 integer digits, maxit1, maxit2
989 common /geocom/ dblmin, dbleps, pi, degree, tiny,
990 + tol0, tol1, tol2, tolb, xthrsh, digits, maxit1, maxit2, init
997 call invers(a, f, lats(i+1), lons(i+1),
998 + lats(mod(i+1,n)+1), lons(mod(i+1,n)+1),
999 + s12, azi1, azi2, omask, dummy, dummy, dummy, dummy, ss12)
1000 call accadd(pacc, s12)
1001 call accadd(aacc, -ss12)
1002 cross = cross + trnsit(lons(i+1), lons(mod(i+1,n)+1))
1009 else if (e2 .gt. 0)
then
1010 c2 = (a**2 + b**2 * atanhx(sqrt(e2)) / sqrt(e2)) / 2
1012 c2 = (a**2 + b**2 * atan(sqrt(abs(e2))) / sqrt(abs(e2))) / 2
1015 call accrem(aacc, area0)
1016 if (mod(abs(cross), 2) .eq. 1)
then
1017 if (aacc(1) .lt. 0)
then
1018 call accadd(aacc, +area0/2)
1020 call accadd(aacc, -area0/2)
1023 if (aacc(1) .gt. area0/2)
then
1024 call accadd(aacc, -area0)
1025 else if (aacc(1) .le. -area0/2)
then
1026 call accadd(aacc, +area0)
1043 integer major, minor, patch
1055 double precision dblmin, dbleps, pi, degree, tiny,
1056 + tol0, tol1, tol2, tolb, xthrsh
1057 integer digits, maxit1, maxit2
1060 common /geocom/ dblmin, dbleps, pi, degree, tiny,
1061 + tol0, tol1, tol2, tolb, xthrsh, digits, maxit1, maxit2, init
1065 double precision dblmin, dbleps, pi, degree, tiny,
1066 + tol0, tol1, tol2, tolb, xthrsh
1067 integer digits, maxit1, maxit2
1069 common /geocom/ dblmin, dbleps, pi, degree, tiny,
1070 + tol0, tol1, tol2, tolb, xthrsh, digits, maxit1, maxit2, init
1073 dblmin = 0.5d0**1022
1074 dbleps = 0.5d0**(digits-1)
1076 pi = atan2(0d0, -1d0)
1082 tiny = 0.5d0**((1022+1)/3)
1091 xthrsh = 1000 * tol2
1093 maxit2 = maxit1 + digits + 10
1100 subroutine lengs(eps, sig12, ssig1, csig1, dn1, ssig2, csig2, dn2,
1101 + cbet1, cbet2, omask,
1102 + s12b, m12b, m0, MM12, MM21, ep2, Ca)
1104 double precision eps, sig12, ssig1, csig1, dn1, ssig2, csig2, dn2,
1108 double precision s12b, m12b, m0, MM12, MM21
1110 double precision Ca(*)
1112 integer ord, nC1, nC2
1113 parameter (ord = 6, nc1 = ord, nc2 = ord)
1115 double precision A1m1f, A2m1f, TrgSum
1116 double precision m0x, J12, A1, A2, B1, B2, csig12, t, Cb(nC2)
1117 logical distp, redlp, scalp
1123 distp = (mod(omask/16, 2) .eq. 1)
1124 redlp = (mod(omask/2, 2) .eq. 1)
1125 scalp = (mod(omask/4, 2) .eq. 1)
1132 if (distp .or. redlp .or. scalp)
then
1135 if (redlp .or. scalp)
then
1144 b1 = trgsum(.true., ssig2, csig2, ca, nc1) -
1145 + trgsum(.true., ssig1, csig1, ca, nc1)
1147 s12b = a1 * (sig12 + b1)
1148 if (redlp .or. scalp)
then
1149 b2 = trgsum(.true., ssig2, csig2, cb, nc2) -
1150 + trgsum(.true., ssig1, csig1, cb, nc2)
1151 j12 = m0x * sig12 + (a1 * b1 - a2 * b2)
1153 else if (redlp .or. scalp)
then
1156 cb(l) = a1 * ca(l) - a2 * cb(l)
1158 j12 = m0x * sig12 + (trgsum(.true., ssig2, csig2, cb, nc2) -
1159 + trgsum(.true., ssig1, csig1, cb, nc2))
1166 m12b = dn2 * (csig1 * ssig2) - dn1 * (ssig1 * csig2) -
1167 + csig1 * csig2 * j12
1170 csig12 = csig1 * csig2 + ssig1 * ssig2
1171 t = ep2 * (cbet1 - cbet2) * (cbet1 + cbet2) / (dn1 + dn2)
1172 mm12 = csig12 + (t * ssig2 - csig2 * j12) * ssig1 / dn1
1173 mm21 = csig12 - (t * ssig1 - csig1 * j12) * ssig2 / dn2
1179 double precision function astrd(x, y)
1183 double precision x, y
1185 double precision cbrt
1186 double precision k, p, q, r, S, r2, r3, disc, u,
1187 + t3, t, ang, v, uv, w
1192 if ( .not. (q .eq. 0 .and. r .lt. 0) )
then
1201 disc = s * (s + 2 * r3)
1203 if (disc .ge. 0)
then
1219 if (t .ne. 0) u = u + t + r2 / t
1222 ang = atan2(sqrt(-disc), -(s + r3))
1225 u = u + 2 * r * cos(ang / 3)
1237 w = (uv - q) / (2 * v)
1241 k = uv / (sqrt(uv + w**2) + w)
1253 double precision function invsta(sbet1, cbet1, dn1,
1254 + sbet2, cbet2, dn2, lam12, slam12, clam12, f, A3x,
1255 + salp1, calp1, salp2, calp2, dnm,
1261 double precision sbet1, cbet1, dn1, sbet2, cbet2, dn2,
1262 + lam12, slam12, clam12, f, A3x(*)
1264 double precision salp1, calp1, salp2, calp2, dnm
1266 double precision Ca(*)
1268 double precision hypotx, A3f, Astrd
1270 double precision f1, e2, ep2, n, etol2, k2, eps, sig12,
1271 + sbet12, cbet12, sbt12a, omg12, somg12, comg12, ssig12, csig12,
1272 + x, y, lamscl, betscl, cbt12a, bt12a, m12b, m0, dummy,
1273 + k, omg12a, sbetm2, lam12x
1275 double precision dblmin, dbleps, pi, degree, tiny,
1276 + tol0, tol1, tol2, tolb, xthrsh
1277 integer digits, maxit1, maxit2
1279 common /geocom/ dblmin, dbleps, pi, degree, tiny,
1280 + tol0, tol1, tol2, tolb, xthrsh, digits, maxit1, maxit2, init
1296 etol2 = 0.1d0 * tol2 /
1297 + sqrt( max(0.001d0, abs(f)) * min(1d0, 1 - f/2) / 2 )
1302 sbet12 = sbet2 * cbet1 - cbet2 * sbet1
1303 cbet12 = cbet2 * cbet1 + sbet2 * sbet1
1304 sbt12a = sbet2 * cbet1 + cbet2 * sbet1
1306 shortp = cbet12 .ge. 0 .and. sbet12 .lt. 0.5d0 .and.
1307 + cbet2 * lam12 .lt. 0.5d0
1310 sbetm2 = (sbet1 + sbet2)**2
1313 sbetm2 = sbetm2 / (sbetm2 + (cbet1 + cbet2)**2)
1314 dnm = sqrt(1 + ep2 * sbetm2)
1315 omg12 = lam12 / (f1 * dnm)
1323 salp1 = cbet2 * somg12
1324 if (comg12 .ge. 0)
then
1325 calp1 = sbet12 + cbet2 * sbet1 * somg12**2 / (1 + comg12)
1327 calp1 = sbt12a - cbet2 * sbet1 * somg12**2 / (1 - comg12)
1330 ssig12 = hypotx(salp1, calp1)
1331 csig12 = sbet1 * sbet2 + cbet1 * cbet2 * comg12
1333 if (shortp .and. ssig12 .lt. etol2)
then
1335 salp2 = cbet1 * somg12
1336 if (comg12 .ge. 0)
then
1337 calp2 = somg12**2 / (1 + comg12)
1341 calp2 = sbet12 - cbet1 * sbet2 * calp2
1342 call norm2x(salp2, calp2)
1344 sig12 = atan2(ssig12, csig12)
1345 else if (abs(n) .gt. 0.1d0 .or. csig12 .ge. 0 .or.
1346 + ssig12 .ge. 6 * abs(n) * pi * cbet1**2)
then
1351 lam12x = atan2(-slam12, -clam12)
1357 eps = k2 / (2 * (1 + sqrt(1 + k2)) + k2)
1358 lamscl = f * cbet1 * a3f(eps, a3x) * pi
1359 betscl = lamscl * cbet1
1364 cbt12a = cbet2 * cbet1 - sbet2 * sbet1
1365 bt12a = atan2(sbt12a, cbt12a)
1368 call lengs(n, pi + bt12a,
1369 + sbet1, -cbet1, dn1, sbet2, cbet2, dn2, cbet1, cbet2, 2,
1370 + dummy, m12b, m0, dummy, dummy, ep2, ca)
1371 x = -1 + m12b / (cbet1 * cbet2 * m0 * pi)
1372 if (x .lt. -0.01d0)
then
1375 betscl = -f * cbet1**2 * pi
1377 lamscl = betscl / cbet1
1381 if (y .gt. -tol1 .and. x .gt. -1 - xthrsh)
then
1384 salp1 = min(1d0, -x)
1385 calp1 = - sqrt(1 - salp1**2)
1387 if (x .gt. -tol1)
then
1392 calp1 = max(calp1, x)
1393 salp1 = sqrt(1 - calp1**2)
1432 omg12a = -x * k/(1 + k)
1434 omg12a = -y * (1 + k)/k
1436 omg12a = lamscl * omg12a
1437 somg12 = sin(omg12a)
1438 comg12 = -cos(omg12a)
1440 salp1 = cbet2 * somg12
1441 calp1 = sbt12a - cbet2 * sbet1 * somg12**2 / (1 - comg12)
1445 if (.not. (salp1 .le. 0))
then
1446 call norm2x(salp1, calp1)
1456 double precision function lam12f(sbet1, cbet1, dn1,
1457 + sbet2, cbet2, dn2, salp1, calp1, slm120, clm120, f, A3x, C3x,
1458 + salp2, calp2, sig12, ssig1, csig1, ssig2, csig2, eps,
1459 + domg12, diffp, dlam12, Ca)
1461 double precision sbet1, cbet1, dn1, sbet2, cbet2, dn2,
1462 + salp1, calp1, slm120, clm120, f, A3x(*), C3x(*)
1465 double precision salp2, calp2, sig12, ssig1, csig1, ssig2, csig2,
1468 double precision dlam12
1470 double precision Ca(*)
1473 parameter(ord = 6, nc3 = ord)
1475 double precision hypotx, A3f, TrgSum
1477 double precision f1, e2, ep2, salp0, calp0,
1478 + somg1, comg1, somg2, comg2, somg12, comg12,
1479 + lam12, eta, b312, k2, dummy
1481 double precision dblmin, dbleps, pi, degree, tiny,
1482 + tol0, tol1, tol2, tolb, xthrsh
1483 integer digits, maxit1, maxit2
1485 common /geocom/ dblmin, dbleps, pi, degree, tiny,
1486 + tol0, tol1, tol2, tolb, xthrsh, digits, maxit1, maxit2, init
1493 if (sbet1 .eq. 0 .and. calp1 .eq. 0) calp1 = -tiny
1496 salp0 = salp1 * cbet1
1498 calp0 = hypotx(calp1, salp1 * sbet1)
1503 somg1 = salp0 * sbet1
1504 csig1 = calp1 * cbet1
1506 call norm2x(ssig1, csig1)
1513 if (cbet2 .ne. cbet1)
then
1514 salp2 = salp0 / cbet2
1522 if (cbet2 .ne. cbet1 .or. abs(sbet2) .ne. -sbet1)
then
1523 if (cbet1 .lt. -sbet1)
then
1524 calp2 = (cbet2 - cbet1) * (cbet1 + cbet2)
1526 calp2 = (sbet1 - sbet2) * (sbet1 + sbet2)
1528 calp2 = sqrt((calp1 * cbet1)**2 + calp2) / cbet2
1535 somg2 = salp0 * sbet2
1536 csig2 = calp2 * cbet2
1538 call norm2x(ssig2, csig2)
1542 sig12 = atan2(0d0 + max(0d0, csig1 * ssig2 - ssig1 * csig2),
1543 + csig1 * csig2 + ssig1 * ssig2)
1546 somg12 = 0d0 + max(0d0, comg1 * somg2 - somg1 * comg2)
1547 comg12 = comg1 * comg2 + somg1 * somg2
1549 eta = atan2(somg12 * clm120 - comg12 * slm120,
1550 + comg12 * clm120 + somg12 * slm120)
1552 eps = k2 / (2 * (1 + sqrt(1 + k2)) + k2)
1553 call c3f(eps, c3x, ca)
1554 b312 = (trgsum(.true., ssig2, csig2, ca, nc3-1) -
1555 + trgsum(.true., ssig1, csig1, ca, nc3-1))
1556 domg12 = -f * a3f(eps, a3x) * salp0 * (sig12 + b312)
1557 lam12 = eta + domg12
1560 if (calp2 .eq. 0)
then
1561 dlam12 = - 2 * f1 * dn1 / sbet1
1563 call lengs(eps, sig12, ssig1, csig1, dn1, ssig2, csig2, dn2,
1565 + dummy, dlam12, dummy, dummy, dummy, ep2, ca)
1566 dlam12 = dlam12 * f1 / (calp2 * cbet2)
1574 double precision function a3f(eps, A3x)
1576 integer ord, nA3, nA3x
1577 parameter(ord = 6, na3 = ord, na3x = na3)
1580 double precision eps
1582 double precision A3x(0: nA3x-1)
1584 double precision polval
1585 A3f = polval(na3 - 1, a3x, eps)
1590 subroutine c3f(eps, C3x, c)
1593 integer ord, nC3, nC3x
1594 parameter(ord = 6, nc3 = ord, nc3x = (nc3 * (nc3 - 1)) / 2)
1597 double precision eps, C3x(0:nC3x-1)
1599 double precision c(nC3-1)
1602 double precision mult, polval
1606 do 10 l = 1, nc3 - 1
1609 c(l) = mult * polval(m, c3x(o), eps)
1616 subroutine c4f(eps, C4x, c)
1619 integer ord, nC4, nC4x
1620 parameter(ord = 6, nc4 = ord, nc4x = (nc4 * (nc4 + 1)) / 2)
1623 double precision eps, C4x(0:nC4x-1)
1625 double precision c(0:nC4-1)
1628 double precision mult, polval
1632 do 10 l = 0, nc4 - 1
1634 c(l) = mult * polval(m, c4x(o), eps)
1642 double precision function a1m1f(eps)
1645 double precision eps
1648 integer ord, nA1, o, m
1649 parameter(ord = 6, na1 = ord)
1650 double precision polval, coeff(nA1/2 + 2)
1651 data coeff /1, 4, 64, 0, 256/
1655 t = polval(m, coeff(o), eps**2) / coeff(o + m + 1)
1656 a1m1f = (t + eps) / (1 - eps)
1661 subroutine c1f(eps, c)
1664 parameter(ord = 6, nc1 = ord)
1667 double precision eps
1669 double precision c(nC1)
1671 double precision eps2, d
1673 double precision polval, coeff((nC1**2 + 7*nC1 - 2*(nC1/2))/4)
1676 + -9, 64, -128, 2048,
1687 c(l) = d * polval(m, coeff(o), eps2) / coeff(o + m + 1)
1695 subroutine c1pf(eps, c)
1698 parameter(ord = 6, nc1p = ord)
1701 double precision eps
1703 double precision c(nC1p)
1705 double precision eps2, d
1707 double precision polval, coeff((nC1p**2 + 7*nC1p - 2*(nC1p/2))/4)
1709 + 205, -432, 768, 1536,
1710 + 4005, -4736, 3840, 12288,
1712 + -7173, 2695, 7680,
1721 c(l) = d * polval(m, coeff(o), eps2) / coeff(o + m + 1)
1730 double precision function a2m1f(eps)
1732 double precision eps
1735 integer ord, nA2, o, m
1736 parameter(ord = 6, na2 = ord)
1737 double precision polval, coeff(nA2/2 + 2)
1738 data coeff /-11, -28, -192, 0, 256/
1742 t = polval(m, coeff(o), eps**2) / coeff(o + m + 1)
1743 a2m1f = (t - eps) / (1 + eps)
1748 subroutine c2f(eps, c)
1751 parameter(ord = 6, nc2 = ord)
1754 double precision eps
1756 double precision c(nC2)
1758 double precision eps2, d
1760 double precision polval, coeff((nC2**2 + 7*nC2 - 2*(nC2/2))/4)
1763 + 35, 64, 384, 2048,
1774 c(l) = d * polval(m, coeff(o), eps2) / coeff(o + m + 1)
1782 subroutine a3cof(n, A3x)
1784 integer ord, nA3, nA3x
1785 parameter(ord = 6, na3 = ord, na3x = na3)
1790 double precision A3x(0:nA3x-1)
1793 double precision polval, coeff((nA3**2 + 7*nA3 - 2*(nA3/2))/4)
1804 do 10 j = na3 - 1, 0, -1
1805 m = min(na3 - j - 1, j)
1806 a3x(k) = polval(m, coeff(o), n) / coeff(o + m + 1)
1814 subroutine c3cof(n, C3x)
1816 integer ord, nC3, nC3x
1817 parameter(ord = 6, nc3 = ord, nc3x = (nc3 * (nc3 - 1)) / 2)
1822 double precision C3x(0:nC3x-1)
1824 integer o, m, l, j, k
1825 double precision polval,
1826 + coeff(((nc3-1)*(nc3**2 + 7*nc3 - 2*(nc3/2)))/8)
1846 do 20 l = 1, nc3 - 1
1847 do 10 j = nc3 - 1, l, -1
1848 m = min(nc3 - j - 1, j)
1849 c3x(k) = polval(m, coeff(o), n) / coeff(o + m + 1)
1858 subroutine c4cof(n, C4x)
1860 integer ord, nC4, nC4x
1861 parameter(ord = 6, nc4 = ord, nc4x = (nc4 * (nc4 + 1)) / 2)
1866 double precision C4x(0:nC4x-1)
1868 integer o, m, l, j, k
1869 double precision polval, coeff((nC4 * (nC4 + 1) * (nC4 + 5)) / 6)
1871 + 97, 15015, 1088, 156, 45045, -224, -4784, 1573, 45045,
1872 + -10656, 14144, -4576, -858, 45045,
1873 + 64, 624, -4576, 6864, -3003, 15015,
1874 + 100, 208, 572, 3432, -12012, 30030, 45045,
1875 + 1, 9009, -2944, 468, 135135, 5792, 1040, -1287, 135135,
1876 + 5952, -11648, 9152, -2574, 135135,
1877 + -64, -624, 4576, -6864, 3003, 135135,
1878 + 8, 10725, 1856, -936, 225225, -8448, 4992, -1144, 225225,
1879 + -1440, 4160, -4576, 1716, 225225,
1880 + -136, 63063, 1024, -208, 105105,
1881 + 3584, -3328, 1144, 315315,
1882 + -128, 135135, -2560, 832, 405405, 128, 99099/
1886 do 20 l = 0, nc4 - 1
1887 do 10 j = nc4 - 1, l, -1
1889 c4x(k) = polval(m, coeff(o), n) / coeff(o + m + 1)
1898 double precision function sumx(u, v, t)
1900 double precision u, v
1904 double precision up, vpp
1915 double precision function remx(x, y)
1919 double precision x, y
1922 if (remx .lt. -y/2)
then
1924 else if (remx .gt. +y/2)
then
1931 double precision function angnm(x)
1935 double precision remx
1936 angnm = remx(x, 360d0)
1937 if (angnm .eq. -180)
then
1944 double precision function latfix(x)
1949 if (.not. (abs(x) .gt. 90))
return
1951 latfix = sqrt(90 - abs(x))
1956 double precision function angdif(x, y, e)
1963 double precision x, y
1967 double precision d, t, sumx, AngNm
1968 d = angnm(sumx(angnm(-x), angnm(y), t))
1969 if (d .eq. 180 .and. t .gt. 0)
then
1972 angdif = sumx(d, t, e)
1977 double precision function angrnd(x)
1987 double precision y, z
1991 if (y .lt. z) y = z - (z - y)
1993 if (x .eq. 0) angrnd = 0
1998 subroutine swap(x, y)
2000 double precision x, y
2010 double precision function hypotx(x, y)
2012 double precision x, y
2015 hypotx = sqrt(x**2 + y**2)
2020 subroutine norm2x(x, y)
2022 double precision x, y
2024 double precision hypotx, r
2032 double precision function log1px(x)
2036 double precision y, z
2042 log1px = x * log(y) / z
2048 double precision function atanhx(x)
2053 double precision log1px, y
2055 y = log1px(2 * y/(1 - y))/2
2061 double precision function cbrt(x)
2065 cbrt = sign(abs(x)**(1/3d0), x)
2070 double precision function trgsum(sinp, sinx, cosx, c, n)
2079 double precision sinx, cosx, c(n)
2081 double precision ar, y0, y1
2085 ar = 2 * (cosx - sinx) * (cosx + sinx)
2087 if (mod(n, 2) .eq. 1)
then
2098 y1 = ar * y0 - y1 + c(k)
2099 y0 = ar * y1 - y0 + c(k-1)
2103 trgsum = 2 * sinx * cosx * y0
2106 trgsum = cosx * (y0 - y1)
2112 integer function trnsit(lon1, lon2)
2114 double precision lon1, lon2
2116 double precision lon1x, lon2x, lon12, AngNm, AngDif, e
2119 lon12 = angdif(lon1x, lon2x, e)
2121 if (lon1x .le. 0 .and. lon2x .gt. 0 .and. lon12 .gt. 0)
then
2123 else if (lon2x .le. 0 .and. lon1x .gt. 0 .and. lon12 .lt. 0)
then
2130 subroutine accini(s)
2133 double precision s(2)
2141 subroutine accadd(s, y)
2146 double precision s(2)
2148 double precision z, u, sumx
2149 z = sumx(y, s(2), u)
2150 s(1) = sumx(z, s(1), s(2))
2151 if (s(1) .eq. 0)
then
2160 subroutine accrem(s, y)
2165 double precision s(2)
2167 double precision remx
2168 s(1) = remx(s(1), y)
2174 subroutine sncsdx(x, sinx, cosx)
2179 double precision sinx, cosx
2181 double precision dblmin, dbleps, pi, degree, tiny,
2182 + tol0, tol1, tol2, tolb, xthrsh
2183 integer digits, maxit1, maxit2
2185 common /geocom/ dblmin, dbleps, pi, degree, tiny,
2186 + tol0, tol1, tol2, tolb, xthrsh, digits, maxit1, maxit2, init
2188 double precision r, s, c
2192 r = (r - 90 * q) * degree
2201 else if (q .eq. 1)
then
2204 else if (q .eq. 2)
then
2221 double precision function atn2dx(y, x)
2223 double precision x, y
2225 double precision dblmin, dbleps, pi, degree, tiny,
2226 + tol0, tol1, tol2, tolb, xthrsh
2227 integer digits, maxit1, maxit2
2229 common /geocom/ dblmin, dbleps, pi, degree, tiny,
2230 + tol0, tol1, tol2, tolb, xthrsh, digits, maxit1, maxit2, init
2232 double precision xx, yy
2234 if (abs(y) .gt. abs(x)) then
2247 atn2dx = atan2(yy, xx) / degree
2250 atn2dx = 180 - atn2dx
2252 atn2dx = -180 - atn2dx
2254 else if (q .eq. 2)
then
2255 atn2dx = 90 - atn2dx
2256 else if (q .eq. 3)
then
2257 atn2dx = -90 + atn2dx
2263 double precision function polval(N, p, x)
2266 double precision p(0:N), x
2275 polval = polval * x + p(i)