      subroutine mstat(a,n,xmax,xmin,xrms,xmean)
      implicit real*8 (a-h,o-z)
      dimension a(n)
      xmax=-1d36
      xmin= 1d36
      xmean=0d0
      xrms=0d0
      do 10 i=1,n
        xmax=max(xmax,a(i))
        xmin=min(xmin,a(i))
   10 continue
      do 20 i=1,n
        xmean=xmean+a(i)
        xrms=xrms+a(i)*a(i)
   20 continue
      if(n.ne.0) then
        xrms=sqrt(xrms/n)
        xmean=xmean/n
      else
        xmax=0d0
        xmin=0d0
      endif
      return
      end


C---------------------------------------------------------------------------
C KING_MODEL : Set of subroutines to calculate King's model
C Version of November 14th 1986
C---------------------------------------------------------------------------
      SUBROUTINE KING(NPTS)
C---------------------------------------------------------------------------
C   Solves the differential equations for King's model to obtain
C   the relative values of density (RHO) and potential (PHI).
C Input :
C   NPTS = on entry : max number of points for the model
C   W0   = Potential in the center (linked with the concentration)
C Output :
C   NPTS = on exit : effective number of points up to the tidal radius
C   RAD  = radii for the model
C   PHI  = potential
C   DPHI = derivate of the potential
C   RTIDAL
C   NINDEX = index incremented after each call in subroutine "OUT"
C
C
C--------------------------------------------------------------------------
      PARAMETER (IDIM=10000)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL FOUND
      DIMENSION RHO(IDIM),PHI(IDIM),RAD(IDIM),
     +          Y(2),W(2,10),DPHI(IDIM)
C
	COMMON /KING/RHO,PHI,RAD,NINDEX,DPHI
	COMMON /KING3/ W0,RTIDAL,RHO0
	COMMON/CONSTANT/PI,PIROOT
C  Subroutines called by NAG Routine D02BBF...
	EXTERNAL FCN,OUT
C     evaluate some numbers required in lower subroutines and used
C     to evaluate the relative density at a given potential
C     from an analytic expression. Passed around in /king2/
C
	PI=3.14159265358979323846
	PIROOT=DSQRT(PI)
	W0ROOT=DSQRT(W0)
	ERF0=S15AEF(W0ROOT,IFAIL)
	RHO0=0.75D0*PIROOT*DEXP(W0)*ERF0
	RHO0=RHO0 - 1.5D0*W0ROOT - W0**1.5D0
C
      TOL=1.0E-4
      NEQS=2
      IRELAB=0
      IFAIL=0
      REND=RAD(NPTS)
      NINDEX=2       ! increment index, first increment filled later
                     ! by initial conditions R=0, W=W0, PHI=1
	RSTART=1.0D-3  !starting conditions a bit away from R=0
C		       ! if not error due to division by 0 in FCN
      TOL=1.0D-4
      Y(1)=W0-1.5D0*RSTART*RSTART    ! initial conditions for NAG/D02BBF
      Y(2)=-3.0D0*RSTART
C
C     NAG routine D02BBF solves Poisson's equation.  The relative densities
C     are evaluated as required in the subroutine FCN
C     Subroutine OUT fills the relevant arrays.
C     At the end of it all, arrays containing the potential and the
C     corresponding radius are filled, (except element 1, see RHORAD)
C     They are RAD and PHI
C
      CALL D02BBF(RSTART,REND,NEQS,Y,TOL,IRELAB,FCN,OUT,
     +             W,IFAIL)
C (Resolution of the system of 2 ordinary equations
C     dy1/dR = y2
C     dy2/dR = 9 Rho(y1)/Rho0  -  2 y2 / R
C
C  Calling FCN and OUT )
C
C     now evaluate the relative density corresponding to each radius
C     element.  We now have three arrays, RADIUS, POTENTIAL and
C     DENSITY (relative to the central value).
C     Also the tidal radius is found here and NPTS is set to its effective
C     value
C
	CALL RHORAD(NPTS)
	PRINT *,' MODEL CALCULATED WITH',NPTS,' POINTS'
	RETURN
	END

C--------------------------------------------------------------------
      SUBROUTINE FCN(R,Y,F)
C---------------------------------------------------------------------
C     subroutine to evaluate the values of the two first order
C     differential equations used to solve poissons equation
C     The relative density is evaluated here using the analytic
C     expression of Hills and Day Ap Lett 17,87, 1976
C     Y(1) = W
C     Y(2) = W1
C     F(1)=DY(1)/D(R) = W1
C     F(2)=DY(2)/D(R) = -9*RHO/RHO0 -2/R * W1
c---------------------------------------------------------------------
	IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 T,Y(2),F(2),RELRHO
C----------------------------------------------------------------------
C
C     trap potential going negative. if it does i.e. we have
C     reached the tidal radius then set the relative density to
C     zero else the analytic function will bomb whilst trying to
C     find the square root of the potential.
C
C
      IF(Y(1).GT.0.0D0) THEN
        CALL RHOEVAL(RELRHO,Y(1))     !find relative density at W=Y(1)
      ELSE
        RELRHO=0.0D0
      END IF
                                    ! the values of the de's
      F(1)=Y(2)
      F(2)=-9.0D0*RELRHO - (2.0D0*Y(2))/R
      RETURN
      END
C--------------------------------------------------------------------------
      SUBROUTINE OUT(R,Y)
