c     program DRZCOMP
c>> 2001-01-24 DRZCOMP  ZSQRT -> ZSQRTX to fix C lib. problems.
c>> 1998-01-22 DRZCOMP  Krogh Added ZDIF,..., ZSUM to exernal statement.
c>> 1996-05-28 DRZCOMP  Krogh Added external statement.
c>> 1993-02-04 CLL Added call to DZABS.
c>> 1987-12-09 DRZCOMP  Lawson  Initial Code.
c     Demo driver for DZABS, ZSUM, ZDIF, ZPRO, ZQUO, and ZSQRTX.
c     C. L. Lawson, JPL, 1987 Feb 17.
c     ------------------------------------------------------------------
      external DZABS, ZDIF, ZPRO, ZQUO, ZSQRTX, ZSUM
      double precision DZABS
      double precision A(2), B(2), C(2), DMAG, U(2), U2(2), V(2), V2(2)
      double precision W(2), W2(2), TEST(2), Z(2)
c     ------------------------------------------------------------------
      A(1) = 6.0D0/7.0D0
      A(2) = -14.0D0/15.0D0
      B(1) = -29.0D0/31.0D0
      B(2) = 47.0D0/43.0D0
      U(1) = 51.0D0/53.0D0
      U(2) = 73.0D0/71.0D0
      call ZSUM(U, A, V)
      call ZPRO(V, B, W)
      call ZSQRTX(W,   Z)
      call ZPRO(Z, Z, W2)
      call ZQUO(W2, B, V2)
      call ZDIF(V2, A, U2)
      call ZDIF(U2, U, TEST)
      C(1) =  3.0d0/7.0d0
      C(2) = -4.0d0/7.0d0
      DMAG = DZABS(C)
      print'(a/)','                             ODZCOMP'
      print '(1x,a,f19.15,a,f19.15,a)',
     *   'A        = (',A(1),',',A(2), ')',
     *   'B        = (',B(1),',',B(2), ')',
     *   'U        = (',U(1),',',U(2), ')',
     *   'V = U+A  = (',V(1),',',V(2), ')',
     *   'W = V*B  = (',W(1),',',W(2), ')',
     *   'Z=sqrt(W)= (',Z(1),',',Z(2), ')',
     *   'W2 = Z*Z = (',W2(1),',',W2(2), ')',
     *   'V2= W2/B = (',V2(1),',',V2(2), ')',
     *   'U2= V2-A = (',U2(1),',',U2(2), ')'
      print '(1x,a,g19.3,a,g19.3,a)',
     *   'TEST=U2-U= (',TEST(1),',',TEST(2), ')'
      C(1) =  3.0d0/7.0d0
      C(2) = -4.0d0/7.0d0
      DMAG = DZABS(C)
      print '(/1x,a,f19.15,a,f19.15,a)',
     *   'C        = (',C(1),',',C(2), ')'
      print '(1x,a,g11.3)',
     *   'TEST2 = DZABS(C)-(5/7) = ',DMAG-(5.0d0/7.0d0)
      stop

      end


! Like array_constructor_6.f90, but test for nested iterators.
! { dg-do run }
program main
  implicit none
  call build (17)
contains
  subroutine build (order)
    integer :: order, i, j

    call test (order, (/ (((j + 100) * i, j = 1, i), i = 1, order) /))
    call test (9, (/ (((j + 100) * i, j = 1, i), i = 1, 9) /))
    call test (3, (/ 101, 202, 204, 303, 306, 309 /))
  end subroutine build

  subroutine test (order, values)
    integer, dimension (:) :: values
    integer :: order, i, j

    if (size (values, dim = 1) .ne. order * (order + 1) / 2) call abort
    do i = 1, order
      do j = 1, i
        if (values (i * (i - 1) / 2 + j) .ne. (j + 100) * i) call abort
      end do
    end do
  end subroutine test
end program main


PROGRAM StandingAccretionShock1D

  USE KindModule, ONLY: &
    DP, Pi
  USE ProgramInitializationModule, ONLY: &
    InitializeProgram, &
    FinalizeProgram
  USE InitializationModule, ONLY: &
    InitializeStandingAccretionShock
  USE TimeSteppingModule, ONLY: &
    EvolveFields, &
    SSP_RK
  USE GravitySolutionModule, ONLY: &
    SolveGravity

  IMPLICIT NONE

  ! --- Problem Parameters ---

  REAL(DP), PARAMETER :: AccretionRate     = 4.0_DP * pi
  REAL(DP), PARAMETER :: GravitationalMass = 0.5_DP
  REAL(DP), PARAMETER :: ShockRadius       = 1.0_DP
  REAL(DP), PARAMETER :: PolytropicGamma   = 4.0_DP / 3.0_DP
  REAL(DP), PARAMETER :: MachNumber        = 3.0d1

  CALL InitializeProgram &
         ( ProgramName_Option &
            = 'StandingAccretionShock1D', &
           nX_Option &
             = [ 128, 1, 1 ], &
           swX_Option &
             = [ 1, 0, 0 ], &
           bcX_Option &
             = [ 10, 0, 0 ], &
           xL_Option &
             = [ 0.2_DP, 0.0_DP, 0.0_DP ], &
           xR_Option &
             = [ 2.0_DP, Pi,     4.0_DP ], &
           zoomX_Option &
             = [ 1.0_DP, 1.0_DP, 1.0_DP ], &
           nNodes_Option &
             = 2, &
           CoordinateSystem_Option &
             = 'SPHERICAL', &
           EquationOfState_Option &
             = 'IDEAL', &
           Gamma_IDEAL_Option &
             = PolytropicGamma, &
           FluidSolver_Option &
             = 'Euler_DG', &
           FluidRiemannSolver_Option &
             = 'HLLC', &
           EvolveFluid_Option &
             = .TRUE., &
           ApplySlopeLimiter_Option &
             = .TRUE., &
           BetaTVB_Option &
             = 0.0d0, &
           BetaTVD_Option &
             = 1.8d0, &
           ApplyPositivityLimiter_Option &
             = .TRUE., &
           EvolveGravity_Option &
             = .TRUE., &
           GravitySolver_Option &
             = 'Newtonian_PointMass', &
           PointMass_Option &
             = GravitationalMass, &
           nStages_SSP_RK_Option &
             = 2 )

  CALL InitializeStandingAccretionShock &
         ( AccretionRate, &
           GravitationalMass, &
           ShockRadius, &
           PolytropicGamma, &
           MachNumber )

  CALL SolveGravity

  CALL EvolveFields &
         ( t_begin  = 0.00_DP, &
           t_end    = 5.00_DP, &
           dt_write = 0.50_DP, &
           UpdateFields = SSP_RK )

  CALL FinalizeProgram

END PROGRAM StandingAccretionShock1D


