      DOUBLE PRECISION FUNCTION gamln(a)
C-----------------------------------------------------------------------
C            EVALUATION OF LN(GAMMA(A)) FOR POSITIVE A
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS
C          NAVAL SURFACE WARFARE CENTER
C          DAHLGREN, VIRGINIA
C--------------------------
C     D = 0.5*(LN(2*PI) - 1)
C--------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION c0,c1,c2,c3,c4,c5,d,t,w
      INTEGER i,n
C     ..
C     .. External Functions ..
      DOUBLE PRECISION gamln1
      EXTERNAL gamln1
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC dlog
C     ..
C     .. Data statements ..
C--------------------------
      DATA d/.418938533204673D0/
      DATA c0/.833333333333333D-01/,c1/-.277777777760991D-02/,
     +     c2/.793650666825390D-03/,c3/-.595202931351870D-03/,
     +     c4/.837308034031215D-03/,c5/-.165322962780713D-02/
C     ..
C     .. Executable Statements ..
C-----------------------------------------------------------------------
      IF (a.GT.0.8D0) GO TO 10
      gamln = gamln1(a) - dlog(a)
      RETURN

   10 IF (a.GT.2.25D0) GO TO 20
      t = (a-0.5D0) - 0.5D0
      gamln = gamln1(t)
      RETURN
C
   20 IF (a.GE.10.0D0) GO TO 40
      n = a - 1.25D0
      t = a
      w = 1.0D0
      DO 30 i = 1,n
          t = t - 1.0D0
          w = t*w
   30 CONTINUE
      gamln = gamln1(t-1.0D0) + dlog(w)
      RETURN
C
   40 t = (1.0D0/a)**2
      w = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/a
      gamln = (d+w) + (a-0.5D0)* (dlog(a)-1.0D0)
      END


! Battery ageing
! Lubello, Papi: apr 2020

subroutine batteryageing(WeeklyChargeHist, & ! Array of weekly charge history
                         ccyc,              & ! State of Health, to be updated
                         Damage)

     USE MODparam,       ONLY: NhourWeek

      implicit real(8) (a-h,o-z), integer(i-n)

      real(8), intent(IN   ), dimension(NhourWeek) :: WeeklyChargeHist
      real(8), intent(INOUT)                       :: ccyc
      integer                                      :: Ncyc
      real(8),                dimension(10008)     :: grezzata2

      real(8), intent(  OUT)                       :: Damage

      ! Calling rainflow to put WeeklyChargeHist in order

      call newrainflow(NhourWeek,        &
                       WeeklyChargeHist, &
                       Ncyc,             &
                       grezzata2)

      ! Weekly damage estimation with Wohler

      Damage =0.d0

      do idam=1,20
        Damage = Damage + grezzata2(idam)/(1512.4525d0*((dble(idam)/20.d0)**(-0.968423d0)))
        !Damage = Damage + grezzata2(idam)/(151245.25d0*((dble(idam)/20.d0*100)**(-0.968423d0)))
      enddo

      ccyc = ccyc + Damage

      ! Updating SoH with new weekly damage
      !SoH = SoH*(1-Damage*0.3)   ! Damage tra 0 e 1, damage = 1 corrisponde a SoH = 70%

      return

end subroutine batteryageing


module simple_ocean

!------------------------------------------------------------
! Purpose:
!
! A collection of routines used to specify fixed
! or compute interactive SSTs, like slab-ocean model, etc.
!
! Author: Marat Khairoutdinov
! Based on dynamic ocean impelemntation from the UW version of SAM.
!------------------------------------------------------------

use grid
implicit none

public set_sst     ! set SST
public sst_evolve ! evolve SST according to a model set by the ocean_type

CONTAINS

SUBROUTINE set_sst()

 use vars, only: sstxy,t00
 use params, only: tabs_s, delta_sst, ocean_type

! parameters of the sinusoidal SST destribution
! along the X for Walker-type simulatons( ocean-type = 1):

 real(8) tmpx(nx), pii, lx, yy
 integer i,j, it,jt

 select case (ocean_type)

   case(0) ! fixed constant SST

      sstxy = tabs_s - t00

   case(1) ! Sinusoidal distribution along the x-direction:

     lx = float(nx_gl)*dx
     do i = 1,nx
        tmpx(i) = float(mod(rank,nsubdomains_x)*nx+i-1)*dx
     end do
     pii = atan2(0.d0,-1.d0)
     do j=1,ny
       do i=1,nx
         sstxy(i,j) = tabs_s-delta_sst*cos(2.*pii*tmpx(i)/lx) - t00
       end do
     end do

   case(2) ! Sinusoidal distribution along the y-direction:

     call task_rank_to_index(rank,it,jt)

     pii = atan2(0.d0,-1.d0)
     lx = float(ny_gl)*dy
     do j=1,ny
        yy = dy*(j+jt-(ny_gl+YES3D-1)/2-1)
       do i=1,nx
         sstxy(i,j) = tabs_s+delta_sst*(2.*cos(pii*yy/lx)-1.) - t00
       end do
     end do

   case(3) ! QOBS SST profile

      call task_rank_to_index(rank,it,jt)
      lx = float(ny_gl)*dy
      do j=1,ny
         yy = dy*(j+jt-(ny_gl+YES3D-1)/2-1)
         do i=1,nx
            call qobs(yy, sstxy(i, j))
            sstxy(i,j) = sstxy(i,j) - t00
         end do
      end do

   case default

     if(masterproc) then
         print*, 'unknown ocean type in set_sst. Exitting...'
         call task_abort
     end if

 end select
end subroutine set_sst

subroutine qobs(y, sst)
  real(8) :: y
  real  :: sst
  ! locals
  real(8) :: lat, cos1, ans, pi_over_2

  pi_over_2 = atan(1.0)*2.0
  lat = y*2.5e-8*360
  cos1 = cos(pi_over_2 * lat/60.)

  ans = 27./2.0 * (3 * cos1**2 - cos1**4) + 273.15
  sst = ans
end subroutine qobs

SUBROUTINE sst_evolve
 use vars, only: sstxy, t00, fluxbt, fluxbq, rhow,qocean_xy
 use params, only: cp, lcond, tabs_s, ocean_type, dossthomo, &
                   depth_slab_ocean, Szero, deltaS, timesimpleocean
 use rad, only: swnsxy, lwnsxy

 real, parameter :: rhor = 1000. ! density of water (kg/m3)
 real, parameter :: cw = 4187.   ! Liquid Water heat capacity = 4187 J/kg/K
 real factor_cp, factor_lc, qoceanxy
 real tmpx(nx), lx
 real(8) sss,ssss, tmp1(1), tmp2(1)
 integer i,j

      if(time.lt.timesimpleocean) return

      lx = float(nx_gl)*dx
      do i = 1,nx
        tmpx(i) = float(mod(rank,nsubdomains_x)*nx+i-1)*dx
      end do

      ! Define weight factors for the mixed layer heating due to
      ! the model's sensible and latent heat flux.
      factor_cp = rhow(1)*cp
      factor_lc = rhow(1)*lcond

      ! Use forward Euler to integrate the differential equation
      ! for the ocean mixed layer temperature: dT/dt = S - E.
      ! The source: CPT?GCSS WG4 idealized Walker-circulation
      ! RCE Intercomparison proposed by C. Bretherton.
      do j=1,ny
         do i=1,nx
           qoceanxy = Szero + deltaS*abs(2.*tmpx(i)/lx - 1)
	   qocean_xy(i,j) = qocean_xy(i,j) + qoceanxy

            sstxy(i,j) = sstxy(i,j) &
                 + dtn*(swnsxy(i,j)          & ! SW Radiative Heating
                 - lwnsxy(i,j)               & ! LW Radiative Heating
                 - factor_cp*fluxbt(i,j)     & ! Sensible Heat Flux
                 - factor_lc*fluxbq(i,j)     & ! Latent Heat Flux
                 + qoceanxy)            & ! Ocean Heating
                 /(rhor*cw*depth_slab_ocean)        ! Convert W/m^2 Heating to K/s
         end do
      end do

     if(dossthomo) then
        sss = 0.
        do j=1,ny
         do i=1,nx
           sss = sss + sstxy(i,j)
         end do
        end do
        sss = sss / dble(nx*ny)
        if(dompi) then
          tmp1(1) = sss
            call task_sum_real8(tmp1,tmp2,1)
            sss = tmp2(1) /float(nsubdomains)
        end if ! dompi
        if(ocean_type.eq.2) then
            tabs_s = sss + t00
            call set_sst()
        else
           sstxy(:,:) = sss
        end if
     end if

end subroutine sst_evolve

end module simple_ocean


*> @file planimeter.for
*! @brief A test program for area()

*> A simple program to compute the area of a geodesic polygon.
*!
*! This program reads in up to 100000 lines with lat, lon for each vertex
*! of a polygon.  At the end of input, the program prints the number of
*! vertices, the perimeter of the polygon and its area (for the WGS84
*! ellipsoid).

      program planimeter
      implicit none

      include 'geodesic.inc'

      integer maxpts
      parameter (maxpts = 100000)
      double precision a, f, lats(maxpts), lons(maxpts), S, P
      integer n

* WGS84 values
      a = 6378137d0
      f = 1/298.257223563d0

      n = 0
 10   continue
      if (n .ge. maxpts) go to 20
      read(*, *, end=20, err=20) lats(n+1), lons(n+1)
      n = n+1
      go to 10
 20   continue
      call area(a, f, lats, lons, n, S, P)
      print 30, n, P, S
 30   format(i6, 1x, f20.8, 1x, f20.3)
      stop
      end


program test_maptran
!! error tolerances are set for single precision, double precision is much more precise.
use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan, ieee_is_nan
use, intrinsic:: iso_fortran_env, only: stderr=>error_unit
use maptran
use vallado
use assert, only: assert_isclose

implicit none (type, external)

type(Ellipsoid), parameter :: spheroid = wgs84Ellipsoid

real, parameter :: &
lat = 42, lon= -82, alt = 200, &
az = 33, el=70, rng= 1e3, &
x0 = 660.6752518e3, y0 = -4700.9486832e3, z0 = 4245.7376622e3, &
xl = 6.609301927610815e+5, yl = -4.701424222957011e6, zl = 4.246579604632881e+06, & !< aer2ecef
east = 186.277521, north = 286.84222, up = 939.69262, & !< aer2enu
ha = 45.482789587392013

type(datetime), parameter :: t0 = datetime(2014,4,6,8,0,0) !< UTC

real :: ea, eb, atol_dist, atol_deg

select case (storage_size(0.))
  case (32)
    atol_dist = 1 !< 1 meter
    atol_deg = 0.1
  case (64)
    atol_dist = 0.001 !< 1 mm
    atol_deg = 0.01
  case (128)
    atol_dist = 0.001 !< 1 mm
    atol_deg = 1e-6
  case default
    error stop "unknown precision"
end select

print *,'BEGIN: Maptran ',storage_size(0.),' bits.'
print '(A,2ES12.3)', 'Abs_tol dist, deg:',atol_dist, atol_deg

ea = spheroid%SemimajorAxis
eb = spheroid%SemiminorAxis

!! scalar degrees

call test_enu2aer(east,north, up, az,el,rng)
print *, "OK: enu2aer"

call test_aer2ecef(az, el, rng, lat, lon, alt)
print *, "OK: aer2ecef"

call test_aer2enu(az, el, rng, east, north, up)
print *, "OK: aer2enu"

call test_geodetic2ecef(lat, lon, alt)
print *, "OK: geodetic2ecef"

call test_ecef2geodetic(x0,y0,z0)
print *, "OK: ecef2geodetic"

call test_enu_ecef(east, north, up, lat, lon, alt, xl, yl, zl)
print *, "OK enu2ecef, ecef2enu"

call test_ecef2aer(xl, yl, zl, lat, lon, alt)
print *, "OK: ecef2aer"

call test_lookatspheroid(lat, lon, alt)
print *, "OK: lookAtSpheroid"

call test_geodetic_aer(lat, lon, alt)
print *, "OK: geodetic2aer, aer2geodetic"

call test_geodetic_enu(lat, lon, alt)
print *, "OK: geodetic2enu, enu2geodetic"

!! ## array tests

call test_array()
print *, "OK: test_array"

!! ## Vallado Tests
call test_vallado(t0)
print *, "OK: vallado"

!! ## Meeus tests

call assert_isclose(anglesep(35.,23., 84.,20.), ha,&
  err_msg='angle_sep')
print *, "OK: Meeus"

print *,'OK: Maptran ',storage_size(0.),' bits'

contains

subroutine test_vallado(t0)

type(datetime), intent(in) :: t0

real, parameter :: azi = 180.1,  eli = 80, jd0 = 2456753.833333

real :: azrd,elrd,rae,dae,jd

jd = toJulian(t0)

!! http://aa.usno.navy.mil/jdconverter?ID=AA&year=2014&month=4&day=6&era=1&hr=8&min=0&sec=0.0

call assert_isclose(jd, jd0, err_msg='toJulian')

call assert_isclose(toGST(jd), 5.4896448816, &
                    rtol=0.1, err_msg='toGST')
call assert_isclose(toLST(radians(-148.), jd), 2.90658, &
                    rtol=0.2, err_msg='toLST')

call azel2radec(azi,eli,lat,lon, jd, rae, dae)
call radec2azel(rae,dae,lat,lon,jd,azrd,elrd)
call assert_isclose([azi,eli],[azrd,elrd],err_msg='azel<->radec')
end subroutine test_vallado

subroutine test_geodetic_enu(lat, lon, alt)
real, intent(in) :: lat, lon, alt
real :: lt, ln, at, e, n, u, ee, nn, uu

call geodetic2enu(lat, lon, alt-1, lat, lon, alt, e, n, u)
call assert_isclose([e,n,u], [0., 0., -1.], atol=atol_dist)

call enu2geodetic(e,n,u, lat,lon,alt, lt, ln, at)
call assert_isclose([lt,ln], [lat,lon])
call assert_isclose(at, alt-1, atol=atol_dist)

