module type_AdvectionSolver

    use, intrinsic :: ISO_Fortran_env, only: &
        ip => INT32, &
        wp => REAL64, &
        stdout => OUTPUT_UNIT

    use spherepack, only: &
        GaussianSphere, &
        PI, &
        TWO_PI

    ! Explicit typing only
    implicit none

    private
    public :: DEGREES_TO_RADIANS
    public :: TIME_TO_CIRCUMVENT_THE_EARTH
    public :: AdvectionSolver

    ! Parameters confined to the module
    real(wp),    parameter :: ZERO = 0.0_wp
    real(wp),    parameter :: ONE = 1.0_wp
    real(wp),    parameter :: TWO = 2.0_wp
    real(wp),    parameter :: SIXTY = 6.0e+1_wp
    real(wp),    parameter :: SIX_HUNDRED = 6.0e+2_wp
    real(wp),    parameter :: ONE_THOUSAND = 1.0e+3_wp
    real(wp),    parameter :: DEGREES_TO_RADIANS = PI/180
    integer(ip), parameter :: TIME_TO_CIRCUMVENT_THE_EARTH = 12*24*3600

    type, public, extends(GaussianSphere) :: AdvectionSolver

        ! Type components
        real(wp) :: TIME_STEP = SIX_HUNDRED
        real(wp) :: ROTATION_RATE_OF_EARTH = TWO_PI/TIME_TO_CIRCUMVENT_THE_EARTH
        real(wp) :: LATITUDE_OF_COSINE_BELL = PI/6
        real(wp) :: RADIUS_OF_EARTH_IN_METERS = ONE/3
        real(wp) :: TILT_ANGLE_IN_DEGREES = SIXTY
        real(wp) :: TILT_ANGLE = SIXTY * DEGREES_TO_RADIANS
        real(wp) :: MAXIMUM_VALUE_OF_COSINE_BELL = ONE_THOUSAND
    contains

        ! Type-bound procedures
        procedure, public :: get_geopotential
        procedure, public :: get_vector_velocities
        procedure, nopass :: atanxy
    end type AdvectionSolver

contains

    ! Purpose:
    !
    ! Computes advecting cosine bell on a tilted grid a time t.
    !
    ! input parameters
    !
    !     t      time in seconds
    !
    !     alpha  tilt angle in radians
    !
    !     beta   colatitude of cosine bell in untilted coordinate
    !            system in radians
    !
    !     omega  angular velocity in radians per second
    !
    !     hzero  maximum value of cosine bell
    !
    !     re     radius of support for cosine bell in radians
    !
    !     nlat   number of latitudes including the poles
    !
    !     nlon   number of distinct longitude lines
    !
    !     idim   first dimension of output array h
    !
    !     colat  vector of Gauss colatitude grid points
    !
    ! output parameter
    !
    !     geopot     an nlat by nlon array containing the geopotential
    !
    !             on a tilted grid
    !
    subroutine get_geopotential(self, t, geopot)

        ! Dummy arguments
        class(AdvectionSolver), intent(inout) :: self
        real(wp),               intent(in)    :: t
        real(wp),               intent(out)   :: geopot(:, :)

        ! Local variables
        integer(ip) :: i, j
        real(wp)    :: xc, yc, zc, x1, y1, z1
        real(wp)    :: lambda, theta, cost, sint, sth , cthclh
        real(wp)    :: cthslh, lhat, cosl, sinl, cth , that, r

        associate (&
            nlat => self%NUMBER_OF_LATITUDES, &
            nlon => self%NUMBER_OF_LONGITUDES, &
            omega => self%ROTATION_RATE_OF_EARTH, &
            beta => self%LATITUDE_OF_COSINE_BELL, &
            re => self%RADIUS_OF_EARTH_IN_METERS, &
            alpha => self%TILT_ANGLE, &
            hzero => self%MAXIMUM_VALUE_OF_COSINE_BELL, &
            colat => self%grid%latitudes &
           )

            associate (lambdc => omega*t)
                call sph2cart(ONE, beta, lambdc, xc, yc, zc)
            end associate

            associate (&
                cosa => cos(alpha), &
                sina => sin(alpha) &
               )
                do j=1, nlon
                    lambda = self%grid%longitudes(j)
                    associate (&
                        cosp => cos(lambda), &
                        sinp => sin(lambda) &
                       )
                        do i=1, nlat
                            theta = colat(i)
                            cost = cos(theta)
                            sint = sin(theta)
                            sth = cosa*cost+sina*sint*cosp
                            cthclh = cosa*sint*cosp-sina*cost
                            cthslh = sint*sinp
                            lhat = atanxy(cthclh, cthslh)
                            cosl = cos(lhat)
                            sinl = sin(lhat)
                            cth = cosl*cthclh+sinl*cthslh
                            that = atanxy(sth, cth)

                            ! Compute scaled radial unit vector
                            call sph2cart(ONE, that, lhat, x1, y1, z1)

                            ! Compute distance
                            associate (dist => norm2([x1-xc, y1-yc, z1-zc]))

                                !  Initialize geopotential
                                geopot(i, j) = ZERO

                                if (dist >= re) cycle

                                r = TWO * asin(dist/2)

                            end associate

                            if (r >= re) cycle

                            !  Set geopotential
                            geopot(i, j) = hzero * (cos(r*PI/re)+ONE)/2
                        end do
                    end associate
                end do
            end associate
        end associate

    end subroutine get_geopotential

    subroutine get_vector_velocities(self, u, v)

        ! Dummy arguments
        class(AdvectionSolver), intent(inout)  :: self
        real(wp),               intent(out)    :: u(:, :)
        real(wp),               intent(out)    :: v(:, :)

        ! Local variables
        integer(ip) :: i, j
        real(wp)    :: sinp, cosp, sint, cost, sinl, cosl
        real(wp)    :: cth, xlhat, uhat

        associate (&
            nlats => self%NUMBER_OF_LATITUDES, &
            nlons => self%NUMBER_OF_LONGITUDES, &
            colat => self%grid%latitudes, &
            omega => self%ROTATION_RATE_OF_EARTH, &
            alpha => self%TILT_ANGLE &
           )

            do j=1, nlons
                associate (xlm => self%grid%longitudes(j))
                    sinp = sin(xlm)
                    cosp = cos(xlm)
                    do i=1, nlats
                        cost = cos(colat(i))
                        sint = sin(colat(i))
                        associate (&
                            sth => cos(alpha)*cost+sin(alpha)*sint*cosp, &
                            cthclh => cos(alpha)*sint*cosp-sin(alpha)*cost, &
                            cthslh => sint*sinp &
                           )

                            xlhat = self%atanxy(cthclh, cthslh)
                            cosl = cos(xlhat)
                            sinl = sin(xlhat)
                            cth = cosl*cthclh+sinl*cthslh
                            uhat = omega*cth
                            u(i, j) = (cos(alpha)*sinp*sinl+cosp*cosl)*uhat
                            v(i, j) = (cos(alpha)*cost*cosp*sinl &
                                -cost*sinp*cosl+sin(alpha)*sint*sinl)*uhat

                        end associate
                    end do
                end associate
            end do
        end associate

    end subroutine get_vector_velocities

    pure function atanxy(x, y) result (return_value)

        ! Dummy arguments
        real(wp), intent(in) :: x
        real(wp), intent(in) :: y
        real(wp)             :: return_value

        return_value = ZERO

        if (x == ZERO .and. y == ZERO) return

        return_value = atan2(y, x)

    end function atanxy

    pure subroutine sph2cart(r, theta, phi, x, y, z)

        ! Dummy arguments
        real(wp), intent(in)  :: r
        real(wp), intent(in)  :: theta
        real(wp), intent(in)  :: phi
        real(wp), intent(out) :: x, y, z

        x = r * sin(theta) * cos(phi)
        y = r * sin(theta) * sin(phi)
        z = r * cos(theta)

    end subroutine sph2cart

end module type_AdvectionSolver


subroutine antialias(yh)
! performs 1d antialias 2/3 filter on vector yh
! zeros out modes (Nx/2 - b) ... (Nx/2) and (-Nx/2 + 1) ... (-Nx / 2 + b) where b = Nx/6
! === Parameters ===
! yh - 1d solution in fourier space. Expected wave number ordering is [0:params.Nx/2, -params.Nx/2+1:-1]
! === Output ===
! yh - anti aliased 1d solution in fourier space
    complex(dp), intent(inout)  :: yh(:)
    integer :: a, b, Np

    Np = size(yh)
    a  = Np / 2
    b  = Np / 6 ! one-half filter length
    yh( a + 1 - b : a + 1 + b) = 0.0_dp;
end subroutine antialias


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download

!> Looking at sampling error for the obs. space part of the problem
!> Assume that the ratio of the prior sample to obs standard dev. is known
!> Want to compute the following:
!>   1. An unbiased estimate of the updated variance
!>   2. An unbiased estimate of the updated mean which should be
!>      expressed as the fraction of the distance to move between
!>      the prior sample mean and the observed value
!>   3. The standard deviation or variance of the updated mean estimate
!>      Need to add this uncertainty into the sample to avoid loss of
!>      variance (see also full_error.f90 which does this for regression).

program obs_sampling_err

use      types_mod, only : r8, digits12
use random_seq_mod, only : random_seq_type, init_random_seq, random_gaussian

implicit none

!!!integer, parameter :: sample_size = 10000000
integer, parameter :: sample_size = 100000
integer :: ens_size
real(r8), allocatable :: sample(:)
real(r8) :: s_var, s_mean, u_var, ratio
real(r8) :: u_var_sum, u_var_mean
real(r8) :: t_var, log_ratio, beta
real(r8) :: s_obs_weight, s_obs_weight_sum, s_obs_weight2_sum
real(r8) :: s_obs_weight_var, s_obs_weight_mean
real(r8) :: s_var_sum, s_var_mean
real(r8) :: mad, mad_sum, mad_mean, sd_sum, sd_mean
type (random_seq_type) :: ran_id
integer :: i, j, k

write(*, *) 'input ensemble size '
read(*, *) ens_size
allocate(sample(ens_size))

write(*, *) 'stats for ensemble size ', ens_size

! Initialize the random number sequence
call init_random_seq(ran_id)

! Loop through a variety of ratios to make a table
do k = 1, 200
   log_ratio = (k - 100.0_r8) / 50.0_r8
   ratio = 10.0_r8**log_ratio

   ! Compute the true updated mean and variance without sampling error
   ! True prior mean is 0.0,
   ! True prior variance is ratio and true obs variance is 1.0
   t_var = 1.0_r8 / (1.0_r8 / ratio**2 + 1.0_r8)

   ! Initialize the sum arrays
   u_var_sum = 0.0_r8; s_var_sum = 0.0_r8
   s_obs_weight_sum = 0.0_r8; s_obs_weight2_sum = 0.0_r8
   mad_sum = 0.0_r8; sd_sum = 0.0_r8

   ! Loop through the sample
   do i = 1, sample_size
      ! Generate a random sample of size ens_size with ratio for variance
      do j = 1, ens_size
         sample(j) = random_gaussian(ran_id, 0.0_r8, ratio)
      enddo

      ! Compute the sample mean and variance
      call sample_mean_var(sample, ens_size, s_mean, s_var)

      ! Compute mean of sample variance
      s_var_sum = s_var_sum + s_var
      ! Compute mean of sd
      sd_sum = sd_sum + sqrt(s_var)
      ! Compute the mean absolute deviation, too
      mad = sum(abs(sample - s_mean)) / ens_size
      mad_sum = mad_sum + mad

      ! Compute the updated standard deviation and mean; obs var is 1.0
      u_var = 1.0_r8 / (1.0_r8 / s_var + 1.0_r8)
      u_var_sum = u_var_sum + u_var

      ! What weight is given to obs here?
      s_obs_weight = u_var / 1.0_r8
      s_obs_weight_sum = s_obs_weight_sum + s_obs_weight
      s_obs_weight2_sum = s_obs_weight2_sum + s_obs_weight**2

   enddo

   ! Output the mean stats
   u_var_mean = u_var_sum / sample_size
   s_obs_weight_mean = s_obs_weight_sum / sample_size
   s_obs_weight_var = (s_obs_weight2_sum - s_obs_weight_sum**2 / sample_size) / &
      (sample_size - 1.0_r8)
   s_var_mean = s_var_sum / sample_size
   sd_mean = sd_sum / sample_size
   mad_mean = mad_sum / sample_size

   ! Compute beta
   beta = s_obs_weight_mean**2 / s_obs_weight_var

   write(*, 22) log_ratio, ratio, t_var / u_var_mean, t_var / s_obs_weight_mean, beta
   22 format(1x, 6(e10.4, 1x))
   write(*, *) 's_var_mean ', s_var_mean, ratio**2
   write(*, *) 'mad ', mad_mean, mad_mean / sqrt(s_var_mean)
   write(*, *) 'sd_mean ', sd_mean, sqrt(s_var_mean), sd_mean / sqrt(s_var_mean)