! mod_least65.f90
!**********************************************************************
! Copyright (c) 2018, Hiroaki Kadowaki (kadowaki@tmu.ac.jp)
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation and/or
! other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may
! be used to endorse or promote products derived from this software without specific
! prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
! INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
! NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!    (See https://opensource.org/licenses/BSD-3-Clause )
!
!**********************************************************************
! A fortran90 program of non-linear least squares
! using LAPACK subroutines DGEQP3, DORMQR, DTRTRS, DSYEVR
!
! mod_least65.f90 : fortran90 source code
! test_mod_ls65.f90 : test program
! tsls65.dat : test input data
! tsls65.out : test output
!
! compile and link:
!   $ gfortran -Wall -O -o test_mod_ls65.ex mod_least65.f90 test_mod_ls65.f90 -llapack -lblas
!   ($ ifort -mkl -O -o test_mod_ls65.ex mod_least65.f90 test_mod_ls65.f90 )
! run
!   $ ./test_mod_ls65.ex < tsls65.dat > tsls65.out
!**********************************************************************
!      1035 LINES
!  non-linear least squares
!   Ver-6.5 f90 module
!       kadowaki@tmu.ac.jp
!**********************************************************************
!  SUBROUTINES: LEAST MARQRT DFMDL DIAGNO DSYEVR DGEQP3 DORMQR DTRTRS
!  MODULE least_var
!**********************************************************************
!  LEAST CALCULATES PA(IPFIT(J)) (J=1-NPFIT)
!  SUMS=SUMMATION(((OBS(I)-CALC(I))/WSQRT(I))**2) (I=1-NS) = minimum
!**********************************************************************
!                   HOW TO USE
!**********************************************************************
!  NS INPUT :NUMBER OF OBSERVED DATA
!     OUTPUT:NO CHANGE
!  OBS(1-NS) INPUT :OBSERVED DATA
!               OUTPUT:NO CHANGE
!  WSQRT(1-NS) INPUT:ERROR OF OBSERVED DATA (ONE SIGMA OF NORMAL
!                    DISTRIBUTION)    IF YOU DO NOT KNOW ERROR OF
!		     OBSERVATION, GIVE APPROXIMATE VALUES.
!              OUTPUT:NO CHANGE
!  NP INPUT :NUMBER OF PARAMETERS
!     OUTPUT:NO CHANGE
!  NPFIT INPUT :NUMBER OF FITTED PARAMETERS (NPFIT >= NP)
!        OUTPUT:NO CHANGE
!  IPFIT(1-NPFIT) INPUT :INDEX OF FITTED PARAMETERS
!                 OUTPUT:NO CHANGE
!  PA(1-NP) INPUT :INITIAL VALUES OF PARAMETERS
!           OUTPUT:FITTED VALUES FOR PA(IPFIT(1-NPFIT))
!  EPSR INPUT :CONVERGENCE CRITERION VALUE
!              FOR NORMAL USE GIVE EPSR = 1.0d-5
!              IF CONVERGENCE IS TOO SLOW, GIVE 1.0d-3 > EPSR > 1.0d-5
!       OUTPUT:EPSR > 1.0d-3 --> EPSR = 1.0d-3
!              EPSR < 1.0d-5 --> EPSR = 1.0d-5
!              OTHERWISE NO CHANGE
!  MAXX INPUT :MAXIMUM ITERATION OF LEAST SQUARE LOOP (MAXX >= 1)
!       OUTPUT:NO CHANGE
!  IDRSW INPUT :SWITCH OF DERIVATIVE
!               =0 --> ANALYTIC DERIVATIVE USING DFMODL
!               =1 --> NUMERICAL DERIVATIVE USING FMODL
!        OUTPUT:NO CHANGE
!  NPR   INPUT :'UNIT' NUMBER FOR PRINT OUT (WRITE(NPR,*))
!        OUTPUT:NO CHANGE
!  IPRSW INPUT :SWITCH OF PRINT OUTPUT
!               =0 --> PRINT OUT STANDARD STATEMENTS
!               =1 --> PRINT OUT ALL STATEMENTS
!               =2 --> PRINT OUT ONLY ERROR MESSAGES
!               =3 --> PRINT OUT NOTHING
!        OUTPUT:NO CHANGE
!  CALC(1-NS) OUTPUT:CALCULATED DATA USING FITTED PA(1-NS)
!  ERPA(1-NP) OUTPUT:ERROR OF PA(1-NS)
!                    ERPA(J)=SQRT(ERMPA(J,J))
!  ERMPA(1-NP,1-NP) OUTPUT:ERROR MATRIX OF PA(1-NP)
!                   ERMPA(I,J)=<(PA(I)-TRUE PA(I))*(PA(J)-TRUE PA(J))>
!  SUMS OUTPUT:SUMMATION(((OBS(I)-CALC(I))/WSQRT(I))**2) (I=1-NS)
!              USING FITTED PA(1-NS)
!              THIS IS KAISQUARE WITH DEGREE OF FREEDOM (NS-NPFIT)
!  SIGST OUTPUT:SIGST=SQRT(SUMS/(NS-NPFIT))
!               IF YOU DO NOT KNOW ERROR OF OBSERVATION (WSQRT(1-NS)),
!               USE THIS FOR NORMARIZATION OF ERROR OF
!               PA(IPFIT(1-NPFIT)).  IN THIS CASE, ERROR OF PA(J) IS
!               SIGST*ERPA(J), AND ERROR MATRIX OF PA(J) IS
!               SIGST**2*ERMPA(I,J).
!  ICONL OUTPUT:CONDITION CODE
!               =0 NO ERROR
!               =10 ITERATION NUMBER > MAXX
!               =20 MARQUARDT NUMBER > UPPER LIMIT
!                   USUALLY FITTING IS OK
!               =30 RANK REDUCTION OF JACOBIAN MATRIX
!                   PARAMETERS ARE NOT INDEPENDENT OR MISTAKES IN
!                   DERIVATIVE
!               =40 IMPOSSIBLE TO DIAGONALIZE TRANSPOSE(AP)*(AP)
!               =50 ERROR IN NUMERICAL DERIVATIVE
!               =100 ERROR IN INPUT
!
!  WRITE FOLLOWING TWO SUBROUTINES WHICH GIVE MODEL FUNCTION (CALC(I))
!  AND ITS PARTIAL DERIVATIVE.
!    SUBROUTINE FMODL
!       INPUT: PA(1-NP)
!       OUTPUT: CALC(1-NS) MODEL FUNCTION
!    SUBROUTINE DFMODL
!       INPUT: PA(1-NP)
!       OUTPUT: AP(I,J)=PARTIAL DERIVATIVE OF CALC(I) BY PA(J)
!                      =DELTA(CALC(I))/DELTA(PA(J))
!                      I=1-NS, J=IPFIT(1-NPFIT)
!       IDRSW=0 --> THIS SUBROUTINE IS INDISPENSABLE
!       IDRSW=1 --> THIS SUBROUTINE IS NOT CALLED, BUT MUST EXIST FOR
!                   LINKAGE. "RETURN" AND "END" IS ENOUGH.
!
!***********   EXAMPLE
!MODULE least_var
!  IMPLICIT NONE
!  integer, parameter :: DP = kind(1.0D0)
!  integer(4), parameter :: set_NSMAX=200
!  real(DP) :: Q(set_NSMAX)
!END MODULE least_var
!-----
!program ts_modls64
!  use mod_least, only : NPR,NS,NP,NPFIT,IPFIT,PA,IPRSW,IDRSW,OBS,WSQRT,LEAST,least_alloc,least_dealloc
!  use least_var, only : Q
!  IMPLICIT NONE
! .....
!  NS=200
!  NP=20
!  call least_alloc
! .....
!  CALL LEAST(EPSR,MAXX,SUMS,SIGST,ICON)
!  call least_dealloc
! .....
!end program ts_modls63
!-----
!subroutine FMODL
!  use mod_least, only : PA,CALC,NS
!  use least_var, only : Q
!  IMPLICIT NONE
!  integer(4) :: I
!  DO I=1,NS
!    CALC(I)=PA(1)+PA(2)*Q(I)+PA(3)/( (Q(I)-PA(4))**2 + PA(5)**2 )
!  end do
!end subroutine FMODL
!
!-----
MODULE mod_least
  IMPLICIT NONE
  private
  public :: LEAST,least_alloc,least_dealloc
  public :: NS,OBS,WSQRT,NP,NPFIT,IPFIT,PA,IDRSW,NPR,IPRSW,CALC,ERPA,ERMPA
  public :: AP
!
  integer, parameter :: DP = kind(1.0D0)
!
  integer(4), save :: NSMAX=200  ! =UPPER LIMIT OF NS
  integer(4), save :: NPMAX=20   ! =UPPER LIMIT OF NP (NPMAX.GE.4)
  integer(4), save :: NSPMAX     ! =NSMAX+NPMAX
  integer(4), save :: NPMAX2     ! =2*NPMAX
!
  real(DP), save, ALLOCATABLE :: PA(:),CALC(:),WSQRT(:),AP(:,:) &
     &,OBS(:),ERMPA(:,:),ERPA(:)
  integer(4), save :: NS,NP,NPFIT,IPRSW,IDRSW,NPR=6
  integer(4), save, ALLOCATABLE :: IPFIT(:)
!
  integer(4), save, ALLOCATABLE :: IVW(:),IPIV(:)
  real(DP), save, ALLOCATABLE :: PAULI(:),PASCAL(:),DELX(:),VP(:)
  real(DP), save, ALLOCATABLE :: VPP(:),APP(:,:),FD(:)
  real(DP), save, ALLOCATABLE :: ERMX(:,:),ERMXX(:,:)
!
  integer(4), save :: LWORK                      ! DGEQP3 + DORMQR + DTRTRS
  integer(4), save, ALLOCATABLE :: JPVT(:)       ! DGEQP3 + DORMQR + DTRTRS
  real(DP), save, ALLOCATABLE :: TAU(:),WORK(:)  ! DGEQP3 + DORMQR + DTRTRS
!
contains
!-----
  SUBROUTINE least_alloc
    IMPLICIT NONE
    integer(4) :: ICON                           ! DGEQP3 + DORMQR + DTRTRS
    NSMAX=NS
    NPMAX=max(4,NP)
    NSPMAX=NSMAX+NPMAX
    NPMAX2=2*NPMAX
    if( ALLOCATED(    PA) ) DEALLOCATE(    PA)
    if( ALLOCATED(  CALC) ) DEALLOCATE(  CALC)
    if( ALLOCATED( WSQRT) ) DEALLOCATE( WSQRT)
    if( ALLOCATED(    AP) ) DEALLOCATE(    AP)
    if( ALLOCATED(   OBS) ) DEALLOCATE(   OBS)
    if( ALLOCATED( ERMPA) ) DEALLOCATE( ERMPA)
    if( ALLOCATED(  ERPA) ) DEALLOCATE(  ERPA)
    if( ALLOCATED( IPFIT) ) DEALLOCATE( IPFIT)
    if( ALLOCATED(   IVW) ) DEALLOCATE(   IVW)
    if( ALLOCATED(  IPIV) ) DEALLOCATE(  IPIV)
    if( ALLOCATED( PAULI) ) DEALLOCATE( PAULI)
    if( ALLOCATED(PASCAL) ) DEALLOCATE(PASCAL)
    if( ALLOCATED(  DELX) ) DEALLOCATE(  DELX)
    if( ALLOCATED(    VP) ) DEALLOCATE(    VP)
    if( ALLOCATED(   VPP) ) DEALLOCATE(   VPP)
    if( ALLOCATED(   APP) ) DEALLOCATE(   APP)
    if( ALLOCATED(    FD) ) DEALLOCATE(    FD)
    if( ALLOCATED(  ERMX) ) DEALLOCATE(  ERMX)
    if( ALLOCATED( ERMXX) ) DEALLOCATE( ERMXX)
    if( ALLOCATED(  JPVT) ) DEALLOCATE(  JPVT)  ! DGEQP3 + DORMQR + DTRTRS
    if( ALLOCATED(   TAU) ) DEALLOCATE(   TAU)  ! DGEQP3 + DORMQR + DTRTRS
    if( ALLOCATED(  WORK) ) DEALLOCATE(  WORK)  ! DGEQP3 + DORMQR + DTRTRS
    ALLOCATE(    PA(NPMAX)        )
    ALLOCATE(  CALC(NSMAX)        )
    ALLOCATE( WSQRT(NSMAX)        )
    ALLOCATE(    AP(NSPMAX,NPMAX) )
    ALLOCATE(   OBS(NSMAX)        )
    ALLOCATE( ERMPA(NPMAX,NPMAX)  )
    ALLOCATE(  ERPA(NPMAX)        )
    ALLOCATE( IPFIT(NPMAX)        )
    ALLOCATE(   IVW(NPMAX)        )
    ALLOCATE(  IPIV(NPMAX)        )
    ALLOCATE( PAULI(NPMAX)        )
    ALLOCATE(PASCAL(NPMAX)        )
    ALLOCATE(  DELX(NPMAX)        )
    ALLOCATE(    VP(NSPMAX)       )
    ALLOCATE(   VPP(NSPMAX)       )
    ALLOCATE(   APP(NSPMAX,NPMAX) )
    ALLOCATE(    FD(NPMAX2)       )
    ALLOCATE(  ERMX(NPMAX,NPMAX)  )
    ALLOCATE( ERMXX(NPMAX,NPMAX)  )
    ALLOCATE(  JPVT(NPMAX)        )  ! DGEQP3 + DORMQR + DTRTRS
    ALLOCATE(   TAU(NPMAX)        )  ! DGEQP3 + DORMQR + DTRTRS
!
    ALLOCATE(WORK(1))                ! DGEQP3 + DORMQR + DTRTRS
      LWORK=-1
      JPVT(1:NPMAX) = 0
      APP(1:NSPMAX,1:NPMAX) = 0.0d0
      ICON=0
      CALL DGEQP3(NSPMAX,NPMAX,APP,NSPMAX,JPVT,TAU,WORK,LWORK,ICON)
!      WRITE(*,'(/,A,I10,G15.7)')'  LWORK=-1  DGEQP3 ;  ICON, WORK(1) = ',ICON,WORK(1)
      LWORK=NINT(WORK(1))
    DEALLOCATE(WORK)
    ALLOCATE(WORK(LWORK))            ! DGEQP3 + DORMQR + DTRTRS
!
  END SUBROUTINE least_alloc
!-----
  SUBROUTINE least_dealloc
    IMPLICIT NONE
    if( ALLOCATED(    PA) ) DEALLOCATE(    PA)
    if( ALLOCATED(  CALC) ) DEALLOCATE(  CALC)
    if( ALLOCATED( WSQRT) ) DEALLOCATE( WSQRT)
    if( ALLOCATED(    AP) ) DEALLOCATE(    AP)
    if( ALLOCATED(   OBS) ) DEALLOCATE(   OBS)
    if( ALLOCATED( ERMPA) ) DEALLOCATE( ERMPA)
    if( ALLOCATED(  ERPA) ) DEALLOCATE(  ERPA)
    if( ALLOCATED( IPFIT) ) DEALLOCATE( IPFIT)
    if( ALLOCATED(   IVW) ) DEALLOCATE(   IVW)
    if( ALLOCATED(  IPIV) ) DEALLOCATE(  IPIV)
    if( ALLOCATED( PAULI) ) DEALLOCATE( PAULI)
    if( ALLOCATED(PASCAL) ) DEALLOCATE(PASCAL)
    if( ALLOCATED(  DELX) ) DEALLOCATE(  DELX)
    if( ALLOCATED(    VP) ) DEALLOCATE(    VP)
    if( ALLOCATED(   VPP) ) DEALLOCATE(   VPP)
    if( ALLOCATED(   APP) ) DEALLOCATE(   APP)
    if( ALLOCATED(    FD) ) DEALLOCATE(    FD)
    if( ALLOCATED(  ERMX) ) DEALLOCATE(  ERMX)
    if( ALLOCATED( ERMXX) ) DEALLOCATE( ERMXX)
    if( ALLOCATED(  JPVT) ) DEALLOCATE(  JPVT)  ! DGEQP3 + DORMQR + DTRTRS
    if( ALLOCATED(   TAU) ) DEALLOCATE(   TAU)  ! DGEQP3 + DORMQR + DTRTRS
    if( ALLOCATED(  WORK) ) DEALLOCATE(  WORK)  ! DGEQP3 + DORMQR + DTRTRS
  END SUBROUTINE least_dealloc
!
!----
  SUBROUTINE LEAST(EPSR,MAXX,SUMS,SIGST,ICONL)
!
    IMPLICIT NONE
    integer, parameter :: DP = kind(1.0D0)
    real(DP), intent(inout) :: EPSR
    real(DP), intent(out) :: SUMS,SIGST
    integer(4), intent(in) :: MAXX
    integer(4), intent(out) :: ICONL
    real(DP) :: SUMSN,WSQRTI(NSMAX),yy
    integer(4) :: J,I,ICON,NDG,NPP
!
!-----------CHECK INPUT
    IF(     NS > NSMAX   .OR. NS <= 0                    &
     & .OR. NP > NPMAX   .OR. NP <= 0                    &
     & .OR. NPFIT > NS   .OR. NPFIT > NP .OR. NPFIT <= 0 &
     & .OR. EPSR < 0.0d0 .OR. MAXX <= 0                  &
     & .OR. IPRSW >= 4   .OR. IPRSW <= -1                &
     & .OR. IDRSW >= 2   .OR. IDRSW <= -1                ) THEN
      IF(IPRSW /= 3) write(NPR,'(A)')'   INVALID NS, NP, NPFIT, EPSR, MAXX, IPRSW OR IDRSW'
      ICONL=100 ;  RETURN
    ENDIF
    DO J=1,NPFIT
      IF(IPFIT(J) <= 0 .OR. IPFIT(J) > NP) THEN
        IF(IPRSW /= 3) write(NPR,'(A,I3,A,I3)')'   INVALID IPFIT(',J,')=',IPFIT(J)
        ICONL=100 ;  RETURN
      ENDIF
      IF(J < NPFIT) THEN
        DO I=J+1,NPFIT
          IF(IPFIT(J) == IPFIT(I)) THEN
            IF(IPRSW /= 3) write(NPR,'(A,I3,A,I3,A)')'   INVALID IPFIT(',J,')=IPFIT(',I,')'
            ICONL=100 ;  RETURN
          ENDIF
        end do
      ENDIF
    end do
    DO I=1,NS
      IF(WSQRT(I) <= 0.0d0) THEN
        IF(IPRSW /= 3) WRITE(NPR,'(A,I5)')'   INVALID WSQRT(I) <= 0   I=',I
        ICONL=100 ;  RETURN
      ENDIF
    end do
!----------- INPUT OK
    IF(IPRSW == 1) write(NPR,'(A)')'   --------SUBROUTINE LEAST START---------'
    ICONL=0
    IF(EPSR > 1.0d-3) THEN
      EPSR=1.0d-3
      IF(IPRSW == 1 .OR. IPRSW == 0) write(NPR,'(A)')'   EPSR IS CHANGED TO 1.0d-3'
    ENDIF
    IF(EPSR < 1.0d-5) THEN
      EPSR=1.0d-5
      IF(IPRSW == 1 .OR. IPRSW == 0) write(NPR,'(A)')'   EPSR IS CHANGED TO 1.0d-5'
    ENDIF
    ERMPA(:,:)=0.0d0
    ERPA(:)=0.0d0
    WSQRTI(1:NS)=1.0d0/WSQRT(1:NS)
    IF(IPRSW == 1) write(NPR,'(A,G15.7)')'   CONVERGENCE CRITERION VALUE EPSR=',EPSR
!-------- LEAST SQUARE PROGRAM ---- MARQUARDT METHOD
    CALL MARQRT(EPSR,MAXX,SUMS,WSQRTI,ICON)
!
    IF(ICON /= 0 .AND. IPRSW /= 3) write(NPR,'(A,I5)')'   AT MARQRT ICON=',ICON
    ICONL=ICON
    IF(ICON == 50) RETURN
    IF(ICON /= 30) THEN
!--      CALCULATE ERROR MATRIX = ERMX
      APP(1:NS,1:NPFIT)=AP(1:NS,1:NPFIT)  ! copy
      call set_ERMX_RAMC('ERMX',ICONL,yy)
    ENDIF
!-------- DIAGNOSYS OF MATRIX AP
    if(IPRSW==0 .OR. IPRSW==1) then
      CALL DIAGNO(SUMS,WSQRTI,ICONL,ICON)
      IF(ICON /= 0) THEN
        IF(IPRSW /= 3) WRITE(NPR,'(A,I5)')'   AT DIAGNO ICON=',ICON
        ICONL=40
      ENDIF
    endif
!---------
    IF(ICONL == 30) RETURN
    DO J=1,NPFIT
    DO I=1,NPFIT
     ERMPA(IPFIT(I),IPFIT(J))=ERMX(I,J)*PASCAL(I) *PASCAL(J)
    end do
    end do
    DO I=1,NPFIT
      ERPA(IPFIT(I))=SQRT(ERMPA(IPFIT(I),IPFIT(I)))
    end do
!----------
!----CHI SQUARE
    NDG=NS-NPFIT
    IF(NS > NPFIT) THEN
      SUMSN=SUMS/NDG
!--   IF ABSOLUTE ERROR IS NOT KNOWN THE FOLLOWING ERROR SHOULD BE USED
      SIGST=SQRT(SUMSN)
    ELSE
      SUMSN=0.0d0
      SIGST=0.0d0
    ENDIF
!---------PRINT OUT RESULTS
    IF(IPRSW == 0 .OR. IPRSW == 1) THEN
      write(NPR,'(/,A,G15.7)') '   CHI SQUARE            SUMS=',SUMS
      write(NPR,'(A,I5)'   ) '   DEGREE OF FREEDOM NS-NPFIT=',NDG
      write(NPR,'(A,G15.7)') '              SUMS/(NS-NPFIT)=',SUMSN
      write(NPR,'(/,A)')'    I     PA FINAL      ERROR   ERROR*SQRT(SUMS/(NP-NPFIT))'
      do I=1,NP
        write(NPR,'(2X,I3,3G15.7)') I,PA(I),ERPA(I),SIGST*ERPA(I)
      end do
    ENDIF
!
    IF(IPRSW == 1) THEN
      NPP= MIN(10,NPFIT)
      write(NPR,'(A)')'   ERROR MATRIX OF PA'
      write(NPR,'(5X,10(I5,6X))')(IPFIT(J),J=1,NPP)
      DO I=1,NPFIT
        WRITE(NPR,'(I5,10G11.3)') IPFIT(I),(ERMPA(IPFIT(I),IPFIT(J)),J=1,NPP)
      end do
      IF(NPFIT > 10) THEN
        NPP= MIN(20,NPFIT)
        write(NPR,'(A)')'   ERROR MATRIX next PART'
        write(NPR,'(5X,10(I5,6X))')(IPFIT(J),J=11,NPP)
        DO I=1,NPFIT
          WRITE(NPR,'(I5,10G11.3)') IPFIT(I),(ERMPA(IPFIT(I),IPFIT(J)),J=11,NPP)
        end do
      ENDIF
    ENDIF
!
    IF(IPRSW == 1) THEN
      write(NPR,'(/,4X,A,9X,A,10X,A)')'I    OBS  ','CALC ','OBS-CALC'
      do I=1,NS
        write(NPR,'(I5,3G15.7)') I,OBS(I),CALC(I),OBS(I)-CALC(I)
      end do
    ENDIF
!
    IF(IPRSW == 1) write(NPR,'(A)')'   ----------LEAST END-----------'
!
  END SUBROUTINE LEAST
!
!-----
  SUBROUTINE MARQRT(EPSR,MAXX,SUMS,WSQRTI,ICONM)
!
    IMPLICIT NONE
    integer, parameter :: DP = kind(1.0D0)
    real(DP), intent(in) :: EPSR,WSQRTI(*)
    real(DP), intent(out) :: SUMS
    integer(4), intent(in) :: MAXX
    integer(4), intent(out) :: ICONM
    real(DP) :: RAM,XX,RMAX,RAMC,RAMUL,EDELS,SUMSN,RSUMS
    integer(4) :: ITN,ITNS,J,I,IER,K,ISW,N,ICON
    integer(4) :: NRHS                              ! DGEQP3 + DORMQR + DTRTRS
!
    ICONM=0
    ITN=0
    ITNS=0
    RAM=0.0d0
    RAMUL=0.0d0
    IF(IDRSW == 1) THEN
!     SET INITIAL DELPA(J)=ERMX(J,1) AND PAP(J)=ERMX(J,2) FOR DFMDL
      DO J=1,NPFIT
        IF( ABS(PA(IPFIT(J))) > 1.0d-30) THEN
          ERMX(J,1)=0.0004d0*ABS(PA(IPFIT(J)))
        ELSE
          ERMX(J,1)=0.0004d0
        ENDIF
        ERMX(J,2)=PA(IPFIT(J))+4.0d0*ERMX(J,1)
      end do
    ENDIF
    IF(IPRSW == 1) write(NPR,'(A)')'   ---------SOBROUTINE MARQRT START---------'
!-----CALCULATE SUMS VP AP -------
    CALL FMODL
!
    VP(1:NS) = WSQRTI(1:NS)*(OBS(1:NS)-CALC(1:NS))
    SUMS = DOT_PRODUCT(VP(1:NS),VP(1:NS))
!-----------------
    CALL DFMDL(WSQRTI,IER)
    IF(IER == 1) THEN
      ICONM=50
      RETURN
    ENDIF
!
!-----   SET PASCAL, PAULI, AND AP
    DO J=1,NPFIT
      XX=DOT_PRODUCT(AP(1:NS,J),AP(1:NS,J))
      PASCAL(J)=SIGN(10.0d0/SQRT(XX) , PA(IPFIT(J)) )
      PAULI(J)=PA(IPFIT(J))-PASCAL(J)
      AP(1:NS,J)=PASCAL(J)*AP(1:NS,J)
    end do
!-----START ITERATION OF MARQUARDT METHOD
    IF(IPRSW == 0 .OR. IPRSW== 1) then
      WRITE(NPR,'(/,A)')'   ITN     SUMSN        MAX(ABS(DELX))     MARQUARDT NUMBER'
    endif
!-----ITN=NUMBER OF ITERATION
 40 ITN=ITN+1
!-----SOLVE VP=AP*DELX LINEAR LEAST SQUARE SOLUTION
!-----SET VP AND AP
      VP(NS+1:NS+NPFIT)=0.0d0
      AP(NS+1:NS+NPFIT,1:NPFIT)=0.0d0
      XX=SQRT(RAM)
      DO J=1,NPFIT
        AP(NS+J,J)=XX
      end do
      APP(1:NS+NPFIT,1:NPFIT)=AP(1:NS+NPFIT,1:NPFIT)  ! copy
      VPP(1:NS+NPFIT)=VP(1:NS+NPFIT)  ! copy
!
!    Solve the least squares problem min( norm2(VPP - APP X) ) for X
      K=NSPMAX
      ISW=1
      N=NS+NPFIT
!
!------LLS  HOUSEHOLDER  QR factorization
      JPVT(1:NPFIT) = 0                                     ! DGEQP3 + DORMQR + DTRTRS
      CALL DGEQP3(N,NPFIT,APP,K,JPVT,TAU,WORK,LWORK,ICON)   !  DGEQP3 + DORMQR + DTRTRS
!!!!!      CALL LAXL(APP,K,N,NPFIT,VPP,ISW,FD,IVW,ICON)     !  LAXL = ULALH + ULALB
!-----
      IF(ICON /= 0) THEN
        IF(IPRSW /= 3) then
          write(NPR,'(A,I7)')'   error AT DGEQP3 (or LAXL) ICON=',ICON
        endif
        ICONM=30 ;  RETURN
      ENDIF
!
      NRHS=1                                                            !  DGEQP3 + DORMQR + DTRTRS
      CALL DORMQR('L','T',N,NRHS,NPFIT,APP,K,TAU,VPP,K,WORK,LWORK,ICON) !  DGEQP3 + DORMQR + DTRTRS
      CALL DTRTRS('U','N','N',NPFIT,NRHS,APP,K,VPP,K,ICON)              !  DGEQP3 + DORMQR + DTRTRS
      FD(JPVT(1:NPFIT)) = VPP(1:NPFIT)                                  !  DGEQP3 + DORMQR + DTRTRS
      VPP(1:NPFIT) = FD(1:NPFIT)                                        !  DGEQP3 + DORMQR + DTRTRS
!
!------CONVERGENCE CRITERION VALUE RMAX=MAX(ABS(DELX(I=1-NPFIT)))--
      DELX(1:NPFIT)=VPP(1:NPFIT)
      RMAX=MAXVAL(ABS(DELX(1:NPFIT)))
!
      IF ( ( MOD(ITNS,5) == 0 .AND. ITNS /= 0) .OR. (RMAX > 0.1d0) .OR. (ITN == 1) ) THEN
!--       CALCULATE STANDARD MARQUARDT NUMBER = RAMC
        APP(1:NS,1:NPFIT)=AP(1:NS,1:NPFIT)   !  copy
        call set_ERMX_RAMC('RAMC',IER,RAMC)  !  calc RAMC using APP
        RAMUL=RAMC*1.0d8                     !  upper limit of RAM
      ENDIF
!------PARAMETER INDICATING NONLINEALITY RSUMS ---
!------CONVERGENCE CRITERION VALUE RMAX=MAX(ABS(DELX(I)))--
!------    RSUMS=(SUMSN-SUMS)/EDELS
!------    EDELS=EXPECTED DECREASE OF SUMS
!------    EDELS=-2*RAM*NORM(DELX)**2-NORM(AP*DELX)**2
      PA(IPFIT(1:NPFIT))=PAULI(1:NPFIT)+(1.0d0+DELX(1:NPFIT))*PASCAL(1:NPFIT)
      EDELS = -2.0d0 * RAM * DOT_PRODUCT( DELX(1:NPFIT) , DELX(1:NPFIT) )
!----------
      CALL FMODL
!----------
      DO I=1,NS
        XX= DOT_PRODUCT( AP(I,1:NPFIT) , DELX(1:NPFIT) )
        EDELS=EDELS-XX*XX
      end do
      VPP(1:NS)= ( OBS(1:NS) - CALC(1:NS) ) * WSQRTI(1:NS)
      SUMSN = DOT_PRODUCT( VPP(1:NS) , VPP(1:NS) )
      IF(EDELS < 0.0d0) THEN
        RSUMS=(SUMSN-SUMS)/EDELS
      ELSE
        RSUMS=0.0d0
      ENDIF
!------
      IF(SUMSN < SUMS) THEN
        ITNS=ITNS+1
        IF(IPRSW == 0 .OR. IPRSW == 1) write(NPR,'(I5,G20.12,2G15.7)')ITN,SUMSN,RMAX,RAM
      ENDIF
!------CHECK NEW SUMS (.LE. OR .GT.) OLD SUMS
      IF(SUMS <= SUMSN) THEN
!-------PA NOT IMPROVED. SET OLD VALUES
        PA(IPFIT(1:NPFIT))=PAULI(1:NPFIT)+PASCAL(1:NPFIT)
      ELSE
!-------SET SUMS VP AP PAULI PASCAL USING IMPROVED PA
        SUMS=SUMSN
        VP(1:NS)=VPP(1:NS)
!---
        CALL DFMDL(WSQRTI,IER)
        IF(IER == 1) THEN
          ICONM=50 ;  RETURN
        ENDIF
!---
        DO J=1,NPFIT
          XX=DOT_PRODUCT(AP(1:NS,J),AP(1:NS,J))
          PASCAL(J)=SIGN(10.0d0/SQRT(XX) , PA(IPFIT(J)) )
          PAULI(J)=PA(IPFIT(J))-PASCAL(J)
          AP(1:NS,J)=PASCAL(J)*AP(1:NS,J)
        end do
      ENDIF
!-----   CHECK CONVERGENCE
      IF(RMAX <= EPSR) THEN
!-----  CONVERGENCE   EXIT
        GOTO 250
      ELSE
!-----  NO CONVERGENCE
!-----  CHECK ITN<MAXX AND RAM<RAMUL, OTHERWISE EXIT
        IF(ITN >= MAXX) THEN
          ICONM=10 ;  GOTO 250
        ELSEIF(RAM > RAMUL) THEN
          ICONM=20 ;  GOTO 250
        ENDIF
!C-----   CONTINUE ITERATION     ADJUST RAM
        IF(RSUMS >= 0.75d0) THEN
          RAM=0.5d0*RAM
          IF(RAM < RAMC) RAM=0.0d0
        ELSEIF(RSUMS <= 0.25d0 .AND. RSUMS >= 0.0d0) THEN
          RAM=2.0d0*RAM
          IF(RAM < RAMC) RAM=RAMC
        ELSEIF(RSUMS < 0.0d0) THEN
          RAM=MIN(2.0d0-RSUMS,10.0d0)*RAM
          IF(RAM < RAMC) RAM=RAMC
        ENDIF
    GOTO 40
    ENDIF
!-----     RETURN
 250  continue
    CALC(1:NS)=-VP(1:NS)/WSQRTI(1:NS)+OBS(1:NS)
!
    IF((ITNS == 0) .AND. (IPRSW /= 3)) write(NPR,'(A)')'   I CANNOT IMPROVE PARAMETERS SOMETHING WRONG?'
    IF((IPRSW == 0) .OR. (IPRSW == 1)) write(NPR,'(A,I5)')'   ITERATION NUMBER ITN=',ITN
    IF(IPRSW == 1) THEN
      write(NPR,'(A,G15.7)')'   STANDARD MARQUARDT NUMBER RAMC=',RAMC
      write(NPR,'(A,G15.7)')'   LAST MARQUARDT NUMBER RAM=',RAM
      write(NPR,'(A)')'   -----  MARQRT END -----'
    ENDIF
!
  END SUBROUTINE MARQRT
!
!-----
  SUBROUTINE DFMDL(WSQRTI,IER)
!
    IMPLICIT NONE
    integer, parameter :: DP = kind(1.0D0)
    real(DP), intent(in) :: WSQRTI(*)
    integer(4), intent(out) :: IER
    integer(4) :: J,I,IPFJ,ISW,ISWB,K
    integer(4), parameter :: KMAX=20
    real(DP), parameter :: EPSRP=1.0d-7,EPSRC=1.0d-6,FACD=0.25d0,FACI=4.0d0
    real(DP) :: PRC(2),XX,XXX,XXXX,XXXXX,FACT,CONV,YY
!
!!      DATA EPSRP,EPSRC,FACD,FACI,KMAX /1.E-7,1.E-6, .25,  4.,20  /
!     IDRSW=0-ANALYTIC DEREVATIVE =1-NUMERICAL DERIVATIVE
!     APP(I,ISW)=DELTA(CALC(I)*WSQRTI(I))/DELTA(PA(IPFIT(J)))
!     DELTA( )=( )(PA(IPFJ)+DELPA(J))-( )(PA(IPFJ)-DELPA(J))
!     APP(I,ISWB)=PREVIOUS APP(I,ISW) BEFORE DELPA(J)=FACT*DELPA(J)
!     ISW,ISWB=1,2 OR 2,1
!     FACT=FACD OR FACI
!     PRC(ISW)=MEASURE OF ROUNDOFF ERROR OF APP(I,ISW)
!     CONV=MEASURE OF CONVERGENCE
!         =SQRT(SUM((APP(I,1)-APP(I,2))**2)/SUM(APP(I,ISW)**2))
!     PAP(J)=PREVIOUS PA(IPFFIT(J))
!     IER= ERROR CODE =0-NO ERROR =1-ERROR
    IER=0
    IF(IDRSW == 0) THEN
      CALL DFMODL
      APP(1:NS,1:NPFIT)=AP(1:NS,IPFIT(1:NPFIT))
      DO J=1,NPFIT
        AP(1:NS,J)=WSQRTI(1:NS)*APP(1:NS,J)
      end do
      RETURN
    ELSEIF(IDRSW == 1) THEN
      DO J=1,NPFIT
        IPFJ=IPFIT(J)
        XX=PA(IPFJ)
        ISW=1
        PA(IPFJ)=XX+ERMX(J,1)  ! PA(IPFJ)=XX+DELPA(J)
        CALL FMODL
        APP(1:NS,3)=CALC(1:NS)*WSQRTI(1:NS)
        PA(IPFJ)=XX-ERMX(J,1)  ! PA(IPFJ)=XX-DELPA(J)
        CALL FMODL
        XXX=0.5d0/ERMX(J,1)    !  XXX=.5/DELPA(J)
        PRC(ISW)=0.0d0
        DO I=1,NS
          APP(I,4)=CALC(I)*WSQRTI(I)
          XXXX=APP(I,3)-APP(I,4)
          APP(I,ISW)=XXXX*XXX
          XXXXX=( ABS(APP(I,3)) + ABS(APP(I,4)) )*0.5d0
          IF(XXXXX > 1.0d-60) THEN
            PRC(ISW)=MAX(PRC(ISW),ABS(XXXX/XXXXX))
          ENDIF
        end do
        IF(ABS(XX-ERMX(J,2)) <= ERMX(J,1) )THEN  ! IF(ABS(XX-PAP(J)).LE.DELPA(J))THEN
          AP(1:NS,J)=APP(1:NS,ISW)
          GOTO 180
        ENDIF
        ISW=2
        ISWB=1
        FACT=FACD
        DO K=1,KMAX
          ERMX(J,1)=FACT*ERMX(J,1)  !    DELPA(J)=FACT*DELPA(J)
          PA(IPFJ)=XX+ERMX(J,1)     !    PA(IPFJ)=XX+DELPA(J)
          CALL FMODL
          APP(1:NS,3)=CALC(1:NS)*WSQRTI(1:NS)
          PA(IPFJ)=XX-ERMX(J,1)     !    PA(IPFJ)=XX-DELPA(J)
          CALL FMODL
          XXX=0.5d0/ERMX(J,1)       !    XXX=.5/DELPA(J)
          PRC(ISW)=0.0d0
          CONV=0.0d0
          YY=0.0d0
          DO I=1,NS
            APP(I,4)=CALC(I)*WSQRTI(I)
            XXXX=APP(I,3)-APP(I,4)
            APP(I,ISW)=XXXX*XXX
            XXXXX=( ABS(APP(I,3)) + ABS(APP(I,4)) )*0.5d0
            IF(XXXXX > 1.0d-60) THEN
              PRC(ISW)=MAX(PRC(ISW),ABS(XXXX/XXXXX))
            ENDIF
            CONV=CONV+(APP(I,1)-APP(I,2))**2
            YY=YY+APP(I,ISW)**2
          end do
          IF(YY < 1.0d-60) GOTO 400
          CONV=SQRT(CONV/YY)
          IF(K == 1) THEN
            IF(PRC(1) < EPSRP .AND. PRC(2) < EPSRP) GOTO 200
          ENDIF
          IF(CONV <= EPSRC .AND. PRC(ISWB) >= EPSRP) THEN
!           CONVERGENCE NEXT J
            IF(PRC(ISW) >= EPSRP) THEN
              AP(1:NS,J)=APP(1:NS,ISW)
            ELSE
              AP(1:NS,J)=APP(1:NS,ISWB)
            ENDIF
            ERMX(J,1)=ERMX(J,1)/FACT  !    DELPA(J)=DELPA(J)/FACT
            GOTO 180
          ELSEIF(PRC(1) >= EPSRP .AND. PRC(2) >= EPSRP) THEN
!           SMALLER DELPA(J) NEXT K
            IF(ISW == 1) THEN
              ISW=2
              ISWB=1
            ELSE
              ISW=1
              ISWB=2
            ENDIF
          ELSE
!           ERROR RETURN
            IF(IPRSW /= 3) THEN
              WRITE(NPR,'(A)') '   no convergence of derivative IN DFMDL'
              WRITE(NPR,'(A)') '   decreasing DELPA(J) = delta PA(IPFIT(J))'
            ENDIF
            GOTO 300
          ENDIF
        end do
!       ERROR K=KMAX RETURN
        IF(IPRSW /= 3) THEN
          WRITE(NPR,'(A)') '   no convergence of derivative IN DFMDL'
          WRITE(NPR,'(A)') '   decreasing DELPA(J) = delta PA(IPFIT(J))'
          WRITE(NPR,'(A,I5)') '   K > KMAX=',KMAX
        ENDIF
        GOTO 300
!
 200    continue
        ERMX(J,1)=ERMX(J,1)/FACT    ! DELPA(J)=DELPA(J)/FACT
        FACT=FACI
        DO K=1,KMAX
          ERMX(J,1)=FACT*ERMX(J,1)  !   DELPA(J)=FACT*DELPA(J)
          PA(IPFJ)=XX+ERMX(J,1)     !   PA(IPFJ)=XX+DELPA(J)
          CALL FMODL
          APP(1:NS,3)=CALC(1:NS)*WSQRTI(1:NS)
          PA(IPFJ)=XX-ERMX(J,1)     !   PA(IPFJ)=XX-DELPA(J)
          CALL FMODL
          XXX=0.5d0/ERMX(J,1)       !   XXX=.5/DELPA(J)
          PRC(ISW)=0.0d0
          CONV=0.0d0
          YY=0.0d0
          DO I=1,NS
            APP(I,4)=CALC(I)*WSQRTI(I)
            XXXX=APP(I,3)-APP(I,4)
            APP(I,ISW)=XXXX*XXX
            XXXXX=( ABS(APP(I,3)) + ABS(APP(I,4)) )*0.5d0
            IF(XXXXX > 1.0d-60) THEN
              PRC(ISW)=MAX(PRC(ISW),ABS(XXXX/XXXXX))
            ENDIF
            CONV=CONV+(APP(I,1)-APP(I,2))**2
            YY=YY+APP(I,ISW)**2
          end do
          IF(YY < 1.0d-60) GOTO 400
          CONV=SQRT(CONV/YY)
          IF(CONV <= EPSRC .AND. PRC(ISW) >= EPSRP) THEN
!           CONVERGENCE NEXT J
            IF(PRC(ISWB) >= EPSRP) THEN
              AP(1:NS,J)=APP(1:NS,ISWB)
            ELSE
              AP(1:NS,J)=APP(1:NS,ISW)
            ENDIF
            GOTO 180
          ELSEIF(PRC(1) < EPSRP .AND. PRC(2) < EPSRP) THEN
!           LARGER DELPA(J) NEXT K
            IF(ISW == 1) THEN
              ISW=2
              ISWB=1
            ELSE
              ISW=1
              ISWB=2
            ENDIF
          ELSE
!           ERROR RETURN
            IF(IPRSW /= 3) THEN
              WRITE(NPR,'(A)') '   no convergence of derivative IN DFMDL'
              WRITE(NPR,'(A)') '   increasing DELPA(J) = delta PA(IPFIT(J))'
            ENDIF
            GOTO 300
          ENDIF
        end do
!       ERROR K=KMAX RETURN
        IF(IPRSW /= 3) THEN
          WRITE(NPR,'(A)') '   no convergence of derivative IN DFMDL'
          WRITE(NPR,'(A)') '   decreasing DELPA(J) = delta PA(IPFIT(J))'
          WRITE(NPR,'(A,I5)') '   K > KMAX=',KMAX
        ENDIF
        GOTO 300
!
 180    continue
        PA(IPFJ)=XX
        ERMX(J,2)=XX    ! PAP(J)=XX
      end do
      RETURN
    ENDIF
    RETURN
!
 300 continue
    IER=1
    PA(IPFJ)=XX
    IF(IPRSW /= 3) THEN
      WRITE(NPR,'(A)')'   ERROR IN DFMDL'
      WRITE(NPR,'(A)')'   K,J,IPFIT(J),PA(IPFIT(J)),DELPA(J)'
      WRITE(NPR,'(3I5,2G15.7)')K,J,IPFJ,XX,ERMX(J,1)  ! ' /3I5,2G15.7)')K,J,IPFJ,XX,DELPA(J)
      WRITE(NPR,'(A)')'   ISW,FACT,CONV,PRC(ISW),PRC(ISWB)'
      WRITE(NPR,'(I5,F7.3,3G15.7)')ISW,FACT,CONV,PRC(ISW),PRC(ISWB)
    ENDIF
    RETURN