C--------------------------------------------------------------------
C Stores the potential and its derivate corresponding to the radii R
C--------------------------------------------------------------------
	PARAMETER (IDIM=10000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	DIMENSION DPHI(IDIM)
	DIMENSION Y(2),RHO(IDIM),PHI(IDIM),RAD(IDIM)
	COMMON /KING/RHO,PHI,RAD,NINDEX,DPHI

	PHI(NINDEX)=Y(1)
	DPHI(NINDEX)=Y(2)
	NINDEX=NINDEX+1
	R=RAD(NINDEX)

	RETURN
	END
C--------------------------------------------------------------------
      SUBROUTINE RHORAD(NPTS)
C----------------------------------------------------------------------
C     subroutine to evaluate the relative density at each of the radius
C     increments and fill the array RHO.
C     Also finds tidal radius rtidal via a parabolic interpolation
C-----------------------------------------------------------------------
      PARAMETER (IDIM=10000)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      REAL*8 PHI(IDIM),RHO(IDIM),RAD(IDIM)
      REAL*8 RTIDAL,DPHI(IDIM)
      CHARACTER*80 OUTPUT
      LOGICAL*4 FOUND_TIDAL
	COMMON /KING3/ W0,RTIDAL,RHO0
	COMMON /KING/RHO,PHI,RAD,NINDEX,DPHI
c----------------------------------------------------------------------
      FOUND_TIDAL=.FALSE.
C
C     fill element 1 of arrays with conditions at R=0
C
      PHI(1)=W0
      RHO(1)=1.0D0

      DO J=2,NINDEX-1     !NINDEX is incremented in OUT after last call
       IF(PHI(J).GT.0.0D0) THEN
         CALL RHOEVAL(RELRHO,PHI(J))  !find RELDENS at W=PHI(J)
         RHO(J)=RELRHO
       ELSE
           CALL FIND_TIDAL(J,RTIDAL)
           FOUND_TIDAL=.TRUE.
           GOTO 100
       END IF
      END DO
 100  NPTS=J-1
      IF(.NOT.FOUND_TIDAL) THEN
        PRINT *,' '
        PRINT *,'YOU HAVE NOT INTEGRATED FAR ENOUGH TO REACH'
        PRINT *,'THE TIDAL RADIUS (IN THE MODEL)'
        WRITE (6,33) RHO(J-1)
  33    FORMAT ('FINAL RELATIVE DENSITY VALUE = ',F20.10)
      ELSE
        PRINT *,' '
        WRITE (6,44) RTIDAL
44	FORMAT ('THE TIDAL RADIUS = ',F20.10)
      END IF
      RETURN
      END
C
C--------------------------------------------------------------------

      SUBROUTINE RHOEVAL(RELRHO,POT)
C--------------------------------------------------------------------
C     subroutine to evaluate the relative density at a given
C     potential pot.  Uses Hills and Day's analytic expression
C--------------------------------------------------------------------
      PARAMETER (IDIM=10000)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 RHO(IDIM),RAD(IDIM),DPHI(IDIM),PHI(IDIM)
      INTEGER*4 IFAIL
	COMMON/CONSTANT/PI,PIROOT
	COMMON/KING3/ W0,RTIDAL,RHO0
	COMMON/KING/RHO,PHI,RAD,NINDEX,DPHI
C----------------------------------------------------------------------
      POTROOT=DSQRT(POT)
      IFAIL=0
      ERF=S15AEF(POTROOT,IFAIL)
      RHO1=0.75D0*PIROOT*DEXP(POT)*ERF
      RHO1=RHO1 - 1.5D0*POTROOT - POT**1.5D0
      RELRHO=RHO1/RHO0     !THE RELATIVE DENSITY AT THE VALUE W=POT
      RETURN
      END
C---------------------------------------------------------------------
      SUBROUTINE FIND_TIDAL(INDEX,RTIDAL)
C---------------------------------------------------------------------
C     subroutine to evaluate the tidal radius position
C     uses parabolic interpolation of last three useful points. The
C     last point is the first point at which the potential becomes
C     negative.
C---------------------------------------------------------------------
	PARAMETER (IDIM=10000)
	IMPLICIT REAL*8 (A-H,O-Z)
	REAL*8 RAD(IDIM),PHI(IDIM),DPHI(IDIM),RHO(IDIM)
	INTEGER*4 INDEX
	COMMON /KING/RHO,PHI,RAD,NINDEX,DPHI
C-----------------------------------------------------------------------

C
C     index is the index of the arrays at which the potential becomes
C     negative.  Set up interpolation coefficients
C
      W1=PHI(INDEX-2)
      W2=PHI(INDEX-1)
      W3=PHI(INDEX)
      R1=RAD(INDEX-2)
      R2=RAD(INDEX-1)
      R3=RAD(INDEX)

      COEF1=W2*W3/( (W1-W2)*(W1-W3) )
      COEF2=W1*W3/( (W2-W1)*(W2-W3) )
      COEF3=W1*W2/( (W3-W1)*(W3-W2) )

C
C     evaluate tidal radius
C
      RTIDAL=R1*COEF1 + R2*COEF2 + R3*COEF3
      RETURN
      END
C**********************************************************************
C	FONCTION DERF DE CALCUL DE LA FONCTION D'ERREUR
C**********************************************************************
	DOUBLE PRECISION FUNCTION DERF(X)
	REAL*8 X,P,T,EER
	DOUBLE PRECISION A(5)
	DATA A/.254829592D0,-.284496736D0,1.421413741D0,
	1	-1.453152027D0,1.061405429D0/
	DATA P/0.3275911D0/
	T=1D0/(1D0+P*X)
	EER=DEXP(-1D0*X*X)
	EER=EER*((((A(5)*T+A(4))*T+A(3))*T+A(2))*T+A(1))*T
	DERF=1D0-EER
	END
C--------------------------------------------------------------------
      SUBROUTINE MASS_KING(RADMAX,XMU1,NPTS)
C--------------------------------------------------------------------
C Subroutine to evaluate the integrated mass MU1 up to a given
C radius RADMAX.
C--------------------------------------------------------------------
	PARAMETER (IDIM=10000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 RHO(IDIM),RAD(IDIM),DPHI(IDIM),PHI(IDIM)
	REAL*8 SPLINE1(IDIM),K1(IDIM)
	REAL*8 YY(IDIM)
	COMMON/CONSTANT/PI,PIROOT
	COMMON/KING3/W0,RTIDAL,RHO0
	COMMON/KING/RHO,PHI,RAD,NINDEX,DPHI
	COMMON/SPLINE1/NCAP71,K1,SPLINE1

	IF(RADMAX.GT.RTIDAL)THEN
	RADMAX=RTIDAL
	PRINT *,' RADMAX GREATER THAN RTIDAL, SO I SET IT TO RTIDAL'
	ENDIF

C Fills the arrays for further interpolation up to RTIDAL:
	RAD(NPTS+1)=RTIDAL
	RHO(NPTS+1)=0.D0
	NPOINT=NPTS+1

C Interpolation of the input points with a cubic-spline :
	CALL SPLINE_INTER(RAD,RHO,NPOINT,SPLINE1,NCAP71,K1)

C Integration from RADMIN to RADMAX
	RADMIN=RAD(1)
	PRINT *,' RADMIN =',RADMIN
	SUM=XMASS_KING1(RADMIN,RADMAX)
	PRINT *,' RHO0 :',RHO0
	XMU1=4.D0*PI*SUM/RHO0

	RETURN
	END
C---------------------------------------------------------------------------
C Function XMASS_KING1
C--------------------------------------------------------------------------
	DOUBLE PRECISION FUNCTION XMASS_KING1(XLOW,XHIGH)
	IMPLICIT REAL*8(A-H,O-Z)
	REAL*8 W(4000)
	INTEGER*4 IW(502)
	EXTERNAL FUN_KING1

C Absolute and relative accuracy :
        EPSABS=0.000001
        EPSREL=0.0001

C Size of the work areas W(real) and IW(integer)
        LW=4000
        LIW=502

C Calling a rather sophisticated integration routine D01AKF :
        IFAIL=1
        CALL D01AKF(FUN_KING1,XLOW,XHIGH,EPSABS,EPSREL,SUM,
	1	ABSERR,W,LW,IW,LIW,IFAIL)

        IF(IFAIL.NE.0) THEN
          PRINT *,' WARNING : FAILURE IN D01AKF,  IFAIL =',IFAIL
        END IF

	XMASS_KING1=SUM

	RETURN
	END
C---------------------------------------------------------------------------
C Function FUN_KING1
C Called by D0AKF
C Generates the value to be integrated at the point X
C---------------------------------------------------------------------------
	DOUBLE PRECISION FUNCTION FUN_KING1(X)
	PARAMETER (IDIM=10000)
	IMPLICIT REAL*8(A-H,O-Z)
	REAL*8 SPLINE1(IDIM),K1(IDIM)
	COMMON/SPLINE1/NCAP71,K1,SPLINE1
	IFAIL=1
	CALL E02BBF(NCAP71,K1,SPLINE1,X,RHOX,IFAIL)

	IF(IFAIL.NE.0)THEN
	PRINT 20,IFAIL
20	FORMAT(' **** WARNING ! **** IN E02BBF  IFAIL =',I3,
	1	/,'   (MASS INTEGRATION)')
	PRINT *,' X=',X
	RHOX=0.
	ENDIF

C Integral of RHO*(RAD**2):
	FUN_KING1=RHOX*X*X

	RETURN
	END


program gmresvsgauss
    USE GMRES
    USE M_SOLVER
    USE IFPORT
    implicit none

    COMPLEX, DIMENSION(:,:), ALLOCATABLE :: random_matrix, gauss_matrix, gmres_matrix
    COMPLEX, DIMENSION(:), ALLOCATABLE :: random_sol, gmres_sol

    integer:: arg_count, num_iterations,i, n,j,iter
    character(200) :: arg
    real:: cpu_time_begin, cpu_time_end, total_cpu_gauss, total_cpu_gmres
    DOUBLE PRECISION :: WALL_START_TIME, WALL_STOP_TIME, total_wall_gauss, total_wall_gmres
    complex :: ONE, ZERO

    n = 2000
    ONE = CMPLX(1., 0.)
    ZERO = CMPLX(0., 0.)

    arg_count = command_argument_count()

    num_iterations = 1

    if(arg_count >=1 ) then
        call get_command_argument(1, arg)
        read(arg,*) num_iterations

    end if

    !CALL RANDOM_SEED()
    total_cpu_gmres = 0
    total_cpu_gauss = 0
    total_wall_gmres = 0
    total_wall_gauss = 0

    do iter=1,num_iterations

        write(*,*) 'Iteration ', iter
        write(*,*) 'Generates ', n , ' x ', n, ' matrix'
        ALLOCATE(random_matrix(n,n))
        ALLOCATE(random_sol(n))
        ALLOCATE(gauss_matrix(n,n+1), gmres_matrix(n,n), gmres_sol(n))

        random_matrix = cmplx(0.,0.)
        do i=1,n
            random_matrix(i,i) = (4.0e0,  0.0e0)
        end do
        do i = 1,n-1
            random_matrix(i,i+1) = (-2.0e0, 1.0e0)
            random_matrix(i+1,i) = (-1.0e0, 1.0e0)
        enddo

        gmres_sol = ONE

        call cgemv('N',n,n,ONE,random_matrix,n,gmres_sol,1,ZERO,random_sol,1)

        do i=1,n
            do j=1,n
                gauss_matrix(i, j) = random_matrix(i,j)
                gmres_matrix(i, j) = random_matrix(i,j)
            end do
            gauss_matrix(i, n+1) = random_sol(i)
            gmres_sol(i) = random_sol(i)
        end do

        write(*,*) 'Solving with gmres started'

        CALL CPU_TIME ( cpu_time_begin )
        WALL_START_TIME = DCLOCK()

        CALL compute_gmres(gmres_matrix, gmres_sol, n)

        WALL_STOP_TIME = DCLOCK()
        CALL CPU_TIME ( cpu_time_end )

        write(*, *) 'GMRES completed with following statistics:'
        write(*,*) 'cpu time(s) ' , cpu_time_end - cpu_time_begin
        write(*,*) 'wall elapsed time(s) ', WALL_STOP_TIME-WALL_START_TIME
        write(*,*)
        total_cpu_gmres = total_cpu_gmres + cpu_time_end - cpu_time_begin
        total_wall_gmres = total_wall_gmres + WALL_STOP_TIME-WALL_START_TIME

        write(*,*) 'Solving with gauss started'
        CALL CPU_TIME ( cpu_time_begin )
        WALL_START_TIME = DCLOCK()

        CALL compute_gauss(gauss_matrix, n)

        WALL_STOP_TIME = DCLOCK()
        CALL CPU_TIME ( cpu_time_end )

        write(*, *) 'GAUSS completed with following statistics:'
        write(*,*) 'cpu time(s) ' , cpu_time_end - cpu_time_begin
        write(*,*) 'wall elapsed time(s) ', WALL_STOP_TIME-WALL_START_TIME
        write(*,*)
        total_cpu_gauss = total_cpu_gauss + cpu_time_end - cpu_time_begin
        total_wall_gauss = total_wall_gauss + WALL_STOP_TIME-WALL_START_TIME

        DEALLOCATE(random_matrix)
        DEALLOCATE(random_sol)
        DEALLOCATE(gauss_matrix, gmres_matrix, gmres_sol)

    end do

    if (num_iterations >= 1) then

        total_cpu_gauss = total_cpu_gauss/real(num_iterations)
        total_cpu_gmres = total_cpu_gmres/real(num_iterations)
        total_wall_gauss = total_wall_gauss/ dble(num_iterations)
        total_wall_gmres = total_wall_gmres/ dble(num_iterations)

        write(*,*) '----------  Average Summary -------------'
        write(*, *) 'GMRES completed with following statistics:'
        write(*,*) 'avg cpu time(s) ' , total_cpu_gmres
        write(*,*) 'avg wall elapsed time(s) ', total_wall_gmres
        write(*,*)
        write(*, *) 'GAUSS completed with following statistics:'
        write(*,*) 'avg cpu time(s) ' , total_cpu_gauss
        write(*,*) 'avg wall elapsed time(s) ', total_wall_gauss
        write(*,*)

    end if

contains
    subroutine compute_gmres(A, b, N)

        COMPLEX,DIMENSION(:,:):: A
        COMPLEX, DIMENSION(:):: b
        INTEGER::N
        integer :: lwork
        integer :: revcom, colx, coly, colz, nbscal
        integer :: irc(5), icntl(8), info(3)
        TYPE(GMRESVAR):: gmres_env
        integer :: matvec, precondLeft, precondRight, dotProd
        parameter (matvec=1, precondLeft=2, precondRight=3, dotProd=4)
        complex, dimension(:), allocatable ::  work
        real ::  cntl(5), rinfo(2)
        complex :: ONE, ZZERO
        INTEGER:: restartParam, maxIterations
        real:: TOL_GMRES

        restartParam = 20
        maxIterations = 100
        TOL_GMRES = 5.E-07

        lwork = (restartParam+10)**2 + (restartParam+10)*(N+5) + 5*N + 1
        ALLOCATE(work(lwork))
        ONE = CMPLX(1., 0.)
        ZZERO = CMPLX(0., 0.)

        !******************************************************
        !* Initialize the control parameters to default value
        !******************************************************

        call init_cgmres(icntl,cntl, gmres_env)

        !************************
        !c Tune some parameters
        !************************

        ! Save the convergence history on standard output
        !icntl(3) = 30
        icntl(2) = 0
        ! Maximum number of iterations
        icntl(7) = maxIterations

        ! Tolerance
        cntl(1) = TOL_GMRES

        ! preconditioner location
        icntl(4) = 0
        ! orthogonalization scheme
        icntl(5)=0
        ! initial guess
        icntl(6) = 0
        ! residual calculation strategy at restart
        icntl(8) = 1
        !* Initialise the right hand side

        work = CMPLX(0., 0.)

        work(1:N) = ONE/2.0

        DO I=1,N

            work(N+I) = b(i)

        END DO

        DO

            call drive_cgmres(N,N,restartParam,lwork,work, &
                irc,icntl,cntl,info,rinfo, gmres_env)
            revcom = irc(1)
            colx   = irc(2)
            coly   = irc(3)
            colz   = irc(4)
            nbscal = irc(5)

            if (revcom == matvec) then
                ! perform the matrix vector product
                !        work(colz) <-- A * work(colx)
                call cgemv('N',N,N,ONE,A,N,work(colx),1, &
                    ZZERO,work(colz),1)

            else if (revcom == precondLeft) then
                ! perform the left preconditioning
                !         work(colz) <-- M^{-1} * work(colx)
                call ccopy(N,work(colx),1,work(colz),1)
                call ctrsm('L','L','N','N',N,1,ONE,A,N,work(colz),N)

            else if (revcom == precondRight) then
                ! perform the right preconditioning
                call ccopy(N,work(colx),1,work(colz),1)
                call ctrsm('L','U','N','N',N,1,ONE,A,N,work(colz),N)

            else if (revcom == dotProd) then
                !      perform the scalar product
                !      work(colz) <-- work(colx) work(coly)

                call cgemv('C',N,nbscal,ONE,work(colx),N, &
                    work(coly),1,ZZERO,work(colz),1)

            ELSE
                exit
            endif

        END DO

    end subroutine compute_gmres

    subroutine compute_gauss(A, N)
        integer:: n
        COMPLEX,DIMENSION(:,:):: A
        CALL GAUSSZ(A,N,N,N)
    end subroutine compute_gauss

end program gmresvsgauss


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  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                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
! This file contains code and documentation for subroutines
! vhses and vhsesi
!
submodule(vector_synthesis_routines) vector_synthesis_regular_grid_saved

contains

    ! Purpose:
    !
    !     subroutine vhses(nlat, nlon, ityp, nt, v, w, idvw, jdvw, br, bi, cr, ci, &
    !                      mdab, ndab, wvhses, ierror)
    !
    !     subroutine vhses performs the vector spherical harmonic synthesis
    !     of the arrays br, bi, cr, and ci and stores the result in the
    !     arrays v and w. v(i, j) and w(i, j) are the colatitudinal
    !     (measured from the north pole) and east longitudinal components
    !     respectively, located at colatitude theta(i) = (i-1)*pi/(nlat-1)
    !     and longitude phi(j) = (j-1)*2*pi/nlon. the spectral
    !     representation of (v, w) is given below at output parameters v, w.
    !
    !     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 londitude 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.
    !
    !     ityp   = 0  no symmetries exist about the equator. the synthesis
    !                 is performed on the entire sphere.  i.e. on the
    !                 arrays v(i, j), w(i, j) for i=1, ..., nlat and
    !                 j=1, ..., nlon.
    !
    !            = 1  no symmetries exist about the equator. the synthesis
    !                 is performed on the entire sphere.  i.e. on the
    !                 arrays v(i, j), w(i, j) for i=1, ..., nlat and
    !                 j=1, ..., nlon. the curl of (v, w) is zero. that is,
    !                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
    !                 the coefficients cr and ci are zero.
    !
    !            = 2  no symmetries exist about the equator. the synthesis
    !                 is performed on the entire sphere.  i.e. on the
    !                 arrays v(i, j), w(i, j) for i=1, ..., nlat and
    !                 j=1, ..., nlon. the divergence of (v, w) is zero. i.e.,
    !                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
    !                 the coefficients br and bi are zero.
    !
    !            = 3  v is symmetric and w is antisymmetric about the
    !                 equator. the synthesis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the synthesis
    !                 is performed on the arrays v(i, j), w(i, j) for
    !                 i=1, ..., (nlat + 1)/2 and j=1, ..., nlon. if nlat is
    !                 even the synthesis is performed on the the arrays
    !                 v(i, j), w(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !            = 4  v is symmetric and w is antisymmetric about the
    !                 equator. the synthesis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the synthesis
    !                 is performed on the arrays v(i, j), w(i, j) for
    !                 i=1, ..., (nlat + 1)/2 and j=1, ..., nlon. if nlat is
    !                 even the synthesis is performed on the the arrays
    !                 v(i, j), w(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !                 the curl of (v, w) is zero. that is,
    !                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
    !                 the coefficients cr and ci are zero.
    !
    !            = 5  v is symmetric and w is antisymmetric about the
    !                 equator. the synthesis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the synthesis
    !                 is performed on the arrays v(i, j), w(i, j) for
    !                 i=1, ..., (nlat + 1)/2 and j=1, ..., nlon. if nlat is
    !                 even the synthesis is performed on the the arrays
    !                 v(i, j), w(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !                 the divergence of (v, w) is zero. i.e.,
    !                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
    !                 the coefficients br and bi are zero.
    !
    !            = 6  v is antisymmetric and w is symmetric about the
    !                 equator. the synthesis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the synthesis
    !                 is performed on the arrays v(i, j), w(i, j) for
    !                 i=1, ..., (nlat + 1)/2 and j=1, ..., nlon. if nlat is
    !                 even the synthesis is performed on the the arrays
    !                 v(i, j), w(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !            = 7  v is antisymmetric and w is symmetric about the
    !                 equator. the synthesis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the synthesis
    !                 is performed on the arrays v(i, j), w(i, j) for
    !                 i=1, ..., (nlat + 1)/2 and j=1, ..., nlon. if nlat is
    !                 even the synthesis is performed on the the arrays
    !                 v(i, j), w(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !                 the curl of (v, w) is zero. that is,
    !                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
    !                 the coefficients cr and ci are zero.
    !
    !            = 8  v is antisymmetric and w is symmetric about the
    !                 equator. the synthesis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the synthesis
    !                 is performed on the arrays v(i, j), w(i, j) for
    !                 i=1, ..., (nlat + 1)/2 and j=1, ..., nlon. if nlat is
    !                 even the synthesis is performed on the the arrays
    !                 v(i, j), w(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !                 the divergence of (v, w) is zero. i.e.,
    !                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
    !                 the coefficients br and bi are zero.
    !
    !
    !     nt     the number of syntheses.  in the program that calls vhses,
    !            the arrays v, w, br, bi, cr, and ci can be three dimensional
    !            in which case multiple syntheses will be performed.
    !            the third index is the synthesis index which assumes the
    !            values k=1, ..., nt.  for a single synthesis set nt=1. the
    !            discription of the remaining parameters is simplified
    !            by assuming that nt=1 or that all the arrays are two
    !            dimensional.
    !
    !     idvw   the first dimension of the arrays v, w as it appears in
    !            the program that calls vhaes. if ityp <= 2 then idvw
    !            must be at least nlat.  if ityp > 2 and nlat is
    !            even then idvw must be at least nlat/2. if ityp > 2
    !            and nlat is odd then idvw must be at least (nlat + 1)/2.
    !
    !     jdvw   the second dimension of the arrays v, w as it appears in
    !            the program that calls vhses. jdvw must be at least nlon.
    !
    !     br, bi  two or three dimensional arrays (see input parameter nt)
    !     cr, ci  that contain the vector spherical harmonic coefficients
    !            in the spectral representation of v(i, j) and w(i, j) given
    !            below at the discription of output parameters v and w.
    !
    !     mdab   the first dimension of the arrays br, bi, cr, and ci as it
    !            appears in the program that calls vhses. mdab must be at
    !            least min(nlat, nlon/2) if nlon is even or at least
    !            min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !     ndab   the second dimension of the arrays br, bi, cr, and ci as it
    !            appears in the program that calls vhses. ndab must be at
    !            least nlat.
    !
    !     wvhses an array which must be initialized by subroutine vhsesi.
    !            once initialized, wvhses can be used repeatedly by vhses
    !            as long as nlon and nlat remain unchanged.  wvhses must
    !            not be altered between calls of vhses.
    !
    !     lvhses the dimension of the array wvhses as it appears in the
    !            program that calls vhses. define
    !
    !               l1 = min(nlat, nlon/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 lvhses must be at least
    !
    !                 l1*l2*(2*nlat-l1+1)+nlon+15
    !
    !     output parameters
    !
    !     v, w    two or three dimensional arrays (see input parameter nt)
    !            in which the synthesis is stored. v is the colatitudinal
    !            component and w is the east longitudinal component.
    !            v(i, j), w(i, j) contain the components at colatitude
    !            theta(i) = (i-1)*pi/(nlat-1) and longitude phi(j) =
    !            (j-1)*2*pi/nlon. the index ranges are defined above at
    !            the input parameter ityp. v and w are computed from the
    !            formulas given below
    !
    !
    !     define
    !
    !     1.  theta is colatitude and phi is east longitude
    !
    !     2.  the normalized associated legendre funnctions
    !
    !         pbar(m, n, theta) = sqrt((2*n+1)*factorial(n-m)
    !                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
    !                        factorial(n)) times the (n+m)th derivative
    !                        of (x**2-1)**n with respect to x=cos(theta)
    !
    !     3.  vbar(m, n, theta) = the derivative of pbar(m, n, theta) with
    !                           respect to theta divided by the square
    !                           root of n(n+1).
    !
    !         vbar(m, n, theta) is more easily computed in the form
    !
    !         vbar(m, n, theta) = (sqrt((n+m)*(n-m+1))*pbar(m-1, n, theta)
    !         -sqrt((n-m)*(n+m+1))*pbar(m+1, n, theta))/(2*sqrt(n*(n+1)))
    !
    !     4.  wbar(m, n, theta) = m/(sin(theta))*pbar(m, n, theta) divided
    !                           by the square root of n(n+1).
    !
    !         wbar(m, n, theta) is more easily computed in the form
    !
    !         wbar(m, n, theta) = sqrt((2n+1)/(2n-1))*(sqrt((n+m)*(n+m-1))
    !         *pbar(m-1, n-1, theta)+sqrt((n-m)*(n-m-1))*pbar(m+1, n-1, theta))
    !         /(2*sqrt(n*(n+1)))
    !
    !
    !    the colatitudnal dependence of the normalized surface vector
    !                spherical harmonics are defined by
    !
    !     5.    bbar(m, n, theta) = (vbar(m, n, theta), i*wbar(m, n, theta))
    !
    !     6.    cbar(m, n, theta) = (i*wbar(m, n, theta), -vbar(m, n, theta))
    !
    !
    !    the coordinate to index mappings
    !
    !     7.   theta(i) = (i-1)*pi/(nlat-1) and phi(j) = (j-1)*2*pi/nlon
    !
    !
    !     the maximum (plus one) longitudinal wave number
    !
    !     8.     mmax = min(nlat, nlon/2) if nlon is even or
    !            mmax = min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !    if we further define the output vector as
    !
    !     9.    h(i, j) = (v(i, j), w(i, j))
    !
    !    and the complex coefficients
    !
    !     10.   b(m, n) = cmplx(br(m+1, n+1), bi(m+1, n+1))
    !
    !     11.   c(m, n) = cmplx(cr(m+1, n+1), ci(m+1, n+1))
    !
    !
    !    then for i=1, ..., nlat and  j=1, ..., nlon
    !
    !        the expansion for real h(i, j) takes the form
    !
    !     h(i, j) = the sum from n=1 to n=nlat-1 of the real part of
    !
    !         0.5*(b(0, n)*bbar(0, n, theta(i))+c(0, n)*cbar(0, n, theta(i)))
    !
    !     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
    !     n=nlat-1 of the real part of
    !
    !              b(m, n)*bbar(m, n, theta(i))*exp(i*m*phi(j))
    !             +c(m, n)*cbar(m, n, theta(i))*exp(i*m*phi(j))
    !
    !   *************************************************************
    !
    !   in terms of real variables this expansion takes the form
    !
    !             for i=1, ..., nlat and  j=1, ..., nlon
    !
    !     v(i, j) = the sum from n=1 to n=nlat-1 of
    !
    !              0.5*br(1, n+1)*vbar(0, n, theta(i))
    !
    !     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
    !     n=nlat-1 of the real part of
    !
    !       (br(m+1, n+1)*vbar(m, n, theta(i))-ci(m+1, n+1)*wbar(m, n, theta(i)))
    !                                          *cos(m*phi(j))
    !      -(bi(m+1, n+1)*vbar(m, n, theta(i))+cr(m+1, n+1)*wbar(m, n, theta(i)))
    !                                          *sin(m*phi(j))
    !
    !    and for i=1, ..., nlat and  j=1, ..., nlon
    !
    !     w(i, j) = the sum from n=1 to n=nlat-1 of
    !
    !              -0.5*cr(1, n+1)*vbar(0, n, theta(i))
    !
    !     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
    !     n=nlat-1 of the real part of
    !
    !      -(cr(m+1, n+1)*vbar(m, n, theta(i))+bi(m+1, n+1)*wbar(m, n, theta(i)))
    !                                          *cos(m*phi(j))
    !      +(ci(m+1, n+1)*vbar(m, n, theta(i))-br(m+1, n+1)*wbar(m, n, theta(i)))
    !                                          *sin(m*phi(j))
    !
    !
    !      br(m+1, nlat), bi(m+1, nlat), cr(m+1, nlat), and ci(m+1, nlat) are
    !      assumed zero for m even.
    !
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of ityp
    !            = 4  error in the specification of nt
    !            = 5  error in the specification of idvw
    !            = 6  error in the specification of jdvw
    !            = 7  error in the specification of mdab
    !            = 8  error in the specification of ndab
    !            = 9  error in the specification of lvhses
    !
    module subroutine vhses(nlat, nlon, ityp, nt, v, w, idvw, jdvw, br, bi, cr, ci, &
        mdab, ndab, wvhses, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: ityp
        integer(ip), intent(in)  :: nt
        real(wp),    intent(out) :: v(idvw, jdvw, nt)
        real(wp),    intent(out) :: w(idvw, jdvw, nt)
        integer(ip), intent(in)  :: idvw
        integer(ip), intent(in)  :: jdvw
        real(wp),    intent(in)  :: br(mdab, ndab, nt)
        real(wp),    intent(in)  :: bi(mdab, ndab, nt)
        real(wp),    intent(in)  :: cr(mdab, ndab, nt)
        real(wp),    intent(in)  :: ci(mdab, ndab, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        real(wp),    intent(in)  :: wvhses(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip) :: idv, idz, imid, ist, lnl, lzimn, mmax
        integer(ip) :: lwork, workspace_indices(6)
        integer(ip) :: required_wavetable_size
        type(VectorSynthesisUtility) :: util

        required_wavetable_size = util%get_lvhsgc(nlat, nlon)

        call util%check_vector_transform_inputs(ityp, idvw, jdvw, &
            mdab, ndab, nlat, nlon, nt, required_wavetable_size, &
            wvhses, ierror)

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

        imid = (nlat + 1)/2
        mmax = min(nlat, (nlon + 1)/2)
        idz = (mmax*(2*nlat-mmax+1))/2
        lzimn = idz*imid

        select case (ityp)
            case (0:2)
                idv = nlat
                ist = imid
            case default
                idv = imid
                ist = 0
        end select

        ! Set required workspace size
        lnl = nt * idv * nlon
        lwork = (2 * lnl) + (idv * nlon)

        block
            real(wp) :: work(lwork)

            !  Set workspace indices
            workspace_indices = get_vhses_workspace_indices(ist, lnl, lzimn)

            associate (&
                iw1 => workspace_indices(1), &
                iw2 => workspace_indices(2), &
                iw3 => workspace_indices(3), &
                iw4 => workspace_indices(4), &
                jw1 => workspace_indices(5), &
                jw2 => workspace_indices(6) &
                )
                call vhses_lower_utility_routine(nlat, nlon, ityp, nt, imid, idvw, &
                    jdvw, v, w, mdab, ndab, br, bi, cr, ci, idv, work, work(iw1:), &
                    work(iw2:), work(iw3:), work(iw4:), idz, wvhses, wvhses(jw1:), &
                    wvhses(jw2:))
            end associate
        end block

    end subroutine vhses

    ! Purpose:
    !
    !     subroutine vhsesi(nlat, nlon, wvhses, ierror)
    !
    !     subroutine vhsesi initializes the array wvhses which can then be
    !     used repeatedly by subroutine vhses until nlat or nlon is changed.
    !
    !     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 londitude 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.
    !
    !     lvhses the dimension of the array wvhses as it appears in the
    !            program that calls vhses. define
    !
    !               l1 = min(nlat, nlon/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 lvhses must be at least
    !
    !                  l1*l2*(2*nlat-l1+1)+nlon+15
    !
    !     output parameters
    !
    !     wvhses an array which is initialized for use by subroutine vhses.
    !            once initialized, wvhses can be used repeatedly by vhses
    !            as long as nlat or nlon remain unchanged.  wvhses must not
    !            be altered between calls of vhses.
    !
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of lvhses
    !
    module subroutine vhsesi(nlat, nlon, wvhses, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        real(wp),    intent(out) :: wvhses(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip) :: imid, labc, lzimn, mmax
        integer(ip) :: lwork, ldwork
        integer(ip) :: workspace_indices(4)
        type(SpherepackUtility) :: util

        associate (lvhses => size(wvhses))

            mmax = min(nlat, (nlon + 1)/2)
            imid = (nlat + 1)/2
            lzimn = (imid*mmax*(2*nlat-mmax+1))/2
            labc = 3*(max(mmax-2, 0)*(2*nlat-mmax-1))/2

            !  Check calling arguments
            if (nlat < 3) then
                ierror = 1
            else if (nlon < 1) then
                ierror = 2
            else if (lvhses < 2*lzimn+nlon+15) then
                ierror = 3
            else
                ierror = 0
            end if

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

            ! Set required workspace sizes
            lwork = (5 * nlat * imid) + labc
            ldwork = 2 * (nlat + 1)

            block
                real(wp) :: work(lwork), dwork(ldwork)

                ! Set workspace indices
                workspace_indices = get_vhsesi_workspace_indices(nlat, imid, mmax, lzimn)

                associate (&
                    iw1 => workspace_indices(1), &
                    idz => workspace_indices(2), &
                    jw1 => workspace_indices(3), &
                    jw2 => workspace_indices(4) &
                    )
                    call vhsesi_lower_utility_routine(nlat, nlon, imid, wvhses, &
                        wvhses(jw1:), idz, work, work(iw1:), dwork)

                    call util%hfft%initialize(nlon, wvhses(jw2:))
                end associate
            end block
        end associate

    end subroutine vhsesi

    pure function get_vhses_workspace_indices(ist, lnl, lzimn) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in)  :: ist
        integer(ip), intent(in)  :: lnl
        integer(ip), intent(in)  :: lzimn
        integer(ip)              :: return_value(6)

        associate (i => return_value)
            i(1) = ist+1
            i(2) = lnl+1
            i(3) = i(2)+ist
            i(4) = i(2)+lnl
            i(5) = lzimn+1
            i(6) = i(5)+lzimn
        end associate

    end function get_vhses_workspace_indices

    subroutine vhses_lower_utility_routine(nlat, nlon, ityp, nt, imid, idvw, jdvw, v, w, mdab, &
        ndab, br, bi, cr, ci, idv, ve, vo, we, wo, work, idz, vb, wb, wrfft)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: ityp
        integer(ip), intent(in)  :: nt
        integer(ip), intent(in)  :: imid
        integer(ip), intent(in)  :: idvw
        integer(ip), intent(in)  :: jdvw
        real(wp),    intent(out) :: v(idvw, jdvw, nt)
        real(wp),    intent(out) :: w(idvw, jdvw, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        real(wp),    intent(in)  :: br(mdab, ndab, nt)
        real(wp),    intent(in)  :: bi(mdab, ndab, nt)
        real(wp),    intent(in)  :: cr(mdab, ndab, nt)
        real(wp),    intent(in)  :: ci(mdab, ndab, nt)
        integer(ip), intent(in)  :: idv
        real(wp),    intent(out)  :: ve(idv, nlon, nt)
        real(wp),    intent(out)  :: vo(idv, nlon, nt)
        real(wp),    intent(out)  :: we(idv, nlon, nt)
        real(wp),    intent(out)  :: wo(idv, nlon, nt)
        real(wp),    intent(out)  :: work(*)
        integer(ip), intent(in)  :: idz
        real(wp),    intent(in)  :: vb(imid, *)
        real(wp),    intent(in)  :: wb(imid, *)
        real(wp),    intent(in)  :: wrfft(*)

        ! Local variables
        integer(ip)    :: i, imm1, j, k, m, mb, mmax, mn
        integer(ip)    :: mp1, mp2, odd_stride, even_stride, np1
        type(VectorSynthesisUtility) :: util

        call util%synthesis_setup(even_stride, imid, imm1, mmax, nlat, &
            odd_stride, ve, vo, we, wo)

        vector_symmetry_cases: select case (ityp)
            case (0)

                ! case ityp=0   no symmetries

                ! case m = 0
                do k=1, nt
                    do np1=2, even_stride, 2
                        ve(:imid, 1, k) = ve(:imid, 1, k) + br(1, np1, k) * vb(:imid, np1)
                        we(:imid, 1, k) = we(:imid, 1, k) - cr(1, np1, k) * vb(:imid, np1)
                    end do
                end do

                do k=1, nt
                    do np1=3, odd_stride, 2
                        vo(:imm1, 1, k) = vo(:imm1, 1, k) + br(1, np1, k) * vb(:imm1, np1)
                        wo(:imm1, 1, k) = wo(:imm1, 1, k) - cr(1, np1, k) * vb(:imm1, np1)
                    end do
                end do

                ! case m = 1 through nlat-1
                if (2 <= mmax) then
                    do mp1=2, mmax
                        m = mp1-1
                        mb = m * (nlat-1) - (m * (m - 1))/2
                        mp2 = mp1+1
                        if (mp1 <= odd_stride) then
                            do k=1, nt
                                do np1=mp1, odd_stride, 2
                                    mn = mb+np1

                                    vo(:imm1, 2*mp1-2, k) = vo(:imm1, 2*mp1-2, k) + br(mp1, np1, k) * vb(:imm1, mn)
                                    ve(:imm1, 2*mp1-2, k) = ve(:imm1, 2*mp1-2, k) - ci(mp1, np1, k) * wb(:imm1, mn)
                                    vo(:imm1, 2*mp1-1, k) = vo(:imm1, 2*mp1-1, k) + bi(mp1, np1, k) * vb(:imm1, mn)
                                    ve(:imm1, 2*mp1-1, k) = ve(:imm1, 2*mp1-1, k) + cr(mp1, np1, k) * wb(:imm1, mn)
                                    wo(:imm1, 2*mp1-2, k) = wo(:imm1, 2*mp1-2, k) - cr(mp1, np1, k) * vb(:imm1, mn)
                                    we(:imm1, 2*mp1-2, k) = we(:imm1, 2*mp1-2, k) - bi(mp1, np1, k) * wb(:imm1, mn)
                                    wo(:imm1, 2*mp1-1, k) = wo(:imm1, 2*mp1-1, k) - ci(mp1, np1, k) * vb(:imm1, mn)
                                    we(:imm1, 2*mp1-1, k) = we(:imm1, 2*mp1-1, k) + br(mp1, np1, k) * wb(:imm1, mn)

                                    if (mod(nlat, 2) /= 0) then
                                        ve(imid, 2*mp1-2, k) = ve(imid, 2*mp1-2, k) &
                                            -ci(mp1, np1, k)*wb(imid, mn)
                                        ve(imid, 2*mp1-1, k) = ve(imid, 2*mp1-1, k) &
                                            +cr(mp1, np1, k)*wb(imid, mn)
                                        we(imid, 2*mp1-2, k) = we(imid, 2*mp1-2, k) &
                                            -bi(mp1, np1, k)*wb(imid, mn)
                                        we(imid, 2*mp1-1, k) = we(imid, 2*mp1-1, k) &
                                            +br(mp1, np1, k)*wb(imid, mn)
                                    end if
                                end do
                            end do
                        end if

                        if (mp2 <= even_stride) then
                            do k=1, nt
                                do np1=mp2, even_stride, 2
                                    mn = mb+np1
                                    ve(:imm1, 2*mp1-2, k) = ve(:imm1, 2*mp1-2, k) + br(mp1, np1, k) * vb(:imm1, mn)
                                    vo(:imm1, 2*mp1-2, k) = vo(:imm1, 2*mp1-2, k) - ci(mp1, np1, k) * wb(:imm1, mn)
                                    ve(:imm1, 2*mp1-1, k) = ve(:imm1, 2*mp1-1, k) + bi(mp1, np1, k) * vb(:imm1, mn)
                                    vo(:imm1, 2*mp1-1, k) = vo(:imm1, 2*mp1-1, k) + cr(mp1, np1, k) * wb(:imm1, mn)
                                    we(:imm1, 2*mp1-2, k) = we(:imm1, 2*mp1-2, k) - cr(mp1, np1, k) * vb(:imm1, mn)
                                    wo(:imm1, 2*mp1-2, k) = wo(:imm1, 2*mp1-2, k) - bi(mp1, np1, k) * wb(:imm1, mn)
                                    we(:imm1, 2*mp1-1, k) = we(:imm1, 2*mp1-1, k) - ci(mp1, np1, k) * vb(:imm1, mn)
                                    wo(:imm1, 2*mp1-1, k) = wo(:imm1, 2*mp1-1, k) + br(mp1, np1, k) * wb(:imm1, mn)
                                    if (mod(nlat, 2) /= 0) then
                                        ve(imid, 2*mp1-2, k) = ve(imid, 2*mp1-2, k) &
                                            + br(mp1, np1, k) * vb(imid, mn)
                                        ve(imid, 2*mp1-1, k) = ve(imid, 2*mp1-1, k) &
                                            + bi(mp1, np1, k) * vb(imid, mn)
                                        we(imid, 2*mp1-2, k) = we(imid, 2*mp1-2, k) &
                                            - cr(mp1, np1, k) * vb(imid, mn)
                                        we(imid, 2*mp1-1, k) = we(imid, 2*mp1-1, k) &
                                            - ci(mp1, np1, k) * vb(imid, mn)
                                    end if
                                end do
                            end do
                        end if
                    end do
                end if
            case (1)

                ! case ityp=1   no symmetries,  cr and ci equal zero

                ! case m = 0
                do k=1, nt
                    do np1=2, even_stride, 2
                        do i=1, imid
                            ve(i, 1, k)=ve(i, 1, k)+br(1, np1, k)*vb(i, np1)
                        end do
                    end do
                end do
                do k=1, nt
                    do np1=3, odd_stride, 2
                        do i=1, imm1
                            vo(i, 1, k)=vo(i, 1, k)+br(1, np1, k)*vb(i, np1)
                        end do
                    end do
                end do

                ! case m = 1 through nlat-1
                if (2 <= mmax) then
                    do mp1=2, mmax
                        m = mp1-1
                        mb = m*(nlat-1)-(m*(m-1))/2
                        mp2 = mp1+1
                        if (mp1 <= odd_stride) then
                            do k=1, nt
                                do np1=mp1, odd_stride, 2
                                    mn = mb+np1
                                    do i=1, imm1
                                        vo(i, 2*mp1-2, k) = vo(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, mn)
                                        vo(i, 2*mp1-1, k) = vo(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, mn)
                                        we(i, 2*mp1-2, k) = we(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, mn)
                                        we(i, 2*mp1-1, k) = we(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, mn)
                                    end do
                                    if (mod(nlat, 2) /= 0) then
                                        we(imid, 2*mp1-2, k) = we(imid, 2*mp1-2, k) &
                                            -bi(mp1, np1, k)*wb(imid, mn)
                                        we(imid, 2*mp1-1, k) = we(imid, 2*mp1-1, k) &
                                            +br(mp1, np1, k)*wb(imid, mn)
                                    end if
                                end do
                            end do
                        end if

                        if (mp2 <= even_stride) then
                            do k=1, nt
                                do np1=mp2, even_stride, 2
                                    mn = mb+np1
                                    do i=1, imm1
                                        ve(i, 2*mp1-2, k) = ve(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, mn)
                                        ve(i, 2*mp1-1, k) = ve(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, mn)
                                        wo(i, 2*mp1-2, k) = wo(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, mn)
                                        wo(i, 2*mp1-1, k) = wo(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, mn)
                                    end do
                                    if (mod(nlat, 2) /= 0) then
                                        ve(imid, 2*mp1-2, k) = ve(imid, 2*mp1-2, k) &
                                            +br(mp1, np1, k)*vb(imid, mn)
                                        ve(imid, 2*mp1-1, k) = ve(imid, 2*mp1-1, k) &
                                            +bi(mp1, np1, k)*vb(imid, mn)
                                    end if
                                end do
                            end do
                        end if
                    end do
                end if
            case (2)

                ! case ityp=2   no symmetries,  br and bi are equal to zero

                ! case m = 0
                do k=1, nt
                    do np1=2, even_stride, 2
                        do i=1, imid
                            we(i, 1, k)=we(i, 1, k)-cr(1, np1, k)*vb(i, np1)
                        end do
                    end do
                end do

                do k=1, nt
                    do np1=3, odd_stride, 2
                        do i=1, imm1
                            wo(i, 1, k)=wo(i, 1, k)-cr(1, np1, k)*vb(i, np1)
                        end do
                    end do
                end do

                ! case m = 1 through nlat-1
                if (2 <= mmax) then
                    do mp1=2, mmax
                        m = mp1-1
                        mb = m*(nlat-1)-(m*(m-1))/2
                        mp2 = mp1+1
                        if (mp1 <= odd_stride) then
                            do k=1, nt
                                do np1=mp1, odd_stride, 2
                                    mn = mb+np1
                                    do i=1, imm1
                                        ve(i, 2*mp1-2, k) = ve(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, mn)
                                        ve(i, 2*mp1-1, k) = ve(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, mn)
                                        wo(i, 2*mp1-2, k) = wo(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, mn)
                                        wo(i, 2*mp1-1, k) = wo(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, mn)
                                    end do

                                    if (mod(nlat, 2) /= 0) then
                                        ve(imid, 2*mp1-2, k) = ve(imid, 2*mp1-2, k) &
                                            -ci(mp1, np1, k)*wb(imid, mn)
                                        ve(imid, 2*mp1-1, k) = ve(imid, 2*mp1-1, k) &
                                            +cr(mp1, np1, k)*wb(imid, mn)
                                    end if
                                end do
                            end do
                        end if

                        if (mp2 <= even_stride) then
                            do k=1, nt
                                do np1=mp2, even_stride, 2
                                    mn = mb+np1
                                    do i=1, imm1
                                        vo(i, 2*mp1-2, k) = vo(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, mn)
                                        vo(i, 2*mp1-1, k) = vo(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, mn)
                                        we(i, 2*mp1-2, k) = we(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, mn)
                                        we(i, 2*mp1-1, k) = we(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, mn)
                                    end do
                                    if (mod(nlat, 2) /= 0) then
                                        we(imid, 2*mp1-2, k) = we(imid, 2*mp1-2, k) &
                                            -cr(mp1, np1, k)*vb(imid, mn)
                                        we(imid, 2*mp1-1, k) = we(imid, 2*mp1-1, k) &
                                            -ci(mp1, np1, k)*vb(imid, mn)
                                    end if
                                end do
                            end do
                        end if
                    end do
                end if
            case (3)
                 !
                 ! case ityp=3   v even,  w odd
                 !
                 ! case m = 0
                 !
                do k=1, nt
                    do np1=2, even_stride, 2
                        do i=1, imid
                            ve(i, 1, k)=ve(i, 1, k)+br(1, np1, k)*vb(i, np1)
                        end do
                    end do
                end do

                do k=1, nt
                    do np1=3, odd_stride, 2
                        do i=1, imm1
                            wo(i, 1, k)=wo(i, 1, k)-cr(1, np1, k)*vb(i, np1)
                        end do
                    end do
                end do
                !
                ! case m = 1 through nlat-1
                !
                if (2 <= mmax) then
                    do mp1=2, mmax
                        m = mp1-1
                        mb = m*(nlat-1)-(m*(m-1))/2
                        mp2 = mp1+1
                        if (mp1 <= odd_stride) then
                            do k=1, nt
                                do np1=mp1, odd_stride, 2
                                    mn = mb+np1
                                    do i=1, imm1
                                        ve(i, 2*mp1-2, k) = ve(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, mn)
                                        ve(i, 2*mp1-1, k) = ve(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, mn)
                                        wo(i, 2*mp1-2, k) = wo(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, mn)
                                        wo(i, 2*mp1-1, k) = wo(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, mn)
                                    end do
                                    if (mod(nlat, 2) /= 0) then
                                        ve(imid, 2*mp1-2, k) = ve(imid, 2*mp1-2, k) &
                                            -ci(mp1, np1, k) * wb(imid, mn)
                                        ve(imid, 2*mp1-1, k) = ve(imid, 2*mp1-1, k) &
                                            +cr(mp1, np1, k) * wb(imid, mn)
                                    end if
                                end do
                            end do
                        end if

                        if (mp2 <= even_stride) then
                            do k=1, nt
                                do np1=mp2, even_stride, 2
                                    mn = mb+np1
                                    do i=1, imm1
                                        ve(i, 2*mp1-2, k) = ve(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, mn)
                                        ve(i, 2*mp1-1, k) = ve(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, mn)
                                        wo(i, 2*mp1-2, k) = wo(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, mn)
                                        wo(i, 2*mp1-1, k) = wo(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, mn)
                                    end do
                                    if (mod(nlat, 2) /= 0) then
                                        ve(imid, 2*mp1-2, k) = ve(imid, 2*mp1-2, k) &
                                            + br(mp1, np1, k) * vb(imid, mn)
                                        ve(imid, 2*mp1-1, k) = ve(imid, 2*mp1-1, k) &
                                            + bi(mp1, np1, k) * vb(imid, mn)
                                    end if
                                end do
                            end do
                        end if
                    end do
                end if
            case (4)
                !
                ! case ityp=4   v even,  w odd, and both cr and ci equal zero
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=2, even_stride, 2
                        ve(:imid, 1, k) = ve(:imid, 1, k) &
                            + br(1, np1, k) * vb(:imid, np1)
                    end do
                end do
                !
                ! case m = 1 through nlat-1
                !
                if (2 <= mmax) then
                    do mp1=2, mmax
                        m = mp1-1
                        mb = m*(nlat-1)-(m*(m-1))/2
                        mp2 = mp1+1
                        if (mp2 <= even_stride) then
                            do k=1, nt
                                do np1=mp2, even_stride, 2
                                    mn = mb+np1
                                    do i=1, imm1
                                        ve(i, 2*mp1-2, k) = ve(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, mn)
                                        ve(i, 2*mp1-1, k) = ve(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, mn)
                                        wo(i, 2*mp1-2, k) = wo(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, mn)
                                        wo(i, 2*mp1-1, k) = wo(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, mn)
                                    end do
                                    if (mod(nlat, 2) /= 0) then
                                        ve(imid, 2*mp1-2, k) = ve(imid, 2*mp1-2, k) &
                                            +br(mp1, np1, k)*vb(imid, mn)
                                        ve(imid, 2*mp1-1, k) = ve(imid, 2*mp1-1, k) &
                                            +bi(mp1, np1, k)*vb(imid, mn)
                                    end if
                                end do
                            end do
                        end if
                    end do
                end if
            case (5)
                !
                ! case ityp=5   v even,  w odd,     br and bi equal zero
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=3, odd_stride, 2
                        do i=1, imm1
                            wo(i, 1, k)=wo(i, 1, k)-cr(1, np1, k)*vb(i, np1)
                        end do
                    end do
                end do
                !
                ! case m = 1 through nlat-1
                !
                if (2 <= mmax) then
                    do mp1=2, mmax
                        m = mp1-1
                        mb = m*(nlat-1)-(m*(m-1))/2
                        mp2 = mp1+1

                        if (mp1 <= odd_stride) then
                            do k=1, nt
                                do np1=mp1, odd_stride, 2
                                    mn = mb+np1
                                    do i=1, imm1
                                        ve(i, 2*mp1-2, k) = ve(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, mn)
                                        ve(i, 2*mp1-1, k) = ve(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, mn)
                                        wo(i, 2*mp1-2, k) = wo(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, mn)
                                        wo(i, 2*mp1-1, k) = wo(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, mn)
                                    end do
                                    if (mod(nlat, 2) /= 0) then
                                        ve(imid, 2*mp1-2, k) = ve(imid, 2*mp1-2, k) &
                                            -ci(mp1, np1, k)*wb(imid, mn)
                                        ve(imid, 2*mp1-1, k) = ve(imid, 2*mp1-1, k) &
                                            +cr(mp1, np1, k)*wb(imid, mn)
                                    end if
                                end do
                            end do
                        end if
                    end do
                end if
            case (6)
                !
                ! case ityp=6   v odd  ,  w even
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=2, even_stride, 2
                        do i=1, imid
                            we(i, 1, k)=we(i, 1, k)-cr(1, np1, k)*vb(i, np1)
                        end do
                    end do
                end do

                do k=1, nt
                    do np1=3, odd_stride, 2
                        do i=1, imm1
                            vo(i, 1, k)=vo(i, 1, k)+br(1, np1, k)*vb(i, np1)
                        end do
                    end do
                end do
                !
                ! case m = 1 through nlat-1
                !
                if (2 <= mmax) then
                    do mp1=2, mmax
                        m = mp1-1
                        mb = m*(nlat-1)-(m*(m-1))/2
                        mp2 = mp1+1
                        if (mp1 <= odd_stride) then
                            do k=1, nt
                                do np1=mp1, odd_stride, 2
                                    mn = mb+np1
                                    do i=1, imm1
                                        vo(i, 2*mp1-2, k) = vo(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, mn)
                                        vo(i, 2*mp1-1, k) = vo(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, mn)
                                        we(i, 2*mp1-2, k) = we(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, mn)
                                        we(i, 2*mp1-1, k) = we(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, mn)
                                    end do
                                    if (mod(nlat, 2) /= 0) then
                                        we(imid, 2*mp1-2, k) = we(imid, 2*mp1-2, k) &
                                            -bi(mp1, np1, k)*wb(imid, mn)
                                        we(imid, 2*mp1-1, k) = we(imid, 2*mp1-1, k) &
                                            +br(mp1, np1, k)*wb(imid, mn)
                                    end if
                                end do
                            end do
                        end if

                        if (mp2 <= even_stride) then
                            do k=1, nt
                                do np1=mp2, even_stride, 2
                                    mn = mb+np1
                                    do i=1, imm1
                                        vo(i, 2*mp1-2, k) = vo(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, mn)
                                        vo(i, 2*mp1-1, k) = vo(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, mn)
                                        we(i, 2*mp1-2, k) = we(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, mn)
                                        we(i, 2*mp1-1, k) = we(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, mn)
                                    end do
                                    if (mod(nlat, 2) /= 0) then
                                        we(imid, 2*mp1-2, k) = we(imid, 2*mp1-2, k) &
                                            -cr(mp1, np1, k)*vb(imid, mn)
                                        we(imid, 2*mp1-1, k) = we(imid, 2*mp1-1, k) &
                                            -ci(mp1, np1, k)*vb(imid, mn)
                                    end if
                                end do
                            end do
                        end if
                    end do
                end if
            case (7)
                !
                ! case ityp=7   v odd, w even   cr and ci equal zero
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=3, odd_stride, 2
                        do i=1, imm1
                            vo(i, 1, k)=vo(i, 1, k)+br(1, np1, k)*vb(i, np1)
                        end do
                    end do
                end do
                !
                ! case m = 1 through nlat-1
                !
                if (2 <= mmax) then
                    do mp1=2, mmax
                        m = mp1-1
                        mb = m*(nlat-1)-(m*(m-1))/2
                        mp2 = mp1+1
                        if (mp1 <= odd_stride) then
                            do k=1, nt
                                do np1=mp1, odd_stride, 2
                                    mn = mb+np1
                                    do i=1, imm1
                                        vo(i, 2*mp1-2, k) = vo(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, mn)
                                        vo(i, 2*mp1-1, k) = vo(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, mn)
                                        we(i, 2*mp1-2, k) = we(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, mn)
                                        we(i, 2*mp1-1, k) = we(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, mn)
                                    end do
                                    if (mod(nlat, 2) /= 0) then
                                        we(imid, 2*mp1-2, k) = we(imid, 2*mp1-2, k) &
                                            -bi(mp1, np1, k)*wb(imid, mn)
                                        we(imid, 2*mp1-1, k) = we(imid, 2*mp1-1, k) &
                                            +br(mp1, np1, k)*wb(imid, mn)
                                    end if
                                end do
                            end do
                        end if
                    end do
                end if
            case (8)
                !
                ! case ityp=8   v odd,  w even   br and bi equal zero
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=2, even_stride, 2
                        do i=1, imid
                            we(i, 1, k)=we(i, 1, k)-cr(1, np1, k)*vb(i, np1)
                        end do
                    end do
                end do
                !
                ! case m = 1 through nlat-1
                !
                if (2 <= mmax) then
                    do mp1=2, mmax
                        m = mp1-1
                        mb = m*(nlat-1)-(m*(m-1))/2
                        mp2 = mp1+1
                        if (mp2 <= even_stride) then
                            do k=1, nt
                                do np1=mp2, even_stride, 2
                                    mn = mb+np1
                                    do i=1, imm1
                                        vo(i, 2*mp1-2, k) = vo(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, mn)
                                        vo(i, 2*mp1-1, k) = vo(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, mn)
                                        we(i, 2*mp1-2, k) = we(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, mn)
                                        we(i, 2*mp1-1, k) = we(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, mn)
                                    end do
                                    if (mod(nlat, 2) /= 0) then
                                        we(imid, 2*mp1-2, k) = we(imid, 2*mp1-2, k) &
                                            -cr(mp1, np1, k)*vb(imid, mn)
                                        we(imid, 2*mp1-1, k) = we(imid, 2*mp1-1, k) &
                                            -ci(mp1, np1, k)*vb(imid, mn)
                                    end if
                                end do
                            end do
                        end if
                    end do
                end if
        end select vector_symmetry_cases

        call util%assemble_transform(idvw, jdvw, idv, imid, &
        imm1, ityp, nlat, nlon, nt, v, ve, vo, w, we, wo, wrfft)

    end subroutine vhses_lower_utility_routine

    pure function get_vhsesi_workspace_indices(nlat, imid, mmax, lzimn) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: imid
        integer(ip), intent(in)  :: mmax
        integer(ip), intent(in)  :: lzimn
        integer(ip)              :: return_value(4)

        associate (i => return_value)
            i(1) = 3*nlat*imid+1
            i(2) = (mmax*(2*nlat-mmax+1))/2
            i(3) = lzimn+1
            i(4) = 2*lzimn+1
        end associate

    end function get_vhsesi_workspace_indices

    subroutine vhsesi_lower_utility_routine(nlat, nlon, imid, vb, wb, idz, vin, wzvin, dwork)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: imid
        real(wp),    intent(out) :: vb(imid, *)
        real(wp),    intent(out) :: wb(imid, *)
        integer(ip), intent(in)  :: idz
        real(wp),    intent(out) :: vin(imid, nlat, 3)
        real(wp),    intent(out) :: wzvin(*)
        real(wp),    intent(out) :: dwork(*)

        ! Local variables
        integer(ip)         :: i3, m, mmax, mn, mp1, np1
        type(SpherepackUtility) :: util

        mmax = min(nlat, (nlon + 1)/2)

        call util%initialize_polar_components_for_regular_grids(nlat, nlon, wzvin, dwork)

        do mp1=1, mmax
            m = mp1-1
            call util%compute_polar_component(0, nlat, nlon, m, vin, i3, wzvin)
            do np1=mp1, nlat
                mn = m*(nlat-1)-(m*(m-1))/2+np1
                vb(1:imid, mn) = vin(1:imid, np1, i3)
            end do
        end do

        call util%initialize_azimuthal_components_for_regular_grids(nlat, nlon, wzvin, dwork)

        do mp1=1, mmax
            m = mp1-1
            call util%compute_azimuthal_component(0, nlat, nlon, m, vin, i3, wzvin)
            do np1=mp1, nlat
                mn = m*(nlat-1)-(m*(m-1))/2+np1
                wb(1:imid, mn) = vin(1:imid, np1, i3)
            end do
        end do

    end subroutine vhsesi_lower_utility_routine

end submodule vector_synthesis_regular_grid_saved


      REAL*8 FUNCTION XINTERP(X,X1,X2,Y1,Y2,LUERR,IERR)
C
C
C   THIS FUNCTION PERFORMS A LINEAR INTERPOLATION/EXTRAPOLATION
C   TO FIND THE VALUE Y OF A FUNCTION GIVEN THE VALUE X AND TWO POINTS
C   ON THE LINE, (X1,Y1) AND (X2,Y2).
C
C VARIABLE  DIM  TYPE  I/O  DESCRIPTION
C --------  ---  ----  ---  -----------
C X          1    R*8   I   KNOWN VALUE FOR WHICH CORRESPONDING
C                           INTERPOLATED VALUE IS DESIRED.
C
C X1         1    R*8   I   X-VALUE FOR THE FIRST KNOWN POINT
C
C X2         1    R*8   I   X-VALUE FOR THE SECOND KNOWN POINT
C                           X1 AND X2 MUST BE DIFFERENT VALUES.
C
C Y1         1    R*8   I   Y-VALUE FOR THE FIRST KNOWN POINT
C
C Y2         1    R*8   I   Y-VALUE FOR THE SECOND KNOWN POINT
C
C LUERR      1    I*4   I   FORTRAN UNIT NUMBER TO WHICH ERROR MESSAGES
C                           CAN BE WRITTEN.
C
C IERR       1    I*4   O   ERROR RETURN FLAG.
C                           = 0, NO ERROR.
C                           = 1, ERROR. ONLY ERROR IS X1=X2.
C                                IF AN ERROR OCCURS,
C                                THEN XINTERP = (Y1+Y2)/2 IS SET.
C
C XINTERP    1    R*8   O   THIS IS THE FUNCTION VALUE THAT IS RETURNED.
C
C-----------------------------------------------------------------------
C
C   CODED BY MARY S. WALKER. 12/83.
C       MODIFIED.....
C
C-----------------------------------------------------------------------
C
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER NERR/0/, MAXERR/6/
C
C
      IF (X1.EQ.X2) THEN
         IERR = 1
         XINTERP = (Y1+Y2)/2.D0
         CALL MESAGE(1,NERR,MAXERR,1,3,0,LUERR,
     *    'ERROR IN XINTERP. X1=X2. INTERPOLATION VALUE = (Y1+Y2)/2.')
      ELSE
         IERR = 0
         GRAD = ( Y2 - Y1 ) / ( X2 - X1 )
         DIFF = ( X - X1 ) * GRAD
         XINTERP = DIFF + Y1
         END IF
C
      RETURN
      END


!! ------------------------------------------------------------------------- !!
!>
!! Common parameters used in llw2d and tdac
!<
!! --
module m_params

  implicit none
  public

  integer, parameter, public :: DP = selected_real_kind(13)
  integer, parameter, public :: STDERR  = 0
  integer, parameter, public :: STDOUT  = 6
  real(DP), parameter :: g0 = 9.80665_DP   !<  Gravity Constant

  !! finite differnce method parametrs
  integer,  parameter :: nx = 200         !<  grid number (NS)
  integer,  parameter :: ny = 200         !<  grid number (EW)
  integer,  parameter :: no = 36           !<  Number of stations
  real(DP), parameter :: dx = 2000._DP     !<  grid width of x-direction (m)
  real(DP), parameter :: dy = 2000._DP     !<  grid width of y-direction (m)
  real(DP), parameter :: dt = 1.0_DP       !<  time step width (sec)

end module m_params
!! ------------------------------------------------------------------------- !!


      SUBROUTINE LDP (G,MDG,M,N,H,X,XNORM,W,INDEX,MODE)
C
C  Algorithm LDP: LEAST DISTANCE PROGRAMMING
C
C  The original version of this code was developed by
C  Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory
C  1974 MAR 1, and published in the book
C  "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974.
C  Revised FEB 1995 to accompany reprinting of the book by SIAM.
C     ------------------------------------------------------------------
      integer I, IW, IWDUAL, IY, IZ, J, JF, M, MDG, MODE, N, NP1
C     integer INDEX(M)
C     double precision G(MDG,N), H(M), X(N), W(*)
      integer INDEX(*)
      double precision G(MDG,*), H(*), X(*), W(*)
      double precision DIFF, FAC, ONE, RNORM, XNORM, ZERO
      parameter(ONE = 1.0d0, ZERO = 0.0d0)
C     ------------------------------------------------------------------
      IF (N.LE.0) GO TO 120
          DO 10 J=1,N
   10     X(J)=ZERO
      XNORM=ZERO
      IF (M.LE.0) GO TO 110
C
C     THE DECLARED DIMENSION OF W() MUST BE AT LEAST (N+1)*(M+2)+2*M.
C
C      FIRST (N+1)*M LOCS OF W()   =  MATRIX E FOR PROBLEM NNLS.
C       NEXT     N+1 LOCS OF W()   =  VECTOR F FOR PROBLEM NNLS.
C       NEXT     N+1 LOCS OF W()   =  VECTOR Z FOR PROBLEM NNLS.
C       NEXT       M LOCS OF W()   =  VECTOR Y FOR PROBLEM NNLS.
C       NEXT       M LOCS OF W()   =  VECTOR WDUAL FOR PROBLEM NNLS.
C     COPY G**T INTO FIRST N ROWS AND M COLUMNS OF E.
C     COPY H**T INTO ROW N+1 OF E.
C
      IW=0
          DO 30 J=1,M
              DO 20 I=1,N
              IW=IW+1
   20         W(IW)=G(J,I)
          IW=IW+1
   30     W(IW)=H(J)
      JF=IW+1
C                                STORE N ZEROS FOLLOWED BY A ONE INTO F.
          DO 40 I=1,N
          IW=IW+1
   40     W(IW)=ZERO
      W(IW+1)=ONE
C
      NP1=N+1
      IZ=IW+2
      IY=IZ+NP1
      IWDUAL=IY+M
C
      CALL NNLS (W,NP1,NP1,M,W(JF),W(IY),RNORM,W(IWDUAL),W(IZ),INDEX,
     *           MODE)
C                      USE THE FOLLOWING RETURN IF UNSUCCESSFUL IN NNLS.
      IF (MODE.NE.1) RETURN
      IF (RNORM) 130,130,50
   50 FAC=ONE
      IW=IY-1
          DO 60 I=1,M
          IW=IW+1
C                               HERE WE ARE USING THE SOLUTION VECTOR Y.
   60     FAC=FAC-H(I)*W(IW)
C
      IF (DIFF(ONE+FAC,ONE)) 130,130,70
   70 FAC=ONE/FAC
          DO 90 J=1,N
          IW=IY-1
              DO 80 I=1,M
              IW=IW+1
C                               HERE WE ARE USING THE SOLUTION VECTOR Y.
   80         X(J)=X(J)+G(I,J)*W(IW)
   90     X(J)=X(J)*FAC
          DO 100 J=1,N
  100     XNORM=XNORM+X(J)**2
      XNORM=sqrt(XNORM)
C                             SUCCESSFUL RETURN.
  110 MODE=1
      RETURN
C                             ERROR RETURN.       N .LE. 0.
  120 MODE=2
      RETURN
C                             RETURNING WITH CONSTRAINTS NOT COMPATIBLE.
  130 MODE=4
      RETURN
      END


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2019 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!     This subroutines enables to calculate the reynolds number correction after:
!     "Discharge coeffcients for incompressible non-cavitating flowthrough long orifices"
!     A. Lichtarowicz, R.K duggins and E. Markland
!     Journal  Mechanical Engineering Science , vol 7, No. 2, 1965
!
!     author: Yannick Muller
!
      subroutine cd_lichtarowicz(cd,cdu,reynolds,amod,bdh)
!
      implicit none
!
      real*8 cdu,reynolds,amod,bdh,eps,A1,cd_diff,cd0,cd
!
      cd0=cdu
      cd_diff=1.d0
!
      do
!
         if(cd_diff.lt.1.d-3) exit
!
         cd=cd0
         A1=20/(reynolds*dsqrt(1.d0-Amod**2))*(1.d0+2.25d0*bdh)
         eps=(0.005d0*bdh)/(1.d0+7.5d0*(log10(0.00015d0*reynolds*
     &        dsqrt(1.d0-Amod**2)/cd))**2)

         cd=((-1/cdu+eps)+dsqrt((1/cdu-eps)**2.d0+4.d0*A1))/(2*A1)
!
         cd_diff=dabs(cd-cd0)
!
         cd0=cd
!
       enddo
!
         return
         end


program Guess_a_number_Player
  implicit none

  integer, parameter :: limit = 100
  integer :: guess, mx = limit, mn = 1
  real :: rnum
  character(1) :: score

  write(*, "(a, i0, a)") "Think of a number between 1 and ", limit, &
                         " and I will try to guess it."
  write(*, "(a)")  "You score my guess by entering: h if my guess is higher than that number"
  write(*, "(a)")  "                                l if my guess is lower than that number"
  write(*, "(a/)") "                                c if my guess is the same as that number"

  call random_seed
  call random_number(rnum)
  guess = rnum * limit + 1
  do
    write(*, "(a, i0, a,)", advance='no') "My quess is: ", guess, "   Score(h, l or c)?: "
    read*, score
    select case(score)
      case("l", "L")
        mn = guess
        guess = (mx-guess+1) / 2 + mn

      case("h", "H")
        mx = guess
        guess = mx - (guess-mn+1) / 2

      case("c", "C")
        write(*, "(a)") "I solved it!"
        exit

      case default
        write(*, "(a)") "I did not understand that"
    end select
  end do
end program


      logical function pvGramsing(G,n)
c--- JC: added comparison to onshellcutoff for each element of the
c---     matrix passed in; if the element is smaller, set to zero
      implicit none
      include 'TRonshellcutoff.f'
      include 'TRscale.f'
      integer nmax,n,j,k
      double complex G(n,n)
      double precision preci,wmax,wmin
      parameter(nmax=4,preci=1d-7)
c--- Regular PV reduction fails checks at the C4 level at approx.
c---  10^-5 level of precision; lower tensors correspond to
c---  much smaller values of preci.
      double precision Ga(nmax,nmax),V(nmax,nmax),w(nmax)
C--- logical function which return true if the
C--- Gram matrix is singular
      if (n .gt. nmax) then
      write(6,*) 'Error in pvGramsing, n .gt. nmax'
      stop
      endif

      do j=1,n
      do k=1,n
        Ga(j,k)=dble(G(j,k))
c--- the next line improves convergence in pvdsvdcmp
        if (abs(Ga(j,k)/musq) .lt. onshellcutoff) Ga(j,k)=0d0
      enddo
      enddo

      call pvdsvdcmp(Ga,n,n,nmax,nmax,w,v)

      wmax=0d0
      do j=1,n
      if (w(j) .gt. wmax)wmax=w(j)
      enddo

      wmin=preci*wmax
      pvGramsing=.false.

      do j=1,n
c        write(6,*) 'wj ',w(j)/wmax
        if (w(j) .lt. wmin) then
          pvGramsing=.true.
          return
        endif
      enddo

      end