subroutine qinit(meqn,mbc,mx,xlower,dx,q,maux,aux)

    ! Set initial conditions for the q array.

    implicit none

    integer, intent(in) :: meqn,mbc,mx,maux
    real(kind=8), intent(in) :: xlower,dx
    real(kind=8), intent(in) :: aux(maux,1-mbc:mx+mbc)
    real(kind=8), intent(inout) :: q(meqn,1-mbc:mx+mbc)

    integer :: i
    real(kind=8) :: xcell, gamma1

    real(kind=8) :: gamma
    common /cparam/  gamma

    gamma1 = gamma - 1.d0

    do i=1,mx
        xcell = xlower + (i-0.5d0)*dx
        q(1,i) = 1.d0
        q(2,i) = 0.d0
        if (xcell .lt. 0.1d0) then
            q(3,i) = 1.d3/gamma1
          else if (xcell .lt. 0.9d0) then
            q(3,i) = 1.d-2/gamma1
          else
            q(3,i) = 1.d2/gamma1
          endif
    enddo

end subroutine qinit


C
C      **********************************************************************
C      ********************* SUBROUTINE RMILLS  *****************************
C      **********************************************************************
C
       SUBROUTINE RMILLS(X,FUNC,TOL)
C
C      *      ALGORITHM AS 138.1 APPL.STATST. (1979) VOL.28. NO.2           *
C      *                                                                    *
C      *         COMPUTE THE RECIPROCAL OF MILLS RATIO                      *
C
       IMPLICIT REAL*8 (A-H,O-Z), INTEGER (I-N)
       DATA FPI /1.2533141/, FPII /0.7978846/
C
       FUNC=0.0
       IF(X .LT. -10.0) RETURN
       FUNC=FPII
       Y=DABS(X)
       IF(Y .LT. 0.000001) RETURN
       SGN=1.0
       IF(X.LT.0.0) SGN=-1.0

       IF(Y.LE.2.0) THEN
          S=0.0
          A=1.0
          T=Y
          R=Y
          B=Y**2
   40     A=A+2.0
          S=T
          R=R*B/A
          T=T+R
          IF(R.GT.TOL) GOTO 40
          FUNC=1.0/(FPI*DEXP(0.5*B)-SGN*T)
          RETURN
       ENDIF

  100  A=2.0
       B1=Y
       S=Y
       A1=Y**2+1.0
       A2=Y*(A1+2.0)
       B2=A1+1.0
       T=A2/B2

  140  A=A+1.0
       A0=A1
       A1=A2
       A2=Y*A1+A*A0
       B0=B1
       B1=B2
       B2=Y*B1+A*B0
       R=S
       S=T
       T=A2/B2

       IF((T-R.GT.TOL) .OR.(T-S.GT.TOL)) GOTO 140
       FUNC=T

       IF(SGN.LT.0.0) FUNC=T/(2.0*FPI*DEXP(0.5*Y**2)*T-1.0)

       RETURN
       END


	SUBROUTINE GSMPRJ  (  proj,  angle1, angle2, angle3,
     +			     dlatll, dlonll, dlatur, dlonur,  iret )
C************************************************************************
C* GSMPRJ								*
C*									*
C* This subroutine provides a general way to specify the map projection	*
C* and bounds to be used when plotting in map coordinates.  The valid   *
C* projection names are:						*
C*									*
C*            CLASS      PROJ        PROJECTION				*
C*									*
C*      Cylindrical       CED        Cylindrical equidistant		*
C*                        MER        Mercator				*
C*                        MCD        Modified cylind. equidistant	*
C*									*
C*        Azimuthal       AED        Azimuthal equidistant		*
C*                        STR        Stereographic			*
C*                        ORT        Orthographic			*
C*                        LEA        Lambert equal area			*
C*                        GNO        Gnomonic				*
C*									*
C*          Conical       LCC        North Lambert conic conformal	*
C*                        SCC        South Lambert conic conformal	*
C*									*
C* Oblique Mercator       TVM        Transverse Mercator		*
C*                        UTM        Universal transverse Mercator	*
C*									*
C* For the UTM projection, the tangential longitude is adjusted to	*
C* a standard longitude by rounding down to ..., -9, -3, 3, 9, ...	*
C*									*
C* The angles are defined for the various map classes.			*
C*									*
C*      Cylindrical       angle1 -- latitude of origin on projection	*
C*				    cylinder (0 = Equator)		*
C*                        angle2 -- longitude of origin on projection	*
C*				    cylinder (0 = Greenwich meridian)	*
C*			  angle3 -- angle to rotate projection about a 	*
C*				    line from the Earth's center thru	*
C*				    the origin point 			*
C*									*
C*        Azimuthal       angle1 -- latitude of projection's point of	*
C*				    tangency (pole latitude)		*
C*                        angle2 -- longitude of projection's point of	*
C*				    tangency (the central longitude)	*
C*                        angle3 -- angle to rotate projection about a  *
C*				    line from the Earth's center thru	*
C*				    the point of tangency		*
C*									*
C*         Conical        angle1 -- standard latitude 1			*
C*                        angle2 -- polon (the central longitude)	*
C*                        angle3 -- standard latitude 2			*
C*									*
C*         Oblique        angle1 -- tangential longitude		*
C*                        angle2 -- not used				*
C*                        angle3 -- not used				*
C*									*
C* Azimuthal and conic projections which include the pole are defined   *
C* by specifying the lower left and upper right corners.  If DLATLL and *
C* DLATUR are equal and DLONLL and DLONUR are also equal, a map area is *
C* defined which includes the area from the pole to the given latitude  *
C* in each direction with DLONLL as the central longitude.		*
C*									*
C* GSMPRJ  ( PROJ, ANGLE1, ANGLE2, ANGLE3, DLATLL, DLONLL, 		*
C*           DLATUR, DLONUR, IRET )					*
C*									*
C* Input parameters:							*
C*	PROJ		CHAR*		Map projection name		*
C*	ANGLE1		REAL		Reference angle 1		*
C*	ANGLE2		REAL		Reference angle 2		*
C*	ANGLE3		REAL		Reference angle 3		*
C*	DLATLL		REAL		Lower left latitude		*
C*	DLONLL		REAL		Lower left longitude		*
C*	DLATUR		REAL		Upper right latitude		*
C*	DLONUR		REAL		Upper right longitude		*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* I. Graffman/RDS	 4/84	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	 6/88	Added character projection name		*
C* K. Brill/NMC		07/91	Documentation				*
C* L. Williams/EAi       3/94   Removed blank comments from header      *
C* K. Brill/EMC		 6/98	Documentation				*
C* A. Hardy/GSC		 6/98	Cleaned up prolog			*
C************************************************************************
	INCLUDE 	'FUNCCODE.PRM'
	INCLUDE 	'ERROR.PRM'
C*
	CHARACTER*(*)	proj
C*
	CHARACTER	cprj*4
	INTEGER 	isend (3)
	REAL 		rsend (7)
C------------------------------------------------------------------------
C*	Put projection name into an integer.
C
	cprj = proj
	CALL ST_STOI  ( cprj, 4, nv, iprj, ier )
C
C*	Load input parameters into buffer and write them to the mailbox.
C*
	isend (1)  = 10
	isend (2)  = FSMPRJ
	isend (3)  = iprj
	rsend (1)  = angle1
	rsend (2)  = angle2
	rsend (3)  = angle3
	rsend (4)  = dlatll
	rsend (5)  = dlonll
	rsend (6)  = dlatur
	rsend (7 ) = dlonur
C*
	CALL GPUT  ( isend, 3, iret )
	IF  ( iret .ne. NORMAL )  RETURN
	CALL GPUTR  ( rsend, 7, iret )
	IF  ( iret .ne. NORMAL )  RETURN
C*
C*	If successful write, get output parameters.
C*
        CALL GGET  ( iret, 1, ier )
	IF  ( ier .ne. NORMAL )  iret = ier
C*
	RETURN
	END


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

implicit none (type, external)

type(Ellipsoid), parameter :: spheroid = wgs84Ellipsoid

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

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

real(wp) :: ea, eb, atol_dist, atol_deg

select case (wp)
  case (real32)
    atol_dist = 1._wp !< 1 meter
    atol_deg = 0.1_wp
  case (real64)
    atol_dist = 0.001_wp !< 1 mm
    atol_deg = 0.01_wp
  case (real128)
    atol_dist = 0.001_wp !< 1 mm
    atol_deg = 1e-6_wp
  case default
    error stop "unknown precision"
end select

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

ea = spheroid%SemimajorAxis
eb = spheroid%SemiminorAxis

!! scalar degrees

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

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

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

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

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

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

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

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

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

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

!! ## array tests

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

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

!! ## Meeus tests

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

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

contains

subroutine test_vallado(t0)

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

real(wp), parameter :: azi = 180.1_wp,  eli = 80, jd0 = 2456753.833333_wp

real(wp) :: azrd,elrd,rae,dae,jd

jd = toJulian(t0)

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

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

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

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

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

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

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

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

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

subroutine test_array()

integer,parameter :: N = 3

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

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

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

end subroutine test_array

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

real(wp), parameter :: lat1 = 42.0026_wp, lon1 = -81.9978_wp, alt1 = 1.1397e3_wp

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

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

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

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

end subroutine test_geodetic_aer

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

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

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

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

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

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

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

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

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

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

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

end subroutine test_ecef2aer

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

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

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

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

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

end subroutine test_enu_ecef

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

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

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

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

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

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

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

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

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

end subroutine test_ecef2geodetic

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

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

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

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

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

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

real(wp) :: e,n,u

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

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

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

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

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

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

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

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

print *, "OK: lookatspheroid"
end subroutine test_lookatspheroid

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

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

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

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

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

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

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

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

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

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

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

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

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

end subroutine test_geodetic2ecef

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

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

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

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

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

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

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

end subroutine test_aer2ecef

end program


!
! SPDX-License-Identifier: MIT
!
module mod_correc
  !
  use mod_types     , only: rp
  !@cuf use cudafor
  !
  implicit none
  !
  private
  public  :: correc
  !
  contains
  !
  subroutine correc(nx,ny,nz,nh_d,nh_u,dxi,dyi,dzi,dzci,dt,rho0,p,up,vp,wp,rho,u,v,w)
    !
    ! corrects the velocity so that the prescribed divergence is imposed
    !
    implicit none
    !
    integer , intent(in )                                     :: nx,ny,nz
    integer , intent(in )                                     :: nh_d,nh_u
    real(rp), intent(in )                                     :: dxi,dyi,dzi
    real(rp), intent(in ), dimension(1-nh_d:)                 :: dzci
    real(rp), intent(in )                                     :: dt,rho0
    real(rp), intent(in ), dimension(0:,0:,0:)                :: p,up,vp,wp
    real(rp), intent(in ), dimension(0:,0:,0:)                :: rho
    real(rp), intent(out), dimension(1-nh_u:,1-nh_u:,1-nh_u:) :: u,v,w
    !
    real(rp) :: factori,factorj
    integer  :: i,j,k,ip,jp,kp
    real(rp) :: rhox,rhoy,rhoz
    real(rp) :: rho0i
    !@cuf attributes(managed) :: u, v, w, rho, p, up, vp, wp, dzci
    !
    rho0i = 1._rp/rho0
    !
    factori = dt*dxi
    factorj = dt*dyi
    !
#if defined(_OPENACC)
    !$acc kernels
#else
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP SHARED(n,factori,factorj,factork,u,v,w,up,vp,wp,p,rho) &
    !$OMP PRIVATE(i,j,k,ip,jp,kp,rhox,rhoy,rhoz)
#endif
    do k=1,nz
      do j=1,ny
        do i=1,nx
          !
          ip = i+1
          jp = j+1
          kp = k+1
          !
#if defined(_CONSTANT_COEFFS_POISSON)
          u(i,j,k) = up(i,j,k) - factori*(    p( ip,j,k)-p( i,j,k) )*rho0i
          v(i,j,k) = vp(i,j,k) - factorj*(    p( i,jp,k)-p( i,j,k) )*rho0i
          w(i,j,k) = wp(i,j,k) - dt*dzci(k)*( p( i,j,kp)-p( i,j,k) )*rho0i
#else
          !
          rhox = 0.5_rp*(rho(ip,j,k)+rho(i,j,k))
          rhoy = 0.5_rp*(rho(i,jp,k)+rho(i,j,k))
          rhoz = 0.5_rp*(rho(i,j,kp)+rho(i,j,k))
          !
          u(i,j,k) = up(i,j,k) - factori*(    p( ip,j,k)-p( i,j,k) )/rhox
          v(i,j,k) = vp(i,j,k) - factorj*(    p( i,jp,k)-p( i,j,k) )/rhoy
          w(i,j,k) = wp(i,j,k) - dt*dzci(k)*( p( i,j,kp)-p( i,j,k) )/rhoz