!
 400 continue
    IER=1
    PA(IPFJ)=XX
    IF(IPRSW /= 3) THEN
      WRITE(NPR,'(A)')'   ERROR IN DFMDL'
      WRITE(NPR,'(A,I3,A)')'   ZERO DERIVATIVE - PA(',IPFJ,')'
    ENDIF
    RETURN
  END SUBROUTINE DFMDL
!
!-----
  SUBROUTINE DIAGNO(SUMS,WSQRTI,ICONL,ICOND)
!
    IMPLICIT NONE
    integer, parameter :: DP = kind(1.0D0)
    real(DP), intent(in) :: SUMS
    real(DP), intent(in) :: WSQRTI(*)
    integer(4), intent(in) :: ICONL
    integer(4), intent(out) :: ICOND
    real(DP) :: CONDAP,S,SS,XX,SSUM             !  DSYEVR
!!!!!    real(DP) :: AMACH,CONDAP,S,SS,XX,SSUM  !  HSHOUS
    integer(4) :: I,J,K,ICON
    real(DP) :: AMYU(NPFIT),VORTH(NPFIT,NPFIT)        !  DSYEVR
!!!!!    real(DP) :: AMYU(NPMAX),VORTH(NPMAX,NPMAX)   !  HSHOUS
    INTEGER(4) :: il,iu,liwork,lwork,m,isuppz(2*NPFIT)  !  DSYEVR
    REAL(DP) :: abstol,vl,vu                            !  DSYEVR
    REAL(DP), Allocatable :: work(:)                    !  DSYEVR
    Integer(4), Allocatable :: iwork(:)                 !  DSYEVR