call geodetic2enu(radians(lt), radians(ln), at, &
  radians(lat),radians(lon),alt, ee,nn,uu, deg=.false.)
call assert_isclose([ee,nn,uu],[e,n,u], atol=atol_dist)

call enu2geodetic(0.,0., -1., radians(lat),radians(lon), 0., lt,ln,at, deg=.false.)
call assert_isclose([degrees(lt),degrees(ln)], [lat,lon])
call assert_isclose(at, -1., atol=atol_dist)
end subroutine test_geodetic_enu

subroutine test_array()

integer,parameter :: N = 3

real, dimension(N), parameter :: alat = [42,52,62], &
                                    deg0 = [15,30,45], &
                                    aaz = [33,43,53]
real, dimension(N) :: &
ax1, ay1, aaaz1, ax2, ay2,az2, aaaz2, ax3,ay3,aaaz3, &
ae1, an1, au1, ae2,an2,au2, &
alat2,alon2,aalt2, alat3,alon3,aalt3, alat4,alon4,aalt4, &
aaz2, ael2, arng2, aaz3,ael3,arng3, aaz4,ael4,arng4

call assert_isclose(degrees(radians(deg0)), deg0, err_msg='deg<->rad')
print *, "OK: degrees < = > radians"

call geodetic2ecef(alat,lon,alt,ax1,ay1,aaaz1)
call aer2enu(aaz, el, rng, ae1, an1, au1)
call aer2ecef(aaz, el, rng, lat,lon,alt, ax2, ay2, aaaz2)
call ecef2geodetic(ax1,ay1,aaaz1,alat2,alon2,aalt2)
call enu2aer(ae1,an1,au1, aaz2, ael2, arng2)
call ecef2aer(ax2,ay2,az2, lat,lon,alt, aaz3, ael3, arng3)
call aer2geodetic(aaz,el,rng,lat,lon,alt, alat3,alon3,aalt3)
call geodetic2enu(alat3, alon3, aalt3, lat, lon, alt, ae2, an2, au2)
call geodetic2aer(alat3,alon3, aalt3,lat,lon,alt, aaz4, ael4, arng4)
call enu2ecef(ae1,an1,au1,lat,lon,alt, ax3, ay3, aaaz3)
call enu2geodetic(ae2,an2,au2,lat,lon,alt,alat4, alon4, aalt4)

end subroutine test_array

subroutine test_geodetic_aer(lat, lon, alt)
real, intent(in) :: lat, lon, alt
real :: lt, ln, at, a, e, r

real, parameter :: lat1 = 42.0026, lon1 = -81.9978, alt1 = 1.1397e3

call aer2geodetic(0., -90., 1., lat, lon, alt, lt,ln,at)
call assert_isclose([lt,ln], [lat, lon])
call assert_isclose(at, alt-1, atol=atol_dist)

call geodetic2aer(0.,45.,-1000., 0., 45., 0., a, e, r)
call assert_isclose([a,e], [0.,-90.])
call assert_isclose(r, 1000., atol=atol_dist)

call aer2geodetic(radians(az),radians(el),rng, radians(lat),radians(lon),alt, &
  lt,ln,at, deg=.false.)
call assert_isclose([degrees(lt),degrees(ln)], [lat1,lon1])
call assert_isclose(at, alt1, atol=2*atol_dist)

call geodetic2aer(lt,ln, at, radians(lat),radians(lon),alt, a,e,r, deg=.false.)
call assert_isclose([degrees(a),degrees(e)],[az,el], atol=atol_deg)
call assert_isclose(r, rng, atol=atol_dist)

end subroutine test_geodetic_aer

subroutine test_ecef2aer(xl, yl, zl, lat, lon, alt)
real, intent(in) :: xl, yl, zl, lat, lon, alt
real :: a, e, r, x, y,z

call ecef2aer(xl,yl,zl, lat,lon,alt, a, e, r)
call assert_isclose([a,e], [az,el], atol=atol_deg)
call assert_isclose(r, rng, atol=atol_dist, rtol=0.001, &
  err_msg='ecef2aer-degrees1')

call ecef2aer(ea-1., 0., 0., 0., 0., 0., a, e, r)
call assert_isclose([a,e,r], [0., -90., 1.], &
  err_msg='ecef2aer-degrees2')

call ecef2aer(-ea+1., 0., 0., 0., 180., 0., a, e, r)
call assert_isclose([a,e,r], [0., -90., 1.], &
  err_msg='ecef2aer-degrees3')

call ecef2aer(0., ea-1., 0., 0., 90., 0., a, e, r)
call assert_isclose([a,e,r], [0., -90., 1.], &
  err_msg='ecef2aer-degrees4')

call ecef2aer(0., -ea+1., 0., 0., -90., 0., a, e, r)
call assert_isclose([a,e,r], [0., -90., 1.], &
  err_msg='ecef2aer-degrees5')

call ecef2aer(0., 0., eb-1000., 90., 0., 0., a, e, r)
call assert_isclose([a,e,r], [0., -90., 1000.], rtol=0.001)

call ecef2aer(0., 0., -eb+1000., -90., 0., 0., a, e, r)
call assert_isclose([a,e,r], [0., -90., 1000.], rtol=0.001)

call ecef2aer((ea-1000.)/sqrt(2.), (ea-1000.)/sqrt(2.), 0., &
              0., 45., 0., a, e, r)
call assert_isclose([a,e,r], [0., -90., 1000.], &
                      rtol=0.001, err_msg='ecef2aer-degrees')

call aer2ecef(radians(az),radians(el),rng, radians(lat),radians(lon),alt, x,y,z, deg=.false.)
call assert_isclose([x,y,z],[xl,yl,zl])

call ecef2aer(x,y,z, radians(lat),radians(lon),alt, a,e,r, deg=.false.)
call assert_isclose([degrees(a),degrees(e)],[az,el], atol=atol_deg)
call assert_isclose(r, rng, atol=atol_dist)

end subroutine test_ecef2aer

subroutine test_enu_ecef(east, north, up, lat, lon, alt, xl, yl, zl)
real, intent(in) :: east, north, up, lat, lon, alt, xl, yl, zl
real :: x, y, z, e, n, u

call enu2ecef(east, north, up, lat,lon,alt, x, y, z)
call assert_isclose([x,y,z], [xl,yl, zl], err_msg='enu2ecef-degrees')

call ecef2enu(x,y,z, lat,lon,alt, e,n,u)
call assert_isclose([e,n,u], [east, north, up], atol=atol_dist)

call enu2ecef(east, north, up, radians(lat),radians(lon),alt, x,y,z, deg=.false.)
call assert_isclose([x,y,z],[xl,yl,zl], err_msg='enu2ecef: rad')

call ecef2enu(x,y,z, radians(lat),radians(lon),alt, e,n,u, deg=.false.)
call assert_isclose([e,n,u],[east, north, up], atol=atol_dist)

end subroutine test_enu_ecef

subroutine test_ecef2geodetic(x0,y0,z0)
real, intent(in) :: x0, y0, z0
real :: lt, ln, at

call ecef2geodetic(x0,y0,z0,lt,ln,at)
call assert_isclose([lt,ln], [lat,lon])
call assert_isclose(at, alt, atol=atol_dist, &
  err_msg='ecef2geodetic-degrees1')

call ecef2geodetic(ea-1, 0., 0., lt, ln, at)
call assert_isclose([lt,ln,at], [0., 0., -1.], &
  err_msg='ecef2geodetic-degrees2')

call ecef2geodetic(0., ea-1, 0., lt, ln, at)
call assert_isclose([lt,ln,at], [0., 90., -1.], &
  err_msg='ecef2geodetic-degrees3')

call ecef2geodetic(0., -ea+1, 0., lt, ln, at)
call assert_isclose([lt,ln,at], [0., -90., -1.], &
  err_msg='ecef2geodetic-degrees4')

call ecef2geodetic(0., 0., eb-1, lt, ln, at)
call assert_isclose([lt,ln,at], [90., 0., -1.], &
  err_msg='ecef2geodetic-degrees5')

call ecef2geodetic(0., 0., -eb+1, lt, ln, at)
call assert_isclose([lt,ln,at], [-90., 0., -1.], &
  err_msg='ecef2geodetic-degrees6')

call ecef2geodetic(-ea+1, 0., 0., lt, ln, at)
call assert_isclose([lt,ln,at], [0., 180., -1.], &
  err_msg='ecef2geodetic-degrees7')

call ecef2geodetic((ea-1000)/sqrt(2.), &
                    (ea-1000)/sqrt(2.), 0., lt, ln, at)
call assert_isclose([lt,ln,at], [0., 45., -1000.], atol=atol_dist)

end subroutine test_ecef2geodetic

subroutine test_enu2aer(east, north, up, az, el, rng)
real, intent(in) :: east, north, up, az, el, rng
real :: a, e, r, ee, n, u

call enu2aer(east, north, up, a, e, r)
call assert_isclose([a, e, r], [az, el, rng], err_msg='enu2aer-degrees')

call enu2aer(1., 0., 0., a, e, r)
call assert_isclose([a, e, r], [90., 0., 1.])

call aer2enu(radians(az),radians(el),rng, ee,n,u, deg=.false.)
call assert_isclose([ee,n,u], [east, north, up])

call enu2aer(ee,n,u, a, e, r, deg=.false.)
call assert_isclose([degrees(a),degrees(e),r],[az,el,rng])
end subroutine test_enu2aer

subroutine test_aer2enu(az, el, rng, east, north, up)
real, intent(in) :: az, el, rng, east, north, up

real :: e,n,u

call aer2enu(az, el, rng, e, n, u)
call assert_isclose([e, n, u], [east, north, up])

call aer2enu(0., -90., 1., e, n, u)
call assert_isclose([e, n, u], [0., 0., -1.], atol=1e-6)

call aer2enu(0., 90., 1., e, n, u)
call assert_isclose([e, n, u], [0., 0., 1.], atol=1e-6)
end subroutine test_aer2enu

subroutine test_lookatspheroid(lat, lon, alt)
real, intent(in) :: lat, lon, alt
real, dimension(3) :: az, tilt, olat, olon, orng

real:: nan
nan = ieee_value(0., ieee_quiet_nan)
if(.not.ieee_is_nan(nan)) then
  write(stderr,*) "SKIP: lookatspheroid: compiler NaN not working"
  return
endif

az = [0., 10., 125.]
tilt = [30, 45, 90]

call lookAtSpheroid(lat, lon, alt, az, 0., olat, olon, orng)
call assert_isclose(olat, lat, err_msg='lookAtSpheroid:lat0')
call assert_isclose(olon, lon, err_msg='lookAtSpheroid:lon0')
call assert_isclose(orng, alt, rtol=0.01, err_msg='lookAtSpheroid:rng0')

call lookAtSpheroid(lat, lon, alt, az, tilt, olat, olon, orng)
call assert_isclose(olat, [42.00103959, 42.00177328, nan],  equal_nan=.true., err_msg='lookAtSpheroid:lat')
call assert_isclose(olon, [lon, -81.9995808, nan],  equal_nan=.true., err_msg='lookAtSpheroid:lon')
call assert_isclose(orng, [230.9413173, 282.84715651, nan], rtol=0.01, equal_nan=.true., err_msg='lookAtSpheroid:rng')

print *, "OK: lookatspheroid"
end subroutine test_lookatspheroid

subroutine test_geodetic2ecef(lat,lon, alt)
real, intent(in) :: lat, lon, alt
real :: x,y,z, lt, ln, at

call geodetic2ecef(lat,lon,alt, x, y, z)
call assert_isclose([x, y, z],[x0,y0,z0], err_msg='geodetic2ecef-degrees1')

call geodetic2ecef(0., 0., -1., x, y, z)
call assert_isclose([x, y, z], [ea-1, 0., 0.], err_msg='geodetic2ecef-degrees2')

call geodetic2ecef(0., 90., -1., x, y, z)
call assert_isclose([x, y, z], [0., ea-1, 0.], err_msg='geodetic2ecef-degrees3')

call geodetic2ecef(0., -90., -1., x, y, z)
call assert_isclose([x,y,z], [0., -ea+1, 0.], err_msg='geodetic2ecef-degrees4')

call geodetic2ecef(0., -180., -1., x, y, z)
call assert_isclose([x,y,z], [-ea+1, 0., 0.], atol=atol_dist, err_msg='geodetic2ecef-degrees5')
call geodetic2ecef(0., 180., -1., x, y, z)
call assert_isclose([x,y,z], [-ea+1, 0., 0.], atol=atol_dist, err_msg='geodetic2ecef-degrees6')

call geodetic2ecef(90., 0., -1., x, y, z)
call assert_isclose([x,y,z], [0., 0., eb-1], err_msg='geodetic2ecef-degrees7')

call geodetic2ecef(-90., 0., -1., x, y, z)
call assert_isclose([x,y,z], [0., 0., -eb+1], err_msg='geodetic2ecef-degrees8')

call geodetic2ecef(90., 15., -1., x, y, z)
call assert_isclose([x,y,z], [0., 0., eb-1], err_msg='geodetic2ecef-degrees9')

call geodetic2ecef(-45., 45., -1., x, y, z)
call assert_isclose([x,y,z], [3.194418645060574e+06, 3.194418645060574e+06, -4.487347701759138e+06], &
  err_msg='geodetic2ecef-degrees10')

call geodetic2ecef(45., -45., -1., x, y, z)
call assert_isclose([x,y,z], [3.194418645060574e+06, -3.194418645060574e+06, 4.487347701759138e+06], &
  err_msg='geodetic2ecef-degrees1')

call ecef2geodetic(x0,y0,z0, lt,ln,at, deg=.false.)
call assert_isclose([degrees(lt),degrees(ln)],[lat,lon], atol=atol_deg)
call assert_isclose(at, alt, atol=atol_dist)

call geodetic2ecef(radians(lat),radians(lon),alt, x,y,z, deg=.false.)
call assert_isclose([x,y,z],[x0,y0,z0])

