c
c
c ... file rgrd2.f
c
c     this file contains documentation for subroutine rgrd2 followed by
c     fortran code for rgrd2 and additional subroutines.
c
c ... author
c
c     John C. Adams (NCAR 1999)
c
c ... subroutine rgrd2(nx,ny,x,y,p,mx,my,xx,yy,q,intpol,w,lw,iw,liw,ier)
c
c ... purpose
c
c     subroutine rgrd2 interpolates the values p(i,j) on the orthogonal
c     grid (x(i),y(j)) for i=1,...,nx and j=1,...,ny onto q(ii,jj) on the
c     orthogonal grid (xx(ii),yy(jj)) for ii=1,...,mx and jj=1,...,my.
c
c ... language
c
c     coded in portable FORTRAN77 and FORTRAN90
c
c ... test program
c
c     file trgrd2.f on regridpack includes a test program for subroutine rgrd2
c
c ... method
c
c     linear or cubic interpolation is used (independently) in
c     each direction (see argument intpol).
c
c ... required files
c
c     file rgrd1.f must be loaded with rgrd2.f.  it includes
c     subroutines called by the routines in rgrd2.f
c
c ... requirements
c
c     each of the x,y grids must be strictly montonically increasing
c     and each of the xx,yy grids must be montonically increasing (see
c     ier = 4).  in addition the (X,Y) region
c
c          [xx(1),xx(mx)] X [yy(1),yy(my)]
c
c     must lie within the (X,Y) region
c
c          [x(1),x(nx)] X [y(1),y(ny)].
c
c     extrapolation is not allowed (see ier=3).  if these (X,Y)
c     regions are identical and the orthogonal grids are UNIFORM
c     in each direction then subroutine rgrd2u (see file rgrd2u.f)
c     should be used instead of rgrd2.
c
c ... efficiency
c
c     inner most loops in regridpack software vectorize.
c     If the arguments mx,my (see below) have different values, optimal
c     vectorization will be achieved if mx > my.
c
c
c *** input argument
c
c
c ... nx
c
c     the integer dimension of the grid vector x and the first dimension
c     of p.  nx > 1 if intpol(1) = 1 or nx > 3 if intpol(1) = 3 is required.
c
c ... ny
c
c     the integer dimension of the grid vector y and the second dimension
c     of p.  ny > 1 if intpol(2) = 1 or ny > 3 if intpol(2) = 3 is required.
c
c ... x
c
c     a real nx vector of strictly increasing values which defines the x
c     portion of the orthogonal grid on which p is given
c
c ... y
c
c     a real ny vector of strictly increasing values which defines the y
c     portion of the orthogonal grid on which p is given
c
c ... p
c
c     a real nx by ny array of values given on the orthogonal (x,y) grid
c
c ... mx
c
c     the integer dimension of the grid vector xx and the first dimension
c     of q.  mx > 0 is required.
c
c ... my
c
c     the integer dimension of the grid vector yy and the second dimension
c     of q.  my > 0 is required.
c
c ... xx
c
c     a real mx vector of increasing values which defines the x portion of the
c     orthogonal grid on which q is defined.  xx(1) < x(1) or xx(mx) > x(nx)
c     is not allowed (see ier = 3)
c
c ... yy
c
c     a real my vector of increasing values which defines the y portion of the
c     orthogonal grid on which q is defined.  yy(1) < y(1) or yy(my) > y(ny)
c     is not allowed (see ier = 3)
c
c ... intpol
c
c     an integer vector of dimension 2 which sets linear or cubic
c     interpolation in the x,y directions as follows:
c
c        intpol(1) = 1 sets linear interpolation in the x direction
c        intpol(1) = 3 sets cubic interpolation in the x direction.
c
c        intpol(2) = 1 sets linear interpolation in the y direction
c        intpol(2) = 3 sets cubic interpolation in the y direction.
c
c     values other than 1 or 3 in intpol are not allowed (ier = 5).
c
c ... w
c
c     a real work space of length at least lw which must be provided in the
c     routine calling rgrd2
c
c ... lw
c
c     the integer length of the real work space w.  let
c
c          lwx =   mx            if intpol(1) = 1
c          lwx = 4*mx            if intpol(1) = 3
c
c          lwy = my+2*mx         if intpol(2) = 1
c          lwy = 4*(mx+my)       if intpol(2) = 3
c
c     then lw must be greater than or equal to lwx+lwy
c
c ... iw
c
c     an integer work space of length at least liw which must be provided in the
c     routine calling rgrd2
c
c ... liw
c
c     the integer length of the integer work space iw.  liw must be at least mx+my
c
c *** output arguments
c
c
c ... q
c
c     a real mx by my array of values on the (xx,yy) grid which are
c     interpolated from p on the (x,y) grid
c
c ... ier
c
c     an integer error flag set as follows:
c
c     ier = 0 if no errors in input arguments are detected
c
c     ier = 1 if  min0(mx,my) < 1
c
c     ier = 2 if nx < 2 when intpol(1)=1 or nx < 4 when intpol(1)=3 (or)
c                ny < 2 when intpol(2)=1 or ny < 4 when intpol(2)=3
c
c     ier = 3 if xx(1) < x(1) or x(nx) < xx(mx) (or)
c                yy(1) < y(1) or y(ny) < yy(my) (or)
c
c *** to avoid this flag when end points are intended to be the
c     same but may differ slightly due to roundoff error, they
c     should be set exactly in the calling routine (e.g., if both
c     grids have the same y boundaries then yy(1)=y(1) and yy(my)=y(ny)
c     should be set before calling rgrd2)
c
c     ier = 4 if one of the grids x,y is not strictly monotonically
c             increasing or if one of the grids xx,yy is not
c             montonically increasing.  more precisely if:
c
c             x(i+1) <= x(i) for some i such that 1 <= i < nx (or)
c
c             y(j+1) <= y(j) for some j such that 1 <= j < ny (or)
c
c             xx(ii+1) < xx(ii) for some ii such that 1 <= ii < mx (or)
c
c             yy(jj+1) < yy(jj) for some jj such that 1 <= jj < my
c
c     ier = 5 if lw or liw is to small (insufficient work space)
c
c     ier = 6 if intpol(1) or intpol(2) is not equal to 1 or 3
c
c ************************************************************************
c
c     end of rgrd2 documentation, fortran code follows:
c
c ************************************************************************
c
      subroutine rgrd2(nx,ny,x,y,p,mx,my,xx,yy,q,intpol,w,lw,iw,liw,ier)
      implicit none
      integer nx,ny,mx,my,lw,liw,ier
      integer intpol(2),iw(liw)
      real x(nx),y(ny),p(nx,ny),xx(mx),yy(my),q(mx,my),w(lw)
      integer i,ii,j,jj,j2,j3,j4,j5,j6,j7,j8,j9,i2,i3,i4,i5
      integer jy,lwx,lwy
c
c     check input arguments
c
      ier = 1
c
c     check (xx,yy) grid resolution
c
      if (min0(mx,my) .lt. 1) return
c
c     check intpol
c
      ier = 6
      if (intpol(1).ne.1 .and. intpol(1).ne.3) return
      if (intpol(2).ne.1 .and. intpol(2).ne.3) return
c
c     check (x,y) grid resolution
c
      ier = 2
      if (intpol(1).eq.1 .and. nx.lt.2) return
      if (intpol(1).eq.3 .and. nx.lt.4) return
      if (intpol(2).eq.1 .and. ny.lt.2) return
      if (intpol(2).eq.3 .and. ny.lt.4) return
c
c     check work space lengths
c
      ier = 5
      if (intpol(1).eq.1) then
      lwx = mx
      else
      lwx = 4*mx
      end if
      if (intpol(2).eq.1) then
      lwy = my+2*mx
      else
      lwy = 4*(mx+my)
      end if
      if (lw .lt. lwx+lwy) return
      if (liw .lt. mx+my) return
c
c     check (xx,yy) grid contained in (x,y) grid
c
      ier = 3
      if (xx(1).lt.x(1) .or. xx(mx).gt.x(nx)) return
      if (yy(1).lt.y(1) .or. yy(my).gt.y(ny)) return
c
c     check montonicity of grids
c
      ier = 4
      do i=2,nx
	if (x(i-1).ge.x(i)) return
      end do
      do j=2,ny
	if (y(j-1).ge.y(j)) return
      end do
      do ii=2,mx
	if (xx(ii-1).gt.xx(ii)) return
      end do
      do jj=2,my
	if (yy(jj-1).gt.yy(jj)) return
      end do
c
c     arguments o.k.
c
      ier = 0
c
c     set pointer in integer work space
c
      jy = mx+1
      if (intpol(2) .eq.1) then
c
c     linearly interpolate in y
c
      j2 = 1
      j3 = j2
      j4 = j3+my
      j5 = j4
      j6 = j5
      j7 = j6
      j8 = j7+mx
      j9 = j8+mx
c
c     set y interpolation indices and scales and linearly interpolate
c
      call linmx(ny,y,my,yy,iw(jy),w(j3))
      i2 = j9
c
c     set work space portion and indices which depend on x interpolation
c
      if (intpol(1) .eq. 1) then
      i3 = i2
      i4 = i3
      i5 = i4
      call linmx(nx,x,mx,xx,iw,w(i3))
      else
      i3 = i2+mx
      i4 = i3+mx
      i5 = i4+mx
      call cubnmx(nx,x,mx,xx,iw,w(i2),w(i3),w(i4),w(i5))
      end if
      call lint2(nx,ny,p,mx,my,q,intpol,iw(jy),w(j3),
     +            w(j7),w(j8),iw,w(i2),w(i3),w(i4),w(i5))
      return

      else
c
c     cubically interpolate in y, set indice pointers
c
      j2 = 1
      j3 = j2+my
      j4 = j3+my
      j5 = j4+my
      j6 = j5+my
      j7 = j6+mx
      j8 = j7+mx
      j9 = j8+mx
      call cubnmx(ny,y,my,yy,iw(jy),w(j2),w(j3),w(j4),w(j5))
      i2 =  j9+mx
c
c     set work space portion and indices which depend on x interpolation
c
      if (intpol(1) .eq. 1) then
      i3 = i2
      i4 = i3
      i5 = i4
      call linmx(nx,x,mx,xx,iw,w(i3))
      else
      i3 = i2+mx
      i4 = i3+mx
      i5 = i4+mx
      call cubnmx(nx,x,mx,xx,iw,w(i2),w(i3),w(i4),w(i5))
      end if
      call cubt2(nx,ny,p,mx,my,q,intpol,iw(jy),w(j2),w(j3),
     +w(j4),w(j5),w(j6),w(j7),w(j8),w(j9),iw,w(i2),w(i3),w(i4),w(i5))
      return
      end if
      end

      subroutine lint2(nx,ny,p,mx,my,q,intpol,jy,dy,pj,pjp,
     +                 ix,dxm,dx,dxp,dxpp)
      implicit none
      integer nx,ny,mx,my,intpol(2),jy(my),ix(mx)
      integer jsave,j,jj,ii
      real p(nx,ny),q(mx,my)
      real pj(mx),pjp(mx),dy(my)
      real dxm(mx),dx(mx),dxp(mx),dxpp(mx)
c
c     linearly interpolate in y
c
      if (intpol(1).eq.1) then
c
c     linear in x
c
      jsave = -1
      do jj=1,my
	j = jy(jj)
	if (j.eq.jsave) then
c
c       j pointer has not moved since last pass (no updates or interpolation)
c
	else if (j.eq.jsave+1) then
c
c       update j and interpolate j+1
c
	  do ii=1,mx
	    pj(ii) = pjp(ii)
	  end do
	  call lint1(nx,p(1,j+1),mx,pjp,ix,dx)
	else
c
c       interpolate j,j+1in pj,pjp on xx mesh
c
	call lint1(nx,p(1,j),mx,pj,ix,dx)
	call lint1(nx,p(1,j+1),mx,pjp,ix,dx)
	end if
c
c       save j pointer for next pass
c
	jsave = j
c
c       linearly interpolate q(ii,jj) from pjp,pj in y direction
c
	do ii=1,mx
	  q(ii,jj) = pj(ii)+dy(jj)*(pjp(ii)-pj(ii))
	end do
      end do

      else
c
c     cubic in x
c
      jsave = -1
      do jj=1,my
	j = jy(jj)
	if (j.eq.jsave) then
c
c       j pointer has not moved since last pass (no updates or interpolation)
c
	else if (j.eq.jsave+1) then
c
c       update j and interpolate j+1
c
	  do ii=1,mx
	    pj(ii) = pjp(ii)
	  end do
	  call cubt1(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp)
	else
c
c       interpolate j,j+1 in pj,pjp on xx mesh
c
	  call cubt1(nx,p(1,j),mx,pj,ix,dxm,dx,dxp,dxpp)
	  call cubt1(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp)
	end if
c
c       save j pointer for next pass
c
	jsave = j