#endif
          !
        enddo
      enddo
    enddo
#if defined(_OPENACC)
    !$acc end kernels
#else
    !$OMP END PARALLEL DO
#endif
    !
    return
  end subroutine correc
  !
end module mod_correc


C-----------------------------------------------------------------------
C This is not the original program!
C
C This file was modified by Matteo Frigo to remove the assumption that
C local variables are SAVEd.  See dsp.tar.gz for the original program.
C
C-----------------------------------------------------------------------
C
C
C
C-----------------------------------------------------------------------
C MAIN PROGRAM: TEST PROGRAM TO EXERCISE THE WFTA SUBROUTINE
C   THE TEST WAVEFORM IS A COMPLEX EXPONENTIAL A**I WHOSE
C   TRANSFORM IS KNOWN ANALYTICALLY TO BE (1 - A**N)/(1 - A*W**K).
C
C AUTHORS:
C   JAMES H. MCCLELLAN     AND     HAMID NAWAB
C   DEPARTMENT OF ELECTRICAL ENGINEERING AND COMPUTER SCIENCE
C   MASSACHUSETTS INSTITUTE OF TECHNOLOGY
C   CAMBRIDGE, MASS.  02139
C
C INPUTS:
C   N-- TRANSFORM LENGTH. IT MUST BE FORMED AS THE PRODUCT OF
C       RELATIVELY PRIME INTEGERS FROM THE SET:
C           2,3,4,5,7,8,9,16
C   INVRS IS THE FLAG FOR FORWARD OR INVERSE TRANSFORM.
C           INVRS = 1 YIELDS INVERSE TRANSFORM
C           INVRS .NE. 1 GIVES FORWARD TRANSFORM
C   RAD AND PHI ARE THE MAGNITUDE AND ANGLE (AS A FRACTION OF
C       2*PI/N) OF THE COMPLEX EXPONENTIAL TEST SIGNAL.
C          SUGGESTION: RAD = 0.98, PHI = 0.5.
C-----------------------------------------------------------------------
C
      DOUBLE PRECISION PI2,PIN,XN,XJ,XT
      DIMENSION XR(5040),XI(5040)
      COMPLEX CONE,CA,CAN,CNUM,CDEN
C
C   OUTPUT WILL BE PUNCHED
C
      IOUT=I1MACH(3)
      INPUT=I1MACH(1)
      CONE=CMPLX(1.0,0.0)
      PI2=8.0D0*DATAN(1.0D0)
 50   CONTINUE
      READ(INPUT,130)N
 130  FORMAT(I5)
      WRITE(IOUT,150) N
 150  FORMAT(10H LENGTH = ,I5)
      IF(N.LE.0 .OR. N.GT.5040) STOP
C
C   ENTER A 1 TO PERFORM THE INVERSE
C
      READ(INPUT,130) INVRS
C
C   ENTER MAGNITUDE AND ANGLE (IN FRACTION OF 2*PI/N)
C   AVOID MULTIPLES OF N FOR THE ANGLE IF THE RADIUS IS
C   CLOSE TO ONE.  SUGGESTION: RAD = 0.98, PHI = 0.5.
C
      READ(INPUT,160) RAD,PHI
 160  FORMAT(2F15.10)
      XN=FLOAT(N)
      PIN=PHI
      PIN=PIN*PI2/XN
C
C   GENERATE Z**J
C
      INIT=0
      DO 200 J=1,N
      AN=RAD**(J-1)
      XJ=J-1
      XJ=XJ*PIN
      XT=DCOS(XJ)
      XR(J)=XT
      XR(J)=XR(J)*AN
      XT=DSIN(XJ)
      XI(J)=XT
      XI(J)=XI(J)*AN
 200  CONTINUE
      CAN=CMPLX(XR(N),XI(N))
      CA=CMPLX(XR(2),XI(2))
      CAN=CAN*CA
C
C   PRINT FIRST 50 VALUES OF INPUT SEQUENCE
C
      MAX=50
      IF(N.LT.50)MAX=N
      WRITE(IOUT,300)(J,XR(J),XI(J),J=1,MAX)
C
C   CALL THE WINOGRAD FOURIER TRANSFORM ALGORITHM
C
      CALL WFTA(XR,XI,N,INVRS,INIT,IERR)
C
C   CHECK FOR ERROR RETURN
C
      IF(IERR.LT.0) WRITE(IOUT,250) IERR
 250  FORMAT(1X,5HERROR,I5)
      IF(IERR.LT.0) GO TO 50
C
C   PRINT FIRST 50 VALUES OF THE TRANSFORMED SEQUENCE
C
      WRITE(IOUT,300)(J,XR(J),XI(J),J=1,MAX)
 300  FORMAT(1X,3HJ =,I3,6HREAL =,E20.12,6HIMAG =,E20.12)
C
C   CALCULATE ABSOLUTE AND RELATIVE DEVIATIONS
C
      DEVABS=0.0
      DEVREL=0.0
      DEVMX1=0.0
      DEVMX2=0.0
      CNUM=CONE-CAN
      PIN=PI2/XN
      DO 350 J=1,N
      XJ=J-1
      XJ=-XJ*PIN
      IF(INVRS.EQ.1) XJ=-XJ
      TR=DCOS(XJ)
      TI=DSIN(XJ)
      CAN=CMPLX(TR,TI)
      CDEN=CONE-CA*CAN
      CDEN=CNUM/CDEN
C
C   TRUE VALUE OF THE TRANSFORM (1. - A**N)/(1. - A*W**K),
C   WHERE A = RAD*EXP(J*PHI*(2*PI/N)), W = EXP(-J*2*PI/N).
C   FOR THE INVERSE TRANSFORM THE COMPLEX EXPONENTIAL W
C   IS CONJUGATED.
C
      TR=REAL(CDEN)
      TI=AIMAG(CDEN)
      IF(INVRS.NE.1) GO TO 330
C
C   SCALE INVERSE TRANSFORM BY 1/N
C
      TR=TR/FLOAT(N)
      TI=TI/FLOAT(N)
 330  TR=XR(J)-TR
      TI=XI(J)-TI
      DEVABS=SQRT(TR*TR+TI*TI)
      XMAG=SQRT(XR(J)*XR(J)+XI(J)*XI(J))
      DEVREL=100.0*DEVABS/XMAG
      IF(DEVABS.LE.DEVMX1)GO TO 340
      DEVMX1=DEVABS
      LABS=J-1
 340  IF(DEVREL.LE.DEVMX2)GO TO 350
      DEVMX2=DEVREL
      LREL=J-1
 350  CONTINUE
C
C   PRINT THE ABSOLUTE AND RELATIVE DEVIATIONS TOGETHER
C   WITH THEIR LOCATIONS.
C
      WRITE(IOUT,380) DEVMX1,LABS,DEVMX2,LREL
 380  FORMAT(1X,21HABSOLUTE DEVIATION = ,E20.12,9H AT INDEX,I5/
     1 1X,21HRELATIVE DEVIATION = ,F11.7,8H PERCENT,1X,9H AT INDEX,I5)
      GO TO 50
      END
C
C-----------------------------------------------------------------------
C SUBROUTINE: INISHL
C   THIS SUBROUTINE INITIALIZES THE WFTA ROUTINE FOR A GIVEN
C   VALUE OF THE TRANSFORM LENGTH N.  THE FACTORS OF N ARE
C   DETERMINED, THE MULTIPLICATION COEFFICIENTS ARE CALCULATED
C   AND STORED IN THE ARRAY COEF(.), THE INPUT AND OUTPUT
C   PERMUTATION VECTORS ARE COMPUTED AND STORED IN THE ARRAYS
C   INDX1(.) AND INDX2(.)
C
C-----------------------------------------------------------------------
C
      SUBROUTINE INISHL(N,COEF,XR,XI,INDX1,INDX2,IERR)
      DIMENSION COEF(1),XR(1),XI(1)
      INTEGER S1,S2,S3,S4,INDX1(1),INDX2(1),P1
      DIMENSION CO3(3),CO4(4),CO8(8),CO9(11),CO16(18),CDA(18),CDB(11),
     1CDC(9),CDD(6)
      COMMON NA,NB,NC,ND,ND1,ND2,ND3,ND4
C
C   DATA STATEMENTS ASSIGN SHORT DFT COEFFICIENTS.
C
      DATA CO4(1),CO4(2),CO4(3),CO4(4)/4*1.0/
C
      DATA CDA(1),CDA(2),CDA(3),CDA(4),CDA(5),CDA(6),CDA(7),
     1 CDA(8),CDA(9),CDA(10),CDA(11),CDA(12),CDA(13),CDA(14),
     2 CDA(15),CDA(16),CDA(17),CDA(18)/18*1.0/
C
      DATA CDB(1),CDB(2),CDB(3),CDB(4),CDB(5),CDB(6),CDB(7),CDB(8),
     1 CDB(9),CDB(10),CDB(11)/11*1.0/
C
      DATA IONCE/1/
C
C   GET MULTIPLIER CONSTANTS
C
      IF(IONCE.NE.1) GO TO 20
      CALL CONST(CO3,CO8,CO16,CO9,CDC,CDD)
 20   IONCE=-1
C
C   FOLLOWING SEGMENT DETERMINES FACTORS OF N AND CHOOSES
C   THE APPROPRIATE SHORT DFT COEFFICIENTS.
C
      IOUT=I1MACH(2)
      IERR=0
      ND1=1
      NA=1
      NB=1
      ND2=1
      NC=1
      ND3=1
      ND=1
      ND4=1
      IF(N.LE.0 .OR. N.GT.5040) GO TO 190
      IF(16*(N/16).EQ.N) GO TO 30
      IF(8*(N/8).EQ.N) GO TO 40
      IF(4*(N/4).EQ.N) GO TO 50
      IF(2*(N/2).NE.N) GO TO 70
      ND1=2
      NA=2
      CDA(2)=1.0
      GO TO 70
 30   ND1=18
      NA=16
      DO 31 J=1,18
 31   CDA(J)=CO16(J)
      GO TO 70
 40   ND1=8
      NA=8
      DO 41 J=1,8
 41   CDA(J)=CO8(J)
      GO TO 70
 50   ND1=4
      NA=4
      DO 51 J=1,4
 51   CDA(J)=CO4(J)
 70   IF(3*(N/3).NE.N) GO TO 120
      IF(9*(N/9).EQ.N) GO TO 100
      ND2=3
      NB=3
      DO 71 J=1,3
 71   CDB(J)=CO3(J)
      GO TO 120
 100  ND2=11
      NB=9
      DO 110 J=1,11
 110  CDB(J)=CO9(J)
 120  IF(7*(N/7).NE.N) GO TO 160
      ND3=9
      NC=7
 160  IF(5*(N/5).NE.N) GO TO 190
      ND4=6
      ND=5
 190  M=NA*NB*NC*ND
      IF(M.EQ.N) GO TO 250
      WRITE(IOUT,210)
 210  FORMAT(21H THIS N DOES NOT WORK)
      IERR=-1
      RETURN
C
C   NEXT SEGMENT GENERATES THE DFT COEFFICIENTS BY
C   MULTIPLYING TOGETHER THE SHORT DFT COEFFICIENTS
C
 250  J=1
      DO 300 N4=1,ND4
      DO 300 N3=1,ND3
      DO 300 N2=1,ND2
      DO 300 N1=1,ND1
      COEF(J)=CDA(N1)*CDB(N2)*CDC(N3)*CDD(N4)
      J=J+1
 300  CONTINUE
C
C   FOLLOWING SEGMENT FORMS THE INPUT INDEXING VECTOR
C
      J=1
      NU=NB*NC*ND
      NV=NA*NC*ND
      NW=NA*NB*ND
      NY=NA*NB*NC
      K=1
      DO 440 N4=1,ND
      DO 430 N3=1,NC
      DO 420 N2=1,NB
      DO 410 N1=1,NA
 405  IF(K.LE.N) GO TO 408
      K=K-N
      GO TO 405
 408  INDX1(J)=K
      J=J+1
 410  K=K+NU
 420  K=K+NV
 430  K=K+NW
 440  K=K+NY