!!!!!    real(DP) :: W1(NPMAX),W2(NPMAX),W3(NPMAX),W4(NPMAX),W5(NPMAX),W6(NPMAX) ! HSHOUS
!!!!!    real(DP) :: W7(1)  ! dummy                                              ! HSHOUS
!!!!!    AMACH=1.0d-6   !      DATA AMACH/1.E-6/        ! HSHOUS
    ICOND=0
    IF(IPRSW == 1) WRITE(NPR,'(A)')'   ------SOBROUTINE DIAGNO START---------'
!
!-----DIAGNOSIS OF AP
    IF(IPRSW == 1) THEN
      write(NPR,'(A)')'   DIAGNOSIS OF JACOBIAN MATRIX (AP) FOR THE FOLLOWING PARAMETERS'
      write(NPR,'(A)')'   I=IPFIT(J)  PA(I)=PAULI(J)+X(J)*PASCAL(J)  X(J)=1'
      write(NPR,'(A)')'     I   J     PA(I)      PAULI(J)        PASCAL(J) '
      DO I=1,NP
        K=0
        DO J=1,NPFIT
          IF(I == IPFIT(J)) THEN
            WRITE(NPR,'(1X,2I5,3G15.7)')I,J,PA(I),PAULI(J),PASCAL(J)
            K=1 ;  exit
          ENDIF
        end do
        if(K==0) WRITE(NPR,'(2X,I5,5X,G15.7)')I,PA(I)
      end do
    ENDIF
    ERMXX(1:NPFIT,1:NPFIT)=MATMUL( TRANSPOSE(AP(1:NS,1:NPFIT)) , AP(1:NS,1:NPFIT) )