enddo

!----------------------------------------------------------------
contains
!----------------------------------------------------------------

subroutine sample_mean_var(x, n, mean, var)

integer,        intent(in) :: n
real(digits12), intent(in) :: x(n)
real(digits12), intent(out) :: mean, var

real(digits12) :: sx, s_x2

sx   = sum(x)
s_x2 = sum(x * x)
mean = sx / n
var  = (s_x2 - sx**2 / n) / (n - 1)

end subroutine sample_mean_var

end program obs_sampling_err


program residuo_ppal

use datasissim_interface
use residuo_interface

implicit none

real, dimension(:,:), allocatable :: a
real, dimension(:), allocatable :: b
real, dimension(:), allocatable :: u
real, dimension(:), allocatable :: r

real :: deter

integer :: n, i, j

print*
print*, 'Introduce o orde do sistema: '
read*, n
print*

print*
print*, 'O orde introduce e: ', n
print*

allocate(a(n,n), b(n), u(n), r(n))

call datasissim(a, b, u)

call residuo(a, b, u, r)

if (allocated(a)) deallocate(a)

if (allocated(b)) deallocate(b)

if (allocated(u)) deallocate(u)

if(allocated(r)) deallocate(r)

end program


program preprocessor11
! #if with >, <, ==
implicit none

#define X 1
#define Y 5
#define Z 1+Y*3

print *, Z

#if X == 1
print *, "X is 1"
#else
print *, "X is not 1"
#endif

#if X == 2
print *, "X is 2"
#else
print *, "X is not 2"
#endif

#if X != 1
print *, "X is not 1"
#else
print *, "Not X is not 1"
#endif

#if X == 1 && Y == 5
print *, "X is 1 and Y is 5"
#else
print *, "Not (X is 1 and Y is 5)"
#endif

#if X == 2 && Y == 5
print *, "X is 2 and Y is 5"
#else
print *, "Not (X is 2 and Y is 5)"
#endif

#if X < 3 && Y > 3
print *, "X<3 and Y>3"
#else
print *, "Not (X<3 and Y>3)"
#endif

#if X > 3 && Y < 3
print *, "X>3 and Y<3"
#else
print *, "Not (X>3 and Y<3)"
#endif

#if X == 3-2
print *, "X is 3-2"
#else
print *, "X is not 3-2"
#endif

#if X == 3-1
print *, "X is 3-1"
#else
print *, "X is not 3-1"
#endif

#if Y == (6*5-5)/5
print *, "Y is (6*5-5)/5"
#else
print *, "Y is not (6*5-5)/5"
#endif

#if Y == (6*5-6)/5
print *, "Y is (6*5-6)/5"
#else
print *, "Y is not (6*5-6)/5"
#endif

#if Y == (-5+6*5)/5
print *, "Y is (-5+6*5)/5"
#else
print *, "Y is not (-5+6*5)/5"
#endif

#if Y == (-6+6*5)/5
print *, "Y is (-6+6*5)/5"
#else
print *, "Y is not (-6+6*5)/5"
#endif

#if Y == (+5+6*5)/7
print *, "Y is (+5+6*5)/7"
#else
print *, "Y is not (+5+6*5)/7"
#endif

#if Y == (+4+6*5)/7
print *, "Y is (+4+6*5)/7"
#else
print *, "Y is not (+4+6*5)/7"
#endif

#if Y == (+5+6*Y)/7
print *, "Y is (+5+6*Y)/7"
#else
print *, "Y is not (+5+6*Y)/7"
#endif

#if Z == 16
print *, "Z is 16"
#else
print *, "Z is not 16"
#endif

#if defined(Y) && (3 <= Y)
print *, "Y defined and 1 <= Y"
#else
print *, "Y not defined or not 1 <= Y"
#endif

#if defined(A) && (3 <= A)
print *, "A defined and 1 <= A"
#else
print *, "A not defined or not 1 <= A"
#endif

end program


      subroutine splind(x,y,tn2,tnl,l)
!     compute cubic coefficients for a curve x-y
      use kinddefine
      use coef, only:e,ne
      implicit none
      integer(kind=K4),intent(in) :: l
      integer(kind=K4) :: j,k,n
      real(kind=K8),dimension(300) :: a,b,c,d,dx,dy,g,sb,xm
      real(kind=K8),dimension(l),intent(in) :: x,y
      real(kind=K8),intent(in) :: tn2,tnl
      real(kind=K8) :: dxr,one,p,px,pxx,pxxx,q,qx,qxx,qxxx,r,s,six,sw
      real(kind=K8):: thr,xj,xk,zero
      data zero/0.0d+0/,one/1.d+0/,thr/3.d+0/,six/6.d+0/
!      call orez (e,5*200)
!      call orez (a,9*300)
      e(:,:)=0.0d0
      a(:)=0.0d0
      b(:)=0.0d0
      c(:)=0.0d0
      d(:)=0.0d0
      dx(:)=0.0d0
      dy(:)=0.0d0
      g(:)=0.0d0
      sb(:)=0.0d0
      xm(:)=0.0d0
!
      dx(1)=zero
      dy(1)=zero
      n=l-1
      do k=2,l
       dx(k)=x(k)-x(k-1)
       dy(k)=y(k)-y(k-1)
      enddo
!
      b(1)=dx(2)/thr
      c(1)=dx(2)/six
      d(1)=dy(2)/dx(2)-tn2
      a(l)=dx(l)/six
      b(l)=dx(l)/thr
      d(l)=tnl-dy(l)/dx(l)
      a(1)=zero
      do k=2,n
       a(k)=dx(k)/six
       b(k)=(dx(k)+dx(k+1))/thr
       d(k)=dy(k+1)/dx(k+1)-dy(k)/dx(k)
       c(k)=dx(k+1)/six
      enddo
      sw=one/b(1)
      sb(1)=sw*c(1)
      g(1)=sw*d(1)
      do k=2,l
       sw=one/(b(k)-a(k)*sb(k-1))
       sb(k)=sw*c(k)
       g(k)=sw*(d(k)-a(k)*g(k-1))
      enddo
      xm(l)=g(l)
      do k=1,n
       j=l-k
       xm(j)=g(j)-sb(j)*xm(j+1)
      enddo
      do k=2,l
       dxr=one/dx(k)
       q=dxr/six
       p=-xm(k-1)*q
       q=q*xm(k)
       r=dx(k)*xm(k-1)/six-dxr*y(k-1)
       s=y(k)*dxr-dx(k)*xm(k)/six
       xk=x(k)
       px=xk*p
       pxx=px*xk
       pxxx=pxx*xk
       xj=x(k-1)
       qx=xj*q
       qxx=qx*xj
       qxxx=qxx*xj
       e(2,k)=p+q
       e(3,k)=-thr*(px+qx)
       e(4,k)=thr*(pxx+qxx)+r+s
       e(5,k)=-pxxx-qxxx-r*xk-s*xj
      enddo
      do k=2,l
       e(1,k)=x(k)
      enddo
      e(1,1)=x(1)
      ne=l
      end subroutine splind


!     -----------------------------------------------------------------
!
!     global_data_m.f90
!
!
!     -----------------------------------------------------------------

MODULE global_data_m

	IMPLICIT NONE

! Constants

	REAL, PARAMETER :: 	pi = 3.14159265358979
	REAL, PARAMETER :: 	keV_per_erg = 1./1.6022e-9

	REAL, PARAMETER :: mass_e = 9.1094e-28		! mass in G
	REAL, PARAMETER :: mass_H = 1836*mass_e		! mass in G
	REAL, PARAMETER :: mass_D = 3670*mass_e		! mass in G
	REAL, PARAMETER :: mass_T = 5497*mass_e		! mass in G
	REAL, PARAMETER :: mass_3He = 5496*mass_e	! mass in G
	REAL, PARAMETER :: mass_4He = 7294*mass_e	! mass in G

! Parameters for program control

	LOGICAL :: l_read_file, l_interpolate_st_grid, l_show_graphics, l_cont_plot_f_st &
				& , l_plot_f_v, l_plot_f_cum, l_plot_f_Max, l_plot_delta_f

! Flags

	LOGICAL :: lHave_Distribution = .false.

! Parameters for plotting and labels

	INTEGER, PARAMETER :: kPlotParams = 6, kparam_label_length = 12, &
			& curve_label_length = 12
	REAL :: PlotParams(kPlotParams)
	CHARACTER (len=kparam_label_length) :: PlotLabels(kPlotParams), xLabel, yLabel
	CHARACTER (len=72) :: PlotTitle
	CHARACTER (len=curve_label_length) :: PlotCurveLabels(10)

! *******************************************************************

END MODULE global_data_m


!==========================================
! integration.f90
! Author: Devansh Shukla
!------------------------------------------
program integration
    implicit none
    ! Define the variables
    real*8 :: x, y, a=0.0, b=0.0, max=0.0, min=0.0, step=0.1, t=0, i=0.0, r=0.0
    real*8 :: f, area, int_area, j
    integer :: hits=0, n=0
    character(len=*), parameter :: fmt="(xF10.3,xF10.3,xF10.3)"

    ! Define the function
    f(x) = (x**2 + 4*x + 9)**3 * (2*x + 4)

    ! Open the data file
    open(unit=8, file="int_area.dat")

    ! Get input from the user
    print *, "Enter a, b"
    read *, a, b
    print *, "Enter step, n"
    read *, step, n
    print *, "-------------------"

    ! Max of f(x) in [a, b]
    i = a
    max = f(i)
    min = f(i)
    do while (i .le. b)
        t = f(i)
        if (max .lt. t) then
            max = t
        endif
        if (min .gt. t) then
            min = t
        endif
        i = i + step
    enddo
    print "(A,F10.3,xxA,F10.3)", "MIN:", min, "MAX:", max
    j = 0.0
    ! Compute the integration
    do while(j .le. n)
        call random_number(r)
        x = a + (b-a)*r
        call random_number(r)
        y = abs(max*r)
        ! print "(F10.3, xxF10.3)", y, f(x)
        write (8, fmt) x, y, f(x)
        if (y .le. abs(f(x))) then
                hits = hits + 1
        endif
    j = j + step
    enddo

    area = (b-a) * max
    int_area = area * hits * step / real(n)
    ! Print for the user
    print "(A,I6)", "HITS=", hits
    print "(A,F10.3)", "INTEGRATION AREA=", int_area
    print *, "-------------------"

    ! Close the data file
    close(8)

end program integration


*DECK FAC
      FUNCTION FAC (N)
C***BEGIN PROLOGUE  FAC
C***PURPOSE  Compute the factorial function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C1
C***TYPE      SINGLE PRECISION (FAC-S, DFAC-D)
C***KEYWORDS  FACTORIAL, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C FAC(N) evaluates the factorial function of N.  FAC is single
C precision.  N must be an integer between 0 and 25 inclusive.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  GAMLIM, R9LGMC, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  FAC
      DIMENSION FACN(26)
      SAVE FACN, SQ2PIL, NMAX
      DATA FACN( 1) / 1.0E0 /
      DATA FACN( 2) / 1.0E0 /
      DATA FACN( 3) / 2.0E0 /
      DATA FACN( 4) / 6.0E0 /
      DATA FACN( 5) / 24.0E0 /
      DATA FACN( 6) / 120.0E0 /
      DATA FACN( 7) / 720.0E0 /
      DATA FACN( 8) / 5040.0E0 /
      DATA FACN( 9) / 40320.0E0 /
      DATA FACN(10) / 362880.0E0 /
      DATA FACN(11) / 3628800.0E0 /
      DATA FACN(12) / 39916800.0E0 /
      DATA FACN(13) / 479001600.0E0 /
      DATA FACN(14) / 6227020800.0E0 /
      DATA FACN(15) / 87178291200.0E0 /
      DATA FACN(16) / 1307674368000.0E0 /
      DATA FACN(17) / 20922789888000.0E0 /
      DATA FACN(18) / 355687428096000.0E0 /
      DATA FACN(19) / 6402373705728000.0E0 /
      DATA FACN(20) /  .12164510040883200E18 /
      DATA FACN(21) /  .24329020081766400E19 /
      DATA FACN(22) /  .51090942171709440E20 /
      DATA FACN(23) /  .11240007277776077E22 /
      DATA FACN(24) /  .25852016738884977E23 /
      DATA FACN(25) /  .62044840173323944E24 /
      DATA FACN(26) /  .15511210043330986E26 /
      DATA SQ2PIL / 0.9189385332 0467274E0/
      DATA NMAX / 0 /
C***FIRST EXECUTABLE STATEMENT  FAC
      IF (NMAX.NE.0) GO TO 10
      CALL GAMLIM (XMIN, XMAX)
      NMAX = XMAX - 1.