C
C   FOLLOWING SEGMENT FORMS THE OUTPUT INDEXING VECTOR
C
      M=1
      S1=0
      S2=0
      S3=0
      S4=0
      IF(NA.EQ.1) GO TO 530
 520  P1=M*NU-1
      IF((P1/NA)*NA.EQ.P1) GO TO 510
      M=M+1
      GO TO 520
 510  S1=P1+1
 530  IF(NB.EQ.1) GO TO 540
      M=1
 550  P1=M*NV-1
      IF((P1/NB)*NB.EQ.P1) GO TO 560
      M=M+1
      GO TO 550
 560  S2=P1+1
 540  IF(NC.EQ.1) GO TO 630
      M=1
 620  P1=M*NW-1
      IF((P1/NC)*NC.EQ.P1) GO TO 610
      M=M+1
      GO TO 620
 610  S3=P1+1
 630  IF(ND.EQ.1) GO TO 660
      M=1
 640  P1=M*NY-1
      IF((P1/ND)*ND.EQ.P1) GO TO 650
      M=M+1
      GO TO 640
 650  S4=P1+1
 660  J=1
      DO 810 N4=1,ND
      DO 810 N3=1,NC
      DO 810 N2=1,NB
      DO 810 N1=1,NA
      INDX2(J)=S1*(N1-1)+S2*(N2-1)+S3*(N3-1)+S4*(N4-1)+1
 900  IF(INDX2(J).LE.N) GO TO 910
      INDX2(J)=INDX2(J)-N
      GO TO 900
 910  J=J+1
 810  CONTINUE
      RETURN
      END
C
C-----------------------------------------------------------------------
C SUBROUTINE: CONST
C   COMPUTES THE MULTIPLIERS FOR THE VARIOUS MODULES
C-----------------------------------------------------------------------
C
      SUBROUTINE CONST(CO3,CO8,CO16,CO9,CDC,CDD)
      DOUBLE PRECISION DTHETA,DTWOPI,DSQ32,DSQ2
      DOUBLE PRECISION DCOS1,DCOS2,DCOS3,DCOS4
      DOUBLE PRECISION DSIN1,DSIN2,DSIN3,DSIN4
      DIMENSION CO3(3),CO8(8),CO16(18),CO9(11),CDC(9),CDD(6)
      DTWOPI=8.0D0*DATAN(1.0D0)
      DSQ32=DSQRT(0.75D0)
      DSQ2=DSQRT(0.5D0)
C
C   MULTIPLIERS FOR THE THREE POINT MODULE
C
      CO3(1)=1.0
      CO3(2)=-1.5
      CO3(3)=-DSQ32
C
C   MULTIPLIERS FOR THE FIVE POINT MODULE
C
      DTHETA=DTWOPI/5.0D0
      DCOS1=DCOS(DTHETA)
      DCOS2=DCOS(2.0D0*DTHETA)
      DSIN1=DSIN(DTHETA)
      DSIN2=DSIN(2.0D0*DTHETA)
      CDD(1)=1.0
      CDD(2)=-1.25
      CDD(3)=-DSIN1-DSIN2
      CDD(4)=0.5*(DCOS1-DCOS2)
      CDD(5)=DSIN1-DSIN2
      CDD(6)=DSIN2
C
C
C   MULTIPLIERS FOR THE SEVEN POINT MODULE
C
      DTHETA=DTWOPI/7.0D0
      DCOS1=DCOS(DTHETA)
      DCOS2=DCOS(2.0D0*DTHETA)
      DCOS3=DCOS(3.0D0*DTHETA)
      DSIN1=DSIN(DTHETA)
      DSIN2=DSIN(2.0D0*DTHETA)
      DSIN3=DSIN(3.0D0*DTHETA)
      CDC(1)=1.0
      CDC(2)=-7.0D0/6.0D0
      CDC(3)=-(DSIN1+DSIN2-DSIN3)/3.0D0
      CDC(4)=(DCOS1+DCOS2-2.0D0*DCOS3)/3.0D0
      CDC(5)=(2.0D0*DCOS1-DCOS2-DCOS3)/3.0D0
      CDC(6)=-(2.0D0*DSIN1-DSIN2+DSIN3)/3.0D0
      CDC(7)=-(DSIN1+DSIN2+2.0D0*DSIN3)/3.0D0
      CDC(8)=(DCOS1-2.0D0*DCOS2+DCOS3)/3.0D0
      CDC(9)=-(DSIN1-2.0D0*DSIN2-DSIN3)/3.0D0
C
C   MULTIPLIERS FOR THE EIGHT POINT MODULE
C
      CO8(1)=1.0
      CO8(2)=1.0
      CO8(3)=1.0
      CO8(4)=-1.0
      CO8(5)=1.0
      CO8(6)=-DSQ2
      CO8(7)=-1.0
      CO8(8)=DSQ2
C
C   MULTIPLIERS FOR THE NINE POINT MODULE
C
      DTHETA=DTWOPI/9.0D0
      DCOS1=DCOS(DTHETA)
      DCOS2=DCOS(2.0D0*DTHETA)
      DCOS4=DCOS(4.0D0*DTHETA)
      DSIN1=DSIN(DTHETA)
      DSIN2=DSIN(2.0D0*DTHETA)
      DSIN4=DSIN(4.0D0*DTHETA)
      CO9(1)=1.0
      CO9(2)=-1.5
      CO9(3)=-DSQ32
      CO9(4)=0.5
      CO9(5)=(2.0D0*DCOS1-DCOS2-DCOS4)/3.0D0
      CO9(6)=(DCOS1-2.0D0*DCOS2+DCOS4)/3.0D0
      CO9(7)=(DCOS1+DCOS2-2.0D0*DCOS4)/3.0D0
      CO9(8)=-(2.0D0*DSIN1+DSIN2-DSIN4)/3.0D0
      CO9(9)=-(DSIN1+2.0D0*DSIN2+DSIN4)/3.0D0
      CO9(10)=-(DSIN1-DSIN2-2.0D0*DSIN4)/3.0D0
      CO9(11)=-DSQ32
C
C   MULTIPLIERS FOR THE SIXTEEN POINT MODULE
C
      DTHETA=DTWOPI/16.0D0
      DCOS1=DCOS(DTHETA)
      DCOS3=DCOS(3.0D0*DTHETA)
      DSIN1=DSIN(DTHETA)
      DSIN3=DSIN(3.0D0*DTHETA)
      CO16(1)=1.0
      CO16(2)=1.0
      CO16(3)=1.0
      CO16(4)=-1.0
      CO16(5)=1.0
      CO16(6)=-DSQ2
      CO16(7)=-1.0
      CO16(8)=DSQ2
      CO16(9)=1.0
      CO16(10)=-(DSIN1-DSIN3)
      CO16(11)=-DSQ2
      CO16(12)=-CO16(10)
      CO16(13)=-1.0
      CO16(14)=-(DSIN1+DSIN3)
      CO16(15)=DSQ2
      CO16(16)=-CO16(14)
      CO16(17)=-DSIN3
      CO16(18)=DCOS3
      RETURN
      END
C
C-----------------------------------------------------------------------
C SUBROUTINE: WFTA
C WINOGRAD FOURIER TRANSFORM ALGORITHM
C-----------------------------------------------------------------------
C
      SUBROUTINE WFTA(XR,XI,N,INVRS,INIT,IERR)
      DIMENSION XR(1),XI(1)
C
C INPUTS:
C   N-- TRANSFORM LENGTH.  MUST BE FORMED AS THE PRODUCT OF
C       RELATIVELY PRIME INTEGERS FROM THE SET:
C           2,3,4,5,7,8,9,16
C       THUS THE LARGEST POSSIBLE VALUE OF N IS 5040.
C   XR(.)-- ARRAY THAT HOLDS THE REAL PART OF THE DATA
C           TO BE TRANSFORMED.
C   XI(.)-- ARRAY THAT HOLDS THE IMAGINARY PART OF THE
C           DATA TO BE TRANSFORMED.
C   INVRS-- PARAMETER THAT FLAGS WHETHER OR NOT THE INVERSE
C           TRANSFORM IS TO BE CALCULATED.  A DIVISION BY N
C           IS INCLUDED IN THE INVERSE.
C           INVRS = 1 YIELDS INVERSE TRANSFORM
C           INVRS .NE. 1 GIVES FORWARD TRANSFORM
C   INIT-- PARAMETER THAT FLAGS WHETHER OR NOT THE PROGRAM
C          IS TO BE INITIALIZED FOR THIS VALUE OF N.  THE
C          INITIALIZATION IS PERFORMED ONLY ONCE IN ORDER TO
C          TO SPEED UP THE COMPUTATION ON SUCCEEDING CALLS
C          TO THE WFTA ROUTINE, WHEN N IS HELD FIXED.
C          INIT = 0 RESULTS IN INITIALIZATION.
C   IERR-- ERROR CODE THAT IS NEGATIVE WHEN THE WFTA
C          TERMINATES INCORRECTLY.
C           0 = SUCCESSFUL COMPLETION
C          -1 = THIS VALUE OF N DOES NOT FACTOR PROPERLY
C          -2 = AN INITIALIZATION HAS NOT BEEN DONE FOR
C               THIS VALUE OF N.
C
C
C   THE FOLLOWING TWO CARDS MAY BE CHANGED IF THE MAXIMUM
C   DESIRED TRANSFORM LENGTH IS LESS THAN 5040
C
C  *********************************************************************
      DIMENSION SR(10692),SI(10692),COEF(10692)
      INTEGER INDX1(5040),INDX2(5040)
      SAVE INDX1
      SAVE INDX2
C  *********************************************************************
C
      COMMON NA,NB,NC,ND,ND1,ND2,ND3,ND4
C
C   TEST FOR INITIAL RUN
C
      IF(INIT.EQ.0) CALL INISHL(N,COEF,XR,XI,INDX1,INDX2,IERR)
C
      IF(IERR.LT.0) RETURN
      M=NA*NB*NC*ND
      IF(M.EQ.N) GO TO 100
      IERR=-2
      RETURN
C
C  ERROR(-2)-- PROGRAM NOT INITIALIZED FOR THIS VALUE OF N
C
 100  NMULT=ND1*ND2*ND3*ND4
C
C   THE FOLLOWING CODE MAPS THE DATA ARRAYS XR AND XI TO
C   THE WORKING ARRAYS SR AND SI VIA THE MAPPING VECTOR
C   INDX1(.).  THE PERMUTATION OF THE DATA FOLLOWS THE
C   SINO CORRESPONDENCE OF THE CHINESE REMAINDER THEOREM.
C
      J=1
      K=1
      INC1=ND1-NA
      INC2=ND1*(ND2-NB)
      INC3=ND1*ND2*(ND3-NC)
      DO 140 N4=1,ND
      DO 130 N3=1,NC
      DO 120 N2=1,NB
      DO 110 N1=1,NA
      IND=INDX1(K)
      SR(J)=XR(IND)
      SI(J)=XI(IND)
      K=K+1
 110  J=J+1
 120  J=J+INC1
 130  J=J+INC2
 140  J=J+INC3
C
C   DO THE PRE-WEAVE MODULES
C
      CALL WEAVE1(SR,SI)
C
C   THE FOLLOWING LOOP PERFORMS ALL THE MULTIPLICATIONS OF THE
C   WINOGRAD FOURIER TRANSFORM ALGORITHM.  THE MULTIPLICATION
C   COEFFICIENTS ARE STORED ON THE INITIALIZATION PASS IN THE
C   ARRAY COEF(.).
C
      DO 200 J=1,NMULT
      SR(J)=SR(J)*COEF(J)
      SI(J)=SI(J)*COEF(J)
 200  CONTINUE
C
C   DO THE POST-WEAVE MODULES
C
      CALL WEAVE2(SR,SI)
C
C
C   THE FOLLOWING CODE MAPS THE WORKING ARRAYS SR AND SI
C   TO THE DATA ARRAYS XR AND XI VIA THE MAPPING VECTOR
C   INDX2(.).  THE PERMUTATION OF THE DATA FOLLOWS THE
C   CHINESE REMAINDER THEOREM.
C
      J=1
      K=1
      INC1=ND1-NA
      INC2=ND1*(ND2-NB)
      INC3=ND1*ND2*(ND3-NC)
C
C   CHECK FOR INVERSE
C
      IF(INVRS.EQ.1) GO TO 400
      DO 340 N4=1,ND
      DO 330 N3=1,NC
      DO 320 N2=1,NB
      DO 310 N1=1,NA
      KNDX=INDX2(K)
      XR(KNDX)=SR(J)
      XI(KNDX)=SI(J)
      K=K+1
 310  J=J+1
 320  J=J+INC1
 330  J=J+INC2
 340  J=J+INC3
      RETURN
C
C   DIFFERENT PERMUTATION FOR THE INVERSE
C
 400  FN=FLOAT(N)
      NP2=N+2
      INDX2(1)=N+1
      DO 440 N4=1,ND
      DO 430 N3=1,NC
      DO 420 N2=1,NB
      DO 410 N1=1,NA
      KNDX=NP2-INDX2(K)
      XR(KNDX)=SR(J)/FN
      XI(KNDX)=SI(J)/FN
      K=K+1
 410  J=J+1
 420  J=J+INC1
 430  J=J+INC2
 440  J=J+INC3
      RETURN
      END