c
c       linearly interpolate q(ii,jj) from pjp,pj in y direction
c
	do ii=1,mx
	  q(ii,jj) = pj(ii)+dy(jj)*(pjp(ii)-pj(ii))
	end do
      end do
      return
      end if
      end

      subroutine cubt2(nx,ny,p,mx,my,q,intpol,jy,dym,dy,dyp,
     +dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
      implicit none
      integer nx,ny,mx,my,intpol(2),jy(my),ix(mx)
      integer jsave,j,jj,ii
      real p(nx,ny),q(mx,my)
      real pjm(mx),pj(mx),pjp(mx),pjpp(mx)
      real dym(my),dy(my),dyp(my),dypp(my)
      real dxm(mx),dx(mx),dxp(mx),dxpp(mx)
      if (intpol(1).eq.1) then
c
c     linear in x
c
      jsave = -3
      do jj=1,my
c
c       load closest four j lines containing interpolate on xx mesh
c       for j-1,j,j+1,j+2 in pjm,pj,pjp,pjpp
c
	j = jy(jj)
	if (j.eq.jsave) then
c
c       j pointer has not moved since last pass (no updates or interpolation)
c
	else if (j.eq.jsave+1) then
c
c       update j-1,j,j+1 and interpolate j+2
c
	  do ii=1,mx
	    pjm(ii) = pj(ii)
	    pj(ii) = pjp(ii)
	    pjp(ii) = pjpp(ii)
	  end do
	  call lint1(nx,p(1,j+2),mx,pjpp,ix,dx)
	else if (j.eq.jsave+2) then
c
c     update j-1,j and interpolate j+1,j+2
c
	  do ii=1,mx
	    pjm(ii) = pjp(ii)
	    pj(ii) = pjpp(ii)
	  end do
	  call lint1(nx,p(1,j+1),mx,pjp,ix,dx)
	  call lint1(nx,p(1,j+2),mx,pjpp,ix,dx)
	else if (j.eq.jsave+3) then
c
c       update j-1 and interpolate j,j+1,j+2
c
	  do ii=1,mx
	    pjm(ii) = pjpp(ii)
	  end do
	  call lint1(nx,p(1,j),mx,pj,ix,dx)
	  call lint1(nx,p(1,j+1),mx,pjp,ix,dx)
	  call lint1(nx,p(1,j+2),mx,pjpp,ix,dx)
	else
c
c       interpolate all four j-1,j,j+1,j+2
c
	  call lint1(nx,p(1,j-1),mx,pjm,ix,dx)
	  call lint1(nx,p(1,j),mx,pj,ix,dx)
	  call lint1(nx,p(1,j+1),mx,pjp,ix,dx)
	  call lint1(nx,p(1,j+2),mx,pjpp,ix,dx)
	end if
c
c     save j pointer for next pass
c
	jsave = j
c
c     cubically interpolate q(ii,jj) from pjm,pj,pjp,pjpp in y direction
c
	do ii=1,mx
	  q(ii,jj) = dym(jj)*pjm(ii)+dy(jj)*pj(ii)+dyp(jj)*pjp(ii)+
     +               dypp(jj)*pjpp(ii)
	end do
      end do
      return

      else
c
c     cubic in x
c
	jsave = -3
	do jj=1,my
c
c       load closest four j lines containing interpolate on xx mesh
c       for j-1,j,j+1,j+2 in pjm,pj,pjp,pjpp
c
	  j = jy(jj)
	  if (j.eq.jsave) then
c
c         j pointer has not moved since last pass (no updates or interpolation)
c
	  else if (j.eq.jsave+1) then
c
c         update j-1,j,j+1 and interpolate j+2
c
	    do ii=1,mx
	      pjm(ii) = pj(ii)
	      pj(ii) = pjp(ii)
	      pjp(ii) = pjpp(ii)
	    end do
	    call cubt1(nx,p(1,j+2),mx,pjpp,ix,dxm,dx,dxp,dxpp)
	  else if (j.eq.jsave+2) then
c
c         update j-1,j and interpolate j+1,j+2
c
	    do ii=1,mx
	      pjm(ii) = pjp(ii)
	      pj(ii) = pjpp(ii)
	    end do
	    call cubt1(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp)
	    call cubt1(nx,p(1,j+2),mx,pjpp,ix,dxm,dx,dxp,dxpp)
	  else if (j.eq.jsave+3) then
c
c         update j-1 and interpolate j,j+1,j+2
c
	    do ii=1,mx
	      pjm(ii) = pjpp(ii)
	    end do
	    call cubt1(nx,p(1,j),mx,pj,ix,dxm,dx,dxp,dxpp)
	    call cubt1(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp)
	    call cubt1(nx,p(1,j+2),mx,pjpp,ix,dxm,dx,dxp,dxpp)
	  else
c
c         interpolate all four j-1,j,j+1,j+2
c
	    call cubt1(nx,p(1,j-1),mx,pjm,ix,dxm,dx,dxp,dxpp)
	    call cubt1(nx,p(1,j),mx,pj,ix,dxm,dx,dxp,dxpp)
	    call cubt1(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp)
	    call cubt1(nx,p(1,j+2),mx,pjpp,ix,dxm,dx,dxp,dxpp)
	  end if
c
c       save j pointer for next pass
c
	jsave = j
c
c       cubically interpolate q(ii,jj) from pjm,pj,pjp,pjpp in y direction
c
	do ii=1,mx
	  q(ii,jj) = dym(jj)*pjm(ii)+dy(jj)*pj(ii)+dyp(jj)*pjp(ii)+
     +               dypp(jj)*pjpp(ii)
	end do
      end do
      return
      end if
      end


SUBROUTINE GammaFunctions(x,n,dir,ftype,gam,param)
!
! Gamma functions for relaxation
!
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
IMPLICIT NONE
INTEGER::n, ftype
REAL(KIND=long), DIMENSION(n) :: x, gam, tmp
REAL(KIND=long) :: param
INTEGER :: dir
IF (n>1) THEN
	tmp = (x - x(1))/(x(n)-x(1))
ELSE
	tmp = x
ENDIF
SELECT CASE (ABS(ftype))
	CASE (9) ! Allan's sponge filter
		gam = one - tmp**param
	CASE (10) ! third order poly. with clamped BCs
		gam = three*tmp**2-two*tmp**3
        CASE (11)
                gam=(exp(tmp**param)-1)/(exp(one)-one)
END SELECT
IF (dir==-1) THEN ! REVERSE
	gam = gam(n:1:-1)  ! FIXME: not just for x
ENDIF
END SUBROUTINE GammaFunctions


c subroutine linfit.f
c
c source
c   Bevington, pages 104-105.
c
c purpose
c   make a least-squares fit to a data set with a straight line
c
c usage
c   call linfit (x, y, sigmay, npts, mode, a, sigmaa, b, sigmab, r)
c
c description of parameters
c   x      - array of data points for independent variable
c   y      - array of data points for dependent variable
c   sigmay - array of standard deviations for y data points
c   npts   - number of pairs of data points
c   mode   - determines method of weighting least-squares fit
c            +1 (instrumental) weight(i) = 1./sigmay(i)**2
c             0 (no weighting) weight(i) = 1.
c            -1 (statistical)  weight(i) = 1./y(i)
c   a      - y intercept of fitted straight line
c   sigmaa - standard deviation of a
c   b      - slope of fitted straight line
c   sigmab - standard deviation of b
c   r      - linear correlation coefficient
c
c subroutines and function subprograms required
c   none
c
      subroutine linfit (x,y,sigmay,npts,mode,a,sigmaa,b,sigmab,r)
      double precision sum,sumx,sumy,sumx2,sumxy,sumy2
      double precision xi,yi,weight,delta,varnce
      dimension x(1),y(1),sigmay(1)
c
c accumulate weighted sums
c
11    sum=0.
      sumx=0.
      sumy=0.
      sumx2=0.
      sumxy=0.
      sumy2=0.
21    do 50 i=1,npts
      xi=x(i)
      yi=y(i)
      if (mode) 31,36,38
31    if (yi) 34,36,32
32    weight=1./yi
      goto 41
34    weight=1./(-yi)
      goto 41
36    weight=1.
      goto 41
38    weight=1./sigmay(i)**2
41    sum=sum+weight
      sumx=sumx+weight*xi
      sumy=sumy+weight*yi
      sumx2=sumx2+weight*xi*xi
      sumxy=sumxy+weight*xi*yi
      sumy2=sumy2+weight*yi*yi
50    continue
c
c calculate coefficients and standard deviations
c
51    delta=sum*sumx2-sumx*sumx
      a=(sumx2*sumy-sumx*sumxy)/delta
53    b=(sumxy*sum-sumx*sumy)/delta
61    if (mode) 62,64,62
62    varnce=1.
      goto 67
64    c=npts-2
      varnce=(sumy2+a*a*sum+b*b*sumx2
     *-2.*(a*sumy+b*sumxy-a*b*sumx))/c
67    sigmaa=dsqrt(varnce*sumx2/delta)
68    sigmab=dsqrt(varnce*sum/delta)
71    r=(sum*sumxy-sumx*sumy)/
     *dsqrt(delta*(sum*sumy2-sumy*sumy))
      return
      end


submodule (maptran) aer

implicit none (type, external)

contains

module procedure ecef2aer
!! ecef2aer  convert ECEF of target to azimuth, elevation, slant range from observer
!!
!! Inputs
!! ------
!! x,y,z: Earth Centered Earth Fixed (ECEF) coordinates of test point (meters)
!! lat0, lon0, alt0: ellipsoid geodetic coordinates of observer/reference (degrees, degrees, meters)
!! spheroid: Ellipsoid parameter struct
!! deg: .true.: degrees
!!
!! Outputs
!! -------
!! az, el, slantrange: look angles and distance to point under test (degrees, degrees, meters)
!! az: azimuth clockwise from local north
!! el: elevation angle above local horizon

real(wp) :: east, north, up

call ecef2enu(x, y, z, lat0, lon0, alt0, east, north, up, spheroid, deg)
call enu2aer(east, north, up, az, el, slantRange, deg)

end procedure ecef2aer

module procedure aer2ecef
! aer2ecef  convert azimuth, elevation, range to target from observer to ECEF coordinates
!
! Inputs
! ------
! az, el, slantrange: look angles and distance to point under test (degrees, degrees, meters)
! az: azimuth clockwise from local north
! el: elevation angle above local horizon
! lat0, lon0, alt0: ellipsoid geodetic coordinates of observer/reference (degrees, degrees, meters)
! spheroid: Ellipsoid parameter struct
! deg: .true. degrees
!
! outputs
! -------
! x,y,z: Earth Centered Earth Fixed (ECEF) coordinates of test point (meters)

real(wp) :: x0,y0,z0, e,n,u,dx,dy,dz

!> Origin of the local system in geocentric coordinates.
call geodetic2ecef(lat0, lon0, alt0,x0, y0, z0, spheroid,deg)
!> Convert Local Spherical AER to ENU
call aer2enu(az, el, slantRange, e, n, u,deg)
!> Rotating ENU to ECEF
call enu2uvw(e, n, u, lat0, lon0, dx, dy, dz,deg)
!> Origin + offset from origin equals position in ECEF
x = x0 + dx
y = y0 + dy
z = z0 + dz

end procedure aer2ecef

module procedure geodetic2aer
! geodetic2aer   from an observer's perspective, convert target coordinates to azimuth, elevation, slant range.
!
! Inputs
! ------
! lat,lon, alt:  ellipsoid geodetic coordinates of point under test (degrees, degrees, meters)
! lat0, lon0, alt0: ellipsoid geodetic coordinates of observer/reference (degrees, degrees, meters)
! spheroid: Ellipsoid parameter struct
! angleUnit: string for angular units. Default 'd': degrees, otherwise Radians
!
! Outputs
! -------
! az, el, slantrange: look angles and distance to point under test (degrees, degrees, meters)
! az: azimuth clockwise from local north
! el: elevation angle above local horizon

real(wp) :: east,north,up

call geodetic2enu(lat, lon, alt, lat0, lon0, alt0, east,north,up, spheroid, deg)
call enu2aer(east, north, up, az, el, slantRange, deg)

end procedure geodetic2aer

module procedure aer2geodetic
!! aer2geodetic  convert azimuth, elevation, range of target from observer to geodetic coordiantes
!!
!! ## Inputs
!!
!! *  az, el, slantrange: look angles and distance to point under test (degrees, degrees, meters)
!! *  az: azimuth clockwise from local north
!! *  el: elevation angle above local horizon
!! *  lat0, lon0, alt0: ellipsoid geodetic coordinates of observer/reference (degrees, degrees, meters)
!! *  spheroid: Ellipsoid parameter struct
!! *  deg: .true.: degrees
!!
!! ## Outputs
!!
!! *  lat1,lon1,alt1: geodetic coordinates of test points (degrees,degrees,meters)

real(wp) :: x,y,z

call aer2ecef(az, el, slantRange, lat0, lon0, alt0, x, y, z, spheroid, deg)

call ecef2geodetic(x, y, z, lat1, lon1, alt1, spheroid, deg)
end procedure aer2geodetic

end submodule aer


! mpiexec -np 4 bin/Debug/WGFM_test2.exe
program matrices_mpi_test
    use meshread_mod
    use linalg_mod
    use WGFM_matrices
    use WGFM_matrices_mpi
    use data_tools
    use mpi
    implicit none

    complex(8), parameter :: IU = (0d0, 1d0)

    ! Variables
    type(Mesh) :: msh
    integer, parameter :: nNS = 6           ! number of quadrature points for EFIE
    complex(8), allocatable :: Z1(:, :)
    complex(8), allocatable :: Z2(:, :)
    complex(8), allocatable :: S1Pot(:, :, :), D1Pot(:, :, :), S2Pot(:, :, :), D2Pot(:, :, :)
    complex(8), allocatable :: S1Pot_m(:, :, :), D1Pot_m(:, :, :), S2Pot_m(:, :, :), D2Pot_m(:, :, :)
    real(8), allocatable :: EvlMsh(:,:)

    ! MPI variables
    integer :: ierr, N_procs, id

    ! Parameters
    real(8), parameter :: ep0 = 1d0 / (35950207149.4727056d0 * PI)  ! vacuum permittivity [F/m]
    real(8), parameter :: mu0 = PI * 4d-7                           ! vacuum permeability [H/m]

    real(8), parameter :: k = 0.1d0 * PI          ! free-space wavenumber [1/m]
    real(8), parameter :: ep1 = ep0             ! upper half-space permittivity [F/m]
    real(8), parameter :: mu1 = mu0             ! upper half-space permeability [H/m]
    real(8), parameter :: ep2 = ep0 * 2.5d0     ! lower half-space permittivity [F/m]
    real(8), parameter :: mu2 = mu0 * 5.3       ! lower half-space permeability [H/m]

    real(8), parameter :: w = k / sqrt(ep0 * mu0)   ! angular frequency [rad/s]
    real(8), parameter :: k1 = w * sqrt(ep1 * mu1)  ! upper half-space wavenumber [1/m]
    real(8), parameter :: k2 = w * sqrt(ep2 * mu2)  ! lower half-space wavenumber [1/m]

    character(len=100) :: file_msh = 'meshes/half_sphere_plane/half_sphere_plane_a5_h04_t20.msh'
    character(len=100) :: file_evl_msh = 'meshes/eval_msh/circle_msh.txt'
    !character(len=100) :: file_msh = 'meshes/convergence_sphere/simple_mesh.msh'

    ! Set window (just to test the program)
    call set_circ_window(Lr=4d0, c_in=0.7d0)

    ! MPI init
    call mpi_init(ierr)
    call mpi_comm_size(MPI_COMM_WORLD, N_procs, ierr)
    call mpi_comm_rank(MPI_COMM_WORLD, id, ierr)
    print *, "Total processes:", N_procs, "Process id:", id

    ! Load mesh
    call load_gmsh(file_msh, msh)

    ! Compute WGFM matrices
    if (id == 0) print *, "WGFM1"
    call genWGFMMat(msh, w, k1, k2, ep1, ep2, mu1, mu2, Z1)
    if (id == 0) print *, "WGFM2"
    call genWGFMMat_mpi(msh, w, k1, k2, ep1, ep2, mu1, mu2, Z2)

    ! Retrieve evaluation points
    call load_matlab_mesh(file_evl_msh, EvlMsh)

    ! Compute WGFM potencial
    if (id == 0) print *, "WGFM Pot1"
    call genWGFMPot(msh, EvlMsh, k1, k2, S1Pot, D1Pot, S2Pot, D2Pot)
    if (id == 0) print *, "WGFM Pot2"
    call genWGFMPot_mpi(msh, EvlMsh, k1, k2, S1Pot_m, D1Pot_m, S2Pot_m, D2Pot_m)

    if (id == 0) then
        ! Compute matrices norm
        print *, "shape", shape(Z1)
        print *, "k", k
        print *, "w", w
        print *,
        print *, "Z", sqrt(sum(abs((Z1-Z2)) ** 2))
        print *, "S1", sqrt(sum(abs((S1Pot-S1Pot_m)) ** 2))
        print *, "D1", sqrt(sum(abs((D1Pot-D1Pot_m)) ** 2))
        print *, "S2", sqrt(sum(abs((S2Pot-S2Pot_m)) ** 2))
        print *, "D2", sqrt(sum(abs((D2Pot-D2Pot_m)) ** 2))
    end if

    call MPI_Finalize(ierr)
end program


program poisson_mg_rb_3d
! A 3D Poisson solver on uniform mesh using Multigrid and Red/Black Gauss-Seidel.
! By Thomas Bewley and Paolo Luchini
include 'poisson_mg_rb_3d.header'
integer :: ta(8);  real*8 :: s, c, y, u, t, w, z, e, nudge, max_error
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! USER INPUT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! XBC=1 for hom. Dirichlet (0:NX), =2 for periodic (-1:NX), =3 for hom. Neumann (-1:NX+1).
! Similar for YBC, ZBC.   NX, NY, NZ must be powers of two.
NX=128; NY=256; NZ=512; XBC=3; YBC=2; ZBC=1; N1=3; N2=3; N3=2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! END OF USER INPUT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
print *, 'BCs: ',XBC,',',YBC,',',ZBC,'. Smoothing: ',N1,',',N2,',',N3,'.  Grids:'
select case(XBC); case(1); xo=1; case(2); xo=2; case(3); xo=2; end select
select case(YBC); case(1); yo=1; case(2); yo=2; case(3); yo=2; end select
select case(ZBC); case(1); zo=1; case(2); zo=2; case(3); zo=2; end select
nlev=int(log10(real(min(NX,NY,NZ)))/log10(2.0))-1; call random_seed;
do lev=0,nlev
   g(lev)%nx = NX/(2**lev); g(lev)%ny = NY/(2**lev); g(lev)%nz = NZ/(2**lev);
   g(lev)%xm=g(lev)%nx+XBC; g(lev)%ym=g(lev)%ny+YBC; g(lev)%zm=g(lev)%nz+ZBC;
   allocate(v(lev)%d(g(lev)%xm,g(lev)%ym,g(lev)%zm));
   allocate(d(lev)%d(g(lev)%xm,g(lev)%ym,g(lev)%zm));
   v(lev)%d=0.0d0; d(lev)%d=0.0d0;  print *,lev,g(lev)%nx,g(lev)%ny,g(lev)%nz
end do
do k=4,g(0)%zm-3; do j=4,g(0)%ym-3; do i=4,g(0)%xm-3
   call random_number(harvest); d(0)%d(i,j,k) = harvest-0.5;
end do; end do; end do;
s=sum(d(0)%d); print *,'SumA = ',s; nudge=s/dfloat((g(0)%xm-6)*(g(0)%ym-6)*(g(0)%zm-6));
do k=4,g(0)%zm-3; do j=4,g(0)%ym-3; do i=4,g(0)%xm-3
   d(0)%d(i,j,k)=d(0)%d(i,j,k)-nudge;
end do; end do; end do; s=sum(d(0)%d); print *,'SumB = ',s;

e = max_error(0); print *,'Iteration =  0 , error = ',e
do i=1,N1; call poisson_rb(0); end do
call date_and_time(values=ta); t = ta(5)*3600 + ta(6)*60 + ta(7) + 0.001*ta(8)
iter=1; do
   o=e; call poisson_mg(0); e = max_error(0)
   print *,'Iteration = ',iter,', error = ',e, 'factor = ', o/e
   if (e<1E-12) then; print *,'Converged'; exit; end if
   if (iter==10) then; print *,'Fed up, quitting.'; exit; end if; iter=iter+1
end do
call date_and_time(values=ta); t = ta(5)*3600 + ta(6)*60 + ta(7) + 0.001*ta(8) - t
print *,'Total time =',t,'sec for',iter,'iterations -> time/iteration: ',t/iter,' sec'
do lev=0,nlev; deallocate(v(lev)%d); deallocate(d(lev)%d); end do
end program poisson_mg_rb_3d
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine enforce_bcs(lev)
include 'poisson_mg_rb_3d.header'
! Enforce the Neumann and/or periodic boundary conditions (nothing to do for Dirichlet)
i=g(lev)%xm; j=g(lev)%ym; k=g(lev)%zm;
if (XBC==3) then; v(lev)%d(1,        1:j,1:k)=v(lev)%d(3,          1:j,1:k)
				  v(lev)%d(g(lev)%xm,1:j,1:k)=v(lev)%d(g(lev)%xm-2,1:j,1:k); end if
if (YBC==3) then; v(lev)%d(1:i,1,        1:k)=v(lev)%d(1:i,3,          1:k)
				  v(lev)%d(1:i,g(lev)%ym,1:k)=v(lev)%d(1:i,g(lev)%ym-2,1:k); end if
if (ZBC==3) then; v(lev)%d(1:i,1:j,1        )=v(lev)%d(1:i,1:j,3          )
				  v(lev)%d(1:i,1:j,g(lev)%zm)=v(lev)%d(1:i,1:j,g(lev)%zm-2); end if
if (XBC==2) then; v(lev)%d(1,        1:j,1:k)=v(lev)%d(g(lev)%xm-1,1:j,1:k)
				  v(lev)%d(g(lev)%xm,1:j,1:k)=v(lev)%d(2,          1:j,1:k); end if
if (YBC==2) then; v(lev)%d(1:i,1,        1:k)=v(lev)%d(1:i,g(lev)%ym-1,1:k)
                  v(lev)%d(1:i,g(lev)%ym,1:k)=v(lev)%d(1:i,2,          1:k); end if
if (ZBC==2) then; v(lev)%d(1:i,1:j,1        )=v(lev)%d(1:i,1:j,g(lev)%zm-1)
                  v(lev)%d(1:i,1:j,g(lev)%zm)=v(lev)%d(1:i,1:j,2          ); end if
end subroutine enforce_bcs
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
recursive subroutine poisson_mg(lev)
real*8 :: sum, nudge
include 'poisson_mg_rb_3d.header'
do i=1,N2; call poisson_rb(lev); end do
do kc=2,g(lev+1)%zm-1; do jc=2,g(lev+1)%ym-1; do ic=2,g(lev+1)%xm-1 ! Compute residual and
   i=2*(ic-xo)+xo; j=2*(jc-yo)+yo; k=2*(kc-zo)+zo               ! restrict to coarser grid
   d(lev+1)%d(ic,jc,kc)=(v(lev)%d(i+1,j,k)    +v(lev)%d(i-1,j,k) +v(lev)%d(i,j+1,k)  &
      & +v(lev)%d(i,j-1,k) +v(lev)%d(i,j,k+1) +v(lev)%d(i,j,k-1))/6.d0               &
      & -v(lev)%d(i,j,k)   +d(lev)%d(i,j,k);
end do; end do; end do
v(lev+1)%d=d(lev+1)%d; call enforce_bcs(lev)
if (lev<nlev-1) then; call poisson_mg(lev+1)     ! Continue to even coarser grid, or
else; do i=1,50; call poisson_rb(nlev); end do   ! solve coarsest system (almost exactly)
end if
do kc=2,g(lev+1)%zm; do jc=2,g(lev+1)%ym; do ic=2,g(lev+1)%xm ! Prolongation (using
   i=2*(ic-xo)+xo; j=2*(jc-yo)+yo; k=2*(kc-zo)+zo             ! bilinear interpolation)
   if ((j<=g(lev)%ym).and.(k<=g(lev)%zm)) then                ! on black interior points
      v(lev)%d(i-1,j,k) = v(lev)%d(i-1,j,k)+(v(lev+1)%d(ic-1,jc,kc)+v(lev+1)%d(ic,jc,kc));
   end if
   if ((i<=g(lev)%xm).and.(k<=g(lev)%zm)) then
      v(lev)%d(i,j-1,k) = v(lev)%d(i,j-1,k)+(v(lev+1)%d(ic,jc-1,kc)+v(lev+1)%d(ic,jc,kc));
   end if
   if ((i<=g(lev)%xm).and.(j<=g(lev)%ym)) then
      v(lev)%d(i,j,k-1) = v(lev)%d(i,j,k-1)+(v(lev+1)%d(ic,jc,kc-1)+v(lev+1)%d(ic,jc,kc));
   end if
v(lev)%d(i-1,j-1,k-1)=v(lev)%d(i-1,j-1,k-1)+(v(lev+1)%d(ic,jc,kc)+v(lev+1)%d(ic-1,jc,kc) &
   & + v(lev+1)%d(ic,jc-1,kc)  +v(lev+1)%d(ic-1,jc-1,kc) + v(lev+1)%d(ic,jc,kc-1)        &
   & + v(lev+1)%d(ic-1,jc,kc-1)+v(lev+1)%d(ic,jc-1,kc-1)+v(lev+1)%d(ic-1,jc-1,kc-1))*0.25;
end do; end do; end do    ! Note that the next call to poisson_rb takes care of red points
call enforce_bcs(lev)
do i=1,N3; call poisson_rb(lev); end do
end subroutine poisson_mg
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine poisson_rb(lev)
include 'poisson_mg_rb_3d.header'      ! Apply Red/Black Gauss-Seidel, with L from Poisson
do irb=0,1; do k=2,g(lev)%zm-1; do j=2,g(lev)%ym-1   ! update red points first, then black
m=2+mod(j+k+irb+xo+yo+zo,2); n=g(lev)%xm-1;
mp=m+1; mm=m-1; np=n+1; nm=n-1; jp=j+1; jm=j-1; kp=k+1; km=k-1
v(lev)%d(m:n:2,j,k)=(v(lev)%d(mp:np:2,j,k) +v(lev)%d(mm:nm:2,j,k) +v(lev)%d(m:n:2,jp,k) &
   & +v(lev)%d(m:n:2,jm,k) +v(lev)%d(m:n:2,j,kp) +v(lev)%d(m:n:2,j,km))/6.d0            &
   & +d(lev)%d(m:n:2,j,k);
end do; end do; call enforce_bcs(lev); end do
end subroutine poisson_rb
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
real*8 function max_error(lev)
include 'poisson_mg_rb_3d.header'
max_error = 0.0; do k=2,g(lev)%nz; do j=2,g(lev)%ny; do i=2,g(lev)%nx
max_error = max(max_error,abs((v(lev)%d(i+1,j,k) + v(lev)%d(i-1,j,k) +v(lev)%d(i,j+1,k) &
   & +v(lev)%d(i,j-1,k) +v(lev)%d(i,j,k-1) + v(lev)%d(i,j,k+1))/6.d0                    &
   & +d(lev)%d(i,j,k)   -v(lev)%d(i,j,k)))
end do; end do; end do
end function max_error
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
recursive subroutine MergeSort(x,a,b)
! This subroutine reorders the vector x based on the elements in its first column.
integer :: b,a,b1,a1; real*8 :: t, x(:)
include 'poisson_mg_rb_3d.header'
if (b-a>0) then
  b1=a+int((b-a)/2); a1=b1+1; call MergeSort(x,a,b1); call MergeSort(x,a1,b);
  do; if ((b1-a<0) .or. (b-a1<0)) then; exit; end if;
      if (x(a1)<x(a)) then; t=x(a1); x(a+1:a1)=x(a:a1-1); x(a)=t; a1=a1+1; b1=b1+1; end if
  a=a+1; end do;
end if
end subroutine MergeSort
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


!  eig.f90
!
!  FUNCTIONS/SUBROUTINES exported from eig.dll:
!  eig      - subroutine
!
subroutine eig ( A, E, V, N )
    implicit none
  ! Variables
  integer, intent (in) :: N

  real*8, dimension(N,N), intent (in) :: A !Input matrix
  real*8, dimension( N ), intent (out) :: E  !Eigenvalues
  real*8, dimension(N,N), intent (out) :: V  !Eigenvectors
!!!
  character*1, parameter :: JOBS = 'V' !Always calculate eigenvalues and vectors
  character*1, parameter :: UPLO = 'U' !Always store the upper triangle of A

  integer :: LDA !leading dimension of A ( = N )
  integer :: LWORK !length of array work
  integer :: INFO  !return state of the program

  real*8, allocatable, dimension(:) :: WORK

  ! Body of eig
  LDA = N           !Set LDA
  E = 0.0           !Zero the eigenvalue array (W in dsyev.f)
  LWORK = 3*N-1     !Set size of WORK array
  allocate(WORK(LWORK))
  WORK = 0.0        !Zero the work array
  INFO = 0

  !Call the eigenvalue decomposition routine
  V = A
  call DSYEV( JOBS, UPLO, N, V, LDA, E, WORK, LWORK, INFO )
  deallocate(WORK)
end subroutine eig


SUBROUTINE calc_tau(ipart,kap,xi,tau)
  !	Calculates the optical depth through a distance xi in a smoothing volume
  !	This routine is kernel dependent

  use sphdata
  use treedata, only: b

  real(kind=8) ::  m,h,xi,x,b_i,tau,kap
  real(kind=8) ::  b_norm, r_f,s
  real(kind=8) ::  rf1,rf2,b1,b2, sigma
  real,parameter  :: pi = 3.141596253d0
  real, parameter :: cnormk = 1.0/pi

  !	Calc normalised values of parameters, and s

  m = xyzmh(4,ipart)
  h = xyzmh(5,ipart)
  b_i= b(ipart)

  b_norm = b_i/h
  sigma = 0.0d0
  s = 2.0d0*DSQRT(4.0d0*h*h - b_i*b_i)

  !	Prevent calculating outside the smoothing volume
  IF(xi>s) x=s
  IF(xi<=s) x=xi

  !	Calc final limit of integral (normalise it)

  r_f = DSQRT(((s/2.0d0)-x)**2 + b_i*b_i)
  r_f = r_f/h

  !	Calc sigma (decide on which case to use for integral)

  rf1 = r_f - 0.5*r_f*r_f*r_f + (3.0d0*r_f**4)/16.0d0
  rf2 = ((2.0d0-r_f)**4)/16.0d0

  b1 = b_norm - 0.5*b_norm**3 + (3.0d0*b_norm**4)/16.0d0
  b2 = ((2.0d0-b_norm)**4)/16.0d0

  IF(x<=s/2.0d0) THEN

     IF(r_f.ge.1.0d0) THEN
        sigma = rf2
     ELSE
        sigma =0.75d0 - rf1
     ENDIF
  ELSE

     IF(b_norm.ge.1.0d0) THEN
        sigma =	2.0d0*b2 - rf2
     ELSE
        IF(r_f<=1.0d0) THEN
           sigma = 0.75d0 -2.0d0*b1 + rf1
        ELSE
           sigma = 33.0d0/16.0d0 - 2.0d0*b1 + rf2
        ENDIF
     ENDIF
  ENDIF

  !	Calc tau = m*sigma*kappa

  tau = m*sigma*kap/(h*h)*umass/(udist*udist)

  !print*, s,xi,b_norm,sigma,kap
  CALL FLUSH(iprint)
  RETURN
END subroutine calc_tau


subroutine riemann ( lmin, lmax, gamma, prgh, urgh, vrgh, plft, ulft, vlft, pmid, umid )

! Solve the Riemann shock tube problem for the left and right input states,
! using the Newton interation procedure described in van Leer (1979).
!---------------------------------------------------------------------------------
! GLOBALS
use sweepsize

IMPLICIT NONE

! LOCALS
INTEGER :: l, lmin, lmax, n
REAL(kind=8) :: gamma, gamfac1, gamfac2
REAL(kind=8), DIMENSION(maxsweep) :: plft, prgh, ulft, urgh, vlft, vrgh, wlft, wrgh, clft, crgh, zlft, zrgh
REAL(kind=8), DIMENSION(maxsweep) ::  umidl, umidr, pmid, umid, pmold, plfti, prghi

REAL(kind=8), PARAMETER :: smallp = 1.0e-25
REAL(kind=8), PARAMETER :: tol = 1.0e-5

! Input variables are:
!
!   lmin   = zone number of first physical zone
!   lmax   = zone number of first ghost zone on right (lmax=nmax+1)
!   gamma    = equation of state gamma
!   prgh   = pressure state on the right side of the boundary
!   plft   = pressure state on the left side of the boundary
!   urgh   = velocity state on the right side of the boundary
!   ulft   = velocity state on the left side of the boundary
!   vrgh   = density state on the right side of the boundary
!   vlft   = density state on the left side of the boundary
!             (vlft and vrgh are inverted to get the specific volume)
!
! Output variables are:
!
!   umid   = time averaged velocity at the zone interface
!   pmid   = time averaged pressure at the zone interface
!
!----------------------------------------------------------------------
gamfac2 = gamma + 1.0
gamfac1 = 0.5*(gamfac2)/gamma

! Obtain first guess for Pmid by assuming Wlft, Wrgh = Clft, Crgh

do l = lmin, lmax
  clft(l) = sqrt(gamma*plft(l)*vlft(l))
  crgh(l) = sqrt(gamma*prgh(l)*vrgh(l))
  vlft(l) = 1.0/vlft(l)
  vrgh(l) = 1.0/vrgh(l)
  plfti(l)= 1.0/plft(l)
  prghi(l)= 1.0/prgh(l)
  pmid(l) = prgh(l) - plft(l) - crgh(l)*(urgh(l)-ulft(l))
  pmid(l) = plft(l) + pmid(l) * clft(l)/(clft(l)+crgh(l))
  pmid(l) = max(smallp,pmid(l))
enddo

! Iterate up to 8 times using Newton's method to converge on correct Pmid
!     -use previous guess for pmid to get wavespeeds: wlft, wrgh
!     -find the slope in the u-P plane for each state: zlft, zrgh
!     -use the wavespeeds and pmid to guess umid on each side: umidl, umidr
!     -project tangents from (pmid,umidl) and (pmid,umidr) to get new pmid
!     -make sure pmid does not fall below floor value for pressure

do l = lmin, lmax
  do n = 1, 12
    pmold(l) = pmid(l)
    wlft (l) = 1.0 + gamfac1*(pmid(l) - plft(l)) * plfti(l)
    wrgh (l) = 1.0 + gamfac1*(pmid(l) - prgh(l)) * prghi(l)
    wlft (l) = clft(l) * sqrt(wlft(l))
    wrgh (l) = crgh(l) * sqrt(wrgh(l))
    zlft (l) = 4.0 * vlft(l) * wlft(l) * wlft(l)
    zrgh (l) = 4.0 * vrgh(l) * wrgh(l) * wrgh(l)
    zlft (l) = -zlft(l) * wlft(l)/(zlft(l) - gamfac2*(pmid(l) - plft(l)))
    zrgh (l) =  zrgh(l) * wrgh(l)/(zrgh(l) - gamfac2*(pmid(l) - prgh(l)))
    umidl(l) = ulft(l) - (pmid(l) - plft(l)) / wlft(l)
    umidr(l) = urgh(l) + (pmid(l) - prgh(l)) / wrgh(l)
    pmid (l) = pmid(l) + (umidr(l) - umidl(l))*(zlft(l) * zrgh(l)) / (zrgh(l) - zlft(l))
    pmid (l) = max(smallp,pmid(l))
    if (abs(pmid(l)-pmold(l))/pmid(l) < tol ) exit
  enddo
enddo

! Calculate umid by averaging umidl, umidr based on new pmid
do l = lmin, lmax
  umidl(l) = ulft(l) - (pmid(l) - plft(l)) / wlft(l)
  umidr(l) = urgh(l) + (pmid(l) - prgh(l)) / wrgh(l)
  umid (l) = 0.5*(umidl(l) + umidr(l))
enddo

return
end


      subroutine mapc2m_annulus(blockno,xc,yc,xp,yp,zp,beta,theta)
      implicit none

      integer blockno
      double precision xc,yc,xp,yp,zp, beta, theta(2)

      double precision pi,pi2
      common /compi/ pi,pi2

      double precision t1, t2, t, r

      t1 = theta(1)
      t2 = theta(2)

      t = t1 + (t2-t1)*xc
      r = beta + (1-beta)*yc
      xp = r*cos(2*pi*t)
      yp = r*sin(2*pi*t)
      zp = 0

      end


!*****************************************************************************
! FILE: omp_dotprod_mpi.f
! DESCRIPTION:
!   This simple program is the MPI version of a dot product and the third
!   of four codes used to show the progression from a serial program to a
!   hybrid MPI/OpenMP program.  The relevant codes are:
!      - omp_dotprod_serial.f  - Serial version
!      - omp_dotprod_openmp.f  - OpenMP only version
!      - omp_dotprod_mpi.f     - MPI only version
!      - omp_dotprod_hybrid.f  - Hybrid MPI and OpenMP version
! SOURCE: Blaise Barney
! LAST REVISED:  06/02/17 Blaise Barney
!******************************************************************************

      program dotprod
      include 'mpif.h'

! Define length of dot product vectors
      integer VECLEN
      parameter(VECLEN=100)

      integer i, myid, numprocs, ierr
      real*8 a(VECLEN), b(VECLEN), mysum, allsum

! MPI Initialization
      call MPI_INIT (ierr)
      call MPI_COMM_SIZE (MPI_COMM_WORLD, numprocs,ierr)
      call MPI_COMM_RANK (MPI_COMM_WORLD, myid, ierr)

! Each MPI task performs the dot product, obtains its partial sum, and then calls
! MPI_Reduce to obtain the global sum.
      if (myid .eq. 0) then
        print *, 'Starting omp_dotprod_mpi. Using',numprocs,' tasks...'
      end if

! Initialize dot product vectors
      do i=1, VECLEN
        a(i)=1.0
        b(i)=a(i)
      end do

! Perform the dot product
      mysum = 0.0
      do i=1, VECLEN
        mysum = mysum + a(i) * b(i)
      end do

      print *,'Task',myid,' partial sum =',mysum

! After the dot product, perform a summation of results on each node
      call MPI_REDUCE (mysum, allsum, 1, MPI_DOUBLE_PRECISION, MPI_SUM,
     &            0, MPI_COMM_WORLD, ierr);
      if (myid .eq. 0) then
        print *, 'Done. MPI version: global sum  =', allsum
      end if

      call MPI_FINALIZE(ierr)

      end


! Mikayla Webber
! 4670 Numerical Analysis
! Homework G Due 12.1.17

! in the orbit problem we have initial x velocity zero and initial y velocity one. experiment with changing the initial y velocity to other values. discuess your results. reading about kepler's laws may be informative. Provide some graphs of interesting orbits.

program WebberHomeworkGQuestion3
  implicit none

  integer :: neq, nsteps, i
  double precision, allocatable, dimension(:) :: yin, yout, t, f1, f2, u
  double precision, allocatable, dimension(:, :) :: archive
  double precision :: tin, tout, dt, a, b, x, y, xactual, yactual

  neq = 4
  nsteps = 10000
  allocate(yin(neq), yout(neq), t(0:nsteps), u(neq), f1(neq), f2(neq), archive(neq, 0:nsteps))

  a = 0.0d0
  b = 3.0d1

  dt = (b - a) / dble(nsteps)

  do i = 0, nsteps
	   t(i) = a + dble(i) * dt
   end do

   archive (:,0) = (/ 1.0d0, 0.0d0, 0.0d0, 1.3d0 /)

   yin = archive(:,0)

   do i = 0, (nsteps - 1)
     tin = t(i)
	   tout = t(i + 1)
	   yin = archive(:,i)
	   call computef(neq, tin, yin, f1)
     u = (yin + (tout - tin) * f1)
     call computef(neq, tout, u, f2)
     yout = yin + (tout - tin) * (f1 + f2) / 2.0d0 ! euler
	   archive(:,i+1) = yout
   end do

   print*,'Creating "out0" '
   open(unit=8,file='q3out2', status='replace')
   do i = 0, nsteps
     write(8,*) archive(1,i), archive(2,i)
   end do

   close(8)

   print*,'writing eulererror'
   open(unit=8, file='eulererror', status='replace')

   do i = 0, nsteps
	    x = archive(1,i)
	    y = archive(2,i)
	    xactual = cos(t(i))
	    yactual = sin(t(i))
	    write(8,*) i, sqrt((x - xactual) ** 2 + (y - yactual) ** 2)
    end do

    close(8)

    deallocate(yin, yout, archive, t, f1, f2)

    stop
end program WebberHomeworkGQuestion3

!----------------------------------------------------------------------

subroutine computef(neq, t, y, f)
  implicit none
  integer :: neq
  double precision :: d, f(neq)
  double precision, intent(in) :: y(neq), t
  ! This subroutine computes the RHS of the differential equation:
  !  dy
  !  -- = f(t, y)
  !  dt
  ! where y is the array of unknowns, indexed from one to neq and f is the array of right sides.

  !y(0) = 0
  d = ((y(1) ** 2.0d0 + y(2) ** 2.0d0) ** 1.5d0)

  f(1) = y(3)
  f(2) = y(4)
  f(3) = (-y(1) / d)
  f(4) = (-y(2) / d)

  return
end


! BSD 3-Clause License
!
! Copyright (c) 2021, Fabio Durastante, Lidia Aceto
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its
!    contributors may be used to endorse or promote products derived from
!    this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
program quadtest
  ! This test program checks the approximation in quadruple precision for values
  ! that do not have a closed form expression.
  ! Usage is:
  !
  !- ``./quadtest N λ μ``
  !
  ! All three parameters are optional. The first one sets the number of
  ! quadrature points, λ μ are the parameters of the Wright function.
  ! The test can be called as:
  !
  !- ``./quadtest N``
  !- ``./quadtest N λ μ``
  !- ``./quadtest λ μ``
  !- ``./quadtest``
  !
  use iso_fortran_env, only : real32, real64, real128, error_unit, output_unit
  use wrightmod
  implicit none

  ! Integer parameter, number of points
  integer, parameter :: N = 100
  ! Integer number of quadrature points
  integer :: Nq
  character(len=25) :: outfilename

  ! Values
  real(real128) :: x(N)
  real(real128), allocatable :: w(:), warb(:)
  real(real128) lambda, mu, h
  real(real128) :: t = 1.0_real128
  character(len = 500) :: commandline
  ! Auxiliary variables
  integer i, exitstat,nlineread
  ! Input of the options from file
  character(len=12), dimension(:), allocatable :: args
  integer :: num_args, ix
  num_args = command_argument_count()
  if (num_args > 0) then
    allocate(args(num_args))
    do ix = 1, num_args
      call get_command_argument(ix,args(ix))
    end do
  end if

  select case (num_args)
  case (1)
    read(args(1),'(I4)')Nq
  case (2)
    read(args(1),'(F20.16)')lambda
    read(args(2),'(F20.16)')mu
  case (3)
    read(args(1),'(I4)')Nq
    read(args(2),'(F20.16)')lambda
    read(args(3),'(F20.16)')mu
  case default
    lambda = -0.5
    mu = 0.5
  end select

  write(output_unit,'("Quadruple precision progam with λ = ",F4.2," μ = ",F4.2)') &
    & lambda, mu

  h = 10.0_real128/(real(N,real128)-1.0)
  do i=1,N
     x(i) = -5.0_real128 + real((i-1),real128)*h
  end do
  ! Write on file
  write(output_unit,'("Write evaluation points")')
  open (unit = 99, file = "quadinput.inp")
  write(99,'(i5)')N
  do i=1,N
     write(99,'(F48.40)')-abs(x(i))
  end do
  close(99)

  ! Compute the value in the Fortran routine
  write(output_unit,'("Compute Wright function")')
  if ( (num_args == 1).or.(num_args == 3)  ) then
    w = wright(x, t, lambda, mu, Nq)
  else
    w = wright(x, t, lambda, mu)
  end if
  ! Compute the value with ARB
  write(commandline,&
    & '("./wrighttest ",F20.4," ",F20.4," 1000 256 quadinput.inp")')&
    & lambda,mu
  write(output_unit,'("Executing ARB: ",A)')trim(commandline)
  call execute_command_line(commandline, exitstat=exitstat)
  if (exitstat /= 0) then
    write(error_unit,'("Error in external command")')
  end if

  ! Read ARB values from file
  write(output_unit,'("Read ARB Wright function values")')
  allocate(warb(N))
  open (unit = 99, file = "wrighttest.out")
  do i=1,N
    read(99, '(F40.39)', iostat=exitstat)warb(i)
  end do
  close(99)

  ! Write the error
  if ( (num_args == 1).or.(num_args == 3) ) then
    write(outfilename,'("quadtest-",I2,".out")')Nq
  else
    write(outfilename,'("quadtest.out")')
  end if
  write(output_unit,'("Write output: ",A)')trim(outfilename)
  open (unit = 99, file = trim(outfilename))
  do i=1,N
    write(99,'(F20.16,",",F40.39,","F50.39,",",F50.39)')&
      & x(i),w(i),warb(i),abs(w(i)-warb(i))
  end do
  close(99)

  ! Clean memory
  deallocate(w,warb)
  if (allocated(args)) then
    deallocate(args)
  end if

end program quadtest


PROGRAM meshTest

  USE KindModule, ONLY: &
    DP
  USE MeshModule, ONLY: &
    MeshX, MeshE, &
    CreateMesh, &
    DestroyMesh

  IMPLICIT NONE

  INTEGER :: &
    iDim, iNode
  INTEGER, PARAMETER :: &
    nNodes = 4, &
    nE = 20
  INTEGER, DIMENSION(3), PARAMETER :: &
    nX = [ 10, 10, 10 ]
  REAL(DP), PARAMETER :: &
    eL = 0.0d0, &
    eR = 1.0d2
  REAL(DP), DIMENSION(3), PARAMETER :: &
    xL = [ 0.0_DP, 0.0_DP, 0.0_DP ], &
    xR = [ 1.0_DP, 1.0_DP, 1.0_DP ]

  ! -- Spatial Grid:

  DO iDim = 1, 3

    CALL CreateMesh( MeshX(iDim), nX(iDim), nNodes, xL(iDim), xR(iDim) )

    WRITE(*,*)
    WRITE(*,'(A4,A7,I1,A8,ES8.2E2)') &
      '', 'Length(', iDim, ')     = ', MeshX(iDim) % Length
    WRITE(*,'(A4,A11,I1,A4,ES8.2E2,A3,ES8.2E2)') &
      '', 'MIN/MAX dx(', iDim, ') = ', &
      MINVAL( MeshX(iDim) % Width ), ' / ', MAXVAL( MeshX(iDim) % Width )
    WRITE(*,'(A4,A11,I1,A4,ES8.2E2,A3,ES8.2E2)') &
      '', 'MIN/MAX xC(', iDim, ') = ', &
      MINVAL( MeshX(iDim) % Center ), ' / ', MAXVAL( MeshX(iDim) % Center )
    WRITE(*,*)
    DO iNode = 1, nNodes
      WRITE(*,'(A6,A6,ES12.4E2,A2,A6,ES12.4E2)') &
        '', 'x_n = ', MeshX(iDim) % Nodes(iNode), &
        '', 'w_n = ', MeshX(iDim) % Weights(iNode)
    END DO

  END DO

  DO iDim = 1, 3

    CALL DestroyMesh( MeshX(iDim) )

  END DO

  ! -- Spectral Grid:

  CALL CreateMesh( MeshE, nE, nNodes, eL, eR, ZoomOption = 1.2385_DP )

  CALL DestroyMesh( MeshE )

END PROGRAM meshTest


subroutine poisson_fort_rhs(blockno, mbc,mx,my,mfields, &
                           xlower,ylower,dx,dy,rhs)
    IMPLICIT NONE

    INTEGER mbc,mx,my, mfields
    DOUBLE PRECISION xlower,ylower,dx,dy
    DOUBLE PRECISION rhs(1-mbc:mx+mbc,1-mbc:my+mbc,mfields)
    double precision q

    INTEGER i,j, m
    DOUBLE PRECISION xc,yc, poisson_qexact_rhs
    INTEGER blockno

    do i = 1-mbc,mx+mbc
        do j = 1-mbc,my+mbc
            xc = xlower + (i-0.5)*dx
            yc = ylower + (j-0.5)*dy
            q = poisson_qexact_rhs(xc,yc)
            do m = 1,mfields
                rhs(i,j,m) =  q
            end do
        end do
    end do

end subroutine poisson_fort_rhs


*********************************************************************
*provide procedure to initialize random seed
*********************************************************************

      module randomSeed

	implicit none
	private
	public :: getRandom

      contains
	subroutine initRandomSeed()
	  use iso_fortran_env, only: int64
	  integer, allocatable :: seed(:)
	  integer :: i, n, un, istat, dt(8), pid
	  integer(int64) :: t

	  call random_seed(size = n)
	  allocate(seed(n))
c	First try if the OS provides a random number generator
	  open(newunit=un, file="/dev/urandom", access="stream",
     $	       form="unformatted", action="read", status="old",
     $	       iostat=istat)
	  if (istat == 0) then
	    read(un) seed
	    close(un)
c	Fallback to XOR:ing the current time and pid. The PID is
c	useful in case one launches multiple instances of the same
c	program in parallel.
	  else
	    call system_clock(t)
	    if (t == 0) then
	      call date_and_time(values=dt)
	      t = (dt(1) - 1970) * 365_int64 * 24 * 60 * 60 * 1000
     $	          + dt(2) * 31_int64 * 24 * 60 * 60 * 1000
     $	          + dt(3) * 24_int64 * 60 * 60 * 1000
     $	          + dt(5) * 60 * 60 * 1000 + dt(6) * 60 * 1000
     $	          + dt(7) * 1000 + dt(8)
	    end if
	    pid = getpid()
	    t = ieor(t, int(pid, kind(t)))
	    do i = 1, n
	      seed(i) = lcg(t)
	    end do
	  end if

	  call random_seed(put=seed)
	end subroutine

	function lcg(s)
	  use iso_fortran_env, only: int64
	  integer :: lcg
	  integer(int64) :: s
	  if (s == 0) then
	    s = 104729
	  else
	    s = mod(s, 4294967296_int64)
	  end if
	  s = mod(s * 279470273_int64, 4294967291_int64)
	  lcg = int(mod(s, int(huge(0), int64)), kind(0))
	end function lcg

	subroutine getRandom(rVal, rPos, rLst)
	  integer, intent(inout) :: rPos
	  double precision, dimension(:), intent(inout) :: rLst(:)
	  double precision, intent(out) :: rVal
	  if(rPos .ge. size(rLst)) then
	    call initRandomSeed()
	    call random_number(rLst)
	    rPos = 1
	  else
	    rPos = rPos + 1
	  endif
	  rVal = rLst(rPos)
	end subroutine
      end module


C NCLFORTSTART
      subroutine dcancorxy (nobs,mx,my,mxy,minxy,maxxy,lrdim,x,y
     +                     ,ndf,canr,eval,wlam,chisq
     +                     ,coefxr,coefyl,rr,yx,rx,lrr,ier)
c
c NCL:   canr = cancor(x,y,opt)
c .             ndf, chisq, coefyl [1d], coefxr [1d]
c .             coefyl and coefxr converted to 2D before return
c .             returned as attributes

      implicit none
c                                            INPUT
      integer              nobs,mx,my,mxy,minxy,maxxy,lrdim,lrr,ier
      double precision     x(nobs,mx) , y(nobs,my)
c                                            OUTPUT
      integer              ndf(mx)
      double precision     canr(mx)
      double precision     eval(mx), wlam(mx), chisq(mx)
      double precision     coefxr(lrdim), coefyl(lrdim)
c rr        - symmetric storage mode correlation matrix
c yx(nobs,m)- merged data matrix which contains the x and y variables
c rx        - 2D work array
      double precision     rr(lrr)
      double precision     yx(nobs,mxy)
      double precision     rx(mxy,mxy)
C NCLEND
c
c nobs   - total number of observations
c mx     - number of x variables
c my     - number of y variables
c mxy    - total number of variables [ mxy = mx+my ]
c minxy  - min( mx,my )
c maxxy  - max( mx,my )
c lrdim  - N*maxxy  [Normally, N=2]
c          The coefxr and coefyl arrays kept going out
c          of bounds in dcanorx. Arbitrarily made these larger.
c x      - independent variables  (nobs,mx)
c y      - dependent variables    (nobs,my)
c ndf    - number of dof
c eval   - eigenvalues
c wlam   - lambda ... used for debug
c chisq  - chisq numbers
c coefxr - x [A, RIGHT] cononical vectors
c coefyl - y [B, LEFT ] cononical vectors
c ier    - error code

c local
c
      integer              m, n, lrwork, icov
      integer              ncend, ncstrt, nc,ncs
      double precision     xmsg
      logical              debug

      ier  = 0
      xmsg = 1.d20
c      lrr  = ((mxy+1)*mxy)/2
      lrwork  = mxy*mxy
      debug   = .false.

c      do m=1,minxy
      do m=1,mx
         ndf(m)   = 0
         canr(m)  = 0.0d0
         eval(m)  = 0.0d0
         wlam(m)  = 0.0d0
         chisq(m) = 0.0d0
      end do

      do m=1,lrdim
         coefyl(m) = 0.0d0
         coefxr(m) = 0.0d0
      end do

      if (ier.ne.0) return
c
c combine y and x
c

      do m=1,my
        do n=1,nobs
           yx(n,m) = y(n,m)
        end do
      end do

      do m=1,mx
        do n=1,nobs
           yx(n,my+m) = x(n,m)
        end do
      end do
c
c use correlation matrix [icov=1]
c
      icov = 1
      if (icov.eq.1) then
          call dcrmssm(yx,nobs,mxy,nobs,mxy,xmsg,rr,lrr,ier)
      else
          call dvcmssm(yx,nobs,mxy,nobs,mxy,xmsg,rr,lrr,ier)
      end if

      if (debug) then
c                  print is lower triangular cuz it is easier
c                  Visually reverse output order foe upper triangular
          ncend=0
          print *, "cancor_xy: rr:"
          do nc=1,mxy
             ncstrt = ncend+1
             ncend  = ncstrt+nc-1
             write( * ,'(2x,i5,10(1x,f12.3),/, (7x,(10(1x,f12.3))))')
     *                   nc,(rr(n),n=ncstrt,ncend)
          end do
      end if

      call dcanorx (nobs,my,mx,rr,eval,wlam,canr,chisq,ndf
     +             ,coefxr,coefyl,rx,lrdim,lrr,lrwork)

      return
      end
c ------------------------
C     ..................................................................CANO  20
C http://pdp-10.trailing-edge.com/decuslib10-02/01/43,50145/canor.ssp
C     ..................................................................CANO  20
C                                                                       CANO  30
C        SUBROUTINE CANOR                                               CANO  40
C                                                                       CANO  50
C        PURPOSE                                                        CANO  60
C           COMPUTE THE CANONICAL CORRELATIONS BETWEEN TWO SETS OF      CANO  70
C           VARIABLES.  CANOR IS NORMALLY PRECEDED BY A CALL TO SUBROU- CANO  80
C           TINE CORRE.                                                 CANO  90
C                                                                       CANO 100
C        USAGE                                                          CANO 110
C           CALL CANOR (N,MP,MQ,RR,ROOTS,WLAM,CANR,CHISQ,NDF,COEFR,     CANO 120
C                       COEFL,R)                                        CANO 130
C                                                                       CANO 140
C        DESCRIPTION OF PARAMETERS                                      CANO 150
C           N     - NUMBER OF OBSERVATIONS                              CANO 160
C           MP    - NUMBER OF LEFT HAND VARIABLES                       CANO 170
c                 ? left refers to independent variables [x]
C           MQ    - NUMBER OF RIGHT HAND VARIABLES                      CANO 180
c                 ? right refers to dependent variables  [y]
C           RR    - INPUT MATRIX (ONLY UPPER TRIANGULAR PORTION OF THE  CANO 190
C                   SYMMETRIC MATRIX OF M X M, WHERE M = MP + MQ)       CANO 200
C                   CONTAINING CORRELATION COEFFICIENTS.  (STORAGE MODE CANO 210
C                   OF 1)                                               CANO 220
C           ROOTS - OUTPUT VECTOR OF LENGTH MQ CONTAINING EIGENVALUES   CANO 230
C                   COMPUTED IN THE NROOT SUBROUTINE.                   CANO 240
C           WLAM  - OUTPUT VECTOR OF LENGTH MQ CONTAINING LAMBDA.       CANO 250
C           CANR  - OUTPUT VECTOR OF LENGTH MQ CONTAINING CANONICAL     CANO 260
C                   CORRELATIONS.                                       CANO 270
C           CHISQ - OUTPUT VECTOR OF LENGTH MQ CONTAINING THE           CANO 280
C                   VALUES OF CHI-SQUARES.                              CANO 290
C           NDF   - OUTPUT VECTOR OF LENGTH MQ CONTAINING THE DEGREES   CANO 300
C                   OF FREEDOM ASSOCIATED WITH CHI-SQUARES.             CANO 310
C           COEFR - OUTPUT MATRIX (MQ X MQ) CONTAINING MQ SETS OF       CANO 320
C                   RIGHT HAND COEFFICIENTS COLUMNWISE.                 CANO 330
C           COEFL - OUTPUT MATRIX (MP X MQ) CONTAINING MQ SETS OF       CANO 340
C                   LEFT HAND COEFFICIENTS COLUMNWISE.                  CANO 350
C           R     - WORK MATRIX (M X M)                                 CANO 360
c
c       remark-djs
c       Using the recommended sizes resulted in bounds errors.
c       lrdim is an (arbitrarily) large number [say, 2*mp*mq]
C                                                                       CANO 370
C        REMARKS                                                        CANO 380
C           THE NUMBER OF LEFT HAND VARIABLES (MP) SHOULD BE GREATER    CANO 390
C           THAN OR EQUAL TO THE NUMBER OF RIGHT HAND VARIABLES (MQ).   CANO 400
c              The above is why I *think* MP=MX  and MQ=MY
C           THE VALUES OF CANONICAL CORRELATION, LAMBDA, CHI-SQUARE,    CANO 410
C           DEGREES OF FREEDOM, AND CANONICAL COEFFICIENTS ARE COMPUTED CANO 420
C           ONLY FOR THOSE EIGENVALUES IN ROOTS WHICH ARE GREATER THAN  CANO 430
C           ZERO.                                                       CANO 440
C                                                                       CANO 450
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED                  CANO 460
C           MINV                                                        CANO 470
C           NROOT  (WHICH, IN TURN, CALLS THE SUBROUTINE EIGEN.)        CANO 480
C                                                                       CANO 490
C        METHOD                                                         CANO 500
C           REFER TO W. W. COOLEY AND P. R. LOHNES, 'MULTIVARIATE PRO-  CANO 510
C           CEDURES FOR THE BEHAVIORAL SCIENCES', JOHN WILEY AND SONS,  CANO 520
C           1962, CHAPTER 3.                                            CANO 530
C                                                                       CANO 540
c     added LCRX,LCLY,LRR,LRWORK for bounds checking
C     ..................................................................CANO 550
C                                                                       CANO 560
      SUBROUTINE DCANORX (N,MP,MQ,RR,ROOTS,WLAM,CANR,CHISQ,NDF,COEFR    CANO 570
     1                   ,COEFL,R,LRDIM,LRR,LRWORK)
      IMPLICIT NONE
      INTEGER          N, MP, MQ, NDF(MQ), LRDIM, LRR, LRWORK
      DOUBLE PRECISION RR(LRR),COEFL(LRDIM),COEFR(LRDIM),R(LRWORK)
      DOUBLE PRECISION ROOTS(MQ),WLAM(MQ),CANR(MQ),CHISQ(MQ)
C                                                                       CANO 610
C        ...............................................................CANO 620
C                                                                       CANO 630
C        IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE  CANO 640
C        C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION      CANO 650
C        STATEMENT WHICH FOLLOWS.                                       CANO 660
C                                                                       CANO 670
C     DOUBLE PRECISION RR,ROOTS,WLAM,CANR,CHISQ,COEFR,COEFL,R,DET,SUM   CANO 680
C                                                                       CANO 690
C        THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS    CANO 700
C        APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS      CANO 710
C        ROUTINE.                                                       CANO 720
C                                                                       CANO 730
C        THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO      CANO 740
C        CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  SQRT IN STATEMENT CANO 750
C        165 MUST BE CHANGED TO DSQRT.  ALOG IN STATEMENT 175 MUST BE   CANO 760
C        CHANGED TO DLOG.                                               CANO 770
C                                                                       CANO 780
C        ...............................................................CANO 790
C                                                                       CANO 800
C     PARTITION INTERCORRELATIONS AMONG LEFT HAND VARIABLES, BETWEEN    CANO 810
C     LEFT AND RIGHT HAND VARIABLES, AND AMONG RIGHT HAND VARIABLES.    CANO 820
C                                                                       CANO 830
      INTEGER          M, N1, N2, N3, I, J, K, L, JJ
      DOUBLE PRECISION FN, FMP, FMQ, SUMX, DET

      M=MP+MQ                                                           CANO 840
      N1=0                                                              CANO 850
      DO 105 I=1,M                                                      CANO 860
      DO 105 J=1,M                                                      CANO 870
      IF(I-J) 102, 103, 103                                             CANO 880
  102 L=I+(J*J-J)/2                                                     CANO 890
      GO TO 104                                                         CANO 900
  103 L=J+(I*I-I)/2                                                     CANO 910
  104 N1=N1+1                                                           CANO 920
  105 R(N1)=RR(L)                                                       CANO 930
c c c print *, "debug 105: N1=",N1," L=",L

      L=MP                                                              CANO 940
      DO 108 J=2,MP                                                     CANO 950
      N1=M*(J-1)                                                        CANO 960
      DO 108 I=1,MP                                                     CANO 970
      L=L+1                                                             CANO 980
      N1=N1+1                                                           CANO 990
  108 R(L)=R(N1)                                                        CANO1000
c c c print *, "debug 108: N1=",N1," L=",L

      N2=MP+1                                                           CANO1010
      L=0                                                               CANO1020
      DO 110 J=N2,M                                                     CANO1030
      N1=M*(J-1)                                                        CANO1040
      DO 110 I=1,MP                                                     CANO1050
      L=L+1                                                             CANO1060
      N1=N1+1                                                           CANO1070
c c c if (L.gt.lrdim .or. N1.gt.lrwork) then
c c c     print *,"debug: 110 bounds: L=",L,"  N1=",N1
c c c end if
  110 COEFL(L)=R(N1)                                                    CANO1080

c c c print *, "debug 110: COEFL: L=",L,"    <========"
      L=0                                                               CANO1090
      DO 120 J=N2,M                                                     CANO1100
      N1=M*(J-1)+MP                                                     CANO1110
      DO 120 I=N2,M                                                     CANO1120
      L=L+1                                                             CANO1130
      N1=N1+1                                                           CANO1140
c c c if (L.gt.lrdim .or. N1.gt.lrwork) then
c c c     print *,"debug: 120 bounds: L=",L,"  N1=",N1
c c c end if
  120 COEFR(L)=R(N1)                                                    CANO1150

c c c print *, "debug 120: COEFR: L=",L,"    <========"
C                                                                       CANO1160
C     SOLVE THE CANONICAL EQUATION                                      CANO1170
C                                                                       CANO1180
      L=MP*MP+1                                                         CANO1190
      K=L+MP                                                            CANO1200
c c c print *, "SOLVE THE CANONICAL EQUATION: L,K=",L,K,"    <========"
      CALL DMINVX (R,MP,DET,R(L),R(K))                                  CANO1210
C                                                                       CANO1220
C        CALCULATE T = INVERSE OF R11 * R12                             CANO1230
C                                                                       CANO1240
      DO 140 I=1,MP                                                     CANO1250
      N2=0                                                              CANO1260
      DO 130 J=1,MQ                                                     CANO1270
      N1=I-MP                                                           CANO1280
      ROOTS(J)=0.0D0                                                    CANO1290
      DO 130 K=1,MP                                                     CANO1300
      N1=N1+MP                                                          CANO1310
      N2=N2+1                                                           CANO1320
  130 ROOTS(J)=ROOTS(J)+R(N1)*COEFL(N2)                                 CANO1330
      L=I-MP                                                            CANO1340
      DO 140 J=1,MQ                                                     CANO1350
      L=L+MP                                                            CANO1360
  140 R(L)=ROOTS(J)                                                     CANO1370
C                                                                       CANO1380
C        CALCULATE A = R21 * T                                          CANO1390
C                                                                       CANO1400
      L=MP*MQ                                                           CANO1410
      N3=L+1                                                            CANO1420
      DO 160 J=1,MQ                                                     CANO1430
      N1=0                                                              CANO1440
      DO 160 I=1,MQ                                                     CANO1450
      N2=MP*(J-1)                                                       CANO1460
      SUMX=0.0D0                                                        CANO1470
      DO 150 K=1,MP                                                     CANO1480
      N1=N1+1                                                           CANO1490
      N2=N2+1                                                           CANO1500
  150 SUMX=SUMX+COEFL(N1)*R(N2)                                         CANO1510
      L=L+1                                                             CANO1520
  160 R(L)=SUMX                                                         CANO1530
C                                                                       CANO1540
C        CALCULATE EIGENVALUES WITH ASSOCIATED EIGENVECTORS OF THE      CANO1550
C        INVERSE OF R22 * A                                             CANO1560
C                                                                       CANO1570
      L=L+1                                                             CANO1580
      CALL DNROOTX (MQ,R(N3),COEFR,ROOTS,R(L))                          CANO1590
C                                                                       CANO1600
C     FOR EACH VALUE OF I = 1, 2, ..., MQ, CALCULATE THE FOLLOWING      CANO1610
C     STATISTICS                                                        CANO1620
C                                                                       CANO1630
      DO 210 I=1,MQ                                                     CANO1640
C                                                                       CANO1650
C        TEST WHETHER EIGENVALUE IS GREATER THAN ZERO                   CANO1660
C                                                                       CANO1670
      IF(ROOTS(I)) 220, 220, 165                                        CANO1680
C                                                                       CANO1690
C        CANONICAL CORRELATION                                          CANO1700
C                                                                       CANO1710
  165 CANR(I)= SQRT(ROOTS(I))                                           CANO1720
C                                                                       CANO1730
C        CHI-SQUARE                                                     CANO1740
C                                                                       CANO1750
      WLAM(I)=1.0D0                                                     CANO1760
      DO 170 J=I,MQ                                                     CANO1770
  170 WLAM(I)=WLAM(I)*(1.0D0-ROOTS(J))                                  CANO1780
      FN=N                                                              CANO1790
      FMP=MP                                                            CANO1800
      FMQ=MQ                                                            CANO1810
  175 CHISQ(I)=-(FN-0.5D0*(FMP+FMQ+1.0D0))*LOG(WLAM(I))                 CANO1820
C                                                                       CANO1830
C        DEGREES OF FREEDOM FOR CHI-SQUARE                              CANO1840
C                                                                       CANO1850
      N1=I-1                                                            CANO1860
      NDF(I)=(MP-N1)*(MQ-N1)                                            CANO1870
C                                                                       CANO1880
C        I-TH SET OF RIGHT HAND COEFFICIENTS                            CANO1890
C                                                                       CANO1900
      N1=MQ*(I-1)                                                       CANO1910
      N2=MQ*(I-1)+L-1                                                   CANO1920
      DO 180 J=1,MQ                                                     CANO1930
      N1=N1+1                                                           CANO1940
      N2=N2+1                                                           CANO1950
  180 COEFR(N1)=R(N2)                                                   CANO1960
C                                                                       CANO1970
C        I-TH SET OF LEFT HAND COEFFICIENTS                             CANO1980
C                                                                       CANO1990
      DO 200 J=1,MP                                                     CANO2000
      N1=J-MP                                                           CANO2010
      N2=MQ*(I-1)                                                       CANO2020
      K=MP*(I-1)+J                                                      CANO2030
      COEFL(K)=0.0D0                                                    CANO2040
      DO 190 JJ=1,MQ                                                    CANO2050
      N1=N1+MP                                                          CANO2060
      N2=N2+1                                                           CANO2070
  190 COEFL(K)=COEFL(K)+R(N1)*COEFR(N2)                                 CANO2080
  200 COEFL(K)=COEFL(K)/CANR(I)                                         CANO2090
  210 CONTINUE                                                          CANO2100
  220 RETURN                                                            CANO2110
      END                                                               CANO2120
C**************************************************************************
C
C     SUBROUTINE MINV
C
C     PURPOSE
C        INVERT A MATRIX
C
C     USAGE
C        CALL MINV(A,N,D,L,M)
C
C     DESCRIPTION OF PARAMETERS
C        A - INPUT MATRIX, DESTROYED IN COMPUTATION AND REPLACED BY
C             RESULTANT INVERSE.
C        N - ORDER OF MATRIX A
C        D - RESULTANT DETERMINANT
C        L - WORK VECTOR OF LENGTH N
C        M - WORK VECTOR OF LENGTH N
C
C     REMARKS
C        MATRIX AX MUST BE A GENERAL MATRIX
C
C     SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C        NONE
C
C     METHOD
C        THE STANDARD GAUSS-JORDAN METHOD IS USED. THE DETERMINANT
C        IS ALSO CALCULATED. A DETERMINANT OF ZERO INDICATES THAT
C        THE MATRIX IS SINGULAR.
C
C **********************************************************************
C
      SUBROUTINE DMINVX(A,N,D,L,M)
      IMPLICIT  NONE
      INTEGER   N
      DOUBLE PRECISION   A(*), L(*), M(*)
      DOUBLE PRECISION   BIGA, D, HOLD

      INTEGER   NK, I, J, K, IJ, IZ, KK, KI, JP, JK, JI, JQ, JR, IK, KJ
C
C **********************************************************************
C
C
C        SEARCH FOR LARGEST ELEMENT
C
      D=1.D0
      NK=-N
      DO 80 K=1,N
      NK=NK+N
      L(K)=K
      M(K)=K
      KK=NK+K
      BIGA=A(KK)
      DO 20 J=K,N
      IZ=N*(J-1)
      DO 20 I=K,N
      IJ=IZ+I
10    IF (ABS(BIGA)-ABS(A(IJ))) 15,20,20
15    BIGA=A(IJ)
      L(K)=I
      M(K)=J
20    CONTINUE
C
C        INTERCHANGE ROWS
C
      J=L(K)
      IF(J-K) 35,35,25
25    KI=K-N
      DO 30 I=1,N
      KI=KI+N
      HOLD=-A(KI)
      JI=KI-K+J
      A(KI)=A(JI)
30    A(JI)=HOLD
C
C        INTERCHANGE COLUMNS
C
35    I=M(K)
      IF(I-K) 45,45,38
38    JP=N*(I-1)
      DO 40 J=1,N
      JK=NK+J
      JI=JP+J
      HOLD=-A(JK)
      A(JK)=A(JI)
40    A(JI)=HOLD
C
C        DIVIDE COLUMN BY MINUS PIVOT (VALUE OF PIVOT ELEMENT IS
C        CONTAINED IN BIGA)
C
45    IF(BIGA) 48,46,48
46    D=0.D0
      RETURN
48    DO 55 I=1,N
      IF (I-K) 50,55,50
50    IK=NK+I
      A(IK)=A(IK)/(-BIGA)
55    CONTINUE
C
C        REDUCE MATRIX
C
      DO 65 I=1,N
      IK=NK+I
      HOLD=A(IK)
      IJ=I-N
      DO 65 J=1,N
      IJ=IJ+N
      IF(I-K) 60,65,60
60    IF(J-K) 62,65,62
62    KJ=IJ-I+K
      A(IJ)=HOLD*A(KJ)+A(IJ)
65    CONTINUE
C
C        DIVIDE ROW BY PIVOT
C
      KJ=K-N
      DO 75 J=1,N
      KJ=KJ+N
      IF(J-K) 70,75,70
70    A(KJ)=A(KJ)/BIGA
75    CONTINUE
C
C        PRODUCT OF PIVOTS
C
      D=D*BIGA
C
C        REPLACE PIVOT BY RECIPROCAL
C
      A(KK)=1.D0/BIGA
80    CONTINUE
C
C        FINAL ROW AND COLUMN INTERCHANGE
C
      K=N
100   K=(K-1)
      IF(K) 150,150,105
105   I=L(K)
      IF(I-K) 120,120,108
108   JQ=N*(K-1)
      JR=N*(I-1)
      DO 110 J=1,N
      JK=JQ+J
      HOLD=A(JK)
      JI=JR+J
      A(JK)=-A(JI)
110   A(JI)=HOLD
120   J=M(K)
      IF(J-K) 100,100,125
125   KI=K-N
      DO 130 I=1,N
      KI=KI+N
      HOLD=A(KI)
      JI=KI-K+J
      A(KI)=-A(JI)
130   A(JI)=HOLD
      GO TO 100
150   RETURN
      END
C     ..................................................................NROO  20
C                                                                       NROO  30
C        SUBROUTINE NROOT                                               NROO  40
C                   DNROOTX   [djs]
C                                                                       NROO  50
C        PURPOSE                                                        NROO  60
C           COMPUTE EIGENVALUES AND EIGENVECTORS OF A REAL NONSYMMETRIC NROO  70
C           MATRIX OF THE FORM B-INVERSE TIMES A.  THIS SUBROUTINE IS   NROO  80
C           NORMALLY CALLED BY SUBROUTINE CANOR IN PERFORMING A         NROO  90
C           CANONICAL CORRELATION ANALYSIS.                             NROO 100
C                                                                       NROO 110
C        USAGE                                                          NROO 120
C           CALL NROOT (M,A,B,XL,X)                                     NROO 130
C           CALL DNROOTX (M,A,B,XL,X)
C                                                                       NROO 140
C        DESCRIPTION OF PARAMETERS                                      NROO 150
C           M  - ORDER OF SQUARE MATRICES A, B, AND X.                  NROO 160
C           A  - INPUT MATRIX (M X M).                                  NROO 170
C           B  - INPUT MATRIX (M X M).                                  NROO 180
C           XL - OUTPUT VECTOR OF LENGTH M CONTAINING EIGENVALUES OF    NROO 190
C                B-INVERSE TIMES A.                                     NROO 200
C           X  - OUTPUT MATRIX (M X M) CONTAINING EIGENVECTORS COLUMN-  NROO 210
C                WISE.                                                  NROO 220
C                                                                       NROO 230
C        REMARKS                                                        NROO 240
C           NONE                                                        NROO 250
C                                                                       NROO 260
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED                  NROO 270
C           EIGEN                                                       NROO 280
C                                                                       NROO 290
C        METHOD                                                         NROO 300
C           REFER TO W. W. COOLEY AND P. R. LOHNES, 'MULTIVARIATE PRO-  NROO 310
C           CEDURES FOR THE BEHAVIORAL SCIENCES', JOHN WILEY AND SONS,  NROO 320
C           1962, CHAPTER 3.                                            NROO 330
C                                                                       NROO 340
C     ..................................................................NROO 350
C                                                                       NROO 360
      SUBROUTINE DNROOTX (M,A,B,XL,X)                                   NROO 370
      IMPLICIT  NONE
      INTEGER   M
      DOUBLE PRECISION XL(M)                                            NROO 380
      DOUBLE PRECISION A(*),B(*),X(*)                                   NROO 380
C                                                                       NROO 390
C        ...............................................................NROO 400
C                                                                       NROO 410
C        IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE  NROO 420
C        C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION      NROO 430
C        STATEMENT WHICH FOLLOWS.                                       NROO 440
C                                                                       NROO 450
C     DOUBLE PRECISION A,B,XL,X,SUMV                                    NROO 460
C                                                                       NROO 470
C        THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS    NROO 480
C        APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS      NROO 490
C        ROUTINE.                                                       NROO 500
C                                                                       NROO 510
C        THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO      NROO 520
C        CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  SQRT IN STATEMENTSNROO 530
C        110 AND 175 MUST BE CHANGED TO DSQRT.  ABS IN STATEMENT 110    NROO 540
C        MUST BE CHANGED TO DABS.                                       NROO 550
C                                                                       NROO 560
C        ...............................................................NROO 570
      INTEGER I, J, K, L, MV, N1, N2
      DOUBLE PRECISION SUMV
C                                                                       NROO 580
C     COMPUTE EIGENVALUES AND EIGENVECTORS OF B                         NROO 590
C                                                                       NROO 600
      K=1                                                               NROO 610
      DO 100 J=2,M                                                      NROO 620
      L=M*(J-1)                                                         NROO 630
      DO 100 I=1,J                                                      NROO 640
      L=L+1                                                             NROO 650
      K=K+1                                                             NROO 660
  100 B(K)=B(L)                                                         NROO 670
C                                                                       NROO 680
C        THE MATRIX B IS A REAL SYMMETRIC MATRIX.                       NROO 690
C                                                                       NROO 700
      MV=0                                                              NROO 710
      CALL DEIGENX (B,X,M,MV)                                           NROO 720
C                                                                       NROO 730
C     FORM RECIPROCALS OF SQUARE ROOT OF EIGENVALUES.  THE RESULTS      NROO 740
C     ARE PREMULTIPLIED BY THE ASSOCIATED EIGENVECTORS.                 NROO 750
C                                                                       NROO 760
      L=0                                                               NROO 770
      DO 110 J=1,M                                                      NROO 780
      L=L+J                                                             NROO 790
  110 XL(J)=1.0D0/SQRT( ABS(B(L)))                                      NROO 800
      K=0                                                               NROO 810
      DO 115 J=1,M                                                      NROO 820
      DO 115 I=1,M                                                      NROO 830
      K=K+1                                                             NROO 840
  115 B(K)=X(K)*XL(J)                                                   NROO 850
C                                                                       NROO 860
C     FORM (B**(-1/2))PRIME * A * (B**(-1/2))                           NROO 870
C                                                                       NROO 880
      DO 120 I=1,M                                                      NROO 890
      N2=0                                                              NROO 900
      DO 120 J=1,M                                                      NROO 910
      N1=M*(I-1)                                                        NROO 920
      L=M*(J-1)+I                                                       NROO 930
      X(L)=0.0D0                                                        NROO 940
      DO 120 K=1,M                                                      NROO 950
      N1=N1+1                                                           NROO 960
      N2=N2+1                                                           NROO 970
  120 X(L)=X(L)+B(N1)*A(N2)                                             NROO 980
      L=0                                                               NROO 990
      DO 130 J=1,M                                                      NROO1000
      DO 130 I=1,J                                                      NROO1010
      N1=I-M                                                            NROO1020
      N2=M*(J-1)                                                        NROO1030
      L=L+1                                                             NROO1040
      A(L)=0.0D0                                                        NROO1050
      DO 130 K=1,M                                                      NROO1060
      N1=N1+M                                                           NROO1070
      N2=N2+1                                                           NROO1080
  130 A(L)=A(L)+X(N1)*B(N2)                                             NROO1090
C                                                                       NROO1100
C     COMPUTE EIGENVALUES AND EIGENVECTORS OF A                         NROO1110
C                                                                       NROO1120
      CALL DEIGENX (A,X,M,MV)                                           NROO1130
      L=0                                                               NROO1140
      DO 140 I=1,M                                                      NROO1150
      L=L+I                                                             NROO1160
  140 XL(I)=A(L)                                                        NROO1170
C                                                                       NROO1180
C     COMPUTE THE NORMALIZED EIGENVECTORS                               NROO1190
C                                                                       NROO1200
      DO 150 I=1,M                                                      NROO1210
      N2=0                                                              NROO1220
      DO 150 J=1,M                                                      NROO1230
      N1=I-M                                                            NROO1240
      L=M*(J-1)+I                                                       NROO1250
      A(L)=0.0D0                                                        NROO1260
      DO 150 K=1,M                                                      NROO1270
      N1=N1+M                                                           NROO1280
      N2=N2+1                                                           NROO1290
  150 A(L)=A(L)+B(N1)*X(N2)                                             NROO1300
      L=0                                                               NROO1310
      K=0                                                               NROO1320
      DO 180 J=1,M                                                      NROO1330
      SUMV=0.0D0                                                        NROO1340
      DO 170 I=1,M                                                      NROO1350
      L=L+1                                                             NROO1360
  170 SUMV=SUMV+A(L)*A(L)                                               NROO1370
  175 SUMV= SQRT(SUMV)                                                  NROO1380
      DO 180 I=1,M                                                      NROO1390
      K=K+1                                                             NROO1400
  180 X(K)=A(K)/SUMV                                                    NROO1410
      RETURN                                                            NROO1420
      END                                                               NROO1430
C SUBROUTINE 'EIGEN' FROM THE IBM SCIENTIFIC SUBROUTINE PACKAGE.
C
C NOTE:  TO CONFORM WITH THE FORTRAN77 STANDARD, DUMMY ARRAY DIMENSIONS
C        (1) HAVE BEEN CHANGED TO (*).
C
C     ..................................................................
C
C        SUBROUTINE  EIGEN
C                   DEIGENX   [djs]
C
C        PURPOSE
C           COMPUTE EIGENVALUES AND EIGENVECTORS OF A REAL SYMMETRIC
C           MATRIX
C
C        USAGE
C           CALL EIGEN(A,R,N,MV)
C
C        DESCRIPTION OF PARAMETERS
C           A - ORIGINAL MATRIX (SYMMETRIC), DESTROYED IN COMPUTATION.
C               RESULTANT EIGENVALUES ARE DEVELOPED IN DIAGONAL OF
C               MATRIX A IN DESCENDING ORDER.
C           R - RESULTANT MATRIX OF EIGENVECTORS (STORED COLUMNWISE,
C               IN SAME SEQUENCE AS EIGENVALUES)
C           N - ORDER OF MATRICES A AND R
C           MV- INPUT CODE
C                   0   COMPUTE EIGENVALUES AND EIGENVECTORS
C                   1   COMPUTE EIGENVALUES ONLY (R NEED NOT BE
C                       DIMENSIONED BUT MUST STILL APPEAR IN CALLING
C                       SEQUENCE)
C
C        REMARKS
C           ORIGINAL MATRIX A MUST BE REAL SYMMETRIC (STORAGE MODE=1)
C           MATRIX A CANNOT BE IN THE SAME LOCATION AS MATRIX R
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           NONE
C
C        METHOD
C           DIAGONALIZATION METHOD ORIGINATED BY JACOBI AND ADAPTED
C           BY VON NEUMANN FOR LARGE COMPUTERS AS FOUND IN 'MATHEMATICAL
C           METHODS FOR DIGITAL COMPUTERS', EDITED BY A. RALSTON AND
C           H.S. WILF, JOHN WILEY AND SONS, NEW YORK, 1962, CHAPTER 7
C
C     ..................................................................
C
      SUBROUTINE DEIGENX(A,R,N,MV)
      IMPLICIT NONE
      INTEGER  N, MV
      DOUBLE PRECISION A(*),R(*)
C
C        ...............................................................
C
C        IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C        C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C        STATEMENT WHICH FOLLOWS.
C
C     DOUBLE PRECISION A,R,ANORM,ANRMX,THR,X,Y,SINX,SINX2,COSX,
C    1                 COSX2,SINCS,RANGE
C
C        THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C        APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C        ROUTINE.
C
C        THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
C        CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  SQRT IN STATEMENTS
C        40, 68, 75, AND 78 MUST BE CHANGED TO DSQRT.  ABS IN STATEMENT
C        62 MUST BE CHANGED TO DABS. THE CONSTANT IN STATEMENT 5 SHOULD
C        BE CHANGED TO 1.0D-12.
C
C        ...............................................................
      INTEGER I, J, IQ, IJ, IND, MQ, LQ, ILO, IMQ, ILR, IMR,
     +        IA, L, M, LM, LL, MM, ILQ, IM, IL, JQ, K
      DOUBLE PRECISION RANG, ANORM, ANRMX, THR, X, Y,
     +                 SINX, SINX2, COSX, COSX2, SINCS
C
C        GENERATE IDENTITY MATRIX
C
    5 RANG=1.0D-12
      IF(MV-1) 10,25,10
   10 IQ=-N
      DO 20 J=1,N
      IQ=IQ+N
      DO 20 I=1,N
      IJ=IQ+I
      R(IJ)=0.0
      IF(I-J) 20,15,20
   15 R(IJ)=1.0D0
   20 CONTINUE
C
C        COMPUTE INITIAL AND FINAL NORMS (ANORM AND ANORMX)
C
   25 ANORM=0.0D0
      DO 35 I=1,N
      DO 35 J=I,N
      IF(I-J) 30,35,30
   30 IA=I+(J*J-J)/2
      ANORM=ANORM+A(IA)*A(IA)
   35 CONTINUE
      IF(ANORM) 165,165,40
   40 ANORM=1.414D0*SQRT(ANORM)
      ANRMX=ANORM*RANG/N
C
C        INITIALIZE INDICATORS AND COMPUTE THRESHOLD, THR
C
      IND=0
      THR=ANORM
   45 THR=THR/N
   50 L=1
   55 M=L+1
C
C        COMPUTE SIN AND COS
C
   60 MQ=(M*M-M)/2
      LQ=(L*L-L)/2
      LM=L+MQ
   62 IF( ABS(A(LM))-THR) 130,65,65
   65 IND=1
      LL=L+LQ
      MM=M+MQ
      X=0.5D0*(A(LL)-A(MM))
   68 Y=-A(LM)/ SQRT(A(LM)*A(LM)+X*X)
      IF(X) 70,75,75
   70 Y=-Y
   75 SINX=Y/ SQRT(2.0D0*(1.0D0+( SQRT(1.0D0-Y*Y))))
      SINX2=SINX*SINX
   78 COSX= SQRT(1.0D0-SINX2)
      COSX2=COSX*COSX
      SINCS =SINX*COSX
C
C        ROTATE L AND M COLUMNS
C
      ILQ=N*(L-1)
      IMQ=N*(M-1)
      DO 125 I=1,N
      IQ=(I*I-I)/2
      IF(I-L) 80,115,80
   80 IF(I-M) 85,115,90
   85 IM=I+MQ
      GO TO 95
   90 IM=M+IQ
   95 IF(I-L) 100,105,105
  100 IL=I+LQ
      GO TO 110
  105 IL=L+IQ
  110 X=A(IL)*COSX-A(IM)*SINX
      A(IM)=A(IL)*SINX+A(IM)*COSX
      A(IL)=X
  115 IF(MV-1) 120,125,120
  120 ILR=ILQ+I
      IMR=IMQ+I
      X=R(ILR)*COSX-R(IMR)*SINX
      R(IMR)=R(ILR)*SINX+R(IMR)*COSX
      R(ILR)=X
  125 CONTINUE
      X=2.0D0*A(LM)*SINCS
      Y=A(LL)*COSX2+A(MM)*SINX2-X
      X=A(LL)*SINX2+A(MM)*COSX2+X
      A(LM)=(A(LL)-A(MM))*SINCS+A(LM)*(COSX2-SINX2)
      A(LL)=Y
      A(MM)=X
C
C        TESTS FOR COMPLETION
C
C        TEST FOR M = LAST COLUMN
C
  130 IF(M-N) 135,140,135
  135 M=M+1
      GO TO 60
C
C        TEST FOR L = SECOND FROM LAST COLUMN
C
  140 IF(L-(N-1)) 145,150,145
  145 L=L+1
      GO TO 55
  150 IF(IND-1) 160,155,160
  155 IND=0
      GO TO 50
C
C        COMPARE THRESHOLD WITH FINAL NORM
C
  160 IF(THR-ANRMX) 165,165,45
C
C        SORT EIGENVALUES AND EIGENVECTORS
C
  165 IQ=-N
      DO 185 I=1,N
      IQ=IQ+N
      LL=I+(I*I-I)/2
      JQ=N*(I-2)
      DO 185 J=I,N
      JQ=JQ+N
      MM=J+(J*J-J)/2
      IF(A(LL)-A(MM)) 170,185,185
  170 X=A(LL)
      A(LL)=A(MM)
      A(MM)=X
      IF(MV-1) 175,185,175
  175 DO 180 K=1,N
      ILR=IQ+K
      IMR=JQ+K
      X=R(ILR)
      R(ILR)=R(IMR)
  180 R(IMR)=X
  185 CONTINUE
      RETURN
      END