end subroutine test_geodetic2ecef

subroutine test_aer2ecef(az, el, rng, lat, lon, alt)
real, intent(in) :: az, el, rng, lat, lon, alt
real :: x,y,z

call aer2ecef(az, el, rng, lat, lon, alt, x, y, z)
call assert_isclose([x, y, z], [xl,yl,zl], err_msg='aer2ecef1')

call aer2ecef(0., -90., 1., 0., 0., -1., x, y, z)
call assert_isclose([x, y, z], [ea-1., 0., 0.], atol=1e-6, err_msg='aer2ecef2')

call aer2ecef(0., -90., 1., 0., 90., -1., x, y, z)
call assert_isclose([x,y,z],[0., ea-1., 0.], atol=1e-6, err_msg='aer2ecef3')

call aer2ecef(0., -90., 1., 90., 0., -1., x, y, z)
call assert_isclose([x,y,z],[0., 0., eb-1.], atol=1e-6, err_msg='aer2ecef4')

call aer2ecef(0., -90., 1., 0., 90., -1., x, y, z)
call assert_isclose([x,y,z],[0., ea-1., 0.], atol=1e-6, err_msg='aer2ecef5')

call aer2ecef(0., -90., 1., 0., 45., -1., x, y, z)
call assert_isclose([x,y,z], &
        [(ea-1.)/sqrt(2.), (ea-1.)/sqrt(2.), 0.], atol=1e-6, err_msg='aer2ecef6')

end subroutine test_aer2ecef

end program


subroutine daxpy ( n, da, dx, incx, dy, incy )

!*****************************************************************************80
!
!! DAXPY computes constant times a vector plus a vector.
!
!  Discussion:
!
!    This routine uses double precision real arithmetic.
!
!    This routine uses unrolled loops for increments equal to one.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    16 May 2005
!
!  Author:
!
!    Original FORTRAN77 version by Charles Lawson, Richard Hanson,
!    David Kincaid, Fred Krogh.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979,
!    ISBN13: 978-0-898711-72-1,
!    LC: QA214.L56.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Algorithm 539,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of elements in DX and DY.
!
!    Input, real ( kind = 8 ) DA, the multiplier of DX.
!
!    Input, real ( kind = 8 ) DX(*), the first vector.
!
!    Input, integer ( kind = 4 ) INCX, the increment between successive
!    entries of DX.
!
!    Input/output, real ( kind = 8 ) DY(*), the second vector.
!    On output, DY(*) has been replaced by DY(*) + DA * DX(*).
!
!    Input, integer ( kind = 4 ) INCY, the increment between successive
!    entries of DY.
!
  implicit none

  real ( kind = 8 ) da
  real ( kind = 8 ) dx(*)
  real ( kind = 8 ) dy(*)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) incx
  integer ( kind = 4 ) incy
  integer ( kind = 4 ) ix
  integer ( kind = 4 ) iy
  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  if ( n <= 0 ) then
    return
  end if

  if ( da == 0.0D+00 ) then
    return
  end if
!
!  Code for unequal increments or equal increments
!  not equal to 1.
!
  if ( incx /= 1 .or. incy /= 1 ) then

    if ( 0 <= incx ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    if ( 0 <= incy ) then
      iy = 1
    else
      iy = ( - n + 1 ) * incy + 1
    end if

    do i = 1, n
      dy(iy) = dy(iy) + da * dx(ix)
      ix = ix + incx
      iy = iy + incy
    end do
!
!  Code for both increments equal to 1.
!
  else

    m = mod ( n, 4 )

    dy(1:m) = dy(1:m) + da * dx(1:m)

    do i = m+1, n, 4
      dy(i  ) = dy(i  ) + da * dx(i  )
      dy(i+1) = dy(i+1) + da * dx(i+1)
      dy(i+2) = dy(i+2) + da * dx(i+2)
      dy(i+3) = dy(i+3) + da * dx(i+3)
    end do

  end if

  return
end
function ddot ( n, dx, incx, dy, incy )

!*****************************************************************************80
!
!! DDOT forms the dot product of two vectors.
!
!  Discussion:
!
!    This routine uses double precision real arithmetic.
!
!    This routine uses unrolled loops for increments equal to one.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    16 May 2005
!
!  Author:
!
!    Original FORTRAN77 version by Charles Lawson, Richard Hanson,
!    David Kincaid, Fred Krogh.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979,
!    ISBN13: 978-0-898711-72-1,
!    LC: QA214.L56.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Algorithm 539,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of entries in the vectors.
!
!    Input, real ( kind = 8 ) DX(*), the first vector.
!
!    Input, integer ( kind = 4 ) INCX, the increment between successive
!    entries in DX.
!
!    Input, real ( kind = 8 ) DY(*), the second vector.
!
!    Input, integer ( kind = 4 ) INCY, the increment between successive
!    entries in DY.
!
!    Output, real ( kind = 8 ) DDOT, the sum of the product of the
!    corresponding entries of DX and DY.
!
  implicit none

  real ( kind = 8 ) ddot
  real ( kind = 8 ) dtemp
  real ( kind = 8 ) dx(*)
  real ( kind = 8 ) dy(*)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) incx
  integer ( kind = 4 ) incy
  integer ( kind = 4 ) ix
  integer ( kind = 4 ) iy
  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  ddot = 0.0D+00
  dtemp = 0.0D+00

  if ( n <= 0 ) then
    return
  end if