C
C-----------------------------------------------------------------------
C SUBROUTINE: WEAVE1
C   THIS SUBROUTINE IMPLEMENTS THE DIFFERENT PRE-WEAVE
C   MODULES OF THE WFTA.  THE WORKING ARRAYS ARE SR AND SI.
C   THE ROUTINE CHECKS TO SEE WHICH FACTORS ARE PRESENT
C   IN THE TRANSFORM LENGTH N = NA*NB*NC*ND AND EXECUTES
C   THE PRE-WEAVE CODE FOR THESE FACTORS.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE WEAVE1(SR,SI)
      COMMON NA,NB,NC,ND,ND1,ND2,ND3,ND4
      DIMENSION Q(8),T(16)
      DIMENSION SR(1),SI(1)
      IF(NA.EQ.1) GO TO 300
      IF(NA.NE.2) GO TO 800
C
C **********************************************************************
C
C     THE FOLLOWING CODE IMPLEMENTS THE 2 POINT PRE-WEAVE MODULE
C
C **********************************************************************
C
      NLUP2=2*(ND2-NB)
      NLUP23=2*ND2*(ND3-NC)
      NBASE=1
      DO 240 N4=1,ND
      DO 230 N3=1,NC
      DO 220 N2=1,NB
      NR1=NBASE+1
      T0=SR(NBASE)+SR(NR1)
      SR(NR1)=SR(NBASE)-SR(NR1)
      SR(NBASE)=T0
      T0=SI(NBASE)+SI(NR1)
      SI(NR1)=SI(NBASE)-SI(NR1)
      SI(NBASE)=T0
 220  NBASE=NBASE+2
 230  NBASE=NBASE+NLUP2
 240  NBASE=NBASE+NLUP23
 800  IF(NA.NE.8) GO TO 1600
C
C **********************************************************************
C
C     THE FOLLOWING CODE IMPLEMENTS THE 8 POINT PRE-WEAVE MODULE
C
C **********************************************************************
C
      NLUP2=8*(ND2-NB)
      NLUP23=8*ND2*(ND3-NC)
      NBASE=1
      DO 840 N4=1,ND
      DO 830 N3=1,NC
      DO 820 N2=1,NB
      NR1=NBASE+1
      NR2=NR1+1
      NR3=NR2+1
      NR4=NR3+1
      NR5=NR4+1
      NR6=NR5+1
      NR7=NR6+1
      T3=SR(NR3)+SR(NR7)
      T7=SR(NR3)-SR(NR7)
      T0=SR(NBASE)+SR(NR4)
      SR(NR4)=SR(NBASE)-SR(NR4)
      T1=SR(NR1)+SR(NR5)
      T5=SR(NR1)-SR(NR5)
      T2=SR(NR2)+SR(NR6)
      SR(NR6)=SR(NR2)-SR(NR6)
      SR(NBASE)=T0+T2
      SR(NR2)=T0-T2
      SR(NR1)=T1+T3
      SR(NR3)=T1-T3
      SR(NR5)=T5+T7
      SR(NR7)=T5-T7
      T3=SI(NR3)+SI(NR7)
      T7=SI(NR3)-SI(NR7)
      T0=SI(NBASE)+SI(NR4)
      SI(NR4)=SI(NBASE)-SI(NR4)
      T1=SI(NR1)+SI(NR5)
      T5=SI(NR1)-SI(NR5)
      T2=SI(NR2)+SI(NR6)
      SI(NR6)=SI(NR2)-SI(NR6)
      SI(NBASE)=T0+T2
      SI(NR2)=T0-T2
      SI(NR1)=T1+T3
      SI(NR3)=T1-T3
      SI(NR5)=T5+T7
      SI(NR7)=T5-T7
 820  NBASE=NBASE+8
 830  NBASE=NBASE+NLUP2
 840  NBASE=NBASE+NLUP23
 1600 IF(NA.NE.16) GO TO 300
C
C **********************************************************************
C
C     THE FOLLOWING CODE IMPLEMENTS THE 16 POINT PRE-WEAVE MODULE
C
C **********************************************************************
C
      NLUP2=18*(ND2-NB)
      NLUP23=18*ND2*(ND3-NC)
      NBASE=1
      DO 1640 N4=1,ND
      DO 1630 N3=1,NC
      DO 1620 N2=1,NB
      NR1=NBASE+1
      NR2=NR1+1
      NR3=NR2+1
      NR4=NR3+1
      NR5=NR4+1
      NR6=NR5+1
      NR7=NR6+1
      NR8=NR7+1
      NR9=NR8+1
      NR10=NR9+1
      NR11=NR10+1
      NR12=NR11+1
      NR13=NR12+1
      NR14=NR13+1
      NR15=NR14+1
      NR16=NR15+1
      NR17=NR16+1
      JBASE=NBASE
      DO 1645 J=1,8
      T(J)=SR(JBASE)+SR(JBASE+8)
      T(J+8)=SR(JBASE)-SR(JBASE+8)
      JBASE=JBASE+1
 1645 CONTINUE
      DO 1650 J=1,4
      Q(J)=T(J)+T(J+4)
      Q(J+4)=T(J)-T(J+4)
 1650 CONTINUE
      SR(NBASE)=Q(1)+Q(3)
      SR(NR2)=Q(1)-Q(3)
      SR(NR1)=Q(2)+Q(4)
      SR(NR3)=Q(2)-Q(4)
      SR(NR5)=Q(6)+Q(8)
      SR(NR7)=Q(6)-Q(8)
      SR(NR4)=Q(5)
      SR(NR6)=Q(7)
      SR(NR8)=T(9)
      SR(NR9)=T(10)+T(16)
      SR(NR15)=T(10)-T(16)
      SR(NR13)=T(14)+T(12)
      SR(NR11)=T(14)-T(12)
      SR(NR17)=SR(NR11)+SR(NR15)
      SR(NR16)=SR(NR9)+SR(NR13)
      SR(NR10)=T(11)+T(15)
      SR(NR14)=T(11)-T(15)
      SR(NR12)=T(13)
      JBASE=NBASE
      DO 1745 J=1,8
      T(J)=SI(JBASE)+SI(JBASE+8)
      T(J+8)=SI(JBASE)-SI(JBASE+8)
      JBASE=JBASE+1
 1745 CONTINUE
      DO 1750 J=1,4
      Q(J)=T(J)+T(J+4)
      Q(J+4)=T(J)-T(J+4)
 1750 CONTINUE
      SI(NBASE)=Q(1)+Q(3)
      SI(NR2)=Q(1)-Q(3)
      SI(NR1)=Q(2)+Q(4)
      SI(NR3)=Q(2)-Q(4)
      SI(NR5)=Q(6)+Q(8)
      SI(NR7)=Q(6)-Q(8)
      SI(NR4)=Q(5)
      SI(NR6)=Q(7)
      SI(NR8)=T(9)
      SI(NR9)=T(10)+T(16)
      SI(NR15)=T(10)-T(16)
      SI(NR13)=T(14)+T(12)
      SI(NR11)=T(14)-T(12)
      SI(NR17)=SI(NR11)+SI(NR15)
      SI(NR16)=SI(NR9)+SI(NR13)
      SI(NR10)=T(11)+T(15)
      SI(NR14)=T(11)-T(15)
      SI(NR12)=T(13)
 1620 NBASE=NBASE+18
 1630 NBASE=NBASE+NLUP2
 1640 NBASE=NBASE+NLUP23
 300  IF(NB.EQ.1) GO TO 700
      IF(NB.NE.3) GO TO 900
C
C **********************************************************************
C
C     THE FOLLOWING CODE IMPLEMENTS THE 3 POINT PRE-WEAVE MODULE
C
C **********************************************************************
C
      NLUP2=2*ND1
      NLUP23=3*ND1*(ND3-NC)
      NBASE=1
      NOFF=ND1
      DO 340 N4=1,ND
      DO 330 N3=1,NC
      DO 310 N2=1,ND1
      NR1=NBASE+NOFF
      NR2=NR1+NOFF
      T1=SR(NR1)+SR(NR2)
      SR(NBASE)=SR(NBASE)+T1
      SR(NR2)=SR(NR1)-SR(NR2)
      SR(NR1)=T1
      T1=SI(NR1)+SI(NR2)
      SI(NBASE)=SI(NBASE)+T1
      SI(NR2)=SI(NR1)-SI(NR2)
      SI(NR1)=T1
 310  NBASE=NBASE+1
 330  NBASE=NBASE+NLUP2
 340  NBASE=NBASE+NLUP23
 900  IF(NB.NE.9) GO TO 700
C
C **********************************************************************
C
C     THE FOLLOWING CODE IMPLEMENTS THE 9 POINT PRE-WEAVE MODULE
C
C **********************************************************************
C
      NLUP2=10*ND1
      NLUP23=11*ND1*(ND3-NC)
      NBASE=1
      NOFF=ND1
      DO 940 N4=1,ND
      DO 930 N3=1,NC
      DO 910 N2=1,ND1
      NR1=NBASE+NOFF
      NR2=NR1+NOFF
      NR3=NR2+NOFF
      NR4=NR3+NOFF
      NR5=NR4+NOFF
      NR6=NR5+NOFF
      NR7=NR6+NOFF
      NR8=NR7+NOFF
      NR9=NR8+NOFF
      NR10=NR9+NOFF
      T3=SR(NR3)+SR(NR6)
      T6=SR(NR3)-SR(NR6)
      SR(NBASE)=SR(NBASE)+T3
      T7=SR(NR7)+SR(NR2)
      T2=SR(NR7)-SR(NR2)
      SR(NR2)=T6
      T1=SR(NR1)+SR(NR8)
      T8=SR(NR1)-SR(NR8)
      SR(NR1)=T3
      T4=SR(NR4)+SR(NR5)
      T5=SR(NR4)-SR(NR5)
      SR(NR3)=T1+T4+T7
      SR(NR4)=T1-T7
      SR(NR5)=T4-T1
      SR(NR6)=T7-T4
      SR(NR10)=T2+T5+T8
      SR(NR7)=T8-T2
      SR(NR8)=T5-T8
      SR(NR9)=T2-T5
      T3=SI(NR3)+SI(NR6)
      T6=SI(NR3)-SI(NR6)
      SI(NBASE)=SI(NBASE)+T3
      T7=SI(NR7)+SI(NR2)
      T2=SI(NR7)-SI(NR2)
      SI(NR2)=T6
      T1=SI(NR1)+SI(NR8)
      T8=SI(NR1)-SI(NR8)
      SI(NR1)=T3
      T4=SI(NR4)+SI(NR5)
      T5=SI(NR4)-SI(NR5)
      SI(NR3)=T1+T4+T7
      SI(NR4)=T1-T7
      SI(NR5)=T4-T1
      SI(NR6)=T7-T4
      SI(NR10)=T2+T5+T8
      SI(NR7)=T8-T2
      SI(NR8)=T5-T8
      SI(NR9)=T2-T5
 910  NBASE=NBASE+1
 930  NBASE=NBASE+NLUP2
 940  NBASE=NBASE+NLUP23
 700  IF(NC.NE.7) GO TO 500
C
C **********************************************************************
C
C     THE FOLLOWING CODE IMPLEMENTS THE 7 POINT PRE-WEAVE MODULE
C
C **********************************************************************
C
      NOFF=ND1*ND2
      NBASE=1
      NLUP2=8*NOFF
      DO 740 N4=1,ND
      DO 710 N1=1,NOFF
      NR1=NBASE+NOFF
      NR2=NR1+NOFF
      NR3=NR2+NOFF
      NR4=NR3+NOFF
      NR5=NR4+NOFF
      NR6=NR5+NOFF
      NR7=NR6+NOFF
      NR8=NR7+NOFF
      T1=SR(NR1)+SR(NR6)
      T6=SR(NR1)-SR(NR6)
      T4=SR(NR4)+SR(NR3)
      T3=SR(NR4)-SR(NR3)
      T2=SR(NR2)+SR(NR5)
      T5=SR(NR2)-SR(NR5)
      SR(NR5)=T6-T3
      SR(NR2)=T5+T3+T6
      SR(NR6)=T5-T6
      SR(NR8)=T3-T5
      SR(NR3)=T2-T1
      SR(NR4)=T1-T4
      SR(NR7)=T4-T2
      T1=T1+T4+T2
      SR(NBASE)=SR(NBASE)+T1
      SR(NR1)=T1
      T1=SI(NR1)+SI(NR6)
      T6=SI(NR1)-SI(NR6)
      T4=SI(NR4)+SI(NR3)
      T3=SI(NR4)-SI(NR3)
      T2=SI(NR2)+SI(NR5)
      T5=SI(NR2)-SI(NR5)
      SI(NR5)=T6-T3
      SI(NR2)=T5+T3+T6
      SI(NR6)=T5-T6
      SI(NR8)=T3-T5
      SI(NR3)=T2-T1
      SI(NR4)=T1-T4
      SI(NR7)=T4-T2
      T1=T1+T4+T2
      SI(NBASE)=SI(NBASE)+T1
      SI(NR1)=T1
 710  NBASE=NBASE+1
 740  NBASE=NBASE+NLUP2
 500  IF(ND.NE.5) RETURN