!-----DIAGONALIZE ERMXX=TRANSPOSE(AP)*AP
!-----                 =VORTH*DIAG(AMYU(I)**2)*TRANS(VORTH)
    IF(NPFIT == 1) THEN
      AMYU(1)=SQRT(ERMXX(1,1))
      VORTH(1,1)=1.0d0
      CONDAP=1.0d0
    ELSEIF(NPFIT >= 2) THEN
      K=NPMAX
      I=1
!         Solve the symmetric eigenvalue problem
  abstol=0.0d0  ;  lwork = -1  ;  liwork = -1        !  DSYEVR
  allocate(work(1),iwork(1))
    call DSYEVR('V','A','U',NPFIT,ERMXX,NPMAX,vl,vu,il,iu,abstol,m,AMYU,VORTH,NPFIT,isuppz,work,lwork,iwork,liwork,ICON)
    lwork = nint(work(1))  ;  liwork = iwork(1)
  deallocate(work,iwork)
  allocate(work(lwork),iwork(liwork))
    Call DSYEVR('V','A','U',NPFIT,ERMXX,NPMAX,vl,vu,il,iu,abstol,m,AMYU,VORTH,NPFIT,isuppz,work,lwork,iwork,liwork,ICON)
  deallocate(work,iwork)                             !  DSYEVR
!!!!!      CALL NSHOUS(ERMXX,K,NPFIT,NPFIT,NPFIT,AMACH,I,AMYU,VORTH,ICON,W1,W2,W3,W4,W5,W6,W7)    !  HSHOUS
      IF(ICON /= 0) THEN
        IF(IPRSW /= 3) write(NPR,'(A,I6)')'   DSYEVR  ICON=',ICON         !  DSYEVR
!!!!!        IF(IPRSW /= 3) write(NPR,'(A,I6)')'   NSHOUS  ICON=',ICON    !  HSHOUS
        ICOND=50
        GOTO 9000
      ENDIF
      AMYU(1:NPFIT)=SQRT(AMYU(1:NPFIT))
      CONDAP=AMYU(NPFIT)/AMYU(1)         !  DSYEVR
!!!!!      CONDAP=AMYU(1)/AMYU(NPFIT)    !  HSHOUS
    ENDIF
!-----PRINT OUT
    IF(IPRSW==0 .OR. IPRSW==1) write(NPR,'(A,G15.7)')'   CONDITION NUMBER CONDAP=',CONDAP
    IF(IPRSW == 1) THEN
      WRITE(NPR,'(A)')'  K SINGULAR VALUE     EIGEN VECTOR (DELTA_PA(IPFIT(J)))'
      DO K=1,NPFIT
        WRITE(NPR,'(I4,6G11.3,/,20(15X,5G11.3,/))') K,AMYU(NPFIT+1-K),(PASCAL(J)*VORTH(J,NPFIT+1-K),J=1,NPFIT)  !  DSYEVR
!!!!!        WRITE(NPR,'(I4,6G11.3,/,10(15X,5G11.3,/))') K,AMYU(K),(PASCAL(J)*VORTH(J,K),J=1,NPFIT)             !  HSHOUS
      end do
    ENDIF
!-----   STEEPEST DECRESING DIRECTION DELX=TRANS(AP)*VP/NORM
    SSUM=0.0D0
    DO J=1,NPFIT
      XX=DOT_PRODUCT(AP(1:NS,J),VP(1:NS))
      SSUM=SSUM+XX**2
      DELX(J)=XX
    end do
    SSUM=SQRT(SSUM)
    IF(SSUM > 0.0D0)THEN
      DELX(1:NPFIT)=DELX(1:NPFIT)/SSUM
    ENDIF
    IF(IPRSW == 1) then
      write(NPR,'(A)')'   - GRADIENT SUMS (DELTA_PA(IPFIT(J)))'
      write(NPR,'(20(3X,5G11.3,/))')(PASCAL(I)*DELX(I),I=1,NPFIT)
    endif
!
    IF(ICONL /= 0 .AND. ICONL /= 10 .AND. ICONL /= 20)GOTO 9000
!-----  SUMS(X+VORTH/AMYU)-SUMS(X)
!-----  SUMS(X-VORTH/AMYU)-SUMS(X)
    VPP(1:NS)=CALC(1:NS)
    IF(IPRSW==0 .OR. IPRSW==1) THEN
      write(NPR,'(/,A)')'   CHECK VALIDITY OF ERRORS'
      write(NPR,'(A)')'   IF SOME OF THE FOLLOWING VALUES ARE MUCH DIFFERENT FROM 1 (FACTOR 2),'
      write(NPR,'(A)')'   THE CALCULATED ERRORS ARE NOT RELIABLE.'
      write(NPR,'(A)')'    K  SUMS(X+-VORTH(K)/AMYU(K))-SUMS(X) =1, IF LINEAR'
    ENDIF
    DO K=1,NPFIT
      PA(IPFIT(1:NPFIT))=PAULI(1:NPFIT)+(1.0d0+VORTH(1:NPFIT,NPFIT+1-K)/AMYU(NPFIT+1-K))*PASCAL(1:NPFIT)  !  DSYEVR
!!!!!      PA(IPFIT(1:NPFIT))=PAULI(1:NPFIT)+(1.0d0+VORTH(1:NPFIT,K)/AMYU(K))*PASCAL(1:NPFIT)             !  HSHOUS
      CALL FMODL
      S=0.0d0
      DO I=1,NS
        S=S+( WSQRTI(I)*(OBS(I)-CALC(I)) )**2
      end do
      S=S-SUMS
      PA(IPFIT(1:NPFIT))=PAULI(1:NPFIT)+(1.0d0-VORTH(1:NPFIT,NPFIT+1-K)/AMYU(NPFIT+1-K))*PASCAL(1:NPFIT)  !  DSYEVR
!!!!!      PA(IPFIT(1:NPFIT))=PAULI(1:NPFIT)+(1.0d0-VORTH(1:NPFIT,K)/AMYU(K))*PASCAL(1:NPFIT)             !  HSHOUS
      CALL FMODL
      SS=0.0d0
      DO I=1,NS
        SS=SS+( WSQRTI(I)*(OBS(I)-CALC(I)) )**2
      end do
      SS=SS-SUMS
      IF(IPRSW==0 .OR. IPRSW==1) WRITE(NPR,'(I5,2G15.7)')K,S,SS
    end do
    CALC(1:NS)=VPP(1:NS)
    PA(IPFIT(1:NPFIT))=PAULI(1:NPFIT)+PASCAL(1:NPFIT)