C
 10   IF (N .LT. 0) CALL XERMSG ('SLATEC', 'FAC',
     +   'FACTORIAL OF NEGATIVE INTEGER UNDEFINED', 1, 2)
C
      IF (N.LE.25) FAC = FACN(N+1)
      IF (N.LE.25) RETURN
C
      IF (N .GT. NMAX) CALL XERMSG ('SLATEC', 'FAC',
     +   'N SO BIG FACTORIAL(N) OVERFLOWS', 2, 2)
C
      X = N + 1
      FAC = EXP ( (X-0.5)*LOG(X) - X + SQ2PIL + R9LGMC(X) )
C
      RETURN
      END


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(scalar_laplacian_routines) scalar_laplacian_regular_grid_saved

contains
    !     subroutine slapes(nlat, nlon, isym, nt, slap, ids, jds, a, b, mdab, ndab, &
    !                       wshses, ierror)
    !
    !
    !     given the scalar spherical harmonic coefficients a and b, precomputed
    !     by subroutine shaes for a scalar field sf, subroutine slapes computes
    !     the laplacian of sf in the scalar array slap.  slap(i, j) is the
    !     laplacian of sf at the colatitude
    !
    !         theta(i) = (i-1)*pi/(nlat-1)
    !
    !     and east longitude
    !
    !         lambda(j) = (j-1)*2*pi/nlon
    !
    !     on the sphere.  i.e.
    !
    !         slap(i, j) =
    !
    !                  2                2
    !         [1/sint*d (sf(i, j)/dlambda + d(sint*d(sf(i, j))/dtheta)/dtheta]/sint
    !
    !
    !     where sint = sin(theta(i)).  the scalar laplacian in slap has the
    !     same symmetry or absence of symmetry about the equator as the scalar
    !     field sf.  the input parameters isym, nt, mdab, ndab must have the
    !     same values used by shaes to compute a and b for sf. the associated
    !     legendre functions are stored rather than recomputed as they are
    !     in subroutine slapec.

    !
    !     input parameters
    !
    !     nlat   the number of colatitudes on the full sphere including the
    !            poles. for example, nlat = 37 for a five degree grid.
    !            nlat determines the grid increment in colatitude as
    !            pi/(nlat-1).  if nlat is odd the equator is located at
    !            grid point i=(nlat + 1)/2. if nlat is even the equator is
    !            located half way between points i=nlat/2 and i=nlat/2+1.
    !            nlat must be at least 3. note: on the half sphere, the
    !            number of grid points in the colatitudinal direction is
    !            nlat/2 if nlat is even or (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct longitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater
    !            than zero. the axisymmetric case corresponds to nlon=1.
    !            the efficiency of the computation is improved when nlon
    !            is a product of small prime numbers.
    !
    !     isym   this parameter should have the same value input to subroutine
    !            shaes to compute the coefficients a and b for the scalar field
    !            sf.  isym is set as follows:
    !
    !            = 0  no symmetries exist in sf about the equator. scalar
    !                 synthesis is used to compute slap on the entire sphere.
    !                 i.e., in the array slap(i, j) for i=1, ..., nlat and
    !                 j=1, ..., nlon.
    !
    !           = 1  sf and slap are antisymmetric about the equator. the
    !                synthesis used to compute slap is performed on the
    !                northern hemisphere only.  if nlat is odd, slap(i, j) is
    !                computed for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.  if
    !                nlat is even, slap(i, j) is computed for i=1, ..., nlat/2
    !                and j=1, ..., nlon.
    !
    !
    !           = 2  sf and slap are symmetric about the equator. the
    !                synthesis used to compute slap is performed on the
    !                northern hemisphere only.  if nlat is odd, slap(i, j) is
    !                computed for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.  if
    !                nlat is even, slap(i, j) is computed for i=1, ..., nlat/2
    !                and j=1, ..., nlon.
    !
    !
    !     nt     the number of analyses.  in the program that calls slapes
    !            the arrays slap, a, and b can be three dimensional in which
    !            case multiple synthesis will be performed.  the third index
    !            is the synthesis index which assumes the values k=1, ..., nt.
    !            for a single analysis set nt=1. the description of the
    !            remaining parameters is simplified by assuming that nt=1
    !            or that all the arrays are two dimensional.
    !
    !   ids      the first dimension of the array slap as it appears in the
    !            program that calls slapes.  if isym = 0 then ids must be at
    !            least nlat.  if isym > 0 and nlat is even then ids must be
    !            at least nlat/2. if isym > 0 and nlat is odd then ids must
    !            be at least (nlat + 1)/2.
    !
    !   jds      the second dimension of the array slap as it appears in the
    !            program that calls slapes. jds must be at least nlon.
    !
    !
    !   a, b      two or three dimensional arrays (see input parameter nt)
    !            that contain scalar spherical harmonic coefficients
    !            of the scalar field sf as computed by subroutine shaes.
    !     ***    a, b must be computed by shaes prior to calling slapes.
    !
    !
    !    mdab    the first dimension of the arrays a and b as it appears
    !            in the program that calls slapes.  mdab must be at
    !            least min(nlat, (nlon+2)/2) if nlon is even or at least
    !            min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !    ndab    the second dimension of the arrays a and b as it appears
    !            in the program that calls slapes. ndbc must be at least
    !            least nlat.
    !
    !            mdab, ndab should have the same values input to shaes to
    !            compute the coefficients a and b.
    !
    !
    !    wshses  an array which must be initialized by subroutine shsesi
    !            before calling slapes.  once initialized, wshses
    !            can be used repeatedly by slapes as long as nlat and nlon
    !            remain unchanged.  wshses must not be altered between calls
    !            of slapes.
    !
    !    lshses  the dimension of the array wshses as it appears in the
    !            program that calls slapes.  let
    !
    !               l1 = min(nlat, (nlon+2)/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd
    !
    !            then lshses must be greater than or equal to
    !
    !               (l1*l2*(2*nlat-l1+1))/2+nlon+15.
    !
    !     output parameters
    !
    !
    !    slap    a two or three dimensional arrays (see input parameter nt) that
    !            contain the scalar laplacian of the scalar field sf.  slap(i, j)
    !            is the scalar laplacian at the colatitude
    !
    !                 theta(i) = (i-1)*pi/(nlat-1)
    !
    !            and longitude
    !
    !                 lambda(j) = (j-1)*2*pi/nlon
    !
    !            for i=1, ..., nlat and j=1, ..., nlon.
    !
    !
    !  ierror    a parameter which flags errors in input parameters as follows:
    !
    !            = 0  no errors detected
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of isym
    !            = 4  error in the specification of nt
    !            = 5  error in the specification of ids
    !            = 6  error in the specification of jds
    !            = 7  error in the specification of mdbc
    !            = 8  error in the specification of ndbc
    !            = 9  error in the specification of lshses
    !
    module subroutine slapes(nlat, nlon, isym, nt, slap, ids, jds, a, b, &
        mdab, ndab, wshses, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: isym
        integer(ip), intent(in)  :: nt
        real(wp),    intent(out) :: slap(ids, jds, nt)
        integer(ip), intent(in)  :: ids
        integer(ip), intent(in)  :: jds
        real(wp),    intent(in)  :: a(mdab, ndab, nt)
        real(wp),    intent(in)  :: b(mdab, ndab, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        real(wp),    intent(in)  :: wshses(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip)                  :: required_wavetable_size
        type(ScalarSynthesisUtility) :: util

        ! Check input arguments
        required_wavetable_size = util%get_lshses(nlat, nlon)

        call util%check_scalar_transform_inputs(isym, ids, jds, &
            mdab, ndab, nlat, nlon, nt, required_wavetable_size, &
            wshses, ierror)

        ! Check error flag
        if (ierror /= 0) return

        call scalar_laplacian_lower_utility_routine(nlat, nlon, isym, nt, slap, &
            a, b, wshses, shses, ierror)

    end subroutine slapes

end submodule scalar_laplacian_regular_grid_saved


MODULE randdp
! Replaces COMMON /randpp/ and defines dp

IMPLICIT NONE
INTEGER, PARAMETER, PUBLIC :: dp = SELECTED_REAL_KIND(15, 60)

REAL (dp), SAVE, PUBLIC    :: poly(101), other, offset
INTEGER, SAVE, PUBLIC      :: index

CONTAINS

!   Nick Maclaren's double precision random number generator.
!   This version, which is compatible with Lahey's ELF90 compiler,
!   is by Alan Miller ( alan @ vic.cmis.csiro.au, www.vic.cmis.csiro.au/~alan )

!   Latest revision - 18 December 1997

!   Copyright (C) 1992  N.M. Maclaren
!   Copyright (C) 1992  The University of Cambridge

!   This software may be reproduced and used freely, provided that all
!   users of it agree that the copyright holders are not liable for any
!   damage or injury caused by use of this software and that this
!   condition is passed onto all subsequent recipients of the software,
!   whether modified or not.

SUBROUTINE sdprnd (iseed)

INTEGER, INTENT(IN)  :: iseed

! Local variables
REAL (dp)            :: x
REAL (dp), PARAMETER :: xmod = 1000009711.0_dp, ymod = 33554432.0_dp
INTEGER              :: ix, iy, iz, i
LOGICAL, SAVE        :: inital = .TRUE.

!   ISEED should be set to an integer between 0 and 9999 inclusive;
!   a value of 0 will initialise the generator only if it has not
!   already been done.

IF (inital .OR. iseed /= 0) THEN
  inital = .false.
ELSE
  RETURN
END IF

!   INDEX must be initialised to an integer between 1 and 101 inclusive,
!   POLY(1...N) to integers between 0 and 1000009710 inclusive (not all 0),
!   and OTHER to a non-negative proper fraction with denominator 33554432.
!   It uses the Wichmann-Hill generator to do this.

ix = MOD(ABS(iseed), 10000) + 1
iy = 2*ix + 1
iz = 3*ix + 1
DO i = -10,101
  IF (i >= 1) poly(i) = AINT(xmod*x)
  ix = MOD(171*ix, 30269)
  iy = MOD(172*iy, 30307)
  iz = MOD(170*iz, 30323)
  x = MOD(DBLE(ix)/30269.0_dp + DBLE(iy)/30307.0_dp + DBLE(iz)/30323.0_dp, 1.0_dp)
END DO
other = AINT(ymod*x)/ymod
offset = 1.0_dp/ymod
INDEX = 1

RETURN
END SUBROUTINE sdprnd

FUNCTION dprand() RESULT(fn_val)

REAL (dp)            :: fn_val

! Local variables
REAL (dp)            :: x, y

! N.B. ymod has been removed from the previous DATA statement; it caused a
!      fatal error as it is not used.
REAL (dp), PARAMETER :: xmod = 1000009711.0_dp, xmod2 = 2000019422.0_dp, &
                        xmod4 = 4000038844.0_dp, tiny = 1.0E-17_dp,  &
                        zero = 0.0_dp, one = 1.0_dp
INTEGER              :: n
LOGICAL, SAVE        :: inital = .TRUE.

!   This returns a uniform (0,1) random number, with extremely good
!   uniformity properties.  It assumes that REAL (dp) provides
!   at least 33 bits of accuracy, and uses a power of two base.

IF (inital) THEN
  CALL sdprnd (0)
  inital = .false.
END IF

!   See [Knuth] for why this implements the algorithm described in the paper.
!   Note that this code is tuned for machines with fast REAL (dp), but
!   slow multiply and divide; many, many other options are possible.

n = INDEX - 64
IF (n <= 0) n = n + 101
x = poly(INDEX) + poly(INDEX)
x = xmod4 - poly(n) - poly(n) - x - x - poly(INDEX)
IF (x < zero) THEN
  IF (x < -xmod) x = x + xmod2
  IF (x < zero) x = x + xmod
ELSE
  IF (x >= xmod2) THEN
    x = x - xmod2
    IF (x >= xmod) x = x - xmod
  END IF
  IF (x >= xmod) x = x - xmod
END IF
poly(INDEX) = x
INDEX = INDEX + 1
IF (INDEX > 101) INDEX = INDEX - 101

!   Add in the second generator modulo 1, and force to be non-zero.
!   The restricted ranges largely cancel themselves out.

DO
  y = 37.0_dp*other + offset
  other = y - AINT(y)
  IF (other /= zero) EXIT
END DO

x = x/xmod + other
IF (x >= one) x = x - one
fn_val = x + tiny

RETURN
END FUNCTION dprand

END MODULE randdp


subroutine dff_test2
use enforce
use cluster
use paracluster

implicit none

integer :: i,n,k
real, allocatable :: dft(:)
real :: arg,freq

allocate(dft(npas))

do i = 1,npas
	dft(i) = 0.d0
enddo

do k=1,npas
	freq = 1.d0/(k*tstep)
	arg = -(2.d0*pi*dble(1.d0/freq)/npas)
	do n =1,npas
		dft(k) = dft(k) + cos(arg*dble(n))*vel_act_est(n)
	enddo
	write(60,*) freq,dft(k)*dft(k)
enddo

end subroutine dff_test2

!======================================================

subroutine dff_test
use ENFORCE!, only: vel_act_est
use CLUSTER
use PARACLUSTER

implicit none

!variables needed:      - N = npas + 1
!			- k = index for N
!			- n = index for chosen frequency
!PLAN:
!	INITIALISE -- size of dft

integer :: N,N_i,freq,a,b,i
real, allocatable :: dft(:,:)
real :: arg

!N = npas + 1!SIZE(vel_acf_est)
!do i = 0,npas
!	write(*,*) vel_act_est(i)
!enddo

allocate(dft(0:npas,2))

do a = 0,npas
	dft(a,1) = 0.d0
	dft(a,2) = 0.d0
end do

!open(11,file = 'fort.59', status = 'old' , action = 'read')

!do b = 0,N
!	read(11,*) dft(b)
!end do
!open(60, file = 'fort.60', status = 'new', action = 'write')

do freq = 1,npas
	do N_i = 1,npas
	arg = -(2*pi*dble(N_i)/npas)
	!write(13,*) N_i,arg
	dft(freq,1) = dft(freq,1) + cos(arg*dble(freq)*tstep)*vel_act_est(N_i)!/npas
	!write(14,*) N_i ,dft(N_i,1) , cos(arg) ,vel_act_est(freq)
	!dft(N_i,2) = dft(N_i,2) + sin(arg*dble(freq))*vel_act_est(freq)!/npas
	!write(15,*) N_i,dft(N_i,2) , sin(arg) ,vel_act_est(freq)
	end do
write(60,*) freq , dft(freq,1)*dft(freq,1) !+ dft(N_i,2)*dft(N_i,2)
end do

!do N_i = 0,npas
	!dft(N_i,1)=dft(N_i,1)/npas
	!dft(N_i,2)=dft(N_i,2)/npas
	!write(60,*) N_i , dft(N_i,1)*dft(N_i,1) + dft(N_i,2)*dft(N_i,2)
!end do

end subroutine dff_test


program semantic_error
    implicit none
    integer :: i
    do i = 0, 3
        print '(2I5)', i, fac(i)
    end do
contains

    integer function fac(n)
        implicit none
        integer, intent(in) :: n
        integer :: i
        fac = 1
        do i = 0, n
            fac = fac*i
        end do
    end function fac

end program semantic_error


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file vtsgs.f
c
c     this file includes documentation and code for
c     subroutines vtsgs and vtsgsi
c
c ... files which must be loaded with vtsgs.f
c
c     sphcom.f, hrfft.f, vhags.f, vhsgs.f,gaqd.f
c
c
c     subroutine vtsgs(nlat,nlon,ityp,nt,vt,wt,idvw,jdvw,br,bi,cr,ci,
c    +                 mdab,ndab,wvts,lwvts,work,lwork,ierror)
c
c     given the vector harmonic analysis br,bi,cr, and ci (computed
c     by subroutine vhags) of some vector function (v,w), this
c     subroutine computes the vector function (vt,wt) which is
c     the derivative of (v,w) with respect to colatitude theta. vtsgs
c     is similar to vhsgs except the vector harmonics are replaced by
c     their derivative with respect to colatitude with the result that
c     (vt,wt) is computed instead of (v,w). vt(i,j) is the derivative
c     of the colatitudinal component v(i,j) at the gaussian colatitude
c     point theta(i) and longitude phi(j) = (j-1)*2*pi/nlon. the
c     spectral representation of (vt,wt) is given below at output
c     parameters vt,wt.
c
c     input parameters
c
c     nlat   the number of gaussian colatitudinal grid points theta(i)
c            such that 0 < theta(1) <...< theta(nlat) < pi. they are
c            computed by subroutine gaqd which is called by this
c            subroutine. if nlat is odd the equator is
c            theta((nlat+1)/2). if nlat is even the equator lies
c            half way between theta(nlat/2) and theta(nlat/2+1). nlat
c            must be at least 3. note: if (v,w) is symmetric about
c            the equator (see parameter ityp below) the number of
c            colatitudinal grid points is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     ityp   = 0  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere. i.e. the arrays
c                 vt(i,j),wt(i,j) are computed for i=1,...,nlat and
c                 j=1,...,nlon.
c
c            = 1  no symmetries exist about the equator however the
c                 the coefficients cr and ci are zero which implies
c                 that the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the calculations are performed on the entire sphere.
c                 i.e. the arrays vt(i,j),wt(i,j) are computed for
c                 i=1,...,nlat and j=1,...,nlon.
c
c            = 2  no symmetries exist about the equator however the
c                 the coefficients br and bi are zero which implies
c                 that the divergence of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the calculations are performed on the entire sphere.
c                 i.e. the arrays vt(i,j),wt(i,j) are computed for
c                 i=1,...,nlat and j=1,...,nlon.
c
c            = 3  vt is odd and wt is even about the equator. the
c                 synthesis is performed on the northern hemisphere
c                 only.  i.e., if nlat is odd the arrays vt(i,j)
c                 and wt(i,j) are computed for i=1,...,(nlat+1)/2
c                 and j=1,...,nlon. if nlat is even the arrays
c                 are computed for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 4  vt is odd and wt is even about the equator and the
c                 coefficients cr and ci are zero. the synthesis is
c                 performed on the northern hemisphere only. i.e. if
c                 nlat is odd the arrays vt(i,j),wt(i,j) are computed
c                 for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the arrays vt(i,j),wt(i,j) are computed for
c                 i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 5  vt is odd and wt is even about the equator and the
c                 coefficients br and bi are zero. the synthesis is
c                 performed on the northern hemisphere only. i.e. if
c                 nlat is odd the arrays vt(i,j),wt(i,j) are computed
c                 for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the arrays vt(i,j),wt(i,j) are computed for
c                 i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 6  vt is even and wt is odd about the equator. the
c                 synthesis is performed on the northern hemisphere
c                 only.  i.e., if nlat is odd the arrays vt(i,j),wt(i,j)
c                 are computed for i=1,...,(nlat+1)/2 and j=1,...,nlon.
C*PL*ERROR* Comment line too long
c                 if nlat is even the arrays vt(i,j),wt(i,j) are computed
c                 for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 7  vt is even and wt is odd about the equator and the
c                 coefficients cr and ci are zero. the synthesis is
c                 performed on the northern hemisphere only. i.e. if
c                 nlat is odd the arrays vt(i,j),wt(i,j) are computed
c                 for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the arrays vt(i,j),wt(i,j) are computed for
c                 i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 8  vt is even and wt is odd about the equator and the
c                 coefficients br and bi are zero. the synthesis is
c                 performed on the northern hemisphere only. i.e. if
c                 nlat is odd the arrays vt(i,j),wt(i,j) are computed
c                 for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the arrays vt(i,j),wt(i,j) are computed for
c                 i=1,...,nlat/2 and j=1,...,nlon.
c
c     nt     the number of syntheses.  in the program that calls vtsgs,
c            the arrays vt,wt,br,bi,cr, and ci can be three dimensional
c            in which case multiple syntheses will be performed.
c            the third index is the synthesis index which assumes the
c            values k=1,...,nt.  for a single synthesis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that all the arrays are two
c            dimensional.
c
c     idvw   the first dimension of the arrays vt,wt as it appears in
c            the program that calls vtsgs. if ityp .le. 2 then idvw
c            must be at least nlat.  if ityp .gt. 2 and nlat is
c            even then idvw must be at least nlat/2. if ityp .gt. 2
c            and nlat is odd then idvw must be at least (nlat+1)/2.
c
c     jdvw   the second dimension of the arrays vt,wt as it appears in
c            the program that calls vtsgs. jdvw must be at least nlon.
c
c     br,bi  two or three dimensional arrays (see input parameter nt)
c     cr,ci  that contain the vector spherical harmonic coefficients
c            of (v,w) as computed by subroutine vhags.
c
c     mdab   the first dimension of the arrays br,bi,cr, and ci as it
c            appears in the program that calls vtsgs. mdab must be at
c            least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndab   the second dimension of the arrays br,bi,cr, and ci as it
c            appears in the program that calls vtsgs. ndab must be at
c            least nlat.
c
c     wvts   an array which must be initialized by subroutine vtsgsi.
c            once initialized, wvts can be used repeatedly by vtsgs
c            as long as nlon and nlat remain unchanged.  wvts must
c            not be altered between calls of vtsgs.
c
c     lwvts  the dimension of the array wvts as it appears in the
c            program that calls vtsgs. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lwvts must be at least
c
c                 l1*l2*(nlat+nlat-l1+1)+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls vtsgs. define
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            if ityp .le. 2 then lwork must be at least
c
c                       (2*nt+1)*nlat*nlon
c
c            if ityp .gt. 2 then lwork must be at least
c
c                        (2*nt+1)*l2*nlon
c
c     **************************************************************
c
c     output parameters
c
c     vt,wt  two or three dimensional arrays (see input parameter nt)
c            in which the derivative of (v,w) with respect to
c            colatitude theta is stored. vt(i,j),wt(i,j) contain the
c            derivatives at gaussian colatitude points theta(i) for
c            i=1,...,nlat and longitude phi(j) = (j-1)*2*pi/nlon.
c            the index ranges are defined above at the input parameter
c            ityp. vt and wt are computed from the formulas for v and
c            w given in subroutine vhsgs but with vbar and wbar replaced
c           with their derivatives with respect to colatitude. these
c            derivatives are denoted by vtbar and wtbar.
c
c
c   *************************************************************
c
c   in terms of real variables this expansion takes the form
c
c             for i=1,...,nlat and  j=1,...,nlon
c
c     vt(i,j) = the sum from n=1 to n=nlat-1 of
c
c               .5*br(1,n+1)*vtbar(0,n,theta(i))
c
c     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
c     n=nlat-1 of the real part of
c
c       (br(m+1,n+1)*vtbar(m,n,theta(i))
c                   -ci(m+1,n+1)*wtbar(m,n,theta(i)))*cos(m*phi(j))
c      -(bi(m+1,n+1)*vtbar(m,n,theta(i))
c                   +cr(m+1,n+1)*wtbar(m,n,theta(i)))*sin(m*phi(j))
c
c    and for i=1,...,nlat and  j=1,...,nlon
c
c     wt(i,j) = the sum from n=1 to n=nlat-1 of
c
c              -.5*cr(1,n+1)*vtbar(0,n,theta(i))
c
c     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
c     n=nlat-1 of the real part of
c
c      -(cr(m+1,n+1)*vtbar(m,n,theta(i))
c                   +bi(m+1,n+1)*wtbar(m,n,theta(i)))*cos(m*phi(j))
c      +(ci(m+1,n+1)*vtbar(m,n,theta(i))
c                   -br(m+1,n+1)*wtbar(m,n,theta(i)))*sin(m*phi(j))
c
c
c      br(m+1,nlat),bi(m+1,nlat),cr(m+1,nlat), and ci(m+1,nlat) are
c      assumed zero for m even.
c
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of ityp
c            = 4  error in the specification of nt
c            = 5  error in the specification of idvw
c            = 6  error in the specification of jdvw
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lwvts
c            = 10 error in the specification of lwork
c
c
c *******************************************************************
c
c     subroutine vtsgsi(nlat,nlon,wvts,lwvts,work,lwork,dwork,ldwork,
c    +                  ierror)
c
c     subroutine vtsgsi initializes the array wvts which can then be
c     used repeatedly by subroutine vtsgs until nlat or nlon is changed.
c
c     input parameters
c
c     nlat   the number of gaussian colatitudinal grid points theta(i)
c            such that 0 < theta(1) <...< theta(nlat) < pi. they are
c            computed by subroutine gaqd which is called by this
c            subroutine. if nlat is odd the equator is
c            theta((nlat+1)/2). if nlat is even the equator lies
c            half way between theta(nlat/2) and theta(nlat/2+1). nlat
c            must be at least 3. note: if (v,w) is symmetric about
c            the equator (see parameter ityp below) the number of
c            colatitudinal grid points is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     lwvts  the dimension of the array wvts as it appears in the
c            program that calls vtsgs. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lwvts must be at least
c
c                  l1*l2*(nlat+nlat-l1+1)+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls vtsgs. lwork must be at least
c
c            3*(max0(l1-2,0)*(nlat+nlat-l1-1))/2+(5*l2+2)*nlat
c
C*PL*ERROR* Comment line too long
c     dwork  a double precision work array that does not have to be saved
c
c     ldwork the length of dwork.  ldwork must be at least
c            3*nlat+2
c
c     **************************************************************
c
c     output parameters
c
c     wvts   an array which is initialized for use by subroutine vtsgs.
c            once initialized, wvts can be used repeatedly by vtsgs
c            as long as nlat or nlon remain unchanged.  wvts must not
c            be altered between calls of vtsgs.
c
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lwvts
c            = 4  error in the specification of lwork
c            = 5  error in the specification of ldwork
c
      SUBROUTINE DVTSGS(NLAT,NLON,ITYP,NT,VT,WT,IDVW,JDVW,BR,BI,CR,CI,
     +                 MDAB,NDAB,WVTS,LWVTS,WORK,LWORK,IERROR)
      DOUBLE PRECISION VT
      DOUBLE PRECISION WT
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION CR
      DOUBLE PRECISION CI
      DOUBLE PRECISION WVTS
      DOUBLE PRECISION WORK
c
      DIMENSION VT(IDVW,JDVW,1),WT(IDVW,JDVW,1),BR(MDAB,NDAB,1),
     +          BI(MDAB,NDAB,1),CR(MDAB,NDAB,1),CI(MDAB,NDAB,1),WORK(1),
     +          WVTS(1)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.1) RETURN
      IERROR = 3
      IF (ITYP.LT.0 .OR. ITYP.GT.8) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      IMID = (NLAT+1)/2
      IF ((ITYP.LE.2.AND.IDVW.LT.NLAT) .OR.
     +    (ITYP.GT.2.AND.IDVW.LT.IMID)) RETURN
      IERROR = 6
      IF (JDVW.LT.NLON) RETURN
      IERROR = 7
      MMAX = MIN0(NLAT, (NLON+1)/2)
      IF (MDAB.LT.MMAX) RETURN
      IERROR = 8
      IF (NDAB.LT.NLAT) RETURN
      IERROR = 9
      IDZ = (MMAX* (NLAT+NLAT-MMAX+1))/2
      LZIMN = IDZ*IMID
      IF (LWVTS.LT.LZIMN+LZIMN+NLON+15) RETURN
      IERROR = 10
      IDV = NLAT
      IF (ITYP.GT.2) IDV = IMID
      LNL = NT*IDV*NLON
      IF (LWORK.LT.LNL+LNL+IDV*NLON) RETURN
      IERROR = 0
      IST = 0
      IF (ITYP.LE.2) IST = IMID
      IW1 = IST + 1
      IW2 = LNL + 1
      IW3 = IW2 + IST
      IW4 = IW2 + LNL
      JW1 = LZIMN + 1
      JW2 = JW1 + LZIMN
      CALL DVTSGS1(NLAT,NLON,ITYP,NT,IMID,IDVW,JDVW,VT,WT,MDAB,NDAB,BR,
     +            BI,CR,CI,IDV,WORK,WORK(IW1),WORK(IW2),WORK(IW3),
     +            WORK(IW4),IDZ,WVTS,WVTS(JW1),WVTS(JW2))
      RETURN
      END
      SUBROUTINE DVTSGS1(NLAT,NLON,ITYP,NT,IMID,IDVW,JDVW,VT,WT,MDAB,
     +                  NDAB,BR,BI,CR,CI,IDV,VTE,VTO,WTE,WTO,WORK,IDZ,
     +                  VB,WB,WRFFT)
      DOUBLE PRECISION VT
      DOUBLE PRECISION WT
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION CR
      DOUBLE PRECISION CI
      DOUBLE PRECISION VTE
      DOUBLE PRECISION VTO
      DOUBLE PRECISION WTE
      DOUBLE PRECISION WTO
      DOUBLE PRECISION WORK
      DOUBLE PRECISION VB
      DOUBLE PRECISION WB
      DOUBLE PRECISION WRFFT
      DIMENSION VT(IDVW,JDVW,1),WT(IDVW,JDVW,1),BR(MDAB,NDAB,1),
     +          BI(MDAB,NDAB,1),CR(MDAB,NDAB,1),CI(MDAB,NDAB,1),
     +          VTE(IDV,NLON,1),VTO(IDV,NLON,1),WTE(IDV,NLON,1),
     +          WTO(IDV,NLON,1),WORK(1),WRFFT(1),VB(IMID,1),WB(IMID,1)

      NLP1 = NLAT + 1
      MLAT = MOD(NLAT,2)
      MLON = MOD(NLON,2)
      MMAX = MIN0(NLAT, (NLON+1)/2)
      IMM1 = IMID
      IF (MLAT.NE.0) IMM1 = IMID - 1
      DO 10 K = 1,NT
          DO 10 J = 1,NLON
              DO 10 I = 1,IDV
                  VTE(I,J,K) = 0.D0
                  WTE(I,J,K) = 0.D0
   10 CONTINUE
      NDO1 = NLAT
      NDO2 = NLAT
      IF (MLAT.NE.0) NDO1 = NLAT - 1
      IF (MLAT.EQ.0) NDO2 = NLAT - 1
   18 ITYPP = ITYP + 1
      GO TO (1,100,200,300,400,500,600,700,800) ITYPP
c
c     case ityp=0   no symmetries
c
c     case m = 0
c
    1 DO 15 K = 1,NT
          DO 15 NP1 = 2,NDO2,2
              DO 15 I = 1,IMM1
                  VTO(I,1,K) = VTO(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
                  WTO(I,1,K) = WTO(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
   15 CONTINUE
      DO 16 K = 1,NT
          DO 16 NP1 = 3,NDO1,2
              DO 16 I = 1,IMID
                  VTE(I,1,K) = VTE(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
                  WTE(I,1,K) = WTE(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
   16 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 30 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 26
          DO 25 K = 1,NT
              DO 24 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 23 I = 1,IMM1
                      VTE(I,2*MP1-2,K) = VTE(I,2*MP1-2,K) +
     +                                   BR(MP1,NP1,K)*VB(I,MN)
                      VTO(I,2*MP1-2,K) = VTO(I,2*MP1-2,K) -
     +                                   CI(MP1,NP1,K)*WB(I,MN)
                      VTE(I,2*MP1-1,K) = VTE(I,2*MP1-1,K) +
     +                                   BI(MP1,NP1,K)*VB(I,MN)
                      VTO(I,2*MP1-1,K) = VTO(I,2*MP1-1,K) +
     +                                   CR(MP1,NP1,K)*WB(I,MN)
                      WTE(I,2*MP1-2,K) = WTE(I,2*MP1-2,K) -
     +                                   CR(MP1,NP1,K)*VB(I,MN)
                      WTO(I,2*MP1-2,K) = WTO(I,2*MP1-2,K) -
     +                                   BI(MP1,NP1,K)*WB(I,MN)
                      WTE(I,2*MP1-1,K) = WTE(I,2*MP1-1,K) -
     +                                   CI(MP1,NP1,K)*VB(I,MN)
                      WTO(I,2*MP1-1,K) = WTO(I,2*MP1-1,K) +
     +                                   BR(MP1,NP1,K)*WB(I,MN)
   23             CONTINUE
                  IF (MLAT.EQ.0) GO TO 24
                  VTE(IMID,2*MP1-2,K) = VTE(IMID,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(IMID,MN)
                  VTE(IMID,2*MP1-1,K) = VTE(IMID,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(IMID,MN)
                  WTE(IMID,2*MP1-2,K) = WTE(IMID,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(IMID,MN)
                  WTE(IMID,2*MP1-1,K) = WTE(IMID,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(IMID,MN)
   24         CONTINUE
   25     CONTINUE
   26     IF (MP2.GT.NDO2) GO TO 30
          DO 29 K = 1,NT
              DO 28 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 27 I = 1,IMM1
                      VTO(I,2*MP1-2,K) = VTO(I,2*MP1-2,K) +
     +                                   BR(MP1,NP1,K)*VB(I,MN)
                      VTE(I,2*MP1-2,K) = VTE(I,2*MP1-2,K) -
     +                                   CI(MP1,NP1,K)*WB(I,MN)
                      VTO(I,2*MP1-1,K) = VTO(I,2*MP1-1,K) +
     +                                   BI(MP1,NP1,K)*VB(I,MN)
                      VTE(I,2*MP1-1,K) = VTE(I,2*MP1-1,K) +
     +                                   CR(MP1,NP1,K)*WB(I,MN)
                      WTO(I,2*MP1-2,K) = WTO(I,2*MP1-2,K) -
     +                                   CR(MP1,NP1,K)*VB(I,MN)
                      WTE(I,2*MP1-2,K) = WTE(I,2*MP1-2,K) -
     +                                   BI(MP1,NP1,K)*WB(I,MN)
                      WTO(I,2*MP1-1,K) = WTO(I,2*MP1-1,K) -
     +                                   CI(MP1,NP1,K)*VB(I,MN)
                      WTE(I,2*MP1-1,K) = WTE(I,2*MP1-1,K) +
     +                                   BR(MP1,NP1,K)*WB(I,MN)
   27             CONTINUE
                  IF (MLAT.EQ.0) GO TO 28
                  VTE(IMID,2*MP1-2,K) = VTE(IMID,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(IMID,MN)
                  VTE(IMID,2*MP1-1,K) = VTE(IMID,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(IMID,MN)
                  WTE(IMID,2*MP1-2,K) = WTE(IMID,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(IMID,MN)
                  WTE(IMID,2*MP1-1,K) = WTE(IMID,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(IMID,MN)
   28         CONTINUE
   29     CONTINUE
   30 CONTINUE
      GO TO 950
c
c     case ityp=1   no symmetries,  cr and ci equal zero
c
c     case m = 0
c
  100 DO 115 K = 1,NT
          DO 115 NP1 = 2,NDO2,2
              DO 115 I = 1,IMM1
                  VTO(I,1,K) = VTO(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
  115 CONTINUE
      DO 116 K = 1,NT
          DO 116 NP1 = 3,NDO1,2
              DO 116 I = 1,IMID
                  VTE(I,1,K) = VTE(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
  116 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 130 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 126
          DO 125 K = 1,NT
              DO 124 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 123 I = 1,IMM1
                      VTE(I,2*MP1-2,K) = VTE(I,2*MP1-2,K) +
     +                                   BR(MP1,NP1,K)*VB(I,MN)
                      VTE(I,2*MP1-1,K) = VTE(I,2*MP1-1,K) +
     +                                   BI(MP1,NP1,K)*VB(I,MN)
                      WTO(I,2*MP1-2,K) = WTO(I,2*MP1-2,K) -
     +                                   BI(MP1,NP1,K)*WB(I,MN)
                      WTO(I,2*MP1-1,K) = WTO(I,2*MP1-1,K) +
     +                                   BR(MP1,NP1,K)*WB(I,MN)
  123             CONTINUE
                  IF (MLAT.EQ.0) GO TO 124
                  VTE(IMID,2*MP1-2,K) = VTE(IMID,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(IMID,MN)
                  VTE(IMID,2*MP1-1,K) = VTE(IMID,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(IMID,MN)
  124         CONTINUE
  125     CONTINUE
  126     IF (MP2.GT.NDO2) GO TO 130
          DO 129 K = 1,NT
              DO 128 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 127 I = 1,IMM1
                      VTO(I,2*MP1-2,K) = VTO(I,2*MP1-2,K) +
     +                                   BR(MP1,NP1,K)*VB(I,MN)
                      VTO(I,2*MP1-1,K) = VTO(I,2*MP1-1,K) +
     +                                   BI(MP1,NP1,K)*VB(I,MN)
                      WTE(I,2*MP1-2,K) = WTE(I,2*MP1-2,K) -
     +                                   BI(MP1,NP1,K)*WB(I,MN)
                      WTE(I,2*MP1-1,K) = WTE(I,2*MP1-1,K) +
     +                                   BR(MP1,NP1,K)*WB(I,MN)
  127             CONTINUE
                  IF (MLAT.EQ.0) GO TO 128
                  WTE(IMID,2*MP1-2,K) = WTE(IMID,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(IMID,MN)
                  WTE(IMID,2*MP1-1,K) = WTE(IMID,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(IMID,MN)
  128         CONTINUE
  129     CONTINUE
  130 CONTINUE
      GO TO 950
c
c     case ityp=2   no symmetries,  br and bi are equal to zero
c
c     case m = 0
c
  200 DO 215 K = 1,NT
          DO 215 NP1 = 2,NDO2,2
              DO 215 I = 1,IMM1
                  WTO(I,1,K) = WTO(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
  215 CONTINUE
      DO 216 K = 1,NT
          DO 216 NP1 = 3,NDO1,2
              DO 216 I = 1,IMID
                  WTE(I,1,K) = WTE(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
  216 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 230 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 226
          DO 225 K = 1,NT
              DO 224 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 223 I = 1,IMM1
                      VTO(I,2*MP1-2,K) = VTO(I,2*MP1-2,K) -
     +                                   CI(MP1,NP1,K)*WB(I,MN)
                      VTO(I,2*MP1-1,K) = VTO(I,2*MP1-1,K) +
     +                                   CR(MP1,NP1,K)*WB(I,MN)
                      WTE(I,2*MP1-2,K) = WTE(I,2*MP1-2,K) -
     +                                   CR(MP1,NP1,K)*VB(I,MN)
                      WTE(I,2*MP1-1,K) = WTE(I,2*MP1-1,K) -
     +                                   CI(MP1,NP1,K)*VB(I,MN)
  223             CONTINUE
                  IF (MLAT.EQ.0) GO TO 224
                  WTE(IMID,2*MP1-2,K) = WTE(IMID,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(IMID,MN)
                  WTE(IMID,2*MP1-1,K) = WTE(IMID,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(IMID,MN)
  224         CONTINUE
  225     CONTINUE
  226     IF (MP2.GT.NDO2) GO TO 230
          DO 229 K = 1,NT
              DO 228 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 227 I = 1,IMM1
                      VTE(I,2*MP1-2,K) = VTE(I,2*MP1-2,K) -
     +                                   CI(MP1,NP1,K)*WB(I,MN)
                      VTE(I,2*MP1-1,K) = VTE(I,2*MP1-1,K) +
     +                                   CR(MP1,NP1,K)*WB(I,MN)
                      WTO(I,2*MP1-2,K) = WTO(I,2*MP1-2,K) -
     +                                   CR(MP1,NP1,K)*VB(I,MN)
                      WTO(I,2*MP1-1,K) = WTO(I,2*MP1-1,K) -
     +                                   CI(MP1,NP1,K)*VB(I,MN)
  227             CONTINUE
                  IF (MLAT.EQ.0) GO TO 228
                  VTE(IMID,2*MP1-2,K) = VTE(IMID,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(IMID,MN)
                  VTE(IMID,2*MP1-1,K) = VTE(IMID,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(IMID,MN)
  228         CONTINUE
  229     CONTINUE
  230 CONTINUE
      GO TO 950
c
c     case ityp=3   v odd,  w even
c
c     case m = 0
c
  300 DO 315 K = 1,NT
          DO 315 NP1 = 2,NDO2,2
              DO 315 I = 1,IMM1
                  VTO(I,1,K) = VTO(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
  315 CONTINUE
      DO 316 K = 1,NT
          DO 316 NP1 = 3,NDO1,2
              DO 316 I = 1,IMID
                  WTE(I,1,K) = WTE(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
  316 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 330 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 326
          DO 325 K = 1,NT
              DO 324 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 323 I = 1,IMM1
                      VTO(I,2*MP1-2,K) = VTO(I,2*MP1-2,K) -
     +                                   CI(MP1,NP1,K)*WB(I,MN)
                      VTO(I,2*MP1-1,K) = VTO(I,2*MP1-1,K) +
     +                                   CR(MP1,NP1,K)*WB(I,MN)
                      WTE(I,2*MP1-2,K) = WTE(I,2*MP1-2,K) -
     +                                   CR(MP1,NP1,K)*VB(I,MN)
                      WTE(I,2*MP1-1,K) = WTE(I,2*MP1-1,K) -
     +                                   CI(MP1,NP1,K)*VB(I,MN)
  323             CONTINUE
                  IF (MLAT.EQ.0) GO TO 324
                  WTE(IMID,2*MP1-2,K) = WTE(IMID,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(IMID,MN)
                  WTE(IMID,2*MP1-1,K) = WTE(IMID,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(IMID,MN)
  324         CONTINUE
  325     CONTINUE
  326     IF (MP2.GT.NDO2) GO TO 330
          DO 329 K = 1,NT
              DO 328 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 327 I = 1,IMM1
                      VTO(I,2*MP1-2,K) = VTO(I,2*MP1-2,K) +
     +                                   BR(MP1,NP1,K)*VB(I,MN)
                      VTO(I,2*MP1-1,K) = VTO(I,2*MP1-1,K) +
     +                                   BI(MP1,NP1,K)*VB(I,MN)
                      WTE(I,2*MP1-2,K) = WTE(I,2*MP1-2,K) -
     +                                   BI(MP1,NP1,K)*WB(I,MN)
                      WTE(I,2*MP1-1,K) = WTE(I,2*MP1-1,K) +
     +                                   BR(MP1,NP1,K)*WB(I,MN)
  327             CONTINUE
                  IF (MLAT.EQ.0) GO TO 328
                  WTE(IMID,2*MP1-2,K) = WTE(IMID,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(IMID,MN)
                  WTE(IMID,2*MP1-1,K) = WTE(IMID,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(IMID,MN)
  328         CONTINUE
  329     CONTINUE
  330 CONTINUE
      GO TO 950
c
c     case ityp=4   v odd,  w even, and both cr and ci equal zero
c
c     case m = 0
c
  400 DO 415 K = 1,NT
          DO 415 NP1 = 2,NDO2,2
              DO 415 I = 1,IMM1
                  VTO(I,1,K) = VTO(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
  415 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 430 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          MP2 = MP1 + 1
          IF (MP2.GT.NDO2) GO TO 430
          DO 429 K = 1,NT
              DO 428 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 427 I = 1,IMM1
                      VTO(I,2*MP1-2,K) = VTO(I,2*MP1-2,K) +
     +                                   BR(MP1,NP1,K)*VB(I,MN)
                      VTO(I,2*MP1-1,K) = VTO(I,2*MP1-1,K) +
     +                                   BI(MP1,NP1,K)*VB(I,MN)
                      WTE(I,2*MP1-2,K) = WTE(I,2*MP1-2,K) -
     +                                   BI(MP1,NP1,K)*WB(I,MN)
                      WTE(I,2*MP1-1,K) = WTE(I,2*MP1-1,K) +
     +                                   BR(MP1,NP1,K)*WB(I,MN)
  427             CONTINUE
                  IF (MLAT.EQ.0) GO TO 428
                  WTE(IMID,2*MP1-2,K) = WTE(IMID,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(IMID,MN)
                  WTE(IMID,2*MP1-1,K) = WTE(IMID,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(IMID,MN)
  428         CONTINUE
  429     CONTINUE
  430 CONTINUE
      GO TO 950
c
c     case ityp=5   v odd,  w even,     br and bi equal zero
c
c     case m = 0
c
  500 DO 516 K = 1,NT
          DO 516 NP1 = 3,NDO1,2
              DO 516 I = 1,IMID
                  WTE(I,1,K) = WTE(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
  516 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 530 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 530
          DO 525 K = 1,NT
              DO 524 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 523 I = 1,IMM1
                      VTO(I,2*MP1-2,K) = VTO(I,2*MP1-2,K) -
     +                                   CI(MP1,NP1,K)*WB(I,MN)
                      VTO(I,2*MP1-1,K) = VTO(I,2*MP1-1,K) +
     +                                   CR(MP1,NP1,K)*WB(I,MN)
                      WTE(I,2*MP1-2,K) = WTE(I,2*MP1-2,K) -
     +                                   CR(MP1,NP1,K)*VB(I,MN)
                      WTE(I,2*MP1-1,K) = WTE(I,2*MP1-1,K) -
     +                                   CI(MP1,NP1,K)*VB(I,MN)
  523             CONTINUE
                  IF (MLAT.EQ.0) GO TO 524
                  WTE(IMID,2*MP1-2,K) = WTE(IMID,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(IMID,MN)
                  WTE(IMID,2*MP1-1,K) = WTE(IMID,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(IMID,MN)
  524         CONTINUE
  525     CONTINUE
  530 CONTINUE
      GO TO 950
c
c     case ityp=6   v even  ,  w odd
c
c     case m = 0
c
  600 DO 615 K = 1,NT
          DO 615 NP1 = 2,NDO2,2
              DO 615 I = 1,IMM1
                  WTO(I,1,K) = WTO(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
  615 CONTINUE
      DO 616 K = 1,NT
          DO 616 NP1 = 3,NDO1,2
              DO 616 I = 1,IMID
                  VTE(I,1,K) = VTE(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
  616 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 630 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 626
          DO 625 K = 1,NT
              DO 624 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 623 I = 1,IMM1
                      VTE(I,2*MP1-2,K) = VTE(I,2*MP1-2,K) +
     +                                   BR(MP1,NP1,K)*VB(I,MN)
                      VTE(I,2*MP1-1,K) = VTE(I,2*MP1-1,K) +
     +                                   BI(MP1,NP1,K)*VB(I,MN)
                      WTO(I,2*MP1-2,K) = WTO(I,2*MP1-2,K) -
     +                                   BI(MP1,NP1,K)*WB(I,MN)
                      WTO(I,2*MP1-1,K) = WTO(I,2*MP1-1,K) +
     +                                   BR(MP1,NP1,K)*WB(I,MN)
  623             CONTINUE
                  IF (MLAT.EQ.0) GO TO 624
                  VTE(IMID,2*MP1-2,K) = VTE(IMID,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(IMID,MN)
                  VTE(IMID,2*MP1-1,K) = VTE(IMID,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(IMID,MN)
  624         CONTINUE
  625     CONTINUE
  626     IF (MP2.GT.NDO2) GO TO 630
          DO 629 K = 1,NT
              DO 628 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 627 I = 1,IMM1
                      VTE(I,2*MP1-2,K) = VTE(I,2*MP1-2,K) -
     +                                   CI(MP1,NP1,K)*WB(I,MN)
                      VTE(I,2*MP1-1,K) = VTE(I,2*MP1-1,K) +
     +                                   CR(MP1,NP1,K)*WB(I,MN)
                      WTO(I,2*MP1-2,K) = WTO(I,2*MP1-2,K) -
     +                                   CR(MP1,NP1,K)*VB(I,MN)
                      WTO(I,2*MP1-1,K) = WTO(I,2*MP1-1,K) -
     +                                   CI(MP1,NP1,K)*VB(I,MN)
  627             CONTINUE
                  IF (MLAT.EQ.0) GO TO 628
                  VTE(IMID,2*MP1-2,K) = VTE(IMID,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(IMID,MN)
                  VTE(IMID,2*MP1-1,K) = VTE(IMID,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(IMID,MN)
  628         CONTINUE
  629     CONTINUE
  630 CONTINUE
      GO TO 950
c
c     case ityp=7   v even, w odd   cr and ci equal zero
c
c     case m = 0
c
  700 DO 716 K = 1,NT
          DO 716 NP1 = 3,NDO1,2
              DO 716 I = 1,IMID
                  VTE(I,1,K) = VTE(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
  716 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 730 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 730
          DO 725 K = 1,NT
              DO 724 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 723 I = 1,IMM1
                      VTE(I,2*MP1-2,K) = VTE(I,2*MP1-2,K) +
     +                                   BR(MP1,NP1,K)*VB(I,MN)
                      VTE(I,2*MP1-1,K) = VTE(I,2*MP1-1,K) +
     +                                   BI(MP1,NP1,K)*VB(I,MN)
                      WTO(I,2*MP1-2,K) = WTO(I,2*MP1-2,K) -
     +                                   BI(MP1,NP1,K)*WB(I,MN)
                      WTO(I,2*MP1-1,K) = WTO(I,2*MP1-1,K) +
     +                                   BR(MP1,NP1,K)*WB(I,MN)
  723             CONTINUE
                  IF (MLAT.EQ.0) GO TO 724
                  VTE(IMID,2*MP1-2,K) = VTE(IMID,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(IMID,MN)
                  VTE(IMID,2*MP1-1,K) = VTE(IMID,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(IMID,MN)
  724         CONTINUE
  725     CONTINUE
  730 CONTINUE
      GO TO 950
c
c     case ityp=8   v even,  w odd,   br and bi equal zero
c
c     case m = 0
c
  800 DO 815 K = 1,NT
          DO 815 NP1 = 2,NDO2,2
              DO 815 I = 1,IMM1
                  WTO(I,1,K) = WTO(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
  815 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 830 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          MP2 = MP1 + 1
          IF (MP2.GT.NDO2) GO TO 830
          DO 829 K = 1,NT
              DO 828 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 827 I = 1,IMM1
                      VTE(I,2*MP1-2,K) = VTE(I,2*MP1-2,K) -
     +                                   CI(MP1,NP1,K)*WB(I,MN)
                      VTE(I,2*MP1-1,K) = VTE(I,2*MP1-1,K) +
     +                                   CR(MP1,NP1,K)*WB(I,MN)
                      WTO(I,2*MP1-2,K) = WTO(I,2*MP1-2,K) -
     +                                   CR(MP1,NP1,K)*VB(I,MN)
                      WTO(I,2*MP1-1,K) = WTO(I,2*MP1-1,K) -
     +                                   CI(MP1,NP1,K)*VB(I,MN)
  827             CONTINUE
                  IF (MLAT.EQ.0) GO TO 828
                  VTE(IMID,2*MP1-2,K) = VTE(IMID,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(IMID,MN)
                  VTE(IMID,2*MP1-1,K) = VTE(IMID,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(IMID,MN)
  828         CONTINUE
  829     CONTINUE
  830 CONTINUE
  950 DO 14 K = 1,NT
          CALL DHRFFTB(IDV,NLON,VTE(1,1,K),IDV,WRFFT,WORK)
          CALL DHRFFTB(IDV,NLON,WTE(1,1,K),IDV,WRFFT,WORK)
   14 CONTINUE
      IF (ITYP.GT.2) GO TO 12
      DO 60 K = 1,NT
          DO 60 J = 1,NLON
              DO 60 I = 1,IMM1
                  VT(I,J,K) = .5D0* (VTE(I,J,K)+VTO(I,J,K))
                  WT(I,J,K) = .5D0* (WTE(I,J,K)+WTO(I,J,K))
                  VT(NLP1-I,J,K) = .5D0* (VTE(I,J,K)-VTO(I,J,K))
                  WT(NLP1-I,J,K) = .5D0* (WTE(I,J,K)-WTO(I,J,K))
   60 CONTINUE
      GO TO 13
   12 DO 11 K = 1,NT
          DO 11 J = 1,NLON
              DO 11 I = 1,IMM1
                  VT(I,J,K) = .5D0*VTE(I,J,K)
                  WT(I,J,K) = .5D0*WTE(I,J,K)
   11 CONTINUE
   13 IF (MLAT.EQ.0) RETURN
      DO 65 K = 1,NT
          DO 65 J = 1,NLON
              VT(IMID,J,K) = .5D0*VTE(IMID,J,K)
              WT(IMID,J,K) = .5D0*WTE(IMID,J,K)
   65 CONTINUE
      RETURN
      END
      SUBROUTINE DVTSGSI(NLAT,NLON,WVTS,LWVTS,WORK,LWORK,DWORK,LDWORK,
     +                  IERROR)
      DOUBLE PRECISION WVTS
      DOUBLE PRECISION WORK
c
c     define imid = (nlat+1)/2 and mmax = min0(nlat,(nlon+1)/2)
c     the length of wvts is imid*mmax*(nlat+nlat-mmax+1)+nlon+15
c     and the length of work is labc+5*nlat*imid+2*nlat where
c     labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
c
      DIMENSION WVTS(LWVTS),WORK(LWORK)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(LDWORK)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.1) RETURN
      IERROR = 3
      MMAX = MIN0(NLAT,NLON/2+1)
      IMID = (NLAT+1)/2
      LZIMN = (IMID*MMAX* (NLAT+NLAT-MMAX+1))/2
      IF (LWVTS.LT.LZIMN+LZIMN+NLON+15) RETURN
      IERROR = 4
      LABC = 3* (MAX0(MMAX-2,0)* (NLAT+NLAT-MMAX-1))/2
      LVIN = 3*NLAT*IMID
      LWVBIN = 2*NLAT*IMID + LABC
      LTHETA = NLAT + NLAT
      IF (LWORK.LT.LVIN+LWVBIN+LTHETA) RETURN
      IERROR = 5
      IF (LDWORK.LT.3*NLAT+2) RETURN
      IERROR = 0
      IW1 = LVIN + 1
      IW2 = IW1 + LWVBIN
      JW1 = NLAT + 1
      JW2 = JW1 + NLAT
      CALL DVETG1(NLAT,NLON,IMID,WVTS,WVTS(LZIMN+1),WORK,WORK(IW1),
     +            DWORK,DWORK(JW1),DWORK(JW2),IERROR)
      IF (IERROR.NE.0) RETURN
      CALL DHRFFTI(NLON,WVTS(2*LZIMN+1))
      RETURN
      END
      SUBROUTINE DVETG1(NLAT,NLON,IMID,VB,WB,VIN,WVBIN,THETA,WTS,DWORK,
     +                 IERROR)
      DOUBLE PRECISION VB
      DOUBLE PRECISION WB
      DOUBLE PRECISION VIN
      DOUBLE PRECISION WVBIN
      DIMENSION VB(IMID,*),WB(IMID,*),VIN(IMID,NLAT,3),WVBIN(*)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(*),THETA(*),WTS(*)

      MMAX = MIN0(NLAT,NLON/2+1)
      LDWORK = 1
      CALL DGAQD(NLAT,THETA,WTS,DWORK,LDWORK,IERR)
      IF (IERR.EQ.0) GO TO 10
      IERROR = 10 + IERR
      RETURN
   10 CALL DVTGINT(NLAT,NLON,THETA,WVBIN,DWORK)
      DO 33 MP1 = 1,MMAX
          M = MP1 - 1
          CALL DVBIN(0,NLAT,NLON,M,VIN,I3,WVBIN)
          DO 33 NP1 = MP1,NLAT
              MN = M* (NLAT-1) - (M* (M-1))/2 + NP1
              DO 33 I = 1,IMID
                  VB(I,MN) = VIN(I,NP1,I3)
   33 CONTINUE
      CALL DWTGINT(NLAT,NLON,THETA,WVBIN,DWORK)
      DO 34 MP1 = 1,MMAX
          M = MP1 - 1
          CALL DWBIN(0,NLAT,NLON,M,VIN,I3,WVBIN)
          DO 34 NP1 = MP1,NLAT
              MN = M* (NLAT-1) - (M* (M-1))/2 + NP1
              DO 34 I = 1,IMID
                  WB(I,MN) = VIN(I,NP1,I3)
   34 CONTINUE
      RETURN
      END


C
C

*+ fun_gammq

       real function fun_gammq( a, x, istat )
C      --------------------------------------
C
C Returns the incomplete gamma function Q(a,x) by argument
C
C Given:
C   parameters for the function
       real*4       a, x
C Updated:
C   error return
       integer      istat
C
C The incomplete Gamma function Q(a,x) is defined by:
C \[
C   Q(a,x) = 1 - \frac{1}{\Gamma(a)} \int_{0}^{x} e^{-t}t^{a-1} dt
C \]
C
C ISTAT should be zero on entry.  The values set by this routine are:
C     ILL_INPUTS         == illegal ranges on input data.
C     ILL_PRECISION      == unable to calculate function to sufficient
C                           precision.  This error can be returned from
C                           one of the internal routines and results from
C                           a to large or not enough iterations within
C                           the respective routine.  This error MUST
C                           be reported.
C
C
C P. Alexander, MRAO, Cambridge.
C Ref: Numerical Recipes, Press et al., Cambridge. pg. 161.
C-

       include '../include/utilities_errors.inc'

C local variables
       real*4    gamser, gammcf, gln

       if (istat.ne.0) return

       if (x.lt.0.0 .or. a.le.0.0) then
         istat = ill_inputs
         fun_gammq = 0.0
       else
         if (x.lt.a+1.0) then
C .. use series representation
           call fun_gser(gamser,a,x,gln,istat)
C .. take complement
           fun_gammq = 1.0 - gamser
         else
C .. use continued fraction
           call fun_gcf(gammcf,a,x,gln,istat)
           fun_gammq = gammcf
         end if
       end if
       call utl_err( istat,'fun_gammq','Failed' )
       end


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE PXN2 (RETMIN, PARTYP, LENARY, NELBLK, IXELB, ISEVOK,
     &           NUMIX, IXNODE, IXELEM, SIG11, SIG22, SIG12, RESULT)
C=======================================================================

C   --*** PXN2 *** (ALGEBRA) Calculate 2x2 principal values
C   --   Written by Amy Gilkey - revised 05/17/88
C   --
C   --PXN2 determines minimum or maximum principal values for a 2 by 2
C   --array.
C   --
C   --Parameters:
C   --   RETMIN - IN - true iff minimum versus maximum to be calculated
C   --   PARTYP - IN - the parameter type (element must be handled differently)
C   --   LENARY - IN - the length of the parameter arrays
C   --   NELBLK - IN - the number of element blocks
C   --   IXELB  - IN - the cumulative element counts for each element block
C   --   ISEVOK - IN - the element variable truth table for each element block
C   --   NUMIX  - IN - the number of selected values; <0 if all
C   --   IXNODE - IN - the indices of the selected nodes (only if NUMIX >= 0)
C   --   IXELEM - IN - the indices of the selected elements (only if NUMIX >= 0)
C   --   SIG11, SIG22, SIG12 - IN - the tensor components
C   --   RESULT - OUT - the returned principal values

      LOGICAL RETMIN
      CHARACTER PARTYP
      INTEGER IXELB(0:NELBLK)
      LOGICAL ISEVOK(*)
      INTEGER IXNODE(*)
      INTEGER IXELEM(*)
      REAL SIG11(*), SIG22(*), SIG12(*)
      REAL RESULT(*)

      IF (NUMIX .GE. 0) THEN
         IF (PARTYP .NE. 'E') THEN
            DO 100 I = 1, NUMIX
               J = IXNODE(I)
               SROOT = SQRT
     &            ((0.5 * (SIG11(J)-SIG22(J)))**2 + SIG12(J)**2)

               IF (RETMIN) THEN
                  RESULT(J) = 0.5 * (SIG11(J)+SIG22(J)) - SROOT
               ELSE
                  RESULT(J) = 0.5 * (SIG11(J)+SIG22(J)) + SROOT
               END IF
  100       CONTINUE
         ELSE
            DO 120 IELB = 1, NELBLK
               IF (ISEVOK(IELB)) THEN
                  DO 110 I = IXELB(IELB-1)+1, IXELB(IELB)
                     J = IXELEM(I)
                     SROOT = SQRT
     &                  ((0.5 * (SIG11(J)-SIG22(J)))**2 + SIG12(J)**2)

                     IF (RETMIN) THEN
                        RESULT(J) = 0.5 * (SIG11(J)+SIG22(J)) - SROOT
                     ELSE
                        RESULT(J) = 0.5 * (SIG11(J)+SIG22(J)) + SROOT
                     END IF
  110             CONTINUE
               END IF
  120       CONTINUE
         END IF

      ELSE
C        NUMIX < 0; ALL VALUES SELECTED
C        NUMEL=NUMELO; NUMNP=NUMNPO; IXELB(J)=IXELBO(J), J=1,NELBLK
         IF (PARTYP .NE. 'E') THEN
            DO 130 J = 1, LENARY
               SROOT = SQRT
     &            ((0.5 * (SIG11(J)-SIG22(J)))**2 + SIG12(J)**2)

               IF (RETMIN) THEN
                  RESULT(J) = 0.5 * (SIG11(J)+SIG22(J)) - SROOT
               ELSE
                  RESULT(J) = 0.5 * (SIG11(J)+SIG22(J)) + SROOT
               END IF
  130       CONTINUE

         ELSE
            DO 150 IELB = 1, NELBLK
               IF (ISEVOK(IELB)) THEN
                  DO 140 J = IXELB(IELB-1)+1, IXELB(IELB)
                     SROOT = SQRT
     &                  ((0.5 * (SIG11(J)-SIG22(J)))**2 + SIG12(J)**2)

                     IF (RETMIN) THEN
                        RESULT(J) = 0.5 * (SIG11(J)+SIG22(J)) - SROOT
                     ELSE
                        RESULT(J) = 0.5 * (SIG11(J)+SIG22(J)) + SROOT
                     END IF
  140             CONTINUE
               END IF
  150       CONTINUE
         END IF
      END IF

      RETURN
      END


        subroutine equ_to_altaz_r(dec,ha,phi,alt,az)

        IMPLICIT REAL*8(A-Z)

        sindec = DSIN(dec)
        cosdec = DCOS(dec)
        sinphi = DSIN(phi)
        cosphi = DCOS(phi)
        cosha  = DCOS(ha)

        alt=ASIN (sinphi*sindec+cosphi*cosdec*cosha)
        az =ACOS((cosphi*sindec-sinphi*cosdec*cosha)/dcos(alt))

        if(ha .gt. 0 .and. ha .lt. 3.1415926535897932d0)then !    0 to +180
            az = 6.2831853071796D0 - az
        endif

        if(ha .lt. -3.1415926535897932d0)then                ! -360 to -180
            az = 6.2831853071796D0 - az
        endif

        return
        end

        subroutine angcoord_2d(c_conv,ni,nj,arg1,arg2,lat1,lon1,phi
     1                                               ,lat2,lon2)

!       General purpose angular coordinate transformations in 2D
!       This version works with single precision arguments in degrees

        include 'trigd.inc'

        parameter (pi = 3.1415926535897932E0)
        parameter (rpd = pi/180.)

        ANGDIF(X,Y)=MOD(X-Y+9.4247779607694E0,6.2831853071796E0)
     1                     -3.1415926535897932E0

        ATAN3DF(x,y) = MOD((ATAN2(x,y)/rpd+360E0),360E0)

        character*20 c_conv

        real lat1(ni,nj),lon1(ni,nj),lat2(ni,nj),lon2(ni,nj) ! degrees
        real lat2s,lon2arg,lst,lstmra,ll0,l0

        write(6,*)' subroutine angcoord_2d ',c_conv

        if(trim(c_conv) .eq. 'altaz2decra')then
          lst = arg1

          do i = 1,ni
          do j = 1,nj
            z = 90. - lat1(i,j)
            azi = lon1(i,j) - 180. ! Counted from meridian

            sindec = cosd(z)*sind(phi)-sind(z)*cosd(phi)*cosd(azi)
            sindec = max(min(sindec,1.0),-1.0)

            cosha = (cosd(z)*cosd(phi)+sind(z)*sind(phi)*cosd(azi))
     1                 /cosd(dec)
            cosdec = sqrt(1.-sindec**2)
            sinha = (sind(azi)*sind(z)) / cosdec
            dec = asind(sindec)
            ha = atan3df(sinha,cosha)
            ra = lst - ha

            lat2(i,j) = dec
            lon2(i,j) = ra
          enddo ! j
          enddo ! i

        elseif(trim(c_conv) .eq. 'decra2galactic')then
          ra0 = 282.86 ! ra of ascending node of galactic equator
          l0 = 32.93 ! galactic longitude of ascending node
          decngp = 27.13

          do i = 1,ni
          do j = 1,nj
            dec = lat1(i,j)
            ra = lon1(i,j)

            sinb = sind(dec)*sind(decngp)
     1           - cosd(dec)*cosd(decngp)*sind(ra-ra0)
            sinb = max(min(sinb,1.0),-1.0)

            cosb = sqrt(1.-sinb**2)
            cosll0 = cosd(ra-ra0)*cosd(dec)/cosb
            sinll0 = (sind(dec)*cosd(decngp)
     1             + cosd(dec)*sind(decngp)*sind(ra-ra0)) / cosb
            ll0 = atan3df(sinll0,cosll0)

            lat2(i,j) = asind(sinb)
            lon2(i,j) = ll0 + l0
          enddo ! j
          enddo ! i

        elseif(trim(c_conv) .eq. 'decra2helioecliptic')then
          obl = 23.446
          sollam = arg1
          do i = 1,ni
          do j = 1,nj
            dec = lat1(i,j)
            ra = lon1(i,j)
            sinb = sind(dec)*cosd(obl)-cosd(dec)*sind(obl)*sind(ra)
            sinb = max(min(sinb,1.0),-1.0)
            cosb = sqrt(1.-sinb**2)
            coslam = cosd(ra)*cosd(dec)/cosb
            sinlam = (sind(dec)*sind(obl)+cosd(dec)*cosd(obl)*sind(ra))
     1                         /cosb
            lat2(i,j) = asind(sinb)
            lon2(i,j) = atan3df(sinlam,coslam) - sollam
          enddo ! j
          enddo ! i
        endif

        where(lon2 .lt. 0.)
            lon2 = lon2 + 360.
        end where

        where(lon2 .gt. 360.)
            lon2 = lon2 - 360.
        end where

        return
        end


module setup_amr_mod

use constants_mod

real(dp), save :: fv8fv3Mat(3,8)
real(dp), save :: fv8fv3Tam(8,3)

contains

subroutine hook_pre_timestep_300

    use share_mod, only: mesh

    use mesh_utils_mod, only: mesh_adapt
    use mesh_utils_mod, only: mesh_partition

    call mesh_adapt(mesh,setup_amr_probe_refine,setup_amr_replace_refine,setup_amr_probe_coarsen,setup_amr_replace_coarsen)
    call mesh_partition(mesh)

end subroutine

subroutine hook_init_223

    use interpol_mod, only: LegendreGaussNodesAndWeights
    use subcellfv_mod, only: subcellfv_vanderMondeMatrix
    use linalg_mod, only: invert
    use utils_mod, only: pp

    real(dp) :: dgnodes(8), dgweights(8)

    real(dp) :: dg2fvMat8(8,8)
    real(dp) :: fv2dgMat8(8,8)

    call LegendreGaussNodesAndWeights(7,dgnodes,dgweights)
    call subcellfv_vanderMondeMatrix(8,8,dgnodes,dgweights,dg2fvMat8)
    fv2dgMat8 = invert(dg2fvMat8,8)

    call subcellfv_vanderMondeMatrix(8,3,dgnodes,dgweights,fv8fv3Mat)

    fv8fv3Mat = matmul(fv8fv3Mat,fv2dgMat8)
    fv8fv3Tam = transpose(fv8fv3Mat)

    ! call pp('fv8fv3Mat', fv8fv3Mat)
    ! call pp('fv8fv3Tam', fv8fv3Tam)

end subroutine

!! pure function calc_loehner(u)
!!
!!     real(dp), intent(in)    :: u(N_NODES,N_NODES)
!!     real(dp)                :: calc_loehner
!!
!!     real(dp), parameter :: eps = 0.25_dp
!!
!!     integer :: i,j
!!
!!     real(dp) :: xtemp(2:N_NODES-1,1:N_NODES)
!!     real(dp) :: ytemp(1:N_NODES,2:N_NODES-1)
!!
!!     forall (j = 1:N_NODES, i = 2:N_NODES-1)
!!         xtemp(i,j) = abs(u(i-1,j) - 2.0_dp*u(i,j) + u(i+1,j)) / &
!!             (abs(u(i+1,j)-u(i,j)) + abs(u(i,j)-u(i-1,j)) + &
!!             eps*(abs(u(i+1,j)) + 2.0_dp*abs(u(i,j)) + abs(u(i-1,j))))
!!     end forall
!!
!!     forall (j = 2:N_NODES-1, i = 1:N_NODES)
!!         ytemp(i,j) = abs(u(i,j-1) - 2.0_dp*u(i,j) + u(i,j+1)) / &
!!             (abs(u(i,j+1)-u(i,j)) + abs(u(i,j)-u(i,j-1)) + &
!!             eps*(abs(u(i,j+1)) + 2.0_dp*abs(u(i,j)) + abs(u(i,j-1))))
!!     end forall
!!
!!     calc_loehner = max(maxval(xtemp),maxval(ytemp))
!!
!! end function

pure function calc_loehner(u)

    real(dp), intent(in)    :: u(N_NODES,N_NODES)
    real(dp)                :: calc_loehner

    real(dp), parameter :: eps = 0.2_dp

    real(dp) :: stencil(-1:1,-1:1)
    real(dp) :: xtemp(-1:1)
    real(dp) :: ytemp(-1:1)

    integer :: i,j

    stencil = matmul(fv8fv3Mat,matmul(u,fv8fv3Tam))

    forall (j = -1:1)
        xtemp(j) = abs(stencil(-1,j) - 2.0_dp*stencil(0,j) + stencil(1,j)) / &
                 (abs(stencil(1,j)-stencil(0,j)) + abs(stencil(0,j)-stencil(-1,j)) + &
                 eps*(abs(stencil(1,j)) + 2.0_dp*abs(stencil(0,j)) + abs(stencil(-1,j))))
    end forall

    forall (i = -1:1)
         ytemp(i) = abs(stencil(i,-1) - 2.0_dp*stencil(i,0) + stencil(i,1)) / &
             (abs(stencil(i,1)-stencil(i,0)) + abs(stencil(i,0)-stencil(i,-1)) + &
             eps*(abs(stencil(i,1)) + 2.0_dp*abs(stencil(i,0)) + abs(stencil(i,-1))))
     end forall

    ! calc_loehner = max(maxval(xtemp),maxval(ytemp))
    calc_loehner = max(sum(xtemp)/3,sum(ytemp)/3)

end function

function setup_amr_probe_refine(quad) result(ok)

    use setup_config_mod
    use equations_const_mod
    use mesh_types_mod, only: quad_t
    use kernel_const_mod, only: DGFV_QMAX

    type(quad_t), intent(in)    :: quad
    logical                     :: ok

    real(dp) :: loehner

    real(dp), parameter :: reftol = 0.3_dp

# if PP_KERNEL_DGFV
    if (quad%aux%hydro%subcell) then
        ok = .true.
        return
    end if
# endif

    loehner = calc_loehner(quad%pld%hydro%state(:,:,DENS_VAR))

    ok = loehner > reftol

end function

function setup_amr_probe_coarsen(family) result(ok)

    use setup_config_mod
    use equations_const_mod
    use mesh_types_mod, only: quad_t
    use mesh_const_mod, only: MESH_CHILDREN
    use mesh_const_mod, only: MESH_CORNERS

    use kernel_const_mod, only: DGFV_QMAX
    use kernel_share_mod, only: coarseMat
    use kernel_share_mod, only: coarseTam
    use share_mod, only: rt => runtime
    use quad_utils_mod, only: quad_get_vertices

    type(quad_t), intent(in)    :: family(MESH_CHILDREN)
    logical                     :: ok

    real(dp) :: loehner
    real(dp), parameter :: cortol = 0.1_dp

    real(dp) :: verts(N_DIMS,MESH_CORNERS)
    real(dp) :: coarsened(N_NODES,N_NODES)

    integer :: q,h,f

    ! ok = .false.
    ! return

    ! do f = 1,MESH_CHILDREN
    !     if (family(f)%aux%hydro%subcell) then
    !         ok = .false.
    !         return
    !     end if
    ! end do

    if (rt%simtime < 0.0025_dp) then
        do f = 1,MESH_CHILDREN
            verts = quad_get_vertices(family(f))
            if (any(abs(SQRT(SUM((verts)**2,dim=1))) < init_amr_min_diameter)) then
                ok = .false.
                return
            end if
        end do
    end if

    coarsened = 0.0_dp
    do q = DGFV_QMAX,0,-1
        do f = 1,MESH_CHILDREN
            coarsened = coarsened + &
                matmul(coarseMat(:,:,X_DIR,f,q),matmul(family(f)%pld%hydro%state(:,:,DENS_VAR),coarseTam(:,:,Y_DIR,f,q)))
        end do
    end do

    loehner = calc_loehner(coarsened)

    ok = loehner < cortol

end function

subroutine setup_amr_replace_refine(incoming,outgoing)

    use mesh_types_mod, only: quad_t
    use mesh_const_mod, only: MESH_CHILDREN

    use kernel_share_mod, only: refineMat
    use kernel_share_mod, only: refineTam

    use kernel_const_mod, only: DGFV_QMAX
    use equations_mod, only: isvalid

    type(quad_t), intent(in)    :: incoming
    type(quad_t), intent(inout) :: outgoing(MESH_CHILDREN)

    integer :: q,h,f
    logical :: ok

    !do q = DGFV_QMAX,0,-1
    do q = 0,0,-1
        do f = 1,MESH_CHILDREN
            do h = 1,N_VARS
                outgoing(f)%pld%hydro%state(:,:,h) = &
                    matmul(refineMat(:,:,X_DIR,f,q),matmul(incoming%pld%hydro%state(:,:,h),refineTam(:,:,Y_DIR,f,q)))
            end do
            ok = isvalid(outgoing(f)%pld%hydro%state)
            if (.not.ok) exit
        end do
        if (ok) exit
    end do

end subroutine

subroutine setup_amr_replace_coarsen(incoming,outgoing)

    use mesh_types_mod, only: quad_t
    use mesh_const_mod, only: MESH_CHILDREN

    use kernel_const_mod, only: DGFV_QMAX
    use equations_mod, only: isvalid

    use kernel_share_mod, only: coarseMat
    use kernel_share_mod, only: coarseTam

    type(quad_t), intent(in)    :: incoming(MESH_CHILDREN)
    type(quad_t), intent(inout) :: outgoing

    integer :: q,h,f

    outgoing%pld%hydro%state = 0.0_dp
    !do q = DGFV_QMAX,0,-1
    do q = 0,0,-1
        do f = 1,MESH_CHILDREN
            do h = 1,N_VARS
                outgoing%pld%hydro%state(:,:,h) = outgoing%pld%hydro%state(:,:,h) + &
                    matmul(coarseMat(:,:,X_DIR,f,q),matmul(incoming(f)%pld%hydro%state(:,:,h),coarseTam(:,:,Y_DIR,f,q)))
            end do
        end do
        if (isvalid(outgoing%pld%hydro%state)) exit
    end do

end subroutine

end module


!> \brief module containing simulation parameters and constants
!> \author M.Theiss
module basic_parameters_mod
use working_prec_mod , only: rk, ik
  implicit none

  real(rk), parameter       :: PI = 3.14159265359_rk
  real(rk), parameter       :: ec = 1.60217733d-19  ! elementary charge in C (SI-units)
  real(rk), parameter       :: eps0 = 8.854187817d-12   ! Permittivität des Vakuums  in SI: As/(Vm)  & As=C
  real(rk), parameter       :: kB = 1.380658d-23    ! in J/K
  real(rk)                  :: CoulCombo
!      CoulCombo = ec * ec * 1.0e10_rk / ( 4.0_rk * PI * eps0 * kB )  ->Umrechnung auf CGS-units (in K)

  integer(ik), parameter    :: intervalls = 256_ik  ! number of intervalls for mean radial distribution function

  integer(ik), parameter    :: Kmax = 9_ik    ! Kmax is an Ewald sum parameter.
  real(rk), parameter       :: Alpha = 5.6_rk   ! Alpha is an Ewald sum parameter, Alpha = kappa * L, for kappa in A + T.

end module basic_parameters_mod