C
C **********************************************************************
C
C     THE FOLLOWING CODE IMPLEMENTS THE 5 POINT PRE-WEAVE MODULE
C
C **********************************************************************
C
      NOFF=ND1*ND2*ND3
      NBASE=1
      DO 510 N1=1,NOFF
      NR1=NBASE+NOFF
      NR2=NR1+NOFF
      NR3=NR2+NOFF
      NR4=NR3+NOFF
      NR5=NR4+NOFF
      T4=SR(NR1)-SR(NR4)
      T1=SR(NR1)+SR(NR4)
      T3=SR(NR3)+SR(NR2)
      T2=SR(NR3)-SR(NR2)
      SR(NR3)=T1-T3
      SR(NR1)=T1+T3
      SR(NBASE)=SR(NBASE)+SR(NR1)
      SR(NR5)=T2+T4
      SR(NR2)=T4
      SR(NR4)=T2
      T4=SI(NR1)-SI(NR4)
      T1=SI(NR1)+SI(NR4)
      T3=SI(NR3)+SI(NR2)
      T2=SI(NR3)-SI(NR2)
      SI(NR3)=T1-T3
      SI(NR1)=T1+T3
      SI(NBASE)=SI(NBASE)+SI(NR1)
      SI(NR5)=T2+T4
      SI(NR2)=T4
      SI(NR4)=T2
 510  NBASE=NBASE+1
      RETURN
      END
C
C-----------------------------------------------------------------------
C
C SUBROUTINE: WEAVE2
C   THIS SUBROUTINE IMPLEMENTS THE POST-WEAVE MODULES
C   OF THE WFTA.  THE WORKING ARRAYS ARE SR AND SI.
C   THE ROUTINE CHECKS TO SEE WHICH FACTORS ARE PRESENT
C   IN THE TRANSFORM LENGTH N = NA*NB*NC*ND AND EXECUTES
C   THE POST-WEAVE CODE FOR THESE FACTORS.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE WEAVE2(SR,SI)
      COMMON NA,NB,NC,ND,ND1,ND2,ND3,ND4
      DIMENSION SR(1),SI(1)
      DIMENSION Q(8),T(16)
      IF(ND.NE.5) GO TO 700
C
C **********************************************************************
C
C     THE FOLLOWING CODE IMPLEMENTS THE 5 POINT POST-WEAVE MODULE
C
C **********************************************************************
C
      NOFF=ND1*ND2*ND3
      NBASE=1
      DO 510 N1=1,NOFF
      NR1=NBASE+NOFF
      NR2=NR1+NOFF
      NR3=NR2+NOFF
      NR4=NR3+NOFF
      NR5=NR4+NOFF
      T1=SR(NBASE)+SR(NR1)
      T3=T1-SR(NR3)
      T1=T1+SR(NR3)
      T4=SI(NR2)+SI(NR5)
      T2=SI(NR4)+SI(NR5)
      SR(NR1)=T1-T4
      SR4=T1+T4
      SR2=T3+T2
      SR(NR3)=T3-T2
      T1=SI(NBASE)+SI(NR1)
      T3=T1-SI(NR3)
      T1=T1+SI(NR3)
      T4=SR(NR2)+SR(NR5)
      T2=SR(NR4)+SR(NR5)
      SI(NR1)=T1+T4
      SI(NR4)=T1-T4
      SI(NR2)=T3-T2
      SI(NR3)=T3+T2
      SR(NR2)=SR2
      SR(NR4)=SR4
 510  NBASE=NBASE+1
 700  IF(NC.NE.7) GO TO 300
C
C **********************************************************************
C
C     THE FOLLOWING CODE IMPLEMENTS THE 7 POINT POST-WEAVE MODULE
C
C **********************************************************************
C
      NOFF=ND1*ND2
      NBASE=1
      NLUP2=8*NOFF
      DO 740 N4=1,ND
      DO 710 N1=1,NOFF
      NR1=NBASE+NOFF
      NR2=NR1+NOFF
      NR3=NR2+NOFF
      NR4=NR3+NOFF
      NR5=NR4+NOFF
      NR6=NR5+NOFF
      NR7=NR6+NOFF
      NR8=NR7+NOFF
      T1=SR(NR1)+SR(NBASE)
      T2=T1-SR(NR3)-SR(NR4)
      T4=T1+SR(NR3)-SR(NR7)
      T1=T1+SR(NR4)+SR(NR7)
      T6=SI(NR2)+SI(NR5)+SI(NR8)
      T5=SI(NR2)-SI(NR5)-SI(NR6)
      T3=SI(NR2)+SI(NR6)-SI(NR8)
      SR(NR1)=T1-T6
      SR6=T1+T6
      SR2=T2-T5
      SR5=T2+T5
      SR(NR4)=T4-T3
      SR(NR3)=T4+T3
      T1=SI(NR1)+SI(NBASE)
      T2=T1-SI(NR3)-SI(NR4)
      T4=T1+SI(NR3)-SI(NR7)
      T1=T1+SI(NR4)+SI(NR7)
      T6=SR(NR2)+SR(NR5)+SR(NR8)
      T5=SR(NR2)-SR(NR5)-SR(NR6)
      T3=SR(NR2)+SR(NR6)-SR(NR8)
      SI(NR1)=T1+T6
      SI(NR6)=T1-T6
      SI(NR2)=T2+T5
      SI(NR5)=T2-T5
      SI(NR4)=T4+T3
      SI(NR3)=T4-T3
      SR(NR2)=SR2
      SR(NR5)=SR5
      SR(NR6)=SR6
 710  NBASE=NBASE+1
 740  NBASE=NBASE+NLUP2
 300  IF(NB.EQ.1) GO TO 400
      IF(NB.NE.3) GO TO 900
C
C **********************************************************************
C
C     THE FOLLOWING CODE IMPLEMENTS THE 3 POINT POST-WEAVE MODULE
C
C **********************************************************************
C
      NLUP2=2*ND1
      NLUP23=3*ND1*(ND3-NC)
      NBASE=1
      NOFF=ND1
      DO 340 N5=1,ND
      DO 330 N4=1,NC
      DO 310 N2=1,ND1
      NR1=NBASE+NOFF
      NR2=NR1+NOFF
      T1=SR(NBASE)+SR(NR1)
      SR(NR1)=T1-SI(NR2)
      SR2=T1+SI(NR2)
      T1=SI(NBASE)+SI(NR1)
      SI(NR1)=T1+SR(NR2)
      SI(NR2)=T1-SR(NR2)
      SR(NR2)=SR2
 310  NBASE=NBASE+1
 330  NBASE=NBASE+NLUP2
 340  NBASE=NBASE+NLUP23
 900  IF(NB.NE.9) GO TO 400
C
C **********************************************************************
C
C     THE FOLLOWING CODE IMPLEMENTS THE 9 POINT POST-WEAVE MODULE
C
C **********************************************************************
C
      NLUP2=10*ND1
      NLUP23=11*ND1*(ND3-NC)
      NBASE=1
      NOFF=ND1
      DO 940 N4=1,ND
      DO 930 N3=1,NC
      DO 910 N2=1,ND1
      NR1=NBASE+NOFF
      NR2=NR1+NOFF
      NR3=NR2+NOFF
      NR4=NR3+NOFF
      NR5=NR4+NOFF
      NR6=NR5+NOFF
      NR7=NR6+NOFF
      NR8=NR7+NOFF
      NR9=NR8+NOFF
      NR10=NR9+NOFF
      T3=SR(NBASE)-SR(NR3)
      T7=SR(NBASE)+SR(NR1)
      SR(NBASE)=SR(NBASE)+SR(NR3)+SR(NR3)
      T6=T3+SI(NR10)
      SR(NR3)=T3-SI(NR10)
      T4=T7+SR(NR5)-SR(NR6)
      T1=T7-SR(NR4)-SR(NR5)
      T7=T7+SR(NR4)+SR(NR6)
      SR(NR6)=T6
      T8=SI(NR2)-SI(NR7)-SI(NR8)
      T5=SI(NR2)+SI(NR8)-SI(NR9)
      T2=SI(NR2)+SI(NR7)+SI(NR9)
      SR(NR1)=T7-T2
      SR8=T7+T2
      SR(NR4)=T1-T8
      SR(NR5)=T1+T8
      SR7=T4-T5
      SR2=T4+T5
      T3=SI(NBASE)-SI(NR3)
      T7=SI(NBASE)+SI(NR1)
      SI(NBASE)=SI(NBASE)+SI(NR3)+SI(NR3)
      T6=T3-SR(NR10)
      SI(NR3)=T3+SR(NR10)
      T4=T7+SI(NR5)-SI(NR6)
      T1=T7-SI(NR4)-SI(NR5)
      T7=T7+SI(NR4)+SI(NR6)
      SI(NR6)=T6
      T8=SR(NR2)-SR(NR7)-SR(NR8)
      T5=SR(NR2)+SR(NR8)-SR(NR9)
      T2=SR(NR2)+SR(NR7)+SR(NR9)
      SI(NR1)=T7+T2
      SI(NR8)=T7-T2
      SI(NR4)=T1+T8
      SI(NR5)=T1-T8
      SI(NR7)=T4+T5
      SI(NR2)=T4-T5
      SR(NR2)=SR2
      SR(NR7)=SR7
      SR(NR8)=SR8
 910  NBASE=NBASE+1
 930  NBASE=NBASE+NLUP2
 940  NBASE=NBASE+NLUP23
 400  IF(NA.EQ.1) RETURN
      IF(NA.NE.4) GO TO 800
C
C **********************************************************************
C
C     THE FOLLOWING CODE IMPLEMENTS THE 4 POINT POST-WEAVE MODULE
C
C **********************************************************************
C
      NLUP2=4*(ND2-NB)
      NLUP23=4*ND2*(ND3-NC)
      NBASE=1
      DO 440 N4=1,ND
      DO 430 N3=1,NC
      DO 420 N2=1,NB
      NR1=NBASE+1
      NR2=NR1+1
      NR3=NR2+1
      TR0=SR(NBASE)+SR(NR2)
      TR2=SR(NBASE)-SR(NR2)
      TR1=SR(NR1)+SR(NR3)
      TR3=SR(NR1)-SR(NR3)
      TI1=SI(NR1)+SI(NR3)
      TI3=SI(NR1)-SI(NR3)
      SR(NBASE)=TR0+TR1
      SR(NR2)=TR0-TR1
      SR(NR1)=TR2+TI3
      SR(NR3)=TR2-TI3
      TI0=SI(NBASE)+SI(NR2)
      TI2=SI(NBASE)-SI(NR2)
      SI(NBASE)=TI0+TI1
      SI(NR2)=TI0-TI1
      SI(NR1)=TI2-TR3
      SI(NR3)=TI2+TR3
 420  NBASE=NBASE+4
 430  NBASE=NBASE+NLUP2
 440  NBASE=NBASE+NLUP23
 800  IF(NA.NE.8) GO TO 1600
C
C **********************************************************************
C
C     THE FOLLOWING CODE IMPLEMENTS THE 8 POINT POST-WEAVE MODULE
C
C **********************************************************************
C
      NLUP2=8*(ND2-NB)
      NLUP23=8*ND2*(ND3-NC)
      NBASE=1
      DO 840 N4=1,ND
      DO 830 N3=1,NC
      DO 820 N2=1,NB
      NR1=NBASE+1
      NR2=NR1+1
      NR3=NR2+1
      NR4=NR3+1
      NR5=NR4+1
      NR6=NR5+1
      NR7=NR6+1
      T1=SR(NBASE)-SR(NR1)
      SR(NBASE)=SR(NBASE)+SR(NR1)
      SR6=SR(NR2)+SI(NR3)
      SR(NR2)=SR(NR2)-SI(NR3)
      T4=SR(NR4)-SI(NR5)
      T5=SR(NR4)+SI(NR5)
      T6=SR(NR7)-SI(NR6)
      T7=SR(NR7)+SI(NR6)
      SR(NR4)=T1
      SR(NR1)=T4+T6
      SR3=T4-T6
      SR5=T5-T7
      SR(NR7)=T5+T7
      T1=SI(NBASE)-SI(NR1)
      SI(NBASE)=SI(NBASE)+SI(NR1)
      T3=SI(NR2)-SR(NR3)
      SI(NR2)=SI(NR2)+SR(NR3)
      T4=SI(NR4)+SR(NR5)
      T5=SI(NR4)-SR(NR5)
      SI(NR6)=T3
      T6=SR(NR6)+SI(NR7)
      T7=SR(NR6)-SI(NR7)
      SI(NR4)=T1
      SI(NR1)=T4+T6
      SI(NR3)=T4-T6
      SI(NR5)=T5+T7
      SI(NR7)=T5-T7
      SR(NR3)=SR3
      SR(NR5)=SR5
      SR(NR6)=SR6
 820  NBASE=NBASE+8
 830  NBASE=NBASE+NLUP2
 840  NBASE=NBASE+NLUP23
 1600 IF(NA.NE.16) RETURN