!
 9000 IF(IPRSW == 1) WRITE(NPR,'(A)')'   ----------DIAGNO END----------'
!
  END SUBROUTINE DIAGNO
!
!-----
  subroutine set_ERMX_RAMC(EorR,ICONL,RAMC)
!
    IMPLICIT NONE
    integer, parameter :: DP = kind(1.0D0)
    character(4), intent(in) :: EorR  ! 'ERMX' (set error matrix) or 'RAMC' (set STANDARD MARQUARDT NUMBER)
    real(DP), intent(out) :: RAMC
    integer(4), intent(out) :: ICONL
    integer(4) :: J,I,ICON,K
    real(DP) :: XX
!     EorR='ERMX'  -->  set error matrix = ERMX
!         ='RAMC'  -->  set STANDARD MARQUARDT NUMBER = RAMC
!
!--      Compute the QR factorization of APP
    K=NSPMAX
    ICON=0
!
    JPVT(1:NPFIT) = 0                                       !  DGEQP3
    CALL DGEQP3(NS,NPFIT,APP,K,JPVT,TAU,WORK,LWORK,ICON)    !  DGEQP3
!!!!!    CALL ULALH(APP,K,NS,NPFIT,FD,IVW,ICON)             !  ULALH
!
    IF(ICON /= 0) THEN
      if(EorR == 'ERMX') then
        IF(IPRSW /= 3) write(NPR,'(A,I7)')'    at DGEQP3 (ULALH) in set_ERMX_RAMC ICON=',ICON
        ICONL=40
        ERMX(1:NPFIT,1:NPFIT)=0.0d0  ! set error matrix = ERMX = 0
        return
      elseif(EorR == 'RAMC')then
        IF(IPRSW /= 3) write(NPR,'(A,I7)')'    AT DGEQP3 (ULALH) IN set_ERMX_RAMC ICON=',ICON
      endif
    endif
!
!       inverting R = APP = upper triangular matrix
!                -->  APP=INV(R)
    DO I=1,NPFIT
!!!!!      APP(I,I)=1.0d0/FD(I)  !  ULALH   diagonal elements of APP=INV(R)
      APP(I,I)=1.0d0/APP(I,I)    !  DGEQP3
    end do
    IF(NPFIT >= 2) THEN
      DO I=NPFIT-1,1,-1
        DO J=NPFIT,I+1,-1
          APP(I,J)=-APP(I,I)*DOT_PRODUCT( APP(I,I+1:J) , APP(I+1:J,J) )  !  APP=INV(R) upper part
          APP(J,I)=0.0d0  !  APP=INV(R) lower part
        end do
      end do
    ENDIF
!
    if(EorR == 'ERMX') then
!--     CALCULATE ERROR MATRIX = ERMXX  USING  R
!--     ERMXX=INV(R)*TRANSPOSE(INV(R))=APP * TRANSPOSE(APP)=ERROR MATRIX (not permuted)
      ERMXX(1:NPFIT,1:NPFIT)=MATMUL( APP(1:NPFIT,1:NPFIT), TRANSPOSE(APP(1:NPFIT,1:NPFIT)) )
!
!--     CALCULATE ERROR MATRIX  ERMX
!--     PERFORM PERMUTATION ERMX=INV(TRANSOSE(AP)*AP)=ERROR MATRIX OF X
!--     SET IPIV (permuation) using  PIVOTING info
      IPIV(JPVT(1:NPFIT))=(/ (i,i=1,NPFIT) /)    !  DGEQP3
!!!!!      IPIV(1:NPFIT)= (/ (I, I=1,NPFIT) /)   !  ULALH
!!!!!      DO I=NPFIT,1,-1
!!!!!        IF(I /= IVW(I)) THEN
!!!!!          J=IPIV(I)
!!!!!          IPIV(I)=IPIV(IVW(I))
!!!!!          IPIV(IVW(I))=J
!!!!!        ENDIF
!!!!!      end do
      ERMX(1:NPFIT,1:NPFIT)=ERMXX(IPIV(1:NPFIT),IPIV(1:NPFIT))
!
    elseif(EorR == 'RAMC')then
!--   CALCULATE RAMC using R     RAMC = 1.0d0/trace( INV(R) TRANSPOSE(INV(R)) )
!--   XX=trace( INV(R) TRANSPOSE(INV(R)) )
!       =trace( APP TRANSPOSE(APP) )  APP=INV(R)=UPPER TRIANGULAR MATRIX
      XX=0.0D0
      DO I=1,NPFIT
        XX=XX + DOT_PRODUCT( APP(I,I:NPFIT) , APP(I,I:NPFIT) )
      end do
      RAMC=ABS(1.0d0/XX)
    endif
!
  end subroutine set_ERMX_RAMC
!
END MODULE mod_least
!


*DECK COSQF1
      SUBROUTINE COSQF1 (N, X, W, XH)
C***BEGIN PROLOGUE  COSQF1
C***SUBSIDIARY
C***PURPOSE  Compute the forward cosine transform with odd wave numbers.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A3
C***TYPE      SINGLE PRECISION (COSQF1-S)
C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C  Subroutine COSQF1 computes the fast Fourier transform of quarter
C  wave data. That is, COSQF1 computes the coefficients in a cosine
C  series representation with only odd wave numbers.  The transform
C  is defined below at Output Parameter X
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C                 Computations (G. Rodrigue, ed.), Academic Press,
C                 1982, pp. 51-83.
C***ROUTINES CALLED  RFFTF
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           changing dummy array size declarations (1) to (*).
C   881128  Modified by Dick Valent to meet prologue standards.
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  COSQF1
      DIMENSION X(*), W(*), XH(*)
C***FIRST EXECUTABLE STATEMENT  COSQF1
      NS2 = (N+1)/2
      NP2 = N+2
      DO 101 K=2,NS2
         KC = NP2-K
         XH(K) = X(K)+X(KC)
         XH(KC) = X(K)-X(KC)
  101 CONTINUE
      MODN = MOD(N,2)
      IF (MODN .EQ. 0) XH(NS2+1) = X(NS2+1)+X(NS2+1)
      DO 102 K=2,NS2
         KC = NP2-K
         X(K) = W(K-1)*XH(KC)+W(KC-1)*XH(K)
         X(KC) = W(K-1)*XH(K)-W(KC-1)*XH(KC)
  102 CONTINUE
      IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*XH(NS2+1)
      CALL RFFTF (N,X,XH)
      DO 103 I=3,N,2
         XIM1 = X(I-1)-X(I)
         X(I) = X(I-1)+X(I)
         X(I-1) = XIM1
  103 CONTINUE
      RETURN
      END


module mod_monolis_c3d4_shape
  use mod_monolis_prm
  implicit none

  private

  real(kdouble), parameter :: gsp(3) = [ &
     0.25d0, 0.25d0, 0.25d0  &
    ]

  real(kdouble), parameter :: np(3,4) = reshape([ &
      0.0d0, 0.0d0, 0.0d0, &
      1.0d0, 0.0d0, 0.0d0, &
      0.0d0, 1.0d0, 0.0d0, &
      0.0d0, 0.0d0, 1.0d0  &
    ], [3,4])

    public :: monolis_C3D4_num_gauss_point
    public :: monolis_C3D4_weight
    public :: monolis_C3D4_integral_point
    public :: monolis_C3D4_node_point
    public :: monolis_C3D4_shapefunc
    public :: monolis_C3D4_shapefunc_deriv

contains

  function monolis_C3D4_num_gauss_point()
    implicit none
    integer(kint) :: monolis_C3D4_num_gauss_point
    monolis_C3D4_num_gauss_point = 1
  end function monolis_C3D4_num_gauss_point

  function monolis_C3D4_weight(i)
    implicit none
    integer(kint), optional :: i
    real(kdouble) :: monolis_C3D4_weight
    monolis_C3D4_weight = 0.166666666666666d0
  end function monolis_C3D4_weight

  subroutine monolis_C3D4_integral_point(i, r)
    implicit none
    integer(kint) :: i
    real(kdouble) :: r(3)

    r(1) = gsp(1)
    r(2) = gsp(2)
    r(3) = gsp(3)
  end subroutine monolis_C3D4_integral_point

  subroutine monolis_C3D4_node_point(i, r)
    implicit none
    integer(kint) :: i
    real(kdouble) :: r(3)

    r(1) = np(1,i)
    r(2) = np(2,i)
    r(3) = np(3,i)
  end subroutine monolis_C3D4_node_point

  subroutine monolis_C3D4_shapefunc(local, func)
    implicit none
    real(kdouble) :: local(3), func(4)

    func(1) = 1.0d0 - local(1) - local(2) - local(3)
    func(2) = local(1)
    func(3) = local(2)
    func(4) = local(3)
  end subroutine monolis_C3D4_shapefunc

  subroutine monolis_C3D4_shapefunc_deriv(local, func)
    implicit none
    real(kdouble) :: local(3), func(4,3)

    func(1,1) = -1.d0
    func(2,1) = 1.d0
    func(3,1) = 0.d0
    func(4,1) = 0.d0

    func(1,2) = -1.d0
    func(2,2) = 0.d0
    func(3,2) = 1.d0
    func(4,2) = 0.d0

    func(1,3) = -1.d0
    func(2,3) = 0.d0
    func(3,3) = 0.d0
    func(4,3) = 1.d0
  end subroutine monolis_C3D4_shapefunc_deriv

end module mod_monolis_c3d4_shape


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  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(vector_analysis_routines) vector_analysis_regular_grid_saved