!
!  Code for unequal increments or equal increments
!  not equal to 1.
!
  if ( incx /= 1 .or. incy /= 1 ) then

    if ( 0 <= incx ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    if ( 0 <= incy ) then
      iy = 1
    else
      iy = ( - n + 1 ) * incy + 1
    end if

    do i = 1, n
      dtemp = dtemp + dx(ix) * dy(iy)
      ix = ix + incx
      iy = iy + incy
    end do
!
!  Code for both increments equal to 1.
!
  else

    m = mod ( n, 5 )

    do i = 1, m
      dtemp = dtemp + dx(i) * dy(i)
    end do

    do i = m+1, n, 5

      dtemp = dtemp + dx(i  ) * dy(i  ) &
                    + dx(i+1) * dy(i+1) &
                    + dx(i+2) * dy(i+2) &
                    + dx(i+3) * dy(i+3) &
                    + dx(i+4) * dy(i+4)
    end do

  end if

  ddot = dtemp

  return
end
function dnrm2 ( n, x, incx )

!*****************************************************************************80
!
!! DNRM2 returns the euclidean norm of a vector.
!
!  Discussion:
!
!    This routine uses double precision real arithmetic.
!
!     DNRM2 ( X ) = sqrt ( X' * X )
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    16 May 2005
!
!  Author:
!
!    Original FORTRAN77 version by Charles Lawson, Richard Hanson,
!    David Kincaid, Fred Krogh.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979,
!    ISBN13: 978-0-898711-72-1,
!    LC: QA214.L56.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Algorithm 539,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of entries in the vector.
!
!    Input, real ( kind = 8 ) X(*), the vector whose norm is to be computed.
!
!    Input, integer ( kind = 4 ) INCX, the increment between successive
!    entries of X.
!
!    Output, real ( kind = 8 ) DNRM2, the Euclidean norm of X.
!
  implicit none

  real ( kind = 8 ) absxi
  real ( kind = 8 ) dnrm2
  integer ( kind = 4 ) incx
  integer ( kind = 4 ) ix
  integer ( kind = 4 ) n
  real ( kind = 8 ) norm
  real ( kind = 8 ) scale
  real ( kind = 8 ) ssq
  real ( kind = 8 ) x(*)

  if ( n < 1 .or. incx < 1 ) then

    norm  = 0.0D+00

  else if ( n == 1 ) then

    norm  = abs ( x(1) )

  else

    scale = 0.0D+00
    ssq = 1.0D+00

    do ix = 1, 1 + ( n - 1 ) * incx, incx
      if ( x(ix) /= 0.0D+00 ) then
        absxi = abs ( x(ix) )
        if ( scale < absxi ) then
          ssq = 1.0D+00 + ssq * ( scale / absxi )**2
          scale = absxi
        else
          ssq = ssq + ( absxi / scale )**2
        end if
      end if
    end do
    norm  = scale * sqrt ( ssq )
  end if

  dnrm2 = norm

  return
end
subroutine dqrank ( a, lda, m, n, tol, kr, jpvt, qraux, work )

!*****************************************************************************80
!
!! DQRANK computes the QR factorization of a rectangular matrix.
!
!  Discussion:
!
!    This routine is used in conjunction with sqrlss to solve
!    overdetermined, underdetermined and singular linear systems
!    in a least squares sense.
!
!    DQRANK uses the LINPACK subroutine DQRDC to compute the QR
!    factorization, with column pivoting, of an M by N matrix A.
!    The numerical rank is determined using the tolerance TOL.
!
!    Note that on output, ABS ( A(1,1) ) / ABS ( A(KR,KR) ) is an estimate
!    of the condition number of the matrix of independent columns,
!    and of R.  This estimate will be <= 1/TOL.
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979,
!    ISBN13: 978-0-898711-72-1,
!    LC: QA214.L56.
!
!  Parameters:
!
!    Input/output, real ( kind = 8 ) A(LDA,N).  On input, the matrix whose
!    decomposition is to be computed.  On output, the information from DQRDC.
!    The triangular matrix R of the QR factorization is contained in the
!    upper triangle and information needed to recover the orthogonal
!    matrix Q is stored below the diagonal in A and in the vector QRAUX.
!
!    Input, integer ( kind = 4 ) LDA, the leading dimension of A, which must
!    be at least M.
!
!    Input, integer ( kind = 4 ) M, the number of rows of A.
!
!    Input, integer ( kind = 4 ) N, the number of columns of A.
!
!    Input, real ( kind = 8 ) TOL, a relative tolerance used to determine the
!    numerical rank.  The problem should be scaled so that all the elements
!    of A have roughly the same absolute accuracy, EPS.  Then a reasonable
!    value for TOL is roughly EPS divided by the magnitude of the largest
!    element.
!
!    Output, integer ( kind = 4 ) KR, the numerical rank.
!
!    Output, integer ( kind = 4 ) JPVT(N), the pivot information from DQRDC.
!    Columns JPVT(1), ..., JPVT(KR) of the original matrix are linearly
!    independent to within the tolerance TOL and the remaining columns
!    are linearly dependent.
!
!    Output, real ( kind = 8 ) QRAUX(N), will contain extra information defining
!    the QR factorization.
!
!    Workspace, real ( kind = 8 ) WORK(N).
!
  implicit none

  integer ( kind = 4 ) lda
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(lda,n)
  integer ( kind = 4 ) j
  integer ( kind = 4 ) job
  integer ( kind = 4 ) jpvt(n)
  integer ( kind = 4 ) k
  integer ( kind = 4 ) kr
  integer ( kind = 4 ) m
  real ( kind = 8 ) qraux(n)
  real ( kind = 8 ) tol
  real ( kind = 8 ) work(n)

  jpvt(1:n) = 0
  job = 1

  call dqrdc ( a, lda, m, n, qraux, jpvt, work, job )

  kr = 0
  k = min ( m, n )

  do j = 1, k
    if ( abs ( a(j,j) ) <= tol * abs ( a(1,1) ) ) then
      return
    end if
    kr = j
  end do

  return
end
subroutine dqrdc ( a, lda, n, p, qraux, jpvt, work, job )

!*****************************************************************************80
!
!! DQRDC computes the QR factorization of a real rectangular matrix.
!
!  Discussion:
!
!    DQRDC uses Householder transformations.
!
!    Column pivoting based on the 2-norms of the reduced columns may be
!    performed at the user's option.
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979,
!    ISBN13: 978-0-898711-72-1,
!    LC: QA214.L56.
!
!  Parameters:
!
!    Input/output, real ( kind = 8 ) A(LDA,P).  On input, the N by P matrix
!    whose decomposition is to be computed.  On output, A contains in
!    its upper triangle the upper triangular matrix R of the QR
!    factorization.  Below its diagonal A contains information from
!    which the orthogonal part of the decomposition can be recovered.
!    Note that if pivoting has been requested, the decomposition is not that
!    of the original matrix A but that of A with its columns permuted
!    as described by JPVT.
!
!    Input, integer ( kind = 4 ) LDA, the leading dimension of the array A.
!    LDA must be at least N.
!
!    Input, integer ( kind = 4 ) N, the number of rows of the matrix A.
!
!    Input, integer ( kind = 4 ) P, the number of columns of the matrix A.
!
!    Output, real ( kind = 8 ) QRAUX(P), contains further information required
!    to recover the orthogonal part of the decomposition.
!
!    Input/output, integer ( kind = 4 ) JPVT(P).  On input, JPVT contains
!    integers that control the selection of the pivot columns.  The K-th
!    column A(*,K) of A is placed in one of three classes according to the
!    value of JPVT(K).
!      > 0, then A(K) is an initial column.
!      = 0, then A(K) is a free column.
!      < 0, then A(K) is a final column.
!    Before the decomposition is computed, initial columns are moved to
!    the beginning of the array A and final columns to the end.  Both
!    initial and final columns are frozen in place during the computation
!    and only free columns are moved.  At the K-th stage of the
!    reduction, if A(*,K) is occupied by a free column it is interchanged
!    with the free column of largest reduced norm.  JPVT is not referenced
!    if JOB == 0.  On output, JPVT(K) contains the index of the column of the
!    original matrix that has been interchanged into the K-th column, if
!    pivoting was requested.
!
!    Workspace, real ( kind = 8 ) WORK(P).  WORK is not referenced if JOB == 0.
!
!    Input, integer ( kind = 4 ) JOB, initiates column pivoting.
!    0, no pivoting is done.
!    nonzero, pivoting is done.
!
  implicit none

  integer ( kind = 4 ) lda
  integer ( kind = 4 ) n
  integer ( kind = 4 ) p

  real ( kind = 8 ) a(lda,p)
  integer ( kind = 4 ) jpvt(p)
  real ( kind = 8 ) qraux(p)
  real ( kind = 8 ) work(p)
  integer ( kind = 4 ) j
  integer ( kind = 4 ) job
  integer ( kind = 4 ) jp
  integer ( kind = 4 ) l
  integer ( kind = 4 ) lup
  integer ( kind = 4 ) maxj
  real ( kind = 8 ) maxnrm
  real ( kind = 8 ) nrmxl
  integer ( kind = 4 ) pl
  integer ( kind = 4 ) pu
  real ( kind = 8 ) ddot
  real ( kind = 8 ) dnrm2
  logical swapj
  real ( kind = 8 ) t
  real ( kind = 8 ) tt

  pl = 1
  pu = 0
!
!  If pivoting is requested, rearrange the columns.
!
  if ( job /= 0 ) then

    do j = 1, p

      swapj = 0 < jpvt(j)

      if ( jpvt(j) < 0 ) then
        jpvt(j) = - j
      else
        jpvt(j) = j
      end if

      if ( swapj ) then

        if ( j /= pl ) then
          call dswap ( n, a(1,pl), 1, a(1,j), 1 )
        end if

        jpvt(j) = jpvt(pl)
        jpvt(pl) = j
        pl = pl + 1

      end if

    end do

    pu = p

    do j = p, 1, -1

      if ( jpvt(j) < 0 ) then

        jpvt(j) = - jpvt(j)

        if ( j /= pu ) then
          call dswap ( n, a(1,pu), 1, a(1,j), 1 )
          jp = jpvt(pu)
          jpvt(pu) = jpvt(j)
          jpvt(j) = jp
        end if

        pu = pu - 1

      end if

    end do

  end if
!
!  Compute the norms of the free columns.
!
  do j = pl, pu
    qraux(j) = dnrm2 ( n, a(1,j), 1 )
  end do

  work(pl:pu) = qraux(pl:pu)
!
!  Perform the Householder reduction of A.
!
  lup = min ( n, p )

  do l = 1, lup
!
!  Bring the column of largest norm into the pivot position.
!
    if ( pl <= l .and. l < pu ) then

      maxnrm = 0.0D+00
      maxj = l
      do j = l, pu
        if ( maxnrm < qraux(j) ) then
          maxnrm = qraux(j)
          maxj = j
        end if
      end do

      if ( maxj /= l ) then
        call dswap ( n, a(1,l), 1, a(1,maxj), 1 )
        qraux(maxj) = qraux(l)
        work(maxj) = work(l)
        jp = jpvt(maxj)
        jpvt(maxj) = jpvt(l)
        jpvt(l) = jp
      end if

    end if
!
!  Compute the Householder transformation for column L.
!
    qraux(l) = 0.0D+00

    if ( l /= n ) then

      nrmxl = dnrm2 ( n-l+1, a(l,l), 1 )

      if ( nrmxl /= 0.0D+00 ) then

        if ( a(l,l) /= 0.0D+00 ) then
          nrmxl = sign ( nrmxl, a(l,l) )
        end if

        call dscal ( n-l+1, 1.0D+00 / nrmxl, a(l,l), 1 )
        a(l,l) = 1.0D+00 + a(l,l)
!
!  Apply the transformation to the remaining columns, updating the norms.
!
        do j = l + 1, p

          t = - ddot ( n-l+1, a(l,l), 1, a(l,j), 1 ) / a(l,l)
          call daxpy ( n-l+1, t, a(l,l), 1, a(l,j), 1 )

          if ( pl <= j .and. j <= pu ) then

            if ( qraux(j) /= 0.0D+00 ) then

              tt = 1.0D+00 - ( abs ( a(l,j) ) / qraux(j) )**2
              tt = max ( tt, 0.0D+00 )
              t = tt
              tt = 1.0D+00 + 0.05D+00 * tt * ( qraux(j) / work(j) )**2

              if ( tt /= 1.0D+00 ) then
                qraux(j) = qraux(j) * sqrt ( t )
              else
                qraux(j) = dnrm2 ( n-l, a(l+1,j), 1 )
                work(j) = qraux(j)
              end if

            end if

          end if

        end do
!
!  Save the transformation.
!
        qraux(l) = a(l,l)
        a(l,l) = - nrmxl

      end if

    end if

  end do

  return
end
subroutine dqrls ( a, lda, m, n, tol, kr, b, x, r, jpvt, qraux, work, &
  itask, ind )

!*****************************************************************************80
!
!! DQRLS factors and solves a linear system in the least squares sense.
!
!  Discussion:
!
!    The linear system may be overdetermined, underdetermined or singular.
!    The solution is obtained using a QR factorization of the
!    coefficient matrix.
!
!    DQRLS can be efficiently used to solve several least squares
!    problems with the same matrix A.  The first system is solved
!    with ITASK = 1.  The subsequent systems are solved with
!    ITASK = 2, to avoid the recomputation of the matrix factors.
!    The parameters KR, JPVT, and QRAUX must not be modified
!    between calls to DQRLS.
!
!    DQRLS is used to solve in a least squares sense
!    overdetermined, underdetermined and singular linear systems.
!    The system is A*X approximates B where A is M by N.
!    B is a given M-vector, and X is the N-vector to be computed.
!    A solution X is found which minimimzes the sum of squares (2-norm)
!    of the residual,  A*X - B.
!
!    The numerical rank of A is determined using the tolerance TOL.
!
!    DQRLS uses the LINPACK subroutine DQRDC to compute the QR
!    factorization, with column pivoting, of an M by N matrix A.
!
!  Modified:
!
!    15 April 2012
!
!  Reference:
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input/output, real ( kind = 8 ) A(LDA,N), an M by N matrix.
!    On input, the matrix whose decomposition is to be computed.
!    In a least squares data fitting problem, A(I,J) is the
!    value of the J-th basis (model) function at the I-th data point.
!    On output, A contains the output from DQRDC.  The triangular matrix R
!    of the QR factorization is contained in the upper triangle and
!    information needed to recover the orthogonal matrix Q is stored
!    below the diagonal in A and in the vector QRAUX.
!
!    Input, integer ( kind = 4 ) LDA, the leading dimension of A.
!
!    Input, integer ( kind = 4 ) M, the number of rows of A.
!
!    Input, integer ( kind = 4 ) N, the number of columns of A.
!
!    Input, real ( kind = 8 ) TOL, a relative tolerance used to determine the
!    numerical rank.  The problem should be scaled so that all the elements
!    of A have roughly the same absolute accuracy EPS.  Then a reasonable
!    value for TOL is roughly EPS divided by the magnitude of the largest
!    element.
!
!    Output, integer ( kind = 4 ) KR, the numerical rank.
!
!    Input, real ( kind = 8 ) B(M), the right hand side of the linear system.
!
!    Output, real ( kind = 8 ) X(N), a least squares solution to the linear
!    system.
!
!    Output, real ( kind = 8 ) R(M), the residual, B - A*X.  R may
!    overwrite B.
!
!    Workspace, integer ( kind = 4 ) JPVT(N), required if ITASK = 1.
!    Columns JPVT(1), ..., JPVT(KR) of the original matrix are linearly
!    independent to within the tolerance TOL and the remaining columns
!    are linearly dependent.  ABS ( A(1,1) ) / ABS ( A(KR,KR) ) is an estimate
!    of the condition number of the matrix of independent columns,
!    and of R.  This estimate will be <= 1/TOL.
!
!    Workspace, real ( kind = 8 ) QRAUX(N), required if ITASK = 1.
!
!    Workspace, real ( kind = 8 ) WORK(N), required if ITASK = 1.
!
!    Input, integer ( kind = 4 ) ITASK.
!    1, DQRLS factors the matrix A and solves the least squares problem.
!    2, DQRLS assumes that the matrix A was factored with an earlier
!       call to DQRLS, and only solves the least squares problem.
!
!    Output, integer ( kind = 4 ) IND, error code.
!    0:  no error
!    -1: LDA < M   (fatal error)
!    -2: N < 1     (fatal error)
!    -3: ITASK < 1 (fatal error)
!
  implicit none

  integer ( kind = 4 ) lda
  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(lda,n)
  real ( kind = 8 ) b(m)
  integer ( kind = 4 ) ind
  integer ( kind = 4 ) itask
  integer ( kind = 4 ) jpvt(n)
  integer ( kind = 4 ) kr
  real ( kind = 8 ) qraux(n)
  real ( kind = 8 ) r(m)
  real ( kind = 8 ) tol
  real ( kind = 8 ) work(n)
  real ( kind = 8 ) x(n)

  if ( lda < m ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'DQRLS - Fatal error!'
    write ( *, '(a)' ) '  LDA < M.'
    stop
  end if

  if ( n <= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'DQRLS - Fatal error!'
    write ( *, '(a)' ) '  N <= 0.'
    stop
  end if

  if ( itask < 1 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'DQRLS - Fatal error!'
    write ( *, '(a)' ) '  ITASK < 1.'
    stop
  end if

  ind = 0
!
!  Factor the matrix.
!
  if ( itask == 1 ) then
    call dqrank ( a, lda, m, n, tol, kr, jpvt, qraux, work )
  end if
!
!  Solve the least-squares problem.
!
  call dqrlss ( a, lda, m, n, kr, b, x, r, jpvt, qraux )

  return
end
subroutine dqrlss ( a, lda, m, n, kr, b, x, r, jpvt, qraux )

!*****************************************************************************80
!
!! DQRLSS solves a linear system in a least squares sense.
!
!  Discussion:
!
!    DQRLSS must be preceeded by a call to DQRANK.
!
!    The system is to be solved is
!      A * X = B
!    where
!      A is an M by N matrix with rank KR, as determined by DQRANK,
!      B is a given M-vector,
!      X is the N-vector to be computed.
!
!    A solution X, with at most KR nonzero components, is found which
!    minimizes the 2-norm of the residual (A*X-B).
!
!    Once the matrix A has been formed, DQRANK should be
!    called once to decompose it.  Then, for each right hand
!    side B, DQRLSS should be called once to obtain the
!    solution and residual.
!
!  Modified:
!
!    15 April 2012
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A(LDA,N), the QR factorization information
!    from DQRANK.  The triangular matrix R of the QR factorization is
!    contained in the upper triangle and information needed to recover
!    the orthogonal matrix Q is stored below the diagonal in A and in
!    the vector QRAUX.
!
!    Input, integer ( kind = 4 ) LDA, the leading dimension of A, which must
!    be at least M.
!
!    Input, integer ( kind = 4 ) M, the number of rows of A.
!
!    Input, integer ( kind = 4 ) N, the number of columns of A.
!
!    Input, integer ( kind = 4 ) KR, the rank of the matrix, as estimated
!    by DQRANK.
!
!    Input, real ( kind = 8 ) B(M), the right hand side of the linear system.
!
!    Output, real ( kind = 8 ) X(N), a least squares solution to the
!    linear system.
!
!    Output, real ( kind = 8 ) R(M), the residual, B - A*X.  R may
!    overwite B.
!
!    Input, integer ( kind = 4 ) JPVT(N), the pivot information from DQRANK.
!    Columns JPVT(1), ..., JPVT(KR) of the original matrix are linearly
!    independent to within the tolerance TOL and the remaining columns
!    are linearly dependent.
!
!    Input, real ( kind = 8 ) QRAUX(N), auxiliary information from DQRANK
!    defining the QR factorization.
!
  implicit none

  integer ( kind = 4 ) lda
  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(lda,n)
  real ( kind = 8 ) b(m)
  integer ( kind = 4 ) info
  integer ( kind = 4 ) j
  integer ( kind = 4 ) job
  integer ( kind = 4 ) jpvt(n)
  integer ( kind = 4 ) k
  integer ( kind = 4 ) kr
  real ( kind = 8 ) qraux(n)
  real ( kind = 8 ) r(m)
  real ( kind = 8 ) t
  real ( kind = 8 ) x(n)

  if ( kr /= 0 ) then
    job = 110
    call dqrsl ( a, lda, m, kr, qraux, b, r, r, x, r, r, job, info )
  end if

  jpvt(1:n) = - jpvt(1:n)

  x(kr+1:n) = 0.0D+00

  do j = 1, n

    if ( jpvt(j) <= 0 ) then

      k = -jpvt(j)
      jpvt(j) = k

      do while ( k /= j )
        t = x(j)
        x(j) = x(k)
        x(k) = t
        jpvt(k) = -jpvt(k)
        k = jpvt(k)
      end do

    end if

  end do

  return
end
subroutine dqrsl ( a, lda, n, k, qraux, y, qy, qty, b, rsd, ab, job, info )

!*****************************************************************************80
!
!! DQRSL computes transformations, projections, and least squares solutions.
!
!  Discussion:
!
!    DQRSL requires the output of DQRDC.
!
!    For K <= min(N,P), let AK be the matrix
!
!      AK = ( A(JPVT(1)), A(JPVT(2)), ..., A(JPVT(K)) )
!
!    formed from columns JPVT(1), ..., JPVT(K) of the original
!    N by P matrix A that was input to DQRDC.  If no pivoting was
!    done, AK consists of the first K columns of A in their
!    original order.  DQRDC produces a factored orthogonal matrix Q
!    and an upper triangular matrix R such that
!
!      AK = Q * (R)
!               (0)
!
!    This information is contained in coded form in the arrays
!    A and QRAUX.
!
!    The parameters QY, QTY, B, RSD, and AB are not referenced
!    if their computation is not requested and in this case
!    can be replaced by dummy variables in the calling program.
!    To save storage, the user may in some cases use the same
!    array for different parameters in the calling sequence.  A
!    frequently occuring example is when one wishes to compute
!    any of B, RSD, or AB and does not need Y or QTY.  In this
!    case one may identify Y, QTY, and one of B, RSD, or AB, while
!    providing separate arrays for anything else that is to be
!    computed.
!
!    Thus the calling sequence
!
!      call dqrsl ( a, lda, n, k, qraux, y, dum, y, b, y, dum, 110, info )
!
!    will result in the computation of B and RSD, with RSD
!    overwriting Y.  More generally, each item in the following
!    list contains groups of permissible identifications for
!    a single calling sequence.
!
!      1. (Y,QTY,B) (RSD) (AB) (QY)
!
!      2. (Y,QTY,RSD) (B) (AB) (QY)
!
!      3. (Y,QTY,AB) (B) (RSD) (QY)
!
!      4. (Y,QY) (QTY,B) (RSD) (AB)
!
!      5. (Y,QY) (QTY,RSD) (B) (AB)
!
!      6. (Y,QY) (QTY,AB) (B) (RSD)
!
!    In any group the value returned in the array allocated to
!    the group corresponds to the last member of the group.
!
!  Modified:
!
!    15 April 2012
!
!  Author:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart
!
!  Reference:
!
!    Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979,
!    ISBN13: 978-0-898711-72-1,
!    LC: QA214.L56.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A(LDA,P), contains the output of DQRDC.
!
!    Input, integer ( kind = 4 ) LDA, the leading dimension of the array A.
!
!    Input, integer ( kind = 4 ) N, the number of rows of the matrix AK.  It
!    must have the same value as N in DQRDC.
!
!    Input, integer ( kind = 4 ) K, the number of columns of the matrix AK.  K
!    must not be greater than min(N,P), where P is the same as in the
!    calling sequence to DQRDC.
!
!    Input, real ( kind = 8 ) QRAUX(P), the auxiliary output from DQRDC.
!
!    Input, real ( kind = 8 ) Y(N), a vector to be manipulated by DQRSL.
!
!    Output, real ( kind = 8 ) QY(N), contains Q * Y, if requested.
!
!    Output, real ( kind = 8 ) QTY(N), contains Q' * Y, if requested.
!
!    Output, real ( kind = 8 ) B(K), the solution of the least squares problem
!      minimize norm2 ( Y - AK * B),
!    if its computation has been requested.  Note that if pivoting was
!    requested in DQRDC, the J-th component of B will be associated with
!    column JPVT(J) of the original matrix A that was input into DQRDC.
!
!    Output, real ( kind = 8 ) RSD(N), the least squares residual Y - AK * B,
!    if its computation has been requested.  RSD is also the orthogonal
!    projection of Y onto the orthogonal complement of the column space
!    of AK.
!
!    Output, real ( kind = 8 ) AB(N), the least squares approximation Ak * B,
!    if its computation has been requested.  AB is also the orthogonal
!    projection of Y onto the column space of A.
!
!    Input, integer ( kind = 4 ) JOB, specifies what is to be computed.  JOB has
!    the decimal expansion ABCDE, with the following meaning:
!
!      if A /= 0, compute QY.
!      if B /= 0, compute QTY.
!      if C /= 0, compute QTY and B.
!      if D /= 0, compute QTY and RSD.
!      if E /= 0, compute QTY and AB.
!
!    Note that a request to compute B, RSD, or AB automatically triggers
!    the computation of QTY, for which an array must be provided in the
!    calling sequence.
!
!    Output, integer ( kind = 4 ) INFO, is zero unless the computation of B has
!    been requested and R is exactly singular.  In this case, INFO is the
!    index of the first zero diagonal element of R, and B is left unaltered.
!
  implicit none

  integer ( kind = 4 ) k
  integer ( kind = 4 ) lda
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(lda,*)
  real ( kind = 8 ) ab(n)
  real ( kind = 8 ) b(k)
  logical cab
  logical cb
  logical cqty
  logical cqy
  logical cr
  integer ( kind = 4 ) info
  integer ( kind = 4 ) j
  integer ( kind = 4 ) jj
  integer ( kind = 4 ) job
  integer ( kind = 4 ) ju
  integer ( kind = 4 ) kp1
  real ( kind = 8 ) qraux(*)
  real ( kind = 8 ) qty(n)
  real ( kind = 8 ) qy(n)
  real ( kind = 8 ) rsd(n)
  real ( kind = 8 ) ddot
  real ( kind = 8 ) t
  real ( kind = 8 ) temp
  real ( kind = 8 ) y(n)
!
!  set info flag.
!
  info = 0
!
!  Determine what is to be computed.
!
  cqy =        job / 10000         /= 0
  cqty = mod ( job,  10000 )       /= 0
  cb =   mod ( job,   1000 ) / 100 /= 0
  cr =   mod ( job,    100 ) /  10 /= 0
  cab =  mod ( job,     10 )       /= 0

  ju = min ( k, n-1 )
!
!  Special action when N = 1.
!
  if ( ju == 0 ) then

    if ( cqy ) then
      qy(1) = y(1)
    end if

    if ( cqty ) then
      qty(1) = y(1)
    end if

    if ( cab ) then
      ab(1) = y(1)
     end if

    if ( cb ) then

      if ( a(1,1) == 0.0D+00 ) then
        info = 1
      else
        b(1) = y(1) / a(1,1)
      end if

    end if

    if ( cr ) then
      rsd(1) = 0.0D+00
    end if

    return

  end if
!
!  Set up to compute QY or QTY.
!
  if ( cqy ) then
    qy(1:n) = y(1:n)
  end if

  if ( cqty ) then
    qty(1:n) = y(1:n)
  end if
!
!  Compute QY.
!
  if ( cqy ) then

    do jj = 1, ju

      j = ju - jj + 1

      if ( qraux(j) /= 0.0D+00 ) then
        temp = a(j,j)
        a(j,j) = qraux(j)
        t = - ddot ( n-j+1, a(j,j), 1, qy(j), 1 ) / a(j,j)
        call daxpy ( n-j+1, t, a(j,j), 1, qy(j), 1 )
        a(j,j) = temp
      end if

    end do

  end if
!
!  Compute Q'*Y.
!
     if ( cqty ) then

        do j = 1, ju
           if ( qraux(j) /= 0.0D+00 ) then
              temp = a(j,j)
              a(j,j) = qraux(j)
              t = - ddot ( n-j+1, a(j,j), 1, qty(j), 1 ) / a(j,j)
              call daxpy ( n-j+1, t, a(j,j), 1, qty(j), 1 )
              a(j,j) = temp
           end if
        end do

     end if
!
!  Set up to compute B, RSD, or AB.
!
     if ( cb ) then
       b(1:k) = qty(1:k)
     end if

     kp1 = k + 1

     if ( cab ) then
       ab(1:k) = qty(1:k)
     end if

     if ( cr .and. k < n ) then
       rsd(k+1:n) = qty(k+1:n)
     end if

     if ( cab .and. k+1 <= n ) then
        ab(k+1:n) = 0.0D+00
     end if

     if ( cr ) then
        rsd(1:k) = 0.0D+00
     end if
!
!  Compute B.
!
     if ( cb ) then

        do jj = 1, k

           j = k - jj + 1

           if ( a(j,j) == 0.0D+00 ) then
              info = j
              exit
           end if

           b(j) = b(j)/a(j,j)

           if ( j /= 1 ) then
              t = -b(j)
              call daxpy ( j-1, t, a(1,j), 1, b, 1 )
           end if

        end do

     end if

     if ( cr .or. cab ) then
!
!  Compute RSD or AB as required.
!
        do jj = 1, ju

           j = ju - jj + 1

           if ( qraux(j) /= 0.0D+00 ) then

              temp = a(j,j)
              a(j,j) = qraux(j)

              if ( cr ) then
                 t = - ddot ( n-j+1, a(j,j), 1, rsd(j), 1 ) / a(j,j)
                 call daxpy ( n-j+1, t, a(j,j), 1, rsd(j), 1 )
              end if

              if ( cab ) then
                 t = - ddot ( n-j+1, a(j,j), 1, ab(j), 1 ) / a(j,j)
                 call daxpy ( n-j+1, t, a(j,j), 1, ab(j), 1 )
              end if

              a(j,j) = temp

           end if

        end do

  end if

  return
end
subroutine drot ( n, x, incx, y, incy, c, s )

!*****************************************************************************80
!
!! DROT applies a plane rotation.
!
!  Discussion:
!
!    This routine uses double precision real arithmetic.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    08 April 1999
!
!  Author:
!
!    Original FORTRAN77 version by Charles Lawson, Richard Hanson,
!    David Kincaid, Fred Krogh.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979,
!    ISBN13: 978-0-898711-72-1,
!    LC: QA214.L56.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Algorithm 539,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of entries in the vectors.
!
!    Input/output, real ( kind = 8 ) X(*), one of the vectors to be rotated.
!
!    Input, integer ( kind = 4 ) INCX, the increment between successive
!    entries of X.
!
!    Input/output, real ( kind = 8 ) Y(*), one of the vectors to be rotated.
!
!    Input, integer ( kind = 4 ) INCY, the increment between successive
!    elements of Y.
!
!    Input, real ( kind = 8 ) C, S, parameters (presumably the cosine and
!    sine of some angle) that define a plane rotation.
!
  implicit none

  real ( kind = 8 ) c
  integer ( kind = 4 ) i
  integer ( kind = 4 ) incx
  integer ( kind = 4 ) incy
  integer ( kind = 4 ) ix
  integer ( kind = 4 ) iy
  integer ( kind = 4 ) n
  real ( kind = 8 ) s
  real ( kind = 8 ) stemp
  real ( kind = 8 ) x(*)
  real ( kind = 8 ) y(*)

  if ( n <= 0 ) then

  else if ( incx == 1 .and. incy == 1 ) then

    do i = 1, n
      stemp = c * x(i) + s * y(i)
      y(i) = c * y(i) - s * x(i)
      x(i) = stemp
    end do

  else

    if ( 0 <= incx ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    if ( 0 <= incy ) then
      iy = 1
    else
      iy = ( - n + 1 ) * incy + 1
    end if

    do i = 1, n
      stemp = c * x(ix) + s * y(iy)
      y(iy) = c * y(iy) - s * x(ix)
      x(ix) = stemp
      ix = ix + incx
      iy = iy + incy
    end do

  end if

  return
end
subroutine drotg ( sa, sb, c, s )

!*****************************************************************************80
!
!! DROTG constructs a Givens plane rotation.
!
!  Discussion:
!
!    This routine uses double precision real arithmetic.
!
!    Given values A and B, this routine computes
!
!    SIGMA = sign ( A ) if abs ( A ) >  abs ( B )
!          = sign ( B ) if abs ( A ) <= abs ( B );
!
!    R     = SIGMA * ( A * A + B * B );
!
!    C = A / R if R is not 0
!      = 1     if R is 0;
!
!    S = B / R if R is not 0,
!        0     if R is 0.
!
!    The computed numbers then satisfy the equation
!
!    (  C  S ) ( A ) = ( R )
!    ( -S  C ) ( B ) = ( 0 )
!
!    The routine also computes
!
!    Z = S     if abs ( A ) > abs ( B ),
!      = 1 / C if abs ( A ) <= abs ( B ) and C is not 0,
!      = 1     if C is 0.
!
!    The single value Z encodes C and S, and hence the rotation:
!
!    If Z = 1, set C = 0 and S = 1;
!    If abs ( Z ) < 1, set C = sqrt ( 1 - Z * Z ) and S = Z;
!    if abs ( Z ) > 1, set C = 1/ Z and S = sqrt ( 1 - C * C );
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    15 May 2006
!
!  Author:
!
!    Original FORTRAN77 version by Charles Lawson, Richard Hanson,
!    David Kincaid, Fred Krogh.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979,
!    ISBN13: 978-0-898711-72-1,
!    LC: QA214.L56.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Algorithm 539,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input/output, real ( kind = 8 ) SA, SB.  On input, SA and SB are the values
!    A and B.  On output, SA is overwritten with R, and SB is
!    overwritten with Z.
!
!    Output, real ( kind = 8 ) C, S, the cosine and sine of the
!    Givens rotation.
!
  implicit none

  real ( kind = 8 ) c
  real ( kind = 8 ) r
  real ( kind = 8 ) roe
  real ( kind = 8 ) s
  real ( kind = 8 ) sa
  real ( kind = 8 ) sb
  real ( kind = 8 ) scale
  real ( kind = 8 ) z

  if ( abs ( sb ) < abs ( sa ) ) then
    roe = sa
  else
    roe = sb
  end if

  scale = abs ( sa ) + abs ( sb )

  if ( scale == 0.0D+00 ) then
    c = 1.0D+00
    s = 0.0D+00
    r = 0.0D+00
  else
    r = scale * sqrt ( ( sa / scale )**2 + ( sb / scale )**2 )
    r = sign ( 1.0D+00, roe ) * r
    c = sa / r
    s = sb / r
  end if

  if ( 0.0D+00 < abs ( c ) .and. abs ( c ) <= s ) then
    z = 1.0D+00 / c
  else
    z = s
  end if

  sa = r
  sb = z

  return
end
subroutine dscal ( n, sa, x, incx )

!*****************************************************************************80
!
!! DSCAL scales a vector by a constant.
!
!  Discussion:
!
!    This routine uses double precision real arithmetic.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    08 April 1999
!
!  Author:
!
!    Original FORTRAN77 version by Charles Lawson, Richard Hanson,
!    David Kincaid, Fred Krogh.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979,
!    ISBN13: 978-0-898711-72-1,
!    LC: QA214.L56.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Algorithm 539,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of entries in the vector.
!
!    Input, real ( kind = 8 ) SA, the multiplier.
!
!    Input/output, real ( kind = 8 ) X(*), the vector to be scaled.
!
!    Input, integer ( kind = 4 ) INCX, the increment between successive
!    entries of X.
!
  implicit none

  integer ( kind = 4 ) i
  integer ( kind = 4 ) incx
  integer ( kind = 4 ) ix
  integer ( kind = 4 ) m
  integer ( kind = 4 ) n
  real ( kind = 8 ) sa
  real ( kind = 8 ) x(*)

  if ( n <= 0 ) then

  else if ( incx == 1 ) then

    m = mod ( n, 5 )

    x(1:m) = sa * x(1:m)

    do i = m+1, n, 5
      x(i)   = sa * x(i)
      x(i+1) = sa * x(i+1)
      x(i+2) = sa * x(i+2)
      x(i+3) = sa * x(i+3)
      x(i+4) = sa * x(i+4)
    end do

  else

    if ( 0 <= incx ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    do i = 1, n
      x(ix) = sa * x(ix)
      ix = ix + incx
    end do

  end if

  return
end
subroutine dsvdc ( a, lda, m, n, s, e, u, ldu, v, ldv, work, job, info )

!*****************************************************************************80
!
!! DSVDC computes the singular value decomposition of a real rectangular matrix.
!
!  Discussion:
!
!    This routine reduces an M by N matrix A to diagonal form by orthogonal
!    transformations U and V.  The diagonal elements S(I) are the singular
!    values of A.  The columns of U are the corresponding left singular
!    vectors, and the columns of V the right singular vectors.
!
!    The form of the singular value decomposition is then
!
!      A(MxN) = U(MxM) * S(MxN) * V(NxN)'
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    16 September 2006
!
!  Author:
!
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979,
!    ISBN13: 978-0-898711-72-1,
!    LC: QA214.L56.
!
!  Parameters:
!
!    Input/output, real ( kind = 8 ) A(LDA,N).  On input, the M by N
!    matrix whose singular value decomposition is to be computed.
!    On output, the matrix has been destroyed.  Depending on the user's
!    requests, the matrix may contain other useful information.
!
!    Input, integer ( kind = 4 ) LDA, the leading dimension of the array A.
!    LDA must be at least N.
!
!    Input, integer ( kind = 4 ) M, the number of rows of the matrix.
!
!    Input, integer ( kind = 4 ) N, the number of columns of the matrix A.
!
!    Output, real ( kind = 8 ) S(MM), where MM = max(M+1,N).  The first
!    min(M,N) entries of S contain the singular values of A arranged in
!    descending order of magnitude.
!
!    Output, real ( kind = 8 ) E(MM), where MM = max(M+1,N).  Ordinarily
!    contains zeros.  However see the discussion of INFO for exceptions.
!
!    Output, real ( kind = 8 ) U(LDU,K).  If JOBA = 1 then K = M;
!    if 2 <= JOBA, then K = min(M,N).  U contains the M by M matrix of
!    left singular vectors.  U is not referenced if JOBA = 0.  If M <= N
!    or if JOBA = 2, then U may be identified with A in the subroutine call.
!
!    Input, integer ( kind = 4 ) LDU, the leading dimension of the array U.
!    LDU must be at least M.
!
!    Output, real ( kind = 8 ) V(LDV,N), the N by N matrix of right singular
!    vectors.  V is not referenced if JOB is 0.  If N <= M, then V may be
!    identified with A in the subroutine call.
!
!    Input, integer ( kind = 4 ) LDV, the leading dimension of the array V.
!    LDV must be at least N.
!
!    Workspace, real ( kind = 8 ) WORK(M).
!
!    Input, integer ( kind = 4 ) JOB, controls the computation of the singular
!    vectors.  It has the decimal expansion AB with the following meaning:
!      A =  0, do not compute the left singular vectors.
!      A =  1, return the M left singular vectors in U.
!      A >= 2, return the first min(M,N) singular vectors in U.
!      B =  0, do not compute the right singular vectors.
!      B =  1, return the right singular vectors in V.
!
!    Output, integer ( kind = 4 ) INFO, status indicator.
!    The singular values (and their corresponding singular vectors)
!    S(INFO+1), S(INFO+2),...,S(MN) are correct.  Here MN = min ( M, N ).
!    Thus if INFO is 0, all the singular values and their vectors are
!    correct.  In any event, the matrix B = U' * A * V is the bidiagonal
!    matrix with the elements of S on its diagonal and the elements of E on
!    its superdiagonal.  Thus the singular values of A and B are the same.
!
  implicit none

  integer ( kind = 4 ) lda
  integer ( kind = 4 ) ldu
  integer ( kind = 4 ) ldv
  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(lda,n)
  real ( kind = 8 ) b
  real ( kind = 8 ) c
  real ( kind = 8 ) cs
  real ( kind = 8 ) e(*)
  real ( kind = 8 ) el
  real ( kind = 8 ) emm1
  real ( kind = 8 ) f
  real ( kind = 8 ) g
  integer ( kind = 4 ) info
  integer ( kind = 4 ) iter
  integer ( kind = 4 ) j
  integer ( kind = 4 ) job
  integer ( kind = 4 ) jobu
  integer ( kind = 4 ) k
  integer ( kind = 4 ) kase
  integer ( kind = 4 ) kk
  integer ( kind = 4 ) l
  integer ( kind = 4 ) ll
  integer ( kind = 4 ) lls
  integer ( kind = 4 ) ls
  integer ( kind = 4 ) lu
  integer ( kind = 4 ), parameter :: maxit = 30
  integer ( kind = 4 ) mm
  integer ( kind = 4 ) mm1
  integer ( kind = 4 ) mn
  integer ( kind = 4 ) nct
  integer ( kind = 4 ) nctp1
  integer ( kind = 4 ) ncu
  integer ( kind = 4 ) nrt
  integer ( kind = 4 ) nrtp1
  real ( kind = 8 ) s(*)
  real ( kind = 8 ) scale
  real ( kind = 8 ) ddot
  real ( kind = 8 ) shift
  real ( kind = 8 ) sl
  real ( kind = 8 ) sm
  real ( kind = 8 ) smm1
  real ( kind = 8 ) sn
  real ( kind = 8 ) dnrm2
  real ( kind = 8 ) t
  real ( kind = 8 ) t1
  real ( kind = 8 ) test
  real ( kind = 8 ) u(ldu,m)
  real ( kind = 8 ) v(ldv,n)
  logical wantu
  logical wantv
  real ( kind = 8 ) work(m)
  real ( kind = 8 ) ztest
!
!  Determine what is to be computed.
!
  wantu = .false.
  wantv = .false.
  jobu = mod ( job, 100 ) / 10

  if ( 1 < jobu ) then
    ncu = min ( m, n )
  else
    ncu = m
  end if

  if ( jobu /= 0 ) then
    wantu = .true.
  end if

  if ( mod ( job, 10 ) /= 0 ) then
    wantv = .true.
  end if
!
!  Reduce A to bidiagonal form, storing the diagonal elements
!  in S and the super-diagonal elements in E.
!
  info = 0
  nct = min ( m-1, n )
  nrt = max ( 0, min ( m, n-2 ) )
  lu = max ( nct, nrt )

  do l = 1, lu
!
!  Compute the transformation for the L-th column and
!  place the L-th diagonal in S(L).
!
    if ( l <= nct ) then

      s(l) = dnrm2 ( m-l+1, a(l,l), 1 )

      if ( s(l) /= 0.0D+00 ) then
        if ( a(l,l) /= 0.0D+00 ) then
          s(l) = sign ( s(l), a(l,l) )
        end if
        call dscal ( m-l+1, 1.0D+00 / s(l), a(l,l), 1 )
        a(l,l) = 1.0D+00 + a(l,l)
      end if

      s(l) = -s(l)

    end if

    do j = l+1, n
!
!  Apply the transformation.
!
      if ( l <= nct .and. s(l) /= 0.0D+00 ) then
        t = -ddot ( m-l+1, a(l,l), 1, a(l,j), 1 ) / a(l,l)
        call daxpy ( m-l+1, t, a(l,l), 1, a(l,j), 1 )
      end if
!
!  Place the L-th row of A into E for the
!  subsequent calculation of the row transformation.
!
      e(j) = a(l,j)

    end do
!
!  Place the transformation in U for subsequent back multiplication.
!
    if ( wantu .and. l <= nct ) then
      u(l:m,l) = a(l:m,l)
    end if
!
!  Compute the L-th row transformation and place the
!  L-th superdiagonal in E(L).
!
    if ( l <= nrt ) then

      e(l) = dnrm2 ( n-l, e(l+1), 1 )

      if ( e(l) /= 0.0D+00 ) then
        if ( e(l+1) /= 0.0D+00 ) then
          e(l) = sign ( e(l), e(l+1) )
        end if
        call dscal ( n-l, 1.0D+00 / e(l), e(l+1), 1 )
        e(l+1) = 1.0D+00 + e(l+1)
      end if

      e(l) = -e(l)
!
!  Apply the transformation.
!
      if ( l + 1 <= m .and. e(l) /= 0.0D+00 ) then

        work(l+1:m) = 0.0D+00

        do j = l+1, n
          call daxpy ( m-l, e(j), a(l+1,j), 1, work(l+1), 1 )
        end do

        do j = l+1, n
          call daxpy ( m-l, -e(j)/e(l+1), work(l+1), 1, a(l+1,j), 1 )
        end do

      end if
!
!  Place the transformation in V for subsequent back multiplication.
!
      if ( wantv ) then
        v(l+1:n,l) = e(l+1:n)
      end if

    end if

  end do
!
!  Set up the final bidiagonal matrix of order MN.
!
  mn = min ( m + 1, n )
  nctp1 = nct + 1
  nrtp1 = nrt + 1

  if ( nct < n ) then
    s(nctp1) = a(nctp1,nctp1)
  end if

  if ( m < mn ) then
    s(mn) = 0.0D+00
  end if

  if ( nrtp1 < mn ) then
    e(nrtp1) = a(nrtp1,mn)
  end if

  e(mn) = 0.0D+00
!
!  If required, generate U.
!
  if ( wantu ) then

    u(1:m,nctp1:ncu) = 0.0D+00

    do j = nctp1, ncu
      u(j,j) = 1.0D+00
    end do

    do ll = 1, nct

      l = nct - ll + 1

      if ( s(l) /= 0.0D+00 ) then

        do j = l+1, ncu
          t = -ddot ( m-l+1, u(l,l), 1, u(l,j), 1 ) / u(l,l)
          call daxpy ( m-l+1, t, u(l,l), 1, u(l,j), 1 )
        end do

        u(l:m,l) = -u(l:m,l)
        u(l,l) = 1.0D+00 + u(l,l)
        u(1:l-1,l) = 0.0D+00

      else

        u(1:m,l) = 0.0D+00
        u(l,l) = 1.0D+00

      end if

    end do

  end if
!
!  If it is required, generate V.
!
  if ( wantv ) then

    do ll = 1, n

      l = n - ll + 1

      if ( l <= nrt .and. e(l) /= 0.0D+00 ) then

        do j = l + 1, n
          t = -ddot ( n-l, v(l+1,l), 1, v(l+1,j), 1 ) / v(l+1,l)
          call daxpy ( n-l, t, v(l+1,l), 1, v(l+1,j), 1 )
        end do

      end if

      v(1:n,l) = 0.0D+00
      v(l,l) = 1.0D+00

    end do

  end if
!
!  Main iteration loop for the singular values.
!
  mm = mn
  iter = 0

  do while ( 0 < mn )
!
!  If too many iterations have been performed, set flag and return.
!
    if ( maxit <= iter ) then
      info = mn
      return
    end if
!
!  This section of the program inspects for
!  negligible elements in the S and E arrays.
!
!  On completion the variables KASE and L are set as follows:
!
!  KASE = 1     if S(MN) and E(L-1) are negligible and L < MN
!  KASE = 2     if S(L) is negligible and L < MN
!  KASE = 3     if E(L-1) is negligible, L < MN, and
!               S(L), ..., S(MN) are not negligible (QR step).
!  KASE = 4     if E(MN-1) is negligible (convergence).
!
    do ll = 1, mn

      l = mn - ll

      if ( l == 0 ) then
        exit
      end if

      test = abs ( s(l) ) + abs ( s(l+1) )
      ztest = test + abs ( e(l) )

      if ( ztest == test ) then
        e(l) = 0.0D+00
        exit
      end if

    end do

    if ( l == mn - 1 ) then

      kase = 4

    else

      do lls = l + 1, mn + 1

        ls = mn - lls + l + 1

        if ( ls == l ) then
          exit
        end if

        test = 0.0D+00
        if ( ls /= mn ) then
          test = test + abs ( e(ls) )
        end if

        if ( ls /= l + 1 ) then
          test = test + abs ( e(ls-1) )
        end if

        ztest = test + abs ( s(ls) )

        if ( ztest == test ) then
          s(ls) = 0.0D+00
          exit
        end if

      end do

      if ( ls == l ) then
        kase = 3
      else if ( ls == mn ) then
        kase = 1
      else
        kase = 2
        l = ls
      end if

    end if

    l = l + 1
!
!  Deflate negligible S(MN).
!
    if ( kase == 1 ) then

      mm1 = mn - 1
      f = e(mn-1)
      e(mn-1) = 0.0D+00

      do kk = l, mm1

        k = mm1 - kk + l
        t1 = s(k)
        call drotg ( t1, f, cs, sn )
        s(k) = t1

        if ( k /= l ) then
          f = -sn * e(k-1)
          e(k-1) = cs * e(k-1)
        end if

        if ( wantv ) then
          call drot ( n, v(1,k), 1, v(1,mn), 1, cs, sn )
        end if

      end do
!
!  Split at negligible S(L).
!
    else if ( kase == 2 ) then

      f = e(l-1)
      e(l-1) = 0.0D+00

      do k = l, mn

        t1 = s(k)
        call drotg ( t1, f, cs, sn )
        s(k) = t1
        f = -sn * e(k)
        e(k) = cs * e(k)
        if ( wantu ) then
          call drot ( m, u(1,k), 1, u(1,l-1), 1, cs, sn )
        end if

      end do
!
!  Perform one QR step.
!
    else if ( kase == 3 ) then
!
!  Calculate the shift.
!
      scale = max ( abs ( s(mn) ), abs ( s(mn-1) ), abs ( e(mn-1) ), &
                    abs ( s(l) ), abs ( e(l) ) )

      sm = s(mn) / scale
      smm1 = s(mn-1) / scale
      emm1 = e(mn-1) / scale
      sl = s(l) / scale
      el = e(l) / scale
      b = ( ( smm1 + sm ) * ( smm1 - sm ) + emm1 * emm1 ) / 2.0D+00
      c = sm  * sm * emm1 * emm1
      shift = 0.0D+00

      if ( b /= 0.0D+00 .or. c /= 0.0D+00 ) then
        shift = sqrt ( b * b + c )
        if ( b < 0.0D+00 ) then
          shift = -shift
        end if
        shift = c / ( b + shift )
      end if

      f = ( sl + sm ) * ( sl - sm ) + shift
      g = sl * el
!
!  Chase zeros.
!
      mm1 = mn - 1

      do k = l, mm1

        call drotg ( f, g, cs, sn )

        if ( k /= l ) then
          e(k-1) = f
        end if

        f = cs * s(k) + sn * e(k)
        e(k) = cs * e(k) - sn * s(k)
        g = sn * s(k+1)
        s(k+1) = cs * s(k+1)

        if ( wantv ) then
          call drot ( n, v(1,k), 1, v(1,k+1), 1, cs, sn )
        end if

        call drotg ( f, g, cs, sn )
        s(k) = f
        f = cs * e(k) + sn * s(k+1)
        s(k+1) = -sn * e(k) + cs * s(k+1)
        g = sn * e(k+1)
        e(k+1) = cs * e(k+1)

        if ( wantu .and. k < m ) then
          call drot ( m, u(1,k), 1, u(1,k+1), 1, cs, sn )
        end if

      end do

      e(mn-1) = f
      iter = iter + 1
!
!  Convergence.
!
    else if ( kase == 4 ) then
!
!  Make the singular value nonnegative.
!
      if ( s(l) < 0.0D+00 ) then
        s(l) = -s(l)
        if ( wantv ) then
          v(1:n,l) = -v(1:n,l)
        end if
      end if
!
!  Order the singular value.
!
      do

        if ( l == mm ) then
          exit
        end if

        if ( s(l+1) <= s(l) ) then
          exit
        end if

        t = s(l)
        s(l) = s(l+1)
        s(l+1) = t

        if ( wantv .and. l < n ) then
          call dswap ( n, v(1,l), 1, v(1,l+1), 1 )
        end if

        if ( wantu .and. l < m ) then
          call dswap ( m, u(1,l), 1, u(1,l+1), 1 )
        end if

        l = l + 1

      end do

      iter = 0
      mn = mn - 1

    end if

  end do

  return
end
subroutine dswap ( n, x, incx, y, incy )

!*****************************************************************************80
!
!! DSWAP interchanges two vectors.
!
!  Discussion:
!
!    This routine uses double precision real arithmetic.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    08 April 1999
!
!  Author:
!
!    Original FORTRAN77 version by Charles Lawson, Richard Hanson,
!    David Kincaid, Fred Krogh.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
!    LINPACK User's Guide,
!    SIAM, 1979,
!    ISBN13: 978-0-898711-72-1,
!    LC: QA214.L56.
!
!    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
!    Algorithm 539,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of entries in the vectors.
!
!    Input/output, real ( kind = 8 ) X(*), one of the vectors to swap.
!
!    Input, integer ( kind = 4 ) INCX, the increment between successive
!    entries of X.
!
!    Input/output, real ( kind = 8 ) Y(*), one of the vectors to swap.
!
!    Input, integer ( kind = 4 ) INCY, the increment between successive
!    elements of Y.
!
  implicit none

  integer ( kind = 4 ) i
  integer ( kind = 4 ) incx
  integer ( kind = 4 ) incy
  integer ( kind = 4 ) ix
  integer ( kind = 4 ) iy
  integer ( kind = 4 ) m
  integer ( kind = 4 ) n
  real ( kind = 8 ) temp
  real ( kind = 8 ) x(*)
  real ( kind = 8 ) y(*)

  if ( n <= 0 ) then

  else if ( incx == 1 .and. incy == 1 ) then

    m = mod ( n, 3 )

    do i = 1, m
      temp = x(i)
      x(i) = y(i)
      y(i) = temp
    end do

    do i = m + 1, n, 3

      temp = x(i)
      x(i) = y(i)
      y(i) = temp

      temp = x(i+1)
      x(i+1) = y(i+1)
      y(i+1) = temp

      temp = x(i+2)
      x(i+2) = y(i+2)
      y(i+2) = temp

    end do

  else

    if ( 0 <= incx ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    if ( 0 <= incy ) then
      iy = 1
    else
      iy = ( - n + 1 ) * incy + 1
    end if

    do i = 1, n
      temp = x(ix)
      x(ix) = y(iy)
      y(iy) = temp
      ix = ix + incx
      iy = iy + incy
    end do

  end if

  return
end
!subroutine normal_solve ( m, n, a, b, x, flag )
!
!!*****************************************************************************80
!!
!!! NORMAL_SOLVE solves a linear system using the normal equations.
!!
!!  Discussion:
!!
!!    Given a presumably rectangular MxN system of equations A*x=b, this routine
!!    sets up the NxN system A'*A*x=A'b.  Assuming N <= M, and that A has full
!!    column rank, the system will be solvable, and the vector x that is returned
!!    will minimize the Euclidean norm of the residual.
!!
!!    One drawback to this approach is that the condition number of the linear
!!    system A'*A is effectively the square of the condition number of A,
!!    meaning that there is a substantial loss of accuracy.
!!
!!  Licensing:
!!
!!    This code is distributed under the GNU LGPL license.
!!
!!  Modified:
!!
!!    17 April 2012
!!
!!  Author:
!!
!!    John Burkardt
!!
!!  Reference:
!!
!!    David Kahaner, Cleve Moler, Steven Nash,
!!    Numerical Methods and Software,
!!    Prentice Hall, 1989,
!!    ISBN: 0-13-627258-4,
!!    LC: TA345.K34.
!!
!!  Parameters:
!!
!!    Input, integer ( kind = 4 ) M, the number of rows of A.
!!
!!    Input, integer ( kind = 4 ) N, the number of columns of A.
!!    It must be the case that N <= M.
!!
!!    Input, real ( kind = 8 ) A(M,N), the matrix.
!!    The matrix must have full column rank.
!!
!!    Input, real ( kind = 8 ) B(M), the right hand side.
!!
!!    Output, real ( kind = 8 ) X(N), the least squares solution.
!!
!!    Output, integer ( kind = 4 ) FLAG,
!!    0, no error was detected.
!!    1, an error occurred.
!!
!  implicit none
!
!  integer ( kind = 4 ) m
!  integer ( kind = 4 ) n
!
!  real ( kind = 8 ) a(m,n)
!  real ( kind = 8 ) ata(n,n)
!  real ( kind = 8 ) ata_c(n,n)
!  real ( kind = 8 ) atb(n)
!  real ( kind = 8 ) b(m)
!  integer ( kind = 4 ) flag
!  real ( kind = 8 ) x(n)
!
!  flag = 0
!
!  if ( m < n ) then
!    flag = 1
!    return
!  end if
!
!  ata(1:n,1:n) = matmul ( transpose ( a(1:m,1:n) ), a(1:m,1:n) )
!
!  atb(1:n) = matmul ( transpose ( a(1:m,1:n) ), b(1:m) )
!
!  call r8mat_cholesky_factor ( n, ata, ata_c, flag )
!
!  if ( flag /= 0 ) then
!    return
!  end if
!
!  call r8mat_cholesky_solve ( n, ata_c, atb, x )
!
!  return
!end
subroutine qr_solve ( m, n, a, b, x )

!*****************************************************************************80
!
!! QR_SOLVE solves a linear system in the least squares sense.
!
!  Discussion:
!
!    If the matrix A has full column rank, then the solution X should be the
!    unique vector that minimizes the Euclidean norm of the residual.
!
!    If the matrix A does not have full column rank, then the solution is
!    not unique; the vector X will minimize the residual norm, but so will
!    various other vectors.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    15 April 2012
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, the number of rows of A.
!
!    Input, integer ( kind = 4 ) N, the number of columns of A.
!
!    Input, real ( kind = 8 ) A(M,N), the matrix.
!
!    Input, real ( kind = 8 ) B(M), the right hand side.
!
!    Output, real ( kind = 8 ) X(N), the least squares solution.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  real ( kind = 8 ) a_qr(m,n)
  real ( kind = 8 ) b(m)
  integer ( kind = 4 ) ind
  integer ( kind = 4 ) itask
  integer ( kind = 4 ) jpvt(n)
  integer ( kind = 4 ) kr
  integer ( kind = 4 ) lda
  real ( kind = 8 ) qraux(n)
  real ( kind = 8 ) r(m)
  real ( kind = 8 ) tol
  real ( kind = 8 ) work(n)
  real ( kind = 8 ) x(n)

  a_qr(1:m,1:n) = a(1:m,1:n)

  lda = m

  tol = epsilon ( tol ) / maxval ( abs ( a_qr(1:m,1:n) ) )

  itask = 1

  call dqrls ( a_qr, lda, m, n, tol, kr, b, x, r, jpvt, qraux, work, &
    itask, ind )

  return
end
subroutine svd_solve ( m, n, a, b, x )

!*****************************************************************************80
!
!! SVD_SOLVE solves a linear system in the least squares sense.
!
!  Discussion:
!
!    The vector X returned by this routine should always minimize the
!    Euclidean norm of the residual ||A*x-b||.
!
!    If the matrix A does not have full column rank, then there are multiple
!    vectors that attain the minimum residual.  In that case, the vector
!    X returned by this routine is the unique such minimizer that has the
!    the minimum possible Euclidean norm, that is, ||A*x-b|| and ||x||
!    are both minimized.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    07 September 2012
!
!  Reference:
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, the number of rows of A.
!
!    Input, integer ( kind = 4 ) N, the number of columns of A.
!
!    Input, real ( kind = 8 ) A(M,N), the matrix.
!
!    Input, real ( kind = 8 ) B(M), the right hand side.
!
!    Output, real ( kind = 8 ) X(N), the least squares solution.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  real ( kind = 8 ) a_copy(m,n)
  real ( kind = 8 ) b(m)
  real ( kind = 8 ) e(max(m+1,n))
  integer ( kind = 4 ) i
  integer ( kind = 4 ) info
  integer ( kind = 4 ) lda
  integer ( kind = 4 ) ldu
  integer ( kind = 4 ) ldv
  integer ( kind = 4 ) job
  real ( kind = 8 ) sdiag(max(m+1,n))
  real ( kind = 8 ) smax
  real ( kind = 8 ) stol
  real ( kind = 8 ) sub(n)
  real ( kind = 8 ) u(m,m)
  real ( kind = 8 ) ub(m)
  real ( kind = 8 ) v(n,n)
  real ( kind = 8 ) work(m)
  real ( kind = 8 ) x(n)
!
!  Get the SVD.
!
  a_copy(1:m,1:n) = a(1:m,1:n)
  lda = m
  ldu = m
  ldv = n
  job = 11

  call dsvdc ( a_copy, lda, m, n, sdiag, e, u, ldu, v, ldv, work, job, info )

  if ( info /= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'SVD_SOLVE - Failure!'
    write ( *, '(a)' ) '  The SVD could not be calculated.'
    write ( *, '(a)' ) '  LINPACK routine DSVDC returned a nonzero'
    write ( *, '(a,i8)' ) '  value of the error flag, INFO = ', info
    stop
  end if

  ub(1:m) = matmul ( transpose ( u(1:m,1:m) ), b(1:m) )

  sub(1:n) = 0.0D+00
!
!  For singular problems, there may be tiny but nonzero singular values
!  that should be ignored.  This is a reasonable attempt to avoid such
!  problems, although in general, the user might wish to control the tolerance.
!
  smax = maxval ( sdiag(1:n) )
  if ( smax <= epsilon ( smax ) ) then
    smax = 1.0D+00
  end if

  stol = epsilon ( smax ) * smax

  do i = 1, n
    if ( i <= m ) then
      if ( stol <= sdiag(i) ) then
        sub(i) = ub(i) / sdiag(i)
      end if
    end if
  end do

  x(1:n) = matmul ( v(1:n,1:n), sub(1:n) )

  return
end


      implicit real *8 (a-h,o-z)

      real *8 roots(10000),pars(10)
      external fval1

      call prini(6,13)
      call prinf('Enter n*',n,0)
      read *, n

      a = 1.1d0
      b = 2.3d0

c      n = 20
      h = 1.0d-4

      nmax = 100

      call chebroots(fval1,pars,a,b,n,h,rerr,nmax,nroots,roots)
      call prin2('roots=*',roots,nroots)

      do i=1,nroots

      call fval1(roots(i),pars,fx)
      call prin2('fx=*',fx,1)

      enddo

      stop
      end
c-------------------------------------------------------------

      subroutine chebroots(fker,pars,a,b,n,h,rerr,nmax,nroots,roots)
      implicit real *8 (a-h,o-z)

c
cc       this subrotine computes the roots of the function
c        fker on the interval [a,b] using boyd's method.
c
c        input
c        fker - function whose roots we wish to find
c        the calling sequence for fker is
c         subroutine fker(x,pars,fx)
c        pars - parameters for the function fker
c        a - left end of interval
c        b - right end of interval
c        n - number of terms in the chebyshev expansion of the function
c        h - spacing between points for finding the zeros
c
c
c        output
c        rerr - estimate for error in function interpolation
c        nroots - number of roots computed
c        roots - location of the roots
c
c
      real *8 tvals(n),fvals(n),fcoefs(n),roots(*)
      real *8 xnodes(n),whts(n),u(n,n),v(n,n),pars(*)
      real *8 pars2(n+10)

      external fker,fkerchebexp

      done = 1
      pi = atan(done)*4

      call chebexps(2,n,xnodes,u,v,whts)

      do i=1,n

      tvals(i) = a + (b-a)/2*(xnodes(i)+1)

      call fker(tvals(i),pars,fvals(i))

      enddo

      call pyplot(11,tvals,fvals,n,3,'a*')
      call chematvec(u,fvals,fcoefs,n)

      call prin2('fcoefs=*',fcoefs,n)

      rerr = abs(fcoefs(n)/fcoefs(1))

      pars2(1) = n+0.1
      pars2(2) = a
      pars2(3) = b
      do i=1,n

      pars2(i+3) = fcoefs(i)

      enddo

c
cc      find roots with spacing h
c

      call findroots(fkerchebexp,pars2,a,b,h,nmax,roots,nroots)

      return
      end
c-------------------------------------------------------------

      subroutine findroots(fker,pars,a,b,h,nmax,roots,nroots)
      implicit real *8 (a-h,o-z)
c
cc       this subroutine computes the roots of a chebyshev expansion
c        on the interval [a,b] by testing at equispaced points with
c        spacing h

      real *8 roots(*),pars(*)
      external fker

        x0 = a
        nh = (b-a)/h

        call fker(x0,pars,val)
        ione = 1
        if(val.ge.0) ipar = 1
        if(val.lt.0) ipar = -1

        nroots = 0

        do 2000 i=1,nh
        x0 = x0 + h
        call fker(x0,pars,val)
        if(val.ge.0) ipar2 = 1
        if(val.lt.0) ipar2 = -1
cc
c           .   .   . bissect
cc
        if (ipar .ne. ipar2) then

        xa = x0-h
        xb = x0
        do 1500 jj=1,64
        xm = (xa+xb)/2
        call fker(xm,pars,val)
        if(val.ge.0) iparm = 1
        if(val.lt.0) iparm = -1

        if (iparm .eq. ipar) xa = xm
        if (iparm .eq. ipar2) xb = xm
 1500 continue

        nroots = nroots+1

        if(nroots.gt.nmax) then

        call prin2('not enough memory*',i,0)
        stop

        endif
        roots(nroots) = xm

        ipar = ipar2

        endif

 2000 continue

      return
      end

c----------------------------------------------------------

      subroutine fval1(x,pars,fx)
      implicit real *8 (a-h,o-z)
      real *8 pars(*)

      fx = sin(12.1d0*x)

      return
      end
c------------------------------------------------

      subroutine fkerchebexp(x,pars,fx)
      implicit real *8 (a-h,o-z)
      real *8 pars(*)
c
cc      this subroutine evaluates a chebyshev expansion
c       at a point x on the interval [a,b]
c
c     input
c     x - point in [a,b] where the chebyshev expansion is to be
c         evaluated
c     pars(1) - order of chebyshev expansion
c     pars(2) - a
c     pars(3) - b
c     pars(4:n+3) - chebyshev expansion coefficients

      n = pars(1)
      a = pars(2)
      b = pars(3)

      xeval = -1 + (x-a)/(b-a)*2
      fx = 0
      call chebexev(xeval,fx,pars(4),n-1)

      return
      end
c------------------------------------------------


      PROGRAM TDEX08
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.  Use one
C of the following:
C
C       PARAMETER (IERF=6,LUNI=2,IWTY=1 ,IWID=1)  !  NCGM
C       PARAMETER (IERF=6,LUNI=2,IWTY=8 ,IWID=1)  !  X Windows
C       PARAMETER (IERF=6,LUNI=2,IWTY=20,IWID=1)  !  PostScript
C       PARAMETER (IERF=6,LUNI=2,IWTY=11,IWID=1)  !  PDF, Portrait
C       PARAMETER (IERF=6,LUNI=2,IWTY=12,IWID=1)  !  PDF, Landscape
C
        PARAMETER (IERF=6,LUNI=2,IWTYPE=1,IWTY=IWTYPE,IWID=1)
C
C Declare variables to hold labels.
C
        CHARACTER*64 UNLB,VNLB,WNLB,UILB,VILB,WILB
C
C Set the desired minimum and maximum values of U, V, and W.
C
        DATA UMIN,VMIN,WMIN,UMAX,VMAX,WMAX / -1.,-1.,-1.,1.,1.,1. /
C
C Set the desired values of parameters determining the eye position.
C ANG1 is a bearing angle, ANG2 is an elevation angle, and RMUL is a
C multiplier of the length of the diagonal of the data box, specifying
C the distance from the center of the box to the eye.
C
        DATA ANG1,ANG2,RMUL / -35.,25.,2.9 /
C
C ISTE is a flag that says whether to do a simple image (ISTE=0),
C a one-frame stereo image (ISTE=-1), or a two-frame stereo image
C (ISTE=+1).
C
        DATA ISTE / -1 /
C
C ASTE is the desired angle (in degrees) between the lines of sight for
C a pair of stereo views.
C
        DATA ASTE / 4. /
C
C WOSW is the width of the stereo windows to be used in one-frame stereo
C images; the width is stated as a fraction of the width of the plotter
C frame.  (The windows are centered vertically; horizontally, they are
C placed as far apart as possible in the plotter frame.)  The value used
C must be positive and non-zero; it may be slightly greater than .5, if
C it is desired that the stereo windows should overlap slightly.
C
        DATA WOSW / .5 /
C
C Define the number of points to be used in defining the curve.
C
        PARAMETER (NCRV=1001)
C
C Declare some arrays in which to define the curve.
C
        DIMENSION XCRV(NCRV),YCRV(NCRV),ZCRV(NCRV)
C
C Define the conversion constant from degrees to radians.
C
        DATA DTOR / .017453292519943 /
C
C Define labels for the edges of the box.
C
        DATA UNLB / ' -1 -.8 -.6 -.4 -.2 0 .2 .4 .6 .8 1 ' /
        DATA VNLB / ' -1 -.8 -.6 -.4 -.2 0 .2 .4 .6 .8 1 ' /
        DATA WNLB / ' -1 -.8 -.6 -.4 -.2 0 .2 .4 .6 .8 1 ' /
C
        DATA UILB / 'U Coordinate Values' /
        DATA VILB / 'V Coordinate Values' /
        DATA WILB / 'W Coordinate Values' /
C
C Define the curve.
C
        DO 101 I=1,NCRV
          XCRV(I)=.75*COS(DTOR*(REAL(I-1)/REAL(NCRV-1))*720.)
          YCRV(I)=.75*SIN(DTOR*(REAL(I-1)/REAL(NCRV-1))*720.)
          ZCRV(I)=-.75+1.5*REAL(I-1)/REAL(NCRV-1)
  101   CONTINUE
C
C Open GKS.
C
        CALL GOPKS (IERF,ISZDM)
        CALL GOPWK (IWID,LUNI,IWTY)
        CALL GACWK (IWID)
C
C Turn clipping off.
C
        CALL GSCLIP (0)
C
C Select font number 25, turn on the outlining of filled fonts, set the
C line width to 1, and turn off the setting of the outline color.
C
        CALL PCSETI ('FN - FONT NUMBER',25)
        CALL PCSETI ('OF - OUTLINE FLAG',1)
        CALL PCSETR ('OL - OUTLINE LINE WIDTH',1.)
        CALL PCSETR ('OC - OUTLINE LINE COLOR',-1.)
C
C Use a 25-degree (instead of the default 20-degree) field of view.
C
        CALL TDSETI ('FOV',25)
C
C Make TDPACK characters a bit bigger.
C
        CALL TDSETR ('CS1',1.25)
C
C Find the midpoint of the data box (to be used as the point looked at).
C
        UMID=.5*(UMIN+UMAX)
        VMID=.5*(VMIN+VMAX)
        WMID=.5*(WMIN+WMAX)
C
C Determine the distance (R) from which the data box will be viewed and,
C given that, the eye position.
C
        R=RMUL*SQRT((UMAX-UMIN)**2+(VMAX-VMIN)**2+(WMAX-WMIN)**2)
C
        UEYE=UMID+R*COS(DTOR*ANG1)*COS(DTOR*ANG2)
        VEYE=VMID+R*SIN(DTOR*ANG1)*COS(DTOR*ANG2)
        WEYE=WMID+R*SIN(DTOR*ANG2)
C
C Initialize the stereo offset argument to do either a single view or
C a left-eye view (whichever is selected by the value of ISTE).
C
        IF (ISTE.EQ.0) THEN
          OTEP=0.
        ELSE
          OTEP=-R*TAN(DTOR*ASTE/2.)
        END IF
C
C Initialize TDPACK.
C
  102   CALL TDINIT (UEYE,VEYE,WEYE,UMID,VMID,WMID,
     +                              UMID,VMID,WMID+R,OTEP)
C
C If stereo views are being done, do the requested thing, either by
C redoing the SET call to put them side by side on the same frame,
C or by calling FRAME to put them on separate frames.
C
        IF (OTEP.NE.0.) THEN
          IF (ISTE.LT.0) THEN
            CALL GETSET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
            IF (OTEP.LT.0.) THEN
              CALL SET  (1.-WOSW,1.,.5-.5*WOSW,.5+.5*WOSW,
     +                           XWDL,XWDR,YWDB,YWDT,LNLG)
            ELSE
              CALL SET  (  0., WOSW,.5-.5*WOSW,.5+.5*WOSW,
     +                           XWDL,XWDR,YWDB,YWDT,LNLG)
            END IF
          ELSE
            IF (OTEP.GT.0.) CALL FRAME
          END IF
        END IF
C
C Draw labels for the axes.
C
        CALL TDLBLS (UMIN,VMIN,WMIN,UMAX,VMAX,WMAX,
     +               UNLB,VNLB,WNLB,UILB,VILB,WILB,1)
C
C Draw the sides of the box that could be hidden.
C
        CALL TDGRDS (UMIN,VMIN,WMIN,UMAX,VMAX,WMAX,
     +               .1*(UMAX-UMIN),.1*(VMAX-VMIN),.1*(WMAX-WMIN),
     +                                                       12,1)
C
C Draw the curve in pieces, with an arrowhead on each one.
C
          DO 103 J=1,NCRV,100
C
C Compute the number of points on this piece.
C
            NPTS=MIN(100,NCRV-J+1)
C
C Draw a curve.  The fourth argument says whether or not there is to be
C an arrowhead on the end of the curve and, if so, how many points are
C to be used in drawing its conical base (48, in the third case) and how
C many of those points are to be connected to the tip (12, in the third
C case).
C
C           CALL TDCURV (XCRV(J),YCRV(J),ZCRV(J),NPTS,    0,.2,.1)
C           CALL TDCURV (XCRV(J),YCRV(J),ZCRV(J),NPTS,    1,.2,.1)
            CALL TDCURV (XCRV(J),YCRV(J),ZCRV(J),NPTS,12048,.2,.1)
C
  103     CONTINUE
C
C Draw the sides of the box that could not be hidden.
C
        CALL TDGRDS (UMIN,VMIN,WMIN,UMAX,VMAX,WMAX,
     +               .1*(UMAX-UMIN),.1*(VMAX-VMIN),.1*(WMAX-WMIN),
     +                                                       12,0)
C
C If a left-eye view has just been done, loop back for a right-eye view.
C
        IF (OTEP.LT.0.) THEN
          OTEP=-OTEP
          GO TO 102
        END IF
C
C Advance the frame.
C
        CALL FRAME
C
C Close GKS.
C
        CALL GDAWK (IWID)
        CALL GCLWK (IWID)
        CALL GCLKS
C
C Done.
C
        STOP
C
      END


!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-----------------------------------------------------------------------
!
! !ROUTINE: slintab - set indices and linear weights respect to a table
!
! !INTERFACE:
  subroutine slintab(nearest,ntab,vtab, ndat,vdat,indx,wght)
    implicit none
    logical, intent(in)		:: nearest	! nearest entries?
    integer, intent(in)		:: ntab		! size of vtab
      real,    intent(in)	:: vtab(ntab)	! a lookup table

    integer, intent(in)		:: ndat		! size of vdat
      real,    intent(in)	:: vdat(ndat)	! a list of values

    integer, intent(out)	:: indx(ndat)	! indices to vtab
    real,    intent(out)	:: wght(ndat)	! weights of vtab
! end subroutine slintab
!
! !DESCRIPTION:
!	*slintab()* sets indices and linear weights for a given data
!	list *vdat(ndat)* respect to a given lookup table *vtab(ntab)*.
!	If *nearest* is .false., indices *indx* point to *vtab(ntab)*
!	entries of nearest (in a linear sense) values, with *wght(ndat)*
!	defined within the range [-.5,+.5).  If *nearest* is .true.,
!	indices *indx* are lower entries of table intervals, with *wght*
!	defined withing [0,1).
!
!	*nearest*=.true. may be used to create an index table for
!	direct table reference, while *nearest*=.false. may be used to
!	create an index table with weights for linear interpolating
!	functions.
!
!	Notice that *vtab(ntab)* must be in a sorted order.
!
! !EXAMPLES:
!
! !BUGS:
!
! !SEE ALSO:
!
! !SYSTEM ROUTINES:
!
! !FILES USED:
!
! !REVISION HISTORY:
!	18May96 - J. Guo	- Fixed a problem with out-of-ranged
!				  data
! 	05Dec95 - J. Guo	- initial coding
!_______________________________________________________________________
!_______________________________________________________________________

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! local vars.
	integer i,j
	real v
!_______________________________________________________________________

	! extreme condition.  Treated as normal

	if(ntab.le.0) return

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!  ..Index the array to the lower index entry of an intervals in vtab.
	call vindex(ntab,vtab,ndat,vdat,indx)

!  ..Compute the linear weights, and adjust the indices if needed.
	do i=1,ndat
	  j=indx(i)

	  v=0.
	  if(j.lt.ntab) v=(vdat(i)-vtab(j))/(vtab(j+1)-vtab(j))
	  v=min(max(0.,v),1.)

	  if(nearest) then
		! indx(i) is the index to the nearest entry in vtab,
		! with wght(i) is within [-.5,+.5).  It is likely to
		! be used for direct table reference

	    indx(i)=j + nint(v)
	    wght(i)=v - nint(v)

	  else
		! indx(i) is the lower index of an interval in vtab,
		! with wght(i) is in [0,1).
	    wght(i)=v
	  endif
	end do
!_______________________________________________________________________
	end
!.