C
C **********************************************************************
C
C     THE FOLLOWING CODE IMPLEMENTS THE 16 POINT POST-WEAVE MODULE
C
C **********************************************************************
C
      NLUP2=18*(ND2-NB)
      NLUP23=18*ND2*(ND3-NC)
      NBASE=1
      DO 1640 N4=1,ND
      DO 1630 N3=1,NC
      DO 1620 N2=1,NB
      NR1=NBASE+1
      NR2=NR1+1
      NR3=NR2+1
      NR4=NR3+1
      NR5=NR4+1
      NR6=NR5+1
      NR7=NR6+1
      NR8=NR7+1
      NR9=NR8+1
      NR10=NR9+1
      NR11=NR10+1
      NR12=NR11+1
      NR13=NR12+1
      NR14=NR13+1
      NR15=NR14+1
      NR16=NR15+1
      NR17=NR16+1
      T(2)=SR(NBASE)-SR(NR1)
      SR(NBASE)=SR(NR1)+SR(NBASE)
      T(4)=SR(NR2)+SI(NR3)
      T(3)=SR(NR2)-SI(NR3)
      T(6)=SR(NR4)+SI(NR5)
      T(5)=SR(NR4)-SI(NR5)
      T(8)=-SI(NR6)-SR(NR7)
      T(7)=-SI(NR6)+SR(NR7)
      T(9)=SR(NR8)+SR(NR14)
      T(15)=SR(NR8)-SR(NR14)
      T(13)=-SI(NR10)-SI(NR12)
      T(11)=SI(NR10)-SI(NR12)
      T(16)=SR(NR15)-SR(NR17)
      T(12)=SR(NR11)-SR(NR17)
      T(10)=-SI(NR9)-SI(NR16)
      T(14)=-SI(NR16)+SI(NR13)
      SR(NR2)=T(5)+T(7)
      SR6=T(5)-T(7)
      SR10=T(6)+T(8)
      SR(NR14)=T(6)-T(8)
      Q(7)=T(9)+T(10)
      Q(8)=T(9)-T(10)
      Q(1)=T(11)+T(12)
      Q(2)=T(11)-T(12)
      Q(4)=T(14)+T(15)
      Q(5)=T(15)-T(14)
      Q(3)=T(13)+T(16)
      Q(6)=T(13)-T(16)
      SR(NR1)=Q(3)+Q(7)
      SR(NR7)=Q(7)-Q(3)
      SR9=Q(6)+Q(8)
      SR(NR15)=Q(8)-Q(6)
      SR5=Q(1)+Q(4)
      SR3=Q(4)-Q(1)
      SR13=Q(2)+Q(5)
      SR11=Q(5)-Q(2)
      SR(NR8)=T(2)
      SR(NR4)=T(3)
      SR12=T(4)
      T(2)=SI(NBASE)-SI(NR1)
      SI(NBASE)=SI(NR1)+SI(NBASE)
      T(4)=SI(NR2)-SR(NR3)
      T(3)=SI(NR2)+SR(NR3)
      T(6)=SI(NR4)-SR(NR5)
      T(5)=SI(NR4)+SR(NR5)
      T(8)=SR(NR6)-SI(NR7)
      T(7)=SR(NR6)+SI(NR7)
      T(9)=SI(NR8)+SI(NR14)
      T(15)=SI(NR8)-SI(NR14)
      T(13)=SR(NR10)+SR(NR12)
      T(11)=SR(NR12)-SR(NR10)
      T(16)=SI(NR15)-SI(NR17)
      T(12)=SI(NR11)-SI(NR17)
      T(10)=SR(NR9)+SR(NR16)
      T(14)=SR(NR16)-SR(NR13)
      SI(NR2)=T(5)+T(7)
      SI(NR6)=T(5)-T(7)
      SI(NR10)=T(6)+T(8)
      SI(NR14)=T(6)-T(8)
      Q(7)=T(9)+T(10)
      Q(8)=T(9)-T(10)
      Q(1)=T(11)+T(12)
      Q(2)=T(11)-T(12)
      Q(4)=T(14)+T(15)
      Q(5)=T(15)-T(14)
      Q(3)=T(13)+T(16)
      Q(6)=T(13)-T(16)
      SI(NR1)=Q(3)+Q(7)
      SI(NR7)=Q(7)-Q(3)
      SI(NR9)=Q(6)+Q(8)
      SI(NR15)=Q(8)-Q(6)
      SI(NR5)=Q(1)+Q(4)
      SI(NR3)=Q(4)-Q(1)
      SI(NR13)=Q(2)+Q(5)
      SI(NR11)=Q(5)-Q(2)
      SI(NR8)=T(2)
      SI(NR4)=T(3)
      SI(NR12)=T(4)
      SR(NR3)=SR3
      SR(NR5)=SR5
      SR(NR6)=SR6
      SR(NR9)=SR9
      SR(NR10)=SR10
      SR(NR11)=SR11
      SR(NR12)=SR12
      SR(NR13)=SR13
 1620 NBASE=NBASE+18
 1630 NBASE=NBASE+NLUP2
 1640 NBASE=NBASE+NLUP23
      RETURN
      END


      subroutine bsplvb ( t, jhigh, index, x, left, biatx )
c  from  * a practical guide to splines *  by c. de boor
calculates the value of all possibly nonzero b-splines at  x  of order
c
c               jout  =  max( jhigh , (j+1)*(index-1) )
c
c  with knot sequence  t .
c
c******  i n p u t  ******
c  t.....knot sequence, of length  left + jout  , assumed to be nonde-
c        creasing.  a s s u m p t i o n . . . .
c                       t(left)  .lt.  t(left + 1)   .
c   d i v i s i o n  b y  z e r o  will result if  t(left) = t(left+1)
c  jhigh,
c  index.....integers which determine the order  jout = max(jhigh,
c        (j+1)*(index-1))  of the b-splines whose values at  x  are to
c        be returned.  index  is used to avoid recalculations when seve-
c        ral columns of the triangular array of b-spline values are nee-
c        ded (e.g., in  bsplpp  or in  bsplvd ). precisely,
c                     if  index = 1 ,
c        the calculation starts from scratch and the entire triangular
c        array of b-spline values of orders 1,2,...,jhigh  is generated
c        order by order , i.e., column by column .
c                     if  index = 2 ,
c        only the b-spline values of order  j+1, j+2, ..., jout  are ge-
c        nerated, the assumption being that  biatx , j , deltal , deltar
c        are, on entry, as they were on exit at the previous call.
c           in particular, if  jhigh = 0, then  jout = j+1, i.e., just
c        the next column of b-spline values is generated.
c
c  w a r n i n g . . .  the restriction   jout .le. jmax (= 20)  is im-
c        posed arbitrarily by the dimension statement for  deltal  and
c        deltar  below, but is  n o w h e r e  c h e c k e d  for .
c
c  x.....the point at which the b-splines are to be evaluated.
c  left.....an integer chosen (usually) so that
c                  t(left) .le. x .le. t(left+1)  .
c
c******  o u t p u t  ******
c  biatx.....array of length  jout , with  biatx(i)  containing the val-
c        ue at  x  of the polynomial of order  jout  which agrees with
c        the b-spline  b(left-jout+i,jout,t)  on the interval (t(left),
c        t(left+1)) .
c
c******  m e t h o d  ******
c  the recurrence relation
c
c                       x - t(i)              t(i+j+1) - x
c     b(i,j+1)(x)  =  -----------b(i,j)(x) + ---------------b(i+1,j)(x)
c                     t(i+j)-t(i)            t(i+j+1)-t(i+1)
c
c  is used (repeatedly) to generate the (j+1)-vector  b(left-j,j+1)(x),
c  ...,b(left,j+1)(x)  from the j-vector  b(left-j+1,j)(x),...,
c  b(left,j)(x), storing the new values in  biatx  over the old. the
c  facts that
c            b(i,1) = 1  if  t(i) .le. x .lt. t(i+1)
c  and that
c            b(i,j)(x) = 0  unless  t(i) .le. x .lt. t(i+j)
c  are used. the particular organization of the calculations follows al-
c  gorithm  (8)  in chapter x of the text.
c
      integer index,jhigh,left,   i,j,jmax,jp1
      parameter (jmax = 20)
      real*8  biatx(jhigh),t(1),x,   deltal(jmax),deltar(jmax),saved,term
C     real biatx(jhigh),t(1),x,   deltal(20),deltar(20),saved,term
c     dimension biatx(jout), t(left+jout)
current fortran standard makes it impossible to specify the length of
c  t  and of  biatx  precisely without the introduction of otherwise
c  superfluous additional arguments.
      data j/1/
      save j,deltal,deltar
c
                                        go to (10,20), index
   10 j = 1
      biatx(1) = 1.
      if (j .ge. jhigh)                 go to 99
c
   20    jp1 = j + 1
         deltar(j) = t(left+j) - x
         deltal(j) = x - t(left+1-j)
         saved = 0.
         do 26 i=1,j
            term = biatx(i)/(deltar(i) + deltal(jp1-i))
            biatx(i) = saved + deltar(i)*term
   26       saved = deltal(jp1-i)*term
         biatx(jp1) = saved
         j = jp1
         if (j .lt. jhigh)              go to 20
c
   99                                   return
      end


!==============================================================================!
  subroutine Surf_Mod_Handle_3_Points(surf, surf_v)
!------------------------------------------------------------------------------!
!   Surface intersects cell at three points                                    !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Surf_Type), target :: surf
  real, dimension(3)      :: surf_v
!-----------------------------------[Locals]-----------------------------------!
  type(Vert_Type), pointer :: vert(:)
  type(Elem_Type), pointer :: elem(:)
  integer,         pointer :: nv, ne
  integer                  :: ver(3)
  real                     :: a(3), b(3), tri_p(3)
!==============================================================================!

  ! Take aliases
  nv   => surf % n_verts
  ne   => surf % n_elems
  vert => surf % vert
  elem => surf % elem

  ne = ne + 1           ! one new element

  ! Store last three vertices for the new element
  elem(ne) % i = nv - 2
  elem(ne) % j = nv - 1
  elem(ne) % k = nv

  ! Take vectors a and b; u connection points 2 and 1;
  ! v connecting 3 and 1
  ver(1) = elem(ne) % i
  ver(2) = elem(ne) % j
  ver(3) = elem(ne) % k

  a(1) = vert(ver(2)) % x_n - vert(ver(1)) % x_n
  a(2) = vert(ver(2)) % y_n - vert(ver(1)) % y_n
  a(3) = vert(ver(2)) % z_n - vert(ver(1)) % z_n

  b(1) = vert(ver(3)) % x_n - vert(ver(1)) % x_n
  b(2) = vert(ver(3)) % y_n - vert(ver(1)) % y_n
  b(3) = vert(ver(3)) % z_n - vert(ver(1)) % z_n

  tri_p = Math_Mod_Cross_Product(a, b)

  if(dot_product(surf_v, tri_p) < 0.0) then
    call Swap_Int(elem(ne) % j,  &
                  elem(ne) % k)
  end if

  end subroutine


program test6
#if (_DP==0)
 use iso_fortran_env,only:int32,int64,wp=>real32
#else
 use iso_fortran_env,only:int32,int64,wp=>real64
#endif
 use modsparse
 implicit none
 integer(kind=int32)::nrow
 integer(kind=int32)::row
 integer(kind=int32)::col
 integer(kind=int32)::iunit, istat
 integer(kind=int32)::i,j
 integer(kind=int32),allocatable::iarray(:,:)
 integer(kind=int32),allocatable::perm(:)
 real(kind=wp)::val
 real(kind=wp),allocatable::x(:),y(:)
 logical::lup=.false.
 type(coosparse)::coo
 type(crssparse)::crs

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !COO UPPER
 open(newunit=iunit,file='matrixija.ascii',status='old',action='read')
 !open(newunit=iunit,file='matkm.dat',status='old',action='read')
 read(iunit,*) nrow

 coo=coosparse(nrow,lupper=.true.)

 do
  read(iunit,*,iostat=istat) row,col,val
  if(istat.ne.0)exit
  call coo%add(row,col,val)