contains

    ! Purpose:
    !
    !     subroutine vhaes(nlat, nlon, ityp, nt, v, w, idvw, jdvw, br, bi, cr, ci, &
    !                      mdab, ndab, wvhaes, lvhaes, work, lwork, ierror)
    !
    !     subroutine vhaes performs the vector spherical harmonic analysis
    !     on the vector field (v, w) and stores the result in the arrays
    !     br, bi, cr, and ci. 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 at output parameters v, w in
    !     subroutine vhses.
    !
    !     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 analysis
    !                 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 analysis
    !                 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 analysis
    !                 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 analysis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the analysis
    !                 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 analysis 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 analysis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the analysis
    !                 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 analysis 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 analysis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the analysis
    !                 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 analysis 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 analysis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the analysis
    !                 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 analysis 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 analysis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the analysis
    !                 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 analysis 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 analysis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the analysis
    !                 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 analysis 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 analyses.  in the program that calls vhaes,
    !            the arrays v, w, br, bi, cr, and ci can be three dimensional
    !            in which case multiple analyses will be performed.
    !            the third index is the analysis index which assumes the
    !            values k=1, ..., nt.  for a single analysis set nt=1. the
    !            discription of the remaining parameters is simplified
    !            by assuming that nt=1 or that all the arrays are two
    !            dimensional.
    !
    !     v, w    two or three dimensional arrays (see input parameter nt)
    !            that contain the vector function to be analyzed.
    !            v is the colatitudnal 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.
    !
    !     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 vhaes. jdvw must be at least nlon.
    !
    !     mdab   the first dimension of the arrays br, bi, cr, and ci as it
    !            appears in the program that calls vhaes. 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 vhaes. ndab must be at
    !            least nlat.
    !
    !     lvhaes an array which must be initialized by subroutine vhaesi.
    !            once initialized, wvhaes can be used repeatedly by vhaes
    !            as long as nlon and nlat remain unchanged.  wvhaes must
    !            not be altered between calls of vhaes.
    !
    !     lvhaes the dimension of the array wvhaes as it appears in the
    !            program that calls vhaes. 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 lvhaes must be at least
    !
    !            l1*l2(2*nlat-l1+1)+nlon+15
    !
    !     output parameters
    !
    !     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
    !            in the discription of subroutine vhses. br(mp1, np1),
    !            bi(mp1, np1), cr(mp1, np1), and ci(mp1, np1) are computed
    !            for mp1=1, ..., mmax and np1=mp1, ..., nlat except for np1=nlat
    !            and odd mp1. mmax=min(nlat, nlon/2) if nlon is even or
    !            mmax=min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !     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 lvhaes
    !
    module subroutine vhaes(nlat, nlon, ityp, nt, v, w, idvw, jdvw, br, bi, cr, ci, &
        mdab, ndab, wvhaes, 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(in)  :: v(idvw, jdvw, nt)
        real(wp),    intent(in)  :: w(idvw, jdvw, nt)
        integer(ip), intent(in)  :: idvw
        integer(ip), intent(in)  :: jdvw
        real(wp),    intent(out) :: br(mdab, ndab, nt)
        real(wp),    intent(out) :: bi(mdab, ndab, nt)
        real(wp),    intent(out) :: cr(mdab, ndab, nt)
        real(wp),    intent(out) :: ci(mdab, ndab, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        real(wp),    intent(in)  :: wvhaes(:)
        integer(ip), intent(out) :: ierror

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

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

        ! Check calling arguments
        call util%check_vector_analysis_inputs(nlat, nlon, ityp, idvw, jdvw, &
            mdab, ndab, nt, required_wavetable_size, wvhaes, ierror)

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

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

        lnl = nt*idv*nlon

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

        block
            real(wp) :: work(lwork)

            !  Set workspace indices
            workspace_indices = get_vhaes_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 vhaes_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, wvhaes, wvhaes(jw1:), wvhaes(jw2:))
            end associate
        end block

    end subroutine vhaes

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

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

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

        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
        required_wavetable_size = 2*lzimn+nlon+15

        ! Check calling arguments
        if (nlat < 3) then
            ierror = 1
        else if (nlon < 1) then
            ierror = 2
        else if (size(wvhaes) < required_wavetable_size) then
            ierror = 3
        else
            ierror = 0
        end if

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

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

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

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

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

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

    end subroutine vhaesi

    pure function get_vhaes_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_vhaes_workspace_indices

    subroutine vhaes_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, zv, zw, 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(in)  :: v(idvw, jdvw, nt)
        real(wp),    intent(in)  :: w(idvw, jdvw, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        real(wp),    intent(out) :: br(mdab, ndab, nt)
        real(wp),    intent(out) :: bi(mdab, ndab, nt)
        real(wp),    intent(out) :: cr(mdab, ndab, nt)
        real(wp),    intent(out) :: 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)  :: zv(idz, *)
        real(wp),    intent(in)  :: zw(idz, *)
        real(wp),    intent(in)  :: wrfft(:)

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

        call util%analysis_setup(idvw, jdvw, mdab, ndab, &
            bi, br, ci, cr, even_stride, idv, imid, imm1, ityp, &
            mmax, nlat, nlon, nt, odd_stride,  v, ve, vo, w, we, wo, wrfft)

        !  Compute coefficients br, bi, cr, ci
        select case (ityp)
            case (0)

                !  case ityp=0,  no symmetries

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

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

                ! case m = 1 through nlat-1
                if (mmax < 2) return

                main_loop_case_0: 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 i=1, imm1
                                do np1=mp1, odd_stride, 2
                                    br(mp1, np1, k) = br(mp1, np1, k)+zv(np1+mb, i)*vo(i, 2*mp1-2, k) &
                                        +zw(np1+mb, i)*we(i, 2*mp1-1, k)
                                    bi(mp1, np1, k) = bi(mp1, np1, k)+zv(np1+mb, i)*vo(i, 2*mp1-1, k) &
                                        -zw(np1+mb, i)*we(i, 2*mp1-2, k)
                                    cr(mp1, np1, k) = cr(mp1, np1, k)-zv(np1+mb, i)*wo(i, 2*mp1-2, k) &
                                        +zw(np1+mb, i)*ve(i, 2*mp1-1, k)
                                    ci(mp1, np1, k) = ci(mp1, np1, k)-zv(np1+mb, i)*wo(i, 2*mp1-1, k) &
                                        -zw(np1+mb, i)*ve(i, 2*mp1-2, k)
                                end do
                            end do
                        end do
                        if (mod(nlat, 2) /= 0) then
                            do k=1, nt
                                do np1=mp1, odd_stride, 2
                                    br(mp1, np1, k) = br(mp1, np1, k)+zw(np1+mb, imid)*we(imid, 2*mp1-1, k)
                                    bi(mp1, np1, k) = bi(mp1, np1, k)-zw(np1+mb, imid)*we(imid, 2*mp1-2, k)
                                    cr(mp1, np1, k) = cr(mp1, np1, k)+zw(np1+mb, imid)*ve(imid, 2*mp1-1, k)
                                    ci(mp1, np1, k) = ci(mp1, np1, k)-zw(np1+mb, imid)*ve(imid, 2*mp1-2, k)
                                end do
                            end do
                        end if
                    end if

                    if (mp2 > even_stride) cycle main_loop_case_0

                    do k=1, nt
                        do i=1, imm1
                            do np1=mp2, even_stride, 2
                                br(mp1, np1, k) = br(mp1, np1, k)+zv(np1+mb, i)*ve(i, 2*mp1-2, k) &
                                    +zw(np1+mb, i)*wo(i, 2*mp1-1, k)
                                bi(mp1, np1, k) = bi(mp1, np1, k)+zv(np1+mb, i)*ve(i, 2*mp1-1, k) &
                                    -zw(np1+mb, i)*wo(i, 2*mp1-2, k)
                                cr(mp1, np1, k) = cr(mp1, np1, k)-zv(np1+mb, i)*we(i, 2*mp1-2, k) &
                                    +zw(np1+mb, i)*vo(i, 2*mp1-1, k)
                                ci(mp1, np1, k) = ci(mp1, np1, k)-zv(np1+mb, i)*we(i, 2*mp1-1, k) &
                                    -zw(np1+mb, i)*vo(i, 2*mp1-2, k)
                            end do
                        end do
                    end do

                    if (mod(nlat, 2) == 0) cycle main_loop_case_0

                    do k=1, nt
                        do np1=mp2, even_stride, 2
                            br(mp1, np1, k) = br(mp1, np1, k)+zv(np1+mb, imid)*ve(imid, 2*mp1-2, k)
                            bi(mp1, np1, k) = bi(mp1, np1, k)+zv(np1+mb, imid)*ve(imid, 2*mp1-1, k)
                            cr(mp1, np1, k) = cr(mp1, np1, k)-zv(np1+mb, imid)*we(imid, 2*mp1-2, k)
                            ci(mp1, np1, k) = ci(mp1, np1, k)-zv(np1+mb, imid)*we(imid, 2*mp1-1, k)
                        end do
                    end do
                end do main_loop_case_0
            case (1)
                !
                !  case ityp=1 ,  no symmetries but cr and ci equal zero
                !
                !    case m=0
                !
                do k=1, nt
                    do i=1, imid
                        do np1=2, even_stride, 2
                            br(1, np1, k) = br(1, np1, k)+zv(np1, i)*ve(i, 1, k)
                        end do
                    end do
                end do

                do k=1, nt
                    do i=1, imm1
                        do np1=3, odd_stride, 2
                            br(1, np1, k) = br(1, np1, k)+zv(np1, i)*vo(i, 1, k)
                        end do
                    end do
                end do
                !
                !  case m = 1 through nlat-1
                !
                if (mmax < 2) return

                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 i=1, imm1
                                do np1=mp1, odd_stride, 2
                                    br(mp1, np1, k) = br(mp1, np1, k)+zv(np1+mb, i)*vo(i, 2*mp1-2, k) &
                                        +zw(np1+mb, i)*we(i, 2*mp1-1, k)
                                    bi(mp1, np1, k) = bi(mp1, np1, k)+zv(np1+mb, i)*vo(i, 2*mp1-1, k) &
                                        -zw(np1+mb, i)*we(i, 2*mp1-2, k)
                                end do
                            end do
                        end do

                        if (mod(nlat, 2) /= 0) then
                            do k=1, nt
                                do np1=mp1, odd_stride, 2
                                    br(mp1, np1, k) = br(mp1, np1, k)+zw(np1+mb, imid)*we(imid, 2*mp1-1, k)
                                    bi(mp1, np1, k) = bi(mp1, np1, k)-zw(np1+mb, imid)*we(imid, 2*mp1-2, k)
                                end do
                            end do
                        end if
                    end if

                    if (mp2 > even_stride) return

                    do k=1, nt
                        do i=1, imm1
                            do np1=mp2, even_stride, 2
                                br(mp1, np1, k) = br(mp1, np1, k)+zv(np1+mb, i)*ve(i, 2*mp1-2, k) &
                                    +zw(np1+mb, i)*wo(i, 2*mp1-1, k)
                                bi(mp1, np1, k) = bi(mp1, np1, k)+zv(np1+mb, i)*ve(i, 2*mp1-1, k) &
                                    -zw(np1+mb, i)*wo(i, 2*mp1-2, k)
                            end do
                        end do
                    end do

                    if (mod(nlat, 2) == 0) return

                    do k=1, nt
                        do np1=mp2, even_stride, 2
                            br(mp1, np1, k) = br(mp1, np1, k)+zv(np1+mb, imid)*ve(imid, 2*mp1-2, k)
                            bi(mp1, np1, k) = bi(mp1, np1, k)+zv(np1+mb, imid)*ve(imid, 2*mp1-1, k)
                        end do
                    end do
                end do
            case (2)
                !
                !  case ityp=2 ,  no symmetries but br and bi equal zero
                !
                !    case m=0
                !
                do k=1, nt
                    do i=1, imid
                        do np1=2, even_stride, 2
                            cr(1, np1, k) = cr(1, np1, k)-zv(np1, i)*we(i, 1, k)
                        end do
                    end do
                end do

                do k=1, nt
                    do i=1, imm1
                        do np1=3, odd_stride, 2
                            cr(1, np1, k) = cr(1, np1, k)-zv(np1, i)*wo(i, 1, k)
                        end do
                    end do
                end do
                !
                !  case m = 1 through nlat-1
                !
                if (mmax < 2) return

                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 i=1, imm1
                                do np1=mp1, odd_stride, 2
                                    cr(mp1, np1, k) = cr(mp1, np1, k)-zv(np1+mb, i)*wo(i, 2*mp1-2, k) &
                                        +zw(np1+mb, i)*ve(i, 2*mp1-1, k)
                                    ci(mp1, np1, k) = ci(mp1, np1, k)-zv(np1+mb, i)*wo(i, 2*mp1-1, k) &
                                        -zw(np1+mb, i)*ve(i, 2*mp1-2, k)
                                end do
                            end do
                        end do

                        if (mod(nlat, 2) /= 0) then
                            do k=1, nt
                                do np1=mp1, odd_stride, 2
                                    cr(mp1, np1, k) = cr(mp1, np1, k)+zw(np1+mb, imid)*ve(imid, 2*mp1-1, k)
                                    ci(mp1, np1, k) = ci(mp1, np1, k)-zw(np1+mb, imid)*ve(imid, 2*mp1-2, k)
                                end do
                            end do
                        end if
                    end if

                    if (mp2 > even_stride) return

                    do k=1, nt
                        do i=1, imm1
                            do np1=mp2, even_stride, 2
                                cr(mp1, np1, k) = cr(mp1, np1, k)-zv(np1+mb, i)*we(i, 2*mp1-2, k) &
                                    +zw(np1+mb, i)*vo(i, 2*mp1-1, k)
                                ci(mp1, np1, k) = ci(mp1, np1, k)-zv(np1+mb, i)*we(i, 2*mp1-1, k) &
                                    -zw(np1+mb, i)*vo(i, 2*mp1-2, k)
                            end do
                        end do
                    end do

                    if (mod(nlat, 2) == 0) return

                    do k=1, nt
                        do np1=mp2, even_stride, 2
                            cr(mp1, np1, k) = cr(mp1, np1, k)-zv(np1+mb, imid)*we(imid, 2*mp1-2, k)
                            ci(mp1, np1, k) = ci(mp1, np1, k)-zv(np1+mb, imid)*we(imid, 2*mp1-1, k)
                        end do
                    end do
                end do
            case (3)
                !
                !  case ityp=3 ,  v even , w odd
                !
                !    case m=0
                !
                do k=1, nt
                    do i=1, imid
                        do np1=2, even_stride, 2
                            br(1, np1, k) = br(1, np1, k)+zv(np1, i)*ve(i, 1, k)
                        end do
                    end do
                end do

                do k=1, nt
                    do i=1, imm1
                        do np1=3, odd_stride, 2
                            cr(1, np1, k) = cr(1, np1, k)-zv(np1, i)*wo(i, 1, k)
                        end do
                    end do
                end do
                !
                !  case m = 1 through nlat-1
                !
                if (mmax < 2) return

                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 i=1, imm1
                                do np1=mp1, odd_stride, 2
                                    cr(mp1, np1, k) = cr(mp1, np1, k)-zv(np1+mb, i)*wo(i, 2*mp1-2, k) &
                                        +zw(np1+mb, i)*ve(i, 2*mp1-1, k)
                                    ci(mp1, np1, k) = ci(mp1, np1, k)-zv(np1+mb, i)*wo(i, 2*mp1-1, k) &
                                        -zw(np1+mb, i)*ve(i, 2*mp1-2, k)
                                end do
                            end do
                        end do

                        if (mod(nlat, 2) /= 0) then
                            do k=1, nt
                                do np1=mp1, odd_stride, 2
                                    cr(mp1, np1, k) = cr(mp1, np1, k)+zw(np1+mb, imid)*ve(imid, 2*mp1-1, k)
                                    ci(mp1, np1, k) = ci(mp1, np1, k)-zw(np1+mb, imid)*ve(imid, 2*mp1-2, k)
                                end do
                            end do
                        end if
                    end if

                    if (mp2 > even_stride) return

                    do k=1, nt
                        do i=1, imm1
                            do np1=mp2, even_stride, 2
                                br(mp1, np1, k) = br(mp1, np1, k)+zv(np1+mb, i)*ve(i, 2*mp1-2, k) &
                                    +zw(np1+mb, i)*wo(i, 2*mp1-1, k)
                                bi(mp1, np1, k) = bi(mp1, np1, k)+zv(np1+mb, i)*ve(i, 2*mp1-1, k) &
                                    -zw(np1+mb, i)*wo(i, 2*mp1-2, k)
                            end do
                        end do
                    end do

                    if (mod(nlat, 2) == 0) return

                    do  k=1, nt
                        do  np1=mp2, even_stride, 2
                            br(mp1, np1, k) = br(mp1, np1, k)+zv(np1+mb, imid)*ve(imid, 2*mp1-2, k)
                            bi(mp1, np1, k) = bi(mp1, np1, k)+zv(np1+mb, imid)*ve(imid, 2*mp1-1, k)
                        end do
                    end do
                end do
            case (4)
                !
                !  case ityp=4 ,  v even, w odd, and cr and ci equal 0.
                !
                !    case m=0
                !
                do k=1, nt
                    do i=1, imid
                        do np1=2, even_stride, 2
                            br(1, np1, k) = br(1, np1, k)+zv(np1, i)*ve(i, 1, k)
                        end do
                    end do
                end do
                !
                !  case m = 1 through nlat-1
                !
                if (mmax < 2) return

                do mp1=2, mmax
                    m = mp1-1
                    mb = m*(nlat-1)-(m*(m-1))/2
                    mp2 = mp1+1

                    if (mp2 > even_stride) exit

                    do k=1, nt
                        do i=1, imm1
                            do np1=mp2, even_stride, 2
                                br(mp1, np1, k) = br(mp1, np1, k)+zv(np1+mb, i)*ve(i, 2*mp1-2, k) &
                                    +zw(np1+mb, i)*wo(i, 2*mp1-1, k)
                                bi(mp1, np1, k) = bi(mp1, np1, k)+zv(np1+mb, i)*ve(i, 2*mp1-1, k) &
                                    -zw(np1+mb, i)*wo(i, 2*mp1-2, k)
                            end do
                        end do
                    end do

                    if (mod(nlat, 2) == 0) return

                    do k=1, nt
                        do np1=mp2, even_stride, 2
                            br(mp1, np1, k) = br(mp1, np1, k)+zv(np1+mb, imid)*ve(imid, 2*mp1-2, k)
                            bi(mp1, np1, k) = bi(mp1, np1, k)+zv(np1+mb, imid)*ve(imid, 2*mp1-1, k)
                        end do
                    end do
                end do
            case (5)
                !
                !  case ityp=5   v even, w odd, and br and bi equal zero
                !
                !    case m=0
                !
                do k=1, nt
                    do i=1, imm1
                        do np1=3, odd_stride, 2
                            cr(1, np1, k) = cr(1, np1, k)-zv(np1, i)*wo(i, 1, k)
                        end do
                    end do
                end do
                !
                !  case m = 1 through nlat-1
                !
                if (mmax < 2) return

                do mp1=2, mmax
                    m = mp1-1
                    mb = m*(nlat-1)-(m*(m-1))/2
                    mp2 = mp1+1

                    if (mp1 > odd_stride) exit

                    do k=1, nt
                        do i=1, imm1
                            do np1=mp1, odd_stride, 2
                                cr(mp1, np1, k) = cr(mp1, np1, k)-zv(np1+mb, i)*wo(i, 2*mp1-2, k) &
                                    +zw(np1+mb, i)*ve(i, 2*mp1-1, k)
                                ci(mp1, np1, k) = ci(mp1, np1, k)-zv(np1+mb, i)*wo(i, 2*mp1-1, k) &
                                    -zw(np1+mb, i)*ve(i, 2*mp1-2, k)
                            end do
                        end do
                    end do

                    if (mod(nlat, 2) == 0) exit

                    do k=1, nt
                        do np1=mp1, odd_stride, 2
                            cr(mp1, np1, k) = cr(mp1, np1, k)+zw(np1+mb, imid)*ve(imid, 2*mp1-1, k)
                            ci(mp1, np1, k) = ci(mp1, np1, k)-zw(np1+mb, imid)*ve(imid, 2*mp1-2, k)
                        end do
                    end do
                end do
            case (6)
                !
                !  case ityp=6 ,  v odd , w even
                !
                !    case m=0
                !
                do k=1, nt
                    do i=1, imid
                        do np1=2, even_stride, 2
                            cr(1, np1, k) = cr(1, np1, k)-zv(np1, i)*we(i, 1, k)
                        end do
                    end do
                end do

                do k=1, nt
                    do i=1, imm1
                        do np1=3, odd_stride, 2
                            br(1, np1, k) = br(1, np1, k)+zv(np1, i)*vo(i, 1, k)
                        end do
                    end do
                end do
                !
                !  case m = 1 through nlat-1
                !
                if (mmax < 2) return

                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  i=1, imm1
                                do  np1=mp1, odd_stride, 2
                                    br(mp1, np1, k) = br(mp1, np1, k)+zv(np1+mb, i)*vo(i, 2*mp1-2, k) &
                                        +zw(np1+mb, i)*we(i, 2*mp1-1, k)
                                    bi(mp1, np1, k) = bi(mp1, np1, k)+zv(np1+mb, i)*vo(i, 2*mp1-1, k) &
                                        -zw(np1+mb, i)*we(i, 2*mp1-2, k)
                                end do
                            end do
                        end do

                        if (mod(nlat, 2) /= 0) then
                            do  k=1, nt
                                do  np1=mp1, odd_stride, 2
                                    br(mp1, np1, k) = br(mp1, np1, k)+zw(np1+mb, imid)*we(imid, 2*mp1-1, k)
                                    bi(mp1, np1, k) = bi(mp1, np1, k)-zw(np1+mb, imid)*we(imid, 2*mp1-2, k)
                                end do
                            end do
                        end if
                    end if

                    if (mp2 > even_stride) return

                    do k=1, nt
                        do  i=1, imm1
                            do  np1=mp2, even_stride, 2
                                cr(mp1, np1, k) = cr(mp1, np1, k)-zv(np1+mb, i)*we(i, 2*mp1-2, k) &
                                    +zw(np1+mb, i)*vo(i, 2*mp1-1, k)
                                ci(mp1, np1, k) = ci(mp1, np1, k)-zv(np1+mb, i)*we(i, 2*mp1-1, k) &
                                    -zw(np1+mb, i)*vo(i, 2*mp1-2, k)
                            end do
                        end do
                    end do

                    if (mod(nlat, 2) == 0) return

                    do k=1, nt
                        do np1=mp2, even_stride, 2
                            cr(mp1, np1, k) = cr(mp1, np1, k)-zv(np1+mb, imid)*we(imid, 2*mp1-2, k)
                            ci(mp1, np1, k) = ci(mp1, np1, k)-zv(np1+mb, imid)*we(imid, 2*mp1-1, k)
                        end do
                    end do
                end do
            case (7)
                !
                !  case ityp=7   v odd, w even, and cr and ci equal zero
                !
                !    case m=0
                !
                do k=1, nt
                    do i=1, imm1
                        do np1=3, odd_stride, 2
                            br(1, np1, k) = br(1, np1, k)+zv(np1, i)*vo(i, 1, k)
                        end do
                    end do
                end do
                !
                !  case m = 1 through nlat-1
                !
                if (mmax < 2) return

                do mp1=2, mmax
                    m = mp1-1
                    mb = m*(nlat-1)-(m*(m-1))/2
                    mp2 = mp1+1

                    if (mp1 > odd_stride) return

                    do  k=1, nt
                        do  i=1, imm1
                            do  np1=mp1, odd_stride, 2
                                br(mp1, np1, k) = br(mp1, np1, k)+zv(np1+mb, i)*vo(i, 2*mp1-2, k) &
                                    +zw(np1+mb, i)*we(i, 2*mp1-1, k)
                                bi(mp1, np1, k) = bi(mp1, np1, k)+zv(np1+mb, i)*vo(i, 2*mp1-1, k) &
                                    -zw(np1+mb, i)*we(i, 2*mp1-2, k)
                            end do
                        end do
                    end do

                    if (mod(nlat, 2) == 0) return

                    do k=1, nt
                        do np1=mp1, odd_stride, 2
                            br(mp1, np1, k) = br(mp1, np1, k)+zw(np1+mb, imid)*we(imid, 2*mp1-1, k)
                            bi(mp1, np1, k) = bi(mp1, np1, k)-zw(np1+mb, imid)*we(imid, 2*mp1-2, k)
                        end do
                    end do
                end do
            case (8)
                !
                !  case ityp=8   v odd, w even, and both br and bi equal zero
                !
                !    case m=0
                !
                do k=1, nt
                    do i=1, imid
                        do np1=2, even_stride, 2
                            cr(1, np1, k) = cr(1, np1, k)-zv(np1, i)*we(i, 1, k)
                        end do
                    end do
                end do
                !
                ! case m = 1 through nlat-1
                !
                if (mmax < 2) return

                do mp1=2, mmax
                    m = mp1-1
                    mb = m*(nlat-1)-(m*(m-1))/2
                    mp2 = mp1+1

                    if (mp2 > even_stride) return

                    do k=1, nt
                        do i=1, imm1
                            do np1=mp2, even_stride, 2
                                cr(mp1, np1, k) = cr(mp1, np1, k)-zv(np1+mb, i)*we(i, 2*mp1-2, k) &
                                    +zw(np1+mb, i)*vo(i, 2*mp1-1, k)
                                ci(mp1, np1, k) = ci(mp1, np1, k)-zv(np1+mb, i)*we(i, 2*mp1-1, k) &
                                    -zw(np1+mb, i)*vo(i, 2*mp1-2, k)
                            end do
                        end do
                    end do

                    if (mod(nlat, 2) == 0) return

                    do k=1, nt
                        do np1=mp2, even_stride, 2
                            cr(mp1, np1, k) = cr(mp1, np1, k)-zv(np1+mb, imid)*we(imid, 2*mp1-2, k)
                            ci(mp1, np1, k) = ci(mp1, np1, k)-zv(np1+mb, imid)*we(imid, 2*mp1-1, k)
                        end do
                    end do
                end do
        end select

    end subroutine vhaes_lower_utility_routine

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

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

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

    end function get_vhaesi_workspace_indices

    subroutine vhaesi_lower_utility_routine(nlat, nlon, imid, zv, zw, idz, zin, wzvin, dwork)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: imid
        real(wp),    intent(out) :: zv(idz, *)
        real(wp),    intent(out) :: zw(idz, *)
        integer(ip), intent(in)  :: idz
        real(wp),    intent(out) :: zin(imid, nlat, 3)
        real(wp),    intent(out) :: wzvin(*)
        real(wp),    intent(out) :: dwork(*)

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

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

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

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

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

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

    end subroutine vhaesi_lower_utility_routine

end submodule vector_analysis_regular_grid_saved