!  if(row.ne.col)call coo%add(col,row,val)
 end do
 close(iunit)

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !CSR UPPER
 crs=coo

 call crs%printstats()

 call crs%printsquare()

#if (_METIS==1)
 call crs%setpermutation(crs%getordering(bglvl=0))
#else
 call crs%setpermutation((/(i,i=1,crs%getdim(1))/))
#endif
 call crs%printstats()

!!!!!!!!!!!!!!!!
 write(*,*)'Matrix'
 allocate(iarray(crs%getdim(1),crs%getdim(2)))
 iarray=0
 do i=1,crs%getdim(1)
  do j=1,crs%getdim(2)
   val=crs%get(i,j)
   if(val.ne.0.)iarray(i,j)=1
  enddo
 enddo

 do i=1,crs%getdim(1)
  write(*,'(10000(i2))')iarray(i,:)
 enddo

 write(*,*)'Permuted matrix'

#if (_METIS==1)
 perm=crs%getordering(bglvl=0)
#else
 perm=(/(i,i=1,crs%getdim(1))/)
#endif
 iarray=0
 do i=1,crs%getdim(1)
  do j=1,crs%getdim(2)
   val=crs%get(perm(i),perm(j))
   if(val.ne.0.)iarray(i,j)=1
  enddo
 enddo

 do i=1,crs%getdim(1)
  write(*,'(10000(i2))')iarray(i,:)
 enddo

!!!!!!

 call crs%spainv()

 call crs%printsquare()

!!!!!!
 crs=coo

 call crs%sort()

#if (_METIS==1)
 perm=crs%getordering(bglvl=0)
#else
 perm=(/(i,i=1,crs%getdim(1))/)
#endif
 call crs%setpermutation(perm)
 call crs%printstats()

 print*,'ord ',perm

 allocate(x(crs%getdim(1)),y(crs%getdim(1)))
 x=1.;y=1.

 call crs%solve(x,y)

print*,'x ',x
print*,'y ',y

end program


      subroutine rand(seed,n,vector)
c---------------------------------------------------------------------
c
c This random number generator generates random numbers in ]0,1[
c Note that if the seed value is zero on the first call, a default
c value of 7931 will be used  in a linear congruential generator to
c generate 55 odd integers for the array 'itab()'. These values are
c preserved by a common statement, so that they may be used in sub-
c sequent calls by setting the seed to zero.If the value of 'seed'
c is greater than zero in a call to the subroutine, then the array
c 'itab' will be initialized and a new seed value will be returned
c by the subroutine. Best results are obtained by making the initial
c call with a seed of your choice and then setting the seed to '0'
c for all subsequent calls.
c
c---------------------------------------------------------------------
      dimension vector(*)
      common /unusual/itab(55),n1,n2,nseed
      integer rn1,seed
c
c Test to see if 55 odd integers must be generated.
c
      if((seed.gt.0).or.(nseed.lt.1)) then
            nseed = seed
            if(seed.le.0) nseed  = 7931
            do i=1,55
                  rn1=mod(nseed*9069,32768)
                  if(mod(rn1,2).eq.0) rn1 = rn1-1
                  itab(i) = rn1
                  nseed = rn1
            end do
            n1 = 0
            n2 = 24
      endif
c
c Generate "n" random components for the vector "VECTOR"
c
      do i=1,n
            itab(55-n1) = mod(itab(55-n2)*itab(55-n1),32768)
            vector(i)   = abs(float(itab(55-n1))/float(32768))
            n1 = mod(n1+1,55)
            n2 = mod(n2+1,55)
      end do
      if(seed.gt.0) seed=nseed
c
c Return with the vector of random numbers:
c
      return
      end


!	Convert from adaptive quadrature scale to normalized latent vector.
!	Use nhchol for modified Cholesky decomposition of negative hessian.
!	Use oldalpha for location.
!	Use scalez for scaling.
!	Quadrature point is z.
function scaleadapt(nhchol,oldalpha,scalez,z)
implicit none

real(kind=8),intent(in)::nhchol(:,:),oldalpha(:),scalez(:),z(:)
real(kind=8)::scaleadapt(size(z))
!	dimlat is dimension of z.
!	row is row number
integer::dimlat,row
dimlat=size(z)

scaleadapt(dimlat)=z(dimlat)*scalez(dimlat)
if (dimlat>1) then
	do row=dimlat-1,1,-1
		scaleadapt(row)=z(row)*scalez(row)&
			-dot_product(nhchol(row+1:dimlat,row),scaleadapt(row+1:dimlat))
	end do
end if

scaleadapt=scaleadapt+oldalpha
return

end function scaleadapt


!+
MODULE Atmosphere1976
! ---------------------------------------------------------------------------
! PURPOSE - Compute properties of the U.S. Standard Atmosphere 1976
! AUTHORS - Steven S. Pietrobon.
!           Ralph L. Carmichael, Public Domain Aeronautical Software
!
!     REVISION HISTORY
!   DATE  VERS PERSON  STATEMENT OF CHANGES
! 28Feb95  0.1   RLC   Assembled several old codes
!  1Aug00  0.2   RLC   Copied from old Tables76
! 23Aug00  0.3   RLC   Added NitrogenNumber using QUANC8
! 24Aug00  0.4   RLC   Added KineticTemperatureGradient
! 30Aug00  0.5   RLC   Corrected numerous errors
! 30Dec00  0.6   RLC   Adapted UpperAtmosphere from Pietrobon's Unofficial
!                        Australian Standard Atmosphere
! 20Jun17  0.61  D.A.  Corrected bug in the values of density for the upper
!                      atmosphere.
!----------------------------------------------------------------------------

use KINDS, only: dk

IMPLICIT NONE
  CHARACTER(LEN=*),PUBLIC,PARAMETER:: ATM76_VERSION = "0.61 (20 June 2017)"
  REAL(dk),PRIVATE,PARAMETER:: PI = 3.14159265_dk
  REAL(dk),PARAMETER:: REARTH = 6356.766_dk               ! radius of the Earth (km)
  REAL(dk),PARAMETER:: GMR = 34.163195_dk                             ! gas constant
  REAL(dk),PARAMETER:: GZERO = 9.80665_dk !  accel. of gravity, m/sec^2

!  REAL,PARAMETER:: FT2METERS = 0.3048       ! mult. ft. to get meters (exact)
!  REAL,PARAMETER:: KELVIN2RANKINE = 1.8             ! mult K to get deg R
!  REAL,PARAMETER:: PSF2NSM = 47.880258          ! mult lb/sq.ft to get N/sq.m
!  REAL,PARAMETER:: SCF2KCM = 515.379         ! mult slug/cu.ft to get kg/cu.m
  REAL(dk),PARAMETER:: TZERO = 288.15_dk                ! temperature at sealevel, K
  REAL(dk),PARAMETER:: PZERO = 101325.0_dk            ! pressure at sealevel, N/sq.m
  REAL(dk),PARAMETER:: RHOZERO = 1.2250_dk            ! density at sealevel, kg/cu.m
  REAL(dk),PARAMETER:: RSTAR = 8314.32_dk       ! perfect gas constant, N-m/(kmol-K)
  REAL(dk),PARAMETER:: ASOUNDZERO = 340.294_dk   ! speed of sound at sealevel, m/sec

  REAL(dk),PARAMETER:: BETAVISC = 1.458E-6_dk    ! viscosity term, N s/(sq.m sqrt(K)
  REAL(dk),PARAMETER:: SUTH = 110.4_dk                    ! Sutherland's constant, K

  REAL(dk),PARAMETER:: MZERO      = 28.9644_dk ! molecular weight of air at sealevel
!  REAL,PARAMETER:: AVOGADRO =  6.022169E26        ! 1/kmol, Avogadro constant
!  REAL,PARAMETER:: BOLTZMANN = 1.380622E-23        ! Nm/K, Boltzmann constant

! TABLE 5 - DEFINITION OF KINETIC TEMPERATURE FROM 86 km to 1000 km
  REAL(dk),PARAMETER:: Z7 =  86.0_dk,  T7=186.8673_dk
  REAL(dk),PARAMETER:: z8 =  91.0_dk,  T8=T7
  REAL(dk),PARAMETER:: Z9 = 110.0_dk,  T9=240.0_dk
  REAL(dk),PARAMETER:: Z10= 120.0_dk, T10=360.0_dk
!  REAL,PARAMETER:: Z11= 500.0, T11=999.2356   ! not used
  REAL(dk),PARAMETER:: Z12=1000.0_dk, T12=1000.0_dk

  REAL(dk),PARAMETER:: FT2METERS = 0.3048_dk               ! mult. ft. to get meters (exact)
  REAL(dk),PARAMETER:: KELVIN2RANKINE = 1.8_dk             ! mult deg K to get deg R
  REAL(dk),PARAMETER:: PSF2NSM = 47.880258_dk          ! mult lb/sq.ft to get N/sq.m
  REAL(dk),PARAMETER:: SCF2KCM = 515.379_dk         ! mult slug/cu.ft to get kg/cu.m

CONTAINS

!+
FUNCTION EvaluateCubic(a,fa,fpa, b,fb,fpb, u) RESULT(fu)
! ---------------------------------------------------------------------------
! PURPOSE - Evaluate a cubic polynomial defined by the function and the
!   1st derivative at two points
  REAL(dk),INTENT(IN):: u   ! point where function is to be evaluated
  REAL(dk),INTENT(IN):: a,fa,fpa   ! a, f(a), f'(a)  at first point
  REAL(dk),INTENT(IN):: b,fb,fpb   ! b, f(b), f'(b)  at second point
  REAL(dk):: fu                    ! computed value of f(u)

  REAL(dk):: d,t,p
!----------------------------------------------------------------------------
  d=(fb-fa)/(b-a)
  t=(u-a)/(b-a)
  p=1.0_dk-t

  fu = p*fa + t*fb - p*t*(b-a)*(p*(d-fpa)-t*(d-fpb))
  RETURN
END Function EvaluateCubic   ! ----------------------------------------------

!+
FUNCTION KineticTemperature(z) RESULT(t)
!   -------------------------------------------------------------------------
! PURPOSE - Compute kinetic temperature above 86 km.

  REAL(dk),INTENT(IN)::  z     ! geometric altitude, km.
  REAL(dk):: t     ! kinetic temperature, K

  REAL(dk),PARAMETER:: C1 = -76.3232_dk  ! uppercase A in document
  REAL(dk),PARAMETER:: C2 = 19.9429_dk   ! lowercase a in document
  REAL(dk),PARAMETER:: C3 = 12.0_dk
  REAL(dk),PARAMETER:: C4 = 0.01875_dk   ! lambda in document
  REAL(dk),PARAMETER:: TC = 263.1905_dk

  REAL(dk):: xx,yy
!----------------------------------------------------------------------------
  IF (z <= Z8) THEN
    t=T7
  ELSE IF (z < Z9) THEN
    xx=(z-Z8)/C2                        ! from Appendix B, p.223
    yy=SQRT(1.0_dk-xx*xx)
    t=TC+C1*yy
  ELSE IF (z <= Z10) THEN
    t=T9+C3*(z-Z9)
  ELSE
    xx=(REARTH+Z10)/(REARTH+z)
    yy=(T12-T10)*EXP(-C4*(z-Z10)*xx)
    t=T12-yy
  END IF

  RETURN
END Function KineticTemperature   ! -----------------------------------------

!+
SUBROUTINE UpperAtmosphere(alt, sigma, delta, theta)
!   -------------------------------------------------------------------------
! PURPOSE - Compute the properties of the 1976 standard atmosphere from
!   86 km. to 1000 km.

  IMPLICIT NONE
!============================================================================
!     A R G U M E N T S                                                     |
!============================================================================
  REAL(dk),INTENT(IN)::  alt    ! geometric altitude, km.
  REAL(dk),INTENT(OUT):: sigma  ! density/sea-level standard density
  REAL(dk),INTENT(OUT):: delta  ! pressure/sea-level standard pressure
  REAL(dk),INTENT(OUT):: theta  ! temperature/sea-level standard temperature
!============================================================================
!     L O C A L   C O N S T A N T S                                         |
!============================================================================

! altitude table (m)
  REAL(dk),PARAMETER,DIMENSION(23):: Z = (/      &
     86._dk,  93._dk, 100._dk, 107._dk, 114._dk, &
    121._dk, 128._dk, 135._dk, 142._dk, 150._dk, &
    160._dk, 170._dk, 180._dk, 190._dk, 200._dk, &
    250._dk, 300._dk, 400._dk, &
    500._dk, 600._dk, 700._dk, 800._dk, 1000._dk /)

! pressure table  (Pa)
!  REAL,PARAMETER,DIMENSION(SIZE(Z)):: P = (/                                &
!    3.7338e-1, 1.0801e-1, 3.2011e-2, 1.0751E-2, 4.4473e-3, &
!    2.3402e-3, 1.4183e-3, 9.3572e-4, 6.5297e-4, 4.5422e-4, &
!    3.0397e-4, 2.1212e-4, 1.5273e-4, 1.1267e-4, 8.4743e-5, &
!    2.4767e-5, 8.7704e-6, 1.4518e-6, &
!    3.0236e-7, 8.2130e-8, 3.1908e-8, 1.7036e-8, 7.5138e-9 /)

! density table  kg/m**3
!  REAL,PARAMETER,DIMENSION(SIZE(Z)):: RHO = (/                              &
!    6.9579e-06, 1.9997e-06, 5.6041e-07, 1.6426E-07, 4.9752e-08, &
!    1.9768e-08, 9.7173e-09, 5.4652e-09, 3.3580e-09, 2.0757e-09, &
!    1.2332e-09, 7.8155e-10, 5.1944e-10, 3.5808e-10, 2.5409e-10, &
!    6.0732e-11, 1.9160e-11, 2.8031e-12, &
!    5.2159e-13, 1.1369e-13, 3.0698e-14, 1.1361e-14, 3.5614e-15 /)

!fit2000
  REAL(dk),PARAMETER,DIMENSION(SIZE(Z)):: LOGP = (/               &
  -0.985159_dk,  -2.225531_dk,  -3.441676_dk,  -4.532756_dk,  -5.415458_dk,  &
  -6.057519_dk,  -6.558296_dk,  -6.974194_dk,  -7.333980_dk,  -7.696929_dk,  &
  -8.098581_dk,  -8.458359_dk,  -8.786839_dk,  -9.091047_dk,  -9.375888_dk,  &
 -10.605998_dk, -11.644128_dk, -13.442706_dk, -15.011647_dk, -16.314962_dk,  &
 -17.260408_dk, -17.887938_dk, -18.706524_dk /)

 REAL(dk),PARAMETER,DIMENSION(SIZE(Z)):: LOGRHO = (/             &
 -11.875633_dk, -13.122514_dk, -14.394597_dk, -15.621816_dk, -16.816216_dk,  &
 -17.739201_dk, -18.449358_dk, -19.024864_dk, -19.511921_dk, -19.992968_dk,  &
 -20.513653_dk, -20.969742_dk, -21.378269_dk, -21.750265_dk, -22.093332_dk,  &
 -23.524549_dk, -24.678196_dk, -26.600296_dk, -28.281895_dk, -29.805302_dk,  &
 -31.114578_dk, -32.108589_dk, -33.268623_dk /)

  REAL(dk),PARAMETER,DIMENSION(SIZE(Z)):: DLOGPDZ = (/            &
  -0.177700_dk,  -0.176950_dk,  -0.167294_dk,  -0.142686_dk,  -0.107868_dk,  &
  -0.079313_dk,  -0.064668_dk,  -0.054876_dk,  -0.048264_dk,  -0.042767_dk,  &
  -0.037847_dk,  -0.034273_dk,  -0.031539_dk,  -0.029378_dk,  -0.027663_dk,  &
  -0.022218_dk,  -0.019561_dk,  -0.016734_dk,  -0.014530_dk,  -0.011315_dk,  &
  -0.007673_dk,  -0.005181_dk,  -0.003500_dk /)

  REAL(dk),PARAMETER,DIMENSION(SIZE(Z)):: DLOGRHODZ = (/          &
  -0.177900_dk,  -0.180782_dk,  -0.178528_dk,  -0.176236_dk,  -0.154366_dk,  &
  -0.113750_dk,  -0.090551_dk,  -0.075044_dk,  -0.064657_dk,  -0.056087_dk,  &
  -0.048485_dk,  -0.043005_dk,  -0.038879_dk,  -0.035637_dk,  -0.033094_dk,  &
  -0.025162_dk,  -0.021349_dk,  -0.017682_dk,  -0.016035_dk,  -0.014330_dk,  &
  -0.011626_dk,  -0.008265_dk,  -0.004200_dk /)

!============================================================================
!     L O C A L   V A R I A B L E S                                         |
!============================================================================
  INTEGER:: i,j,k                                                  ! counters
!  REAL:: h                                       ! geopotential altitude (km)
!  REAL:: tgrad, tbase      ! temperature gradient and base temp of this layer
!  REAL:: tlocal                                           ! local temperature
!  REAL:: deltah                             ! height above base of this layer

  REAL(dk):: p,rho
!----------------------------------------------------------------------------

  IF (alt >= Z(SIZE(Z))) THEN          ! trap altitudes greater than 1000 km.
    ! delta=1.E-20_dk
    ! sigma=1.E-21_dk
    delta=0._dk
    sigma=0._dk
    theta=1000.0_dk/TZERO
    RETURN
  END IF

  i=1
  j=SIZE(Z)                                    ! setting up for binary search
  DO
    k=(i+j)/2                                              ! integer division
    IF (alt < Z(k)) THEN
      j=k
    ELSE
      i=k
    END IF
    IF (j <= i+1) EXIT
  END DO

  p=EXP(EvaluateCubic(Z(i),LOGP(i),DLOGPDZ(i), &
                      Z(i+1),LOGP(i+1),DLOGPDZ(i+1), alt))
  delta=p/PZERO

  rho=EXP(EvaluateCubic(Z(i),LOGRHO(i),DLOGRHODZ(i), &
                      Z(i+1),LOGRHO(i+1),DLOGRHODZ(i+1), alt))
  sigma=rho/RHOZERO

  theta=KineticTemperature(alt)/TZERO
  RETURN
END Subroutine UpperAtmosphere   ! ------------------------------------------

!+
SUBROUTINE LowerAtmosphere(alt, sigma, delta, theta)
!   -------------------------------------------------------------------------
! PURPOSE - Compute the properties of the 1976 standard atmosphere to 86 km.

  IMPLICIT NONE
!============================================================================
!     A R G U M E N T S                                                     |
!============================================================================
  REAL(dk),INTENT(IN)::  alt    ! geometric altitude, km.
  REAL(dk),INTENT(OUT):: sigma  ! density/sea-level standard density
  REAL(dk),INTENT(OUT):: delta  ! pressure/sea-level standard pressure
  REAL(dk),INTENT(OUT):: theta  ! temperature/sea-level standard temperature
!============================================================================
!     L O C A L   C O N S T A N T S                                         |
!============================================================================
  REAL(dk),PARAMETER:: REARTH = 6369.0_dk                 ! radius of the Earth (km)
  REAL(dk),PARAMETER:: GMR = 34.163195_dk                             ! gas constant
  INTEGER,PARAMETER:: NTAB=8       ! number of entries in the defining tables
!============================================================================
!     L O C A L   V A R I A B L E S                                         |
!============================================================================
  INTEGER:: i,j,k                                                  ! counters
  REAL(dk):: h                                       ! geopotential altitude (km)
  REAL(dk):: tgrad, tbase      ! temperature gradient and base temp of this layer
  REAL(dk):: tlocal                                           ! local temperature
  REAL(dk):: deltah                             ! height above base of this layer
!============================================================================
!     L O C A L   A R R A Y S   ( 1 9 7 6   S T D.  A T M O S P H E R E )   |
!============================================================================
  REAL(dk),DIMENSION(NTAB),PARAMETER:: htab= &
                          (/0.0_dk, 11.0_dk, 20.0_dk, 32.0_dk, 47.0_dk, 51.0_dk&
                          &, 71.0_dk, 84.852_dk/)
  REAL(dk),DIMENSION(NTAB),PARAMETER:: ttab= &
          (/288.15_dk, 216.65_dk, 216.65_dk, 228.65_dk, 270.65_dk, 270.65_dk,&
          & 214.65_dk, 186.946_dk/)
  REAL(dk),DIMENSION(NTAB),PARAMETER:: ptab= &
               (/1.0_dk, 2.233611E-1_dk, 5.403295E-2_dk, 8.5666784E-3_dk, &
               1.0945601E-3_dk, 6.6063531E-4_dk, 3.9046834E-5_dk, 3.68501E-6_dk/)
  REAL(dk),DIMENSION(NTAB),PARAMETER:: gtab= &
                                (/-6.5_dk, 0.0_dk, 1.0_dk, 2.8_dk, 0.0_dk, &
                                &-2.8_dk, -2.0_dk, 0.0_dk/)
!----------------------------------------------------------------------------
  h=alt*REARTH/(alt+REARTH)      ! convert geometric to geopotential altitude

  i=1
  j=NTAB                                  ! setting up for binary search
  DO
    k=(i+j)/2                                              ! integer division
    IF (h < htab(k)) THEN
      j=k
    ELSE
      i=k
    END IF
    IF (j <= i+1) EXIT
  END DO

  tgrad=gtab(i)                                     ! i will be in 1...NTAB-1
  tbase=ttab(i)
  deltah=h-htab(i)
  tlocal=tbase+tgrad*deltah
  theta=tlocal/ttab(1)                                    ! temperature ratio

  IF (tgrad == 0.0_dk) THEN                                     ! pressure ratio
    delta=ptab(i)*EXP(-GMR*deltah/tbase)
  ELSE
    delta=ptab(i)*(tbase/tlocal)**(GMR/tgrad)
  END IF

  sigma=delta/theta                                           ! density ratio
  RETURN
END Subroutine LowerAtmosphere   ! ------------------------------------------

!+
SUBROUTINE SimpleAtmosphere(alt,sigma,delta,theta)
!   -------------------------------------------------------------------------
! PURPOSE - Compute the characteristics of the atmosphere below 20 km.

! NOTES-Correct to 20 km. Only approximate above there

  IMPLICIT NONE
!============================================================================
!     A R G U M E N T S                                                     |
!============================================================================
  REAL(dk),INTENT(IN)::  alt    ! geometric altitude, km.
  REAL(dk),INTENT(OUT):: sigma  ! density/sea-level standard density
  REAL(dk),INTENT(OUT):: delta  ! pressure/sea-level standard pressure
  REAL(dk),INTENT(OUT):: theta  ! temperature/sea-level standard temperature
!============================================================================
!     L O C A L   C O N S T A N T S                                         |
!============================================================================
  REAL(dk),PARAMETER:: REARTH = 6369.0_dk                ! radius of the Earth (km)
  REAL(dk),PARAMETER:: GMR = 34.163195_dk                            ! gas constant
!============================================================================
!     L O C A L   V A R I A B L E S                                         |
!============================================================================
  REAL(dk):: h   ! geopotential altitude
!----------------------------------------------------------------------------
  h=alt*REARTH/(alt+REARTH)      ! convert geometric to geopotential altitude

  IF (h < 11.0_dk) THEN
    theta=1.0_dk+(-6.5_dk/288.15_dk)*h                               ! Troposphere
    delta=theta**(GMR/6.5_dk)
  ELSE
    theta=216.65_dk/288.15_dk                                        ! Stratosphere
    delta=0.2233611_dk*EXP(-GMR*(h-11.0_dk)/216.65_dk)
  END IF

  sigma=delta/theta
  RETURN
END Subroutine SimpleAtmosphere   ! -----------------------------------------

!+
FUNCTION Viscosity(theta) RESULT(visc)
!   -------------------------------------------------------------------------
! PURPOSE - Compute viscosity using Sutherland's formula.
!        Returns viscosity in kg/(meter-sec)

  IMPLICIT NONE
  REAL(dk),INTENT(IN) :: theta                ! temperature/sea-level temperature
  REAL(dk):: visc
  REAL(dk):: temp                              ! temperature in deg Kelvin
!----------------------------------------------------------------------------
  temp=TZERO*theta
  visc=BETAVISC*Sqrt(temp*temp*temp)/(temp+SUTH)
  RETURN
END Function Viscosity   ! --------------------------------------------

!+
SUBROUTINE Atmosphere(alt,sigma,delta,theta)
!   -------------------------------------------------------------------------
! PURPOSE - Compute the characteristics of the U.S. Standard Atmosphere 1976

  IMPLICIT NONE
  REAL(dk),INTENT(IN)::  alt    ! geometric altitude, km.
  REAL(dk),INTENT(OUT):: sigma  ! density/sea-level standard density
  REAL(dk),INTENT(OUT):: delta  ! pressure/sea-level standard pressure
  REAL(dk),INTENT(OUT):: theta  ! temperature/sea-level standard temperature
!============================================================================
  IF (alt > 86.0_dk) THEN
    CALL UpperAtmosphere(alt,sigma,delta,theta)
  ELSE
    CALL LowerAtmosphere(alt,sigma,delta,theta)
  END IF
  RETURN
END Subroutine Atmosphere   ! -----------------------------------------------

END Module Atmosphere1976   ! ===============================================