program testRDM_ED_NupNdw
  USE SCIFOR
  !< use COMMON_VARIABLES module to load global variables
  USE COMMON_VARS
  !
  !< use AUXILIARY FUNCTIONS module to load some auxiliary procedures: binary_decomposition, sector_buildup, etc...
  USE AUX_FUNX
  !
  !< fortran-esque to force explicit declaration of all variables.
  implicit none
  !
  !< define variables to be used in THIS code. Variables are shared with
  !any procedure contained here.
  integer                          :: i,j,k,io,jo
  integer                          :: ibathUp,ibathDw,Ibath,Jbath
  integer                          :: iimpUp,iimpDw,iimp,jimp
  integer                          :: jimpUp,jimpDw
  integer                          :: Ntot,sIup,sIdw,sJup,sJdw
  integer                          :: iup,idw,kup,kdw,bup,bdw,jup,jdw
  integer                          :: Nup,Ndw
  integer                          :: LenInterUp,LenInterDw
  integer,allocatable              :: InterUp(:),InterDw(:)
  integer                          :: Dim
  integer,allocatable              :: ivecUp(:),ivecDw(:)
  integer,allocatable              :: jvecUp(:),jvecDw(:)
  integer                          :: unit
  character(len=32)                :: finput
  !
  !< CUSTOM TYPE: a user defined variable/structure which contains
  !the map between the states of a given sector S and those of the Fock space F
  type(sector_map)                     :: H,Hup,Hdw
  !
  real(8),dimension(:),allocatable     :: state_dvec
  real(8),dimension(:,:),allocatable   :: impurity_density_matrix
  real(8),dimension(:,:),allocatable   :: impurity_density_matrix_
  real(8),dimension(:,:),allocatable   :: reduced_density_matrix
  real(8),dimension(:,:),allocatable   :: big_density_matrix
  real(8),dimension(:,:),allocatable   :: small_density_matrix
  real(8)                              :: peso,delta
  real(8),dimension(:),allocatable     :: dens,dens_up,dens_dw
  real(8),dimension(:),allocatable     :: docc

  !
  !< define some useful parameters:
  call parse_cmd_variable(finput,"FINPUT",default='inputDM')
  call parse_input_variable(Nbath,"Nbath",finput,default=3)
  call parse_input_variable(Nlat,"Nlat",finput,default=2)
  call parse_input_variable(Norb,"Norb",finput,default=1)
  call parse_input_variable(Nup,"Nup",finput,default=4)
  call parse_input_variable(Ndw,"Ndw",finput,default=4)
  call parse_input_variable(verbose,"verbose",finput,default=.false.)
  call parse_input_variable(fast,"fast",finput,default=.true.)
  call parse_input_variable(random,"random",finput,default=.false.)
  !< Number of impurity levels
  Nimp  = Nlat*Norb
  !< Number of spins: keep this low for better visualization
  Ns = Nimp*(1+Nbath)
  !< Total number of bath levels (per spin)
  Nbath_tot = Nimp*Nbath
  if(Nup+Ndw/=Ns)stop "ERROR: The given parameters are inconsistent."
  !
  !< Total number of levels for fermions. 1Fermion=2*spin
  Ntot  = 2*Ns
  !< set default output unit. 6==std.output in fortran-esque
  unit=6
  if(verbose)then
    write(unit,*)""
    write(unit,*)""
    write(unit,*)"Ns      =", Ns
    write(unit,*)"Ntot    =", Ntot
    write(unit,*)"2**Ns   =", 2**Ns
    write(unit,*)"2**Ntot =", 2**Ntot
    write(unit,*)""
    write(unit,*)""
  endif
  !
  !
  allocate(IvecUp(Ns),IvecDw(Ns))
  allocate(JvecUp(Ns),JvecDw(Ns))
  allocate(dens(Nimp),dens_up(Nimp),dens_dw(Nimp))
  allocate(docc(Nimp))

  !> BUILD SECTORS MAP (map + sp)
  write(unit,*)""
  write(unit,"(A,2I3,A,I10)")"Test --- sector: [ Nup Ndw ] = [",Nup,Ndw,"  ] ---- total dimension:",dim_sector_normal(Nup)*dim_sector_normal(Ndw)
  write(unit,*)""
  call build_sector_normal_sigma(Nup,Hup)
  call build_sector_normal_sigma(Ndw,Hdw)

  Dim = dim_sector_normal(Nup)*dim_sector_normal(Ndw)
  !> SECTOR PRINTOUT
  if(verbose)then
    !If dim is small enough list all the states in Human Readable form:
    if(Dim < 65000)then
      write(unit,'(A9,A,A9,A,A1,2A4,A6,2A4,A1)',advance='no')"i"," =>","K"," -- ","(","iup","idw",") => (","kup","kdw",")"
      write(unit,'(A)',advance='no')"|"
      write(unit,"("//str(Ns)//"A1)",advance="no")("b",j=1,Ns)
      write(unit,"(A1)",advance="no")">"
      write(unit,'(A)',advance='no')"|"
      write(unit,"("//str(Ns)//"A1)",advance="no")("b",j=1,Ns)
      write(unit,"(A1)",advance="no")">"
      write(unit,"(A3)",advance="no")" - "
      write(unit,"(A7,A1,"//str(Nimp)//"A1,A1)",advance="no")"kimpUp","|",("b",j=1,Nimp),">"
      write(unit,"(A3)",advance="no")"+"
      write(unit,"(A7,A1,"//str(Nbath_tot)//"A1,A1)",advance="no")"kbathUp","|",("b",j=Nimp+1,Ns),">"
      write(unit,"(A1)",advance="no")" "
      write(unit,"(A7,A1,"//str(Nimp)//"A1,A1)",advance="no")"kimpDw","|",("b",j=1,Nimp),">"
      write(unit,"(A3)",advance="no")"+"
      write(unit,"(A7,A1,"//str(Nbath_tot)//"A1,A1)",advance="no")"kbathDw","|",("b",j=Nimp+1,Ns),">"
      write(unit,"(A1)",advance="yes")""

      do idw = 1,dim_sector_normal(Ndw)
          kdw = Hdw%map(idw)
          ivecDw = bdecomp(kdw,Ns)
          iimpDw = get_imp_state(kdw)
          ibathDw= get_bath_state(kdw)
          !
          do iup = 1,dim_sector_normal(Nup)
            kup    = Hup%map(iup)
            ivecUp = bdecomp(kup,Ns)
            iimpUp = get_imp_state(kup)
            ibathUp= get_bath_state(kup)
            !
            i      = iup + (idw-1)*dim_sector_normal(Nup)
            k      = kup + 2**Ns*kdw
            !
            !
            write(unit,'(i9,A,i9,A)',advance='no')i," =>",k," -- "
            write(unit,'(A1,2i4,A6,2i4,A1)',advance='no')"(",iup,idw,") => (",kup,kdw,")"
            write(unit,'(A)',advance='no')"|"
            write(unit,"("//str(Ns)//"I1)",advance="no")(ivecUp(j),j=1,Ns)
            write(unit,"(A1)",advance="no")">"
            write(unit,'(A)',advance='no')"|"
            write(unit,"("//str(Ns)//"I1)",advance="no")(ivecDw(j),j=1,Ns)
            write(unit,"(A1)",advance="no")">"
            write(unit,"(A3)",advance="no")" - "
            write(unit,"(I7,A1,"//str(Nimp)//"I1,A1)",advance="no")iimpUp,"|",(ivecUp(j),j=1,Nimp),">"
            write(unit,"(A3)",advance="no")"+"
            write(unit,"(I7,A1,"//str(Nbath_tot)//"I1,A1)",advance="no")ibathUp,"|",(ivecUp(j),j=Nimp+1,Ns),">"
            write(unit,"(A1)",advance="no")" "
            write(unit,"(I7,A1,"//str(Nimp)//"I1,A1)",advance="no")iimpDw,"|",(ivecDw(j),j=1,Nimp),">"
            write(unit,"(A3)",advance="no")"+"
            write(unit,"(I7,A1,"//str(Nbath_tot)//"I1,A1)",advance="no")ibathDw,"|",(ivecDw(j),j=Nimp+1,Ns),">"
            write(unit,"(A1)",advance="yes")""
            !
            !
          enddo
      enddo
      write(unit,'(A9,A,A9,A,A1,2A4,A6,2A4,A1)',advance='no')"i"," =>","K"," -- ","(","iup","idw",") => (","Kup","Kdw",")"
      write(unit,'(A)',advance='no')"|"
      write(unit,"("//str(Ns)//"A1)",advance="no")("b",j=1,Ns)
      write(unit,"(A1)",advance="no")">"
      write(unit,'(A)',advance='no')"|"
      write(unit,"("//str(Ns)//"A1)",advance="no")("b",j=1,Ns)
      write(unit,"(A1)",advance="no")">"
      write(unit,"(A3)",advance="no")" - "
      write(unit,"(A7,A1,"//str(Nimp)//"A1,A1)",advance="no")"KimpUp","|",("b",j=1,Nimp),">"
      write(unit,"(A3)",advance="no")"+"
      write(unit,"(A7,A1,"//str(Nbath_tot)//"A1,A1)",advance="no")"KbathUp","|",("b",j=Nimp+1,Ns),">"
      write(unit,"(A1)",advance="no")" "
      write(unit,"(A7,A1,"//str(Nimp)//"A1,A1)",advance="no")"KimpDw","|",("b",j=1,Nimp),">"
      write(unit,"(A3)",advance="no")"+"
      write(unit,"(A7,A1,"//str(Nbath_tot)//"A1,A1)",advance="no")"KbathDw","|",("b",j=Nimp+1,Ns),">"
      write(unit,*)""
    endif
  endif

  !> EVALUATE THE INTERSECTION A_up \cap B_up BETWEEN ANY PAIR OF IMP_UP INDICES
  if(verbose)then
    write(unit,*)""
    do iimpUp=0,Hup%sp%Nimp_state-1
      do jimpUp=0,Hup%sp%Nimp_state-1
          call sp_return_intersection(Hup%sp,iimpUp,jimpUp,InterUp,LenInterUp)
          write(unit,*)"Intersect IimpUP="//str(iimpUp)//", IimpUP="//str(jimpUp)
          write(unit,*)"Size(Intersection)",LenInterUp
          if(LenInterUp==0)cycle
          write(unit,*)"Intersection:"
          write(*,"(10000I5)")(InterUp(i),i=1,size(InterUp))
          write(unit,*)""
      enddo
    enddo
  endif

  !> ALLOCATE AND BUILD A VECTOR OF THE SECTOR: i.e. the linear combination of the basis using random/unit coefficient.
  !> NORMALIZED
  allocate(state_dvec(Dim))
  state_dvec=1d0
  if(random)call mt_random(state_dvec)
  state_dvec = state_dvec/sqrt(dot_product(state_dvec,state_dvec))

  !> EVALUATE OCCUPATION AND DOUBLE OCCUPATIONS FOR THIS STATE
  dens    = 0.d0
  dens_up = 0.d0
  dens_dw = 0.d0
  docc    = 0.d0
  do idw = 1,dim_sector_normal(Ndw)
     kdw = Hdw%map(idw)
     ivecDw = bdecomp(kdw,Ns)
     do iup = 1,dim_sector_normal(Nup)
        kup    = Hup%map(iup)
        ivecUp = bdecomp(kup,Ns)
        !
        i = iup + (idw-1)*dim_sector_normal(Nup)
        peso=abs(state_dvec(i))**2
        !
        do io=1,Nimp
           dens(io)     = dens(io)      +  (ivecUp(io)+IvecDw(io))*peso
           dens_up(io)  = dens_up(io)   +  IvecUp(io)*peso
           dens_dw(io)  = dens_dw(io)   +  IvecDw(io)*peso
           docc(io)     = docc(io)      +  IvecUp(io)*IvecDw(io)*peso
        enddo
     enddo
  enddo

  !> ALLOCATE IMP DENSITY MATRIX (and a spare copy to test)
  allocate(impurity_density_matrix(4**Nimp,4**Nimp))
  allocate(impurity_density_matrix_(4**Nimp,4**Nimp))

  !>SLOW ALGORITHM:
  print*,"SLOW ALGORITHM"
  if(fast)then
      write(unit,"(A,2I3,A,I10)")"[skipping since <fast> option is enabled]"
      print*, " "
  else
      call start_timer()
      impurity_density_matrix=0d0
      do idw = 1,dim_sector_normal(Ndw)
         ivecDw = bdecomp(Hdw%map(idw),Ns)
         do iup = 1,dim_sector_normal(Nup)
            ivecUp = bdecomp(Hup%map(iup),Ns)
            Iimp = bjoin([IvecUp(1:Nimp),IvecDw(1:Nimp)],2*Nimp) + 1
            Ibath= bjoin([IvecUp(Nimp+1:),IvecDw(Nimp+1:)],2*Nbath_tot) + 1
            !
            do jdw = 1,dim_sector_normal(Ndw)
               jvecDw = bdecomp(Hdw%map(jdw),Ns)
               do jup = 1,dim_sector_normal(Nup)
                  jvecUp = bdecomp(Hup%map(jup),Ns)
                  Jimp = bjoin([JvecUp(1:Nimp),JvecDw(1:Nimp)],2*Nimp) + 1
                  Jbath= bjoin([JvecUp(Nimp+1:),JvecDw(Nimp+1:)],2*Nbath_tot) + 1
                  !
                  if(Jbath/=Ibath)cycle
                  i = iup + (idw-1)*dim_sector_normal(Nup)
                  j = jup + (jdw-1)*dim_sector_normal(Nup)
                  impurity_density_matrix(Iimp,Jimp) = impurity_density_matrix(Iimp,Jimp) + &
                        state_dvec(i)*state_dvec(j)
               enddo
            enddo
         enddo
      enddo
      impurity_density_matrix_ = impurity_density_matrix
      if(Nimp<=2)then
            do i=1,4**Nimp
               !PRINT FULL MATRIX
               write(*,"(1000F7.3)")(impurity_density_matrix(i,j),j=1,4**Nimp)
            enddo
      endif
      call stop_timer()
      print*, " "
  endif

  !>FAST ALGORITHM:
  print*,"FAST ALGORITHM"
  call start_timer()
  impurity_density_matrix=0d0
  do IimpUp=0,Hup%sp%Nimp_state-1
     do JimpUp=0,Hup%sp%Nimp_state-1
        !Finding the unique bath states connecting IimpUp and JimpUp -> InterUp(:)
        call sp_return_intersection(Hup%sp,IimpUp,JimpUp,InterUp,LenInterUp)
        if(LenInterUp==0)cycle  !there are no bath states intersecting IimpUp,JimpUp
        do IimpDw=0,Hdw%sp%Nimp_state-1
           do JimpDw=0,Hdw%sp%Nimp_state-1
              !Finding the unique bath states connecting IimpDw and JimpDw -> InterDw(:)
              call sp_return_intersection(Hdw%sp,IimpDw,JimpDw,InterDw,LenInterDw)
              if(LenInterDw==0)cycle  !there are no bath states intersecting IimpDw,JimpDw
              !------------------------------------------------------------------------------------
              !Arrived here we have finally determined the {IbathUp,IbathDw} states to trace on.
              !We shall use them to build back the Fock space states (IimpSIGMA,IbathSIGMA) and
              !through those search the map to retrieve the formal labels i=(iUP,iDW), j=(jUP,jDW)
              !------------------------------------------------------------------------------------
              do bup=1,LenInterUp !=== >>> THE TRACE OVER THE BATH <<< ============================
                 IbathUp = InterUp(bup)
                 do bdw=1,LenInterDw
                    IbathDw = InterDw(bdw)
                    !-----------------------------------------------------
                    !Allowed spin Fock Indices:
                    Iup= binary_search(Hup%map,IimpUp + 2**Nimp*IbathUp)
                    Idw= binary_search(Hdw%map,IimpDw + 2**Nimp*IbathDw)
                    !Global sector index:
                    i  = Iup + (Idw-1)*dim_sector_normal(Nup)
                    !-----------------------------------------------------
                    !Allowed spin Fock Jndices:
                    Jup= binary_search(Hup%map,JimpUp + 2**Nimp*IbathUp)
                    Jdw= binary_search(Hdw%map,JimpDw + 2**Nimp*IbathDw)
                    !Global sector jndex:
                    j  = Jup + (Jdw-1)*dim_sector_normal(Nup)
                    !-----------------------------------------------------
                    !Final Lin-Gubernatis composition for the impurity
                    io = (IimpUp+1) + 2**Nimp*IimpDw
                    jo = (JimpUp+1) + 2**Nimp*JimpDw
                    !------------------------------------------------------------------
                    !(i,j)_th contribution to the (io,jo)_th element of \rho_IMP
                    impurity_density_matrix(io,jo) = impurity_density_matrix(io,jo) + &
                         state_dvec(i)*state_dvec(j)
                    !------------------------------------------------------------------
                 enddo
              enddo !==============================================================================
              !
           enddo
        enddo
        !
     enddo
  enddo
  if(Nimp<=2)then
      do i=1,4**Nimp
         !PRINT FULL MATRIX
         write(*,"(1000F7.3)")(impurity_density_matrix(i,j),j=1,4**Nimp)
      enddo
  endif
  call stop_timer()
  print*, " "

  !>CROSSCHECK ALGORITHMS
  if(.not.fast)then
    print*,    "***************************************************"
    if( any(abs(impurity_density_matrix_-impurity_density_matrix)/=0d0) )then
      print*, "ERROR: SLOW and FAST algorithms fail to match"
    else
      print*, "SLOW and FAST algorithms match to machine-precision"
    endif
    print*,    "***************************************************"
  endif

  !>SUBTRACING
  write(*,*)
  write(*,*) "=================="
  write(*,*) "SUBTRACING-ROUTINE"
  write(*,*) "=================="
  write(*,*)
  print*,"ALL REDUCED DENSITY MATRICES"
  big_density_matrix = impurity_density_matrix
  do k=1,Nlat-1
     !<From cluster-dm to all reduced dms [increasing Ntrace]
     call subtrace(reduced_density_matrix,impurity_density_matrix,Nlat,Nlat-k)
     DIM = size(reduced_density_matrix(:,1))
     write(*,"(A,2I3,A,I10)") ">rank-"//str(DIM)//" [DIRECT]"
     if(verbose)then
         do i=1,DIM
            !PRINT REDUCED MATRIX [DIRECT]
            write(*,"(1000F7.3)")(reduced_density_matrix(i,j),j=1,DIM)
         enddo
     else
         print*, "(no print)"
     endif
     !<From cluster-dm to all reduced dms [site by site]
     call subtrace(small_density_matrix,big_density_matrix,Nlat-k+1,Nlat-k)
     DIM = size(small_density_matrix(:,1))
     write(*,"(A,2I3,A,I10)") ">rank-"//str(DIM)//" [ITERATIVE]"
     if(verbose)then
         do i=1,DIM
            !PRINT REDUCED MATRIX [ITERATIVE]
            write(*,"(1000F7.3)")(small_density_matrix(i,j),j=1,DIM)
         enddo
      else
         print*, "(no print)"
      endif
     !>CROSSCHECK ALGORITHMS
     print*,   "**************************************************************"
     delta = maxval(abs(reduced_density_matrix-small_density_matrix))
     if(delta > 0.00001d0)then
       print*, "ERROR: DIRECT and ITERATIVE subtracings fail to match"
     elseif(delta == 0.d0)then
       print*, "DIRECT and ITERATIVE subtracings match up to machine precision"
     else
       print*, "DIRECT and ITERATIVE subtracings match up to:",real(delta)
     endif
    print*,    "**************************************************************"
    !
    deallocate(big_density_matrix)
    big_density_matrix = small_density_matrix
    !
  enddo
  !
  !
  if(Norb==1)then
      print*, " "
      print*, "==============================================================="
      print*, "BENCHMARK: LOCAL DENSITY-MATRIX versus SEMI-ANALYTICAL FORMULAE"
      print*, "==============================================================="
      print*, "------ ESTIMATE ------ | -------- ERROR ----------- "
      print*, 1-dens_up(1)-dens_dw(1)+docc(1),abs(1-dens_up(1)-dens_dw(1)+docc(1)-reduced_density_matrix(1,1))
      print*, dens_up(1)-docc(1),abs(dens_up(1)-docc(1)-reduced_density_matrix(2,2))
      print*, dens_dw(1)-docc(1),abs(dens_dw(1)-docc(1)-reduced_density_matrix(3,3))
      print*, docc(1),abs(docc(1)-reduced_density_matrix(4,4))
      print*, "==============================================================="
      print*, " "
  endif

  call map_deallocate(Hup)
  call map_deallocate(Hdw)
  write(unit,*)""
  write(unit,*)""
  write(unit,*)""

end program testRDM_ED_NupNdw


!> \file mo_dds.f90

!> \brief Dynamically Dimensioned Search (DDS)

!> \details This module provides routines for Dynamically Dimensioned Search (DDS)
!> of Tolson and Shoemaker (2007). It searches the minimum or maximum of a user-specified function,
!> using an n-dimensional continuous global optimization algorithm (DDS).

!> \authors Original by Bryan Tolson and later modified by Rohini Kumar.
!> Matthias Cuntz and Juliane Mai for the module, MDDS, etc.
!> \date Jul 2012

module mo_dds

  ! This module contains routines for Dynamically Dimensioned Search (DDS)

  ! Written Jul 2012, Matthias Cuntz - module version of modified DDS v1.1 of R. Kumar to
  ! original DDS of Bryan Tolson

  ! License
  ! -------
  ! This file is part of the JAMS Fortran package, distributed under the MIT License.
  !
  ! Copyright (c) 2012 Bryan Tolson, Matthias Cuntz, Juliane Mai, Rohini Kumar - mc (at) macu (dot) de
  !
  ! Permission is hereby granted, free of charge, to any person obtaining a copy
  ! of this software and associated documentation files (the "Software"), to deal
  ! in the Software without restriction, including without limitation the rights
  ! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  ! copies of the Software, and to permit persons to whom the Software is
  ! furnished to do so, subject to the following conditions:
  !
  ! The above copyright notice and this permission notice shall be included in all
  ! copies or substantial portions of the Software.
  !
  ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  ! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  ! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  ! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  ! SOFTWARE.

  IMPLICIT NONE

  PRIVATE

  PUBLIC :: DDS    ! Dynamically Dimensioned Search (DDS)
  PUBLIC :: MDDS   ! Modified Dynamically Dimensioned Search (DDS)

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

CONTAINS

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

  !     NAME
  !>        \brief DDS

  !     PURPOSE
  !>        \details Searches Minimum or Maximum of a user-specified function using
  !>        Dynamically Dimensioned Search (DDS).
  !>
  !>        DDS is an n-dimensional continuous global optimization algorithm.
  !>        It is coded as a minimizer but one can give maxit=True in a maximization problem,
  !>        so that the algorithm minimizes the negative of the objective function F=(-1*F).

  !>        The function to be minimized is the first argument of DDS and must be defined as \n
  !>        \code
  !>            function func(p)
  !>              use mo_kind, only: dp
  !>              implicit none
  !>              real(dp), dimension(:), intent(in) :: p
  !>              real(dp) :: func
  !>            end function func
  !>        \endcode

  !     CALLING SEQUENCE
  !         popt = DDS(obj_func, pini, prange, r=r, seed=seed, maxiter=maxiter, maxit=maxit, funcbest=funcbest)

  !     INTENT(IN)
  !>        \param[in] "real(dp) :: obj_func(p)"             Function on which to search the minimum
  !>        \param[in] "real(dp) :: pini(:)"                 inital value of decision variables
  !>        \param[in] "real(dp) :: prange(size(pini),2)"    Min/max range of decision variables

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         None

  !     INTENT(IN), OPTIONAL
  !>        \param[in] "real(dp), optional           :: r"                 DDS perturbation parameter\n
  !>                                                                       (default: 0.2)
  !>        \param[in] "integer(i8), optional        :: seed"              User seed to initialise the random number generator
  !>                                                                       (default: None)
  !>        \param[in] "integer(i8), optional        :: maxiter"           Maximum number of iteration or function evaluation
  !>                                                                       (default: 1000)
  !>        \param[in] "logical, optional            :: maxit"             Maximization (.True.) or
  !>                                                                       minimization (.False.) of function
  !>                                                                       (default: .False.)
  !>        \param[in] "logical, optional            :: mask(size(pini))"  parameter to be optimized (true or false)
  !>                                                                       (default: .True.)
  !>        \param[in]  "character(len=*) , optional :: tmp_file"          file with temporal output

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !>        \param[out] "real(dp), optional              :: funcbest"    the best value of the function.
  !>        \param[out] "real(dp), optional, allocatable :: history(:)"  the history of best function values,
  !>                                                                     history(maxiter)=funcbest\n
  !>                                          allocatable only to be in correspondance with other optimization routines

  !     RETURN
  !>        \return real(dp) :: DDS  —  The parameters of the point which is estimated to minimize the function.

  !     RESTRICTIONS
  !         None.

  !     EXAMPLE
  !         dv_range(:,1) = (/ -600.0, -600.0, -600.0, -600.0, -600.0, -600.0, -600.0, -600.0, -600.0, -600.0 /)
  !         dv_range(:,2) = (/ 600.0, 600.0, 600.0, 600.0, 600.0, 600.0, 600.0, 600.0, 600.0, 600.0 /)
  !         dv_ini        = (/ -.226265E+01, -.130187E+01, -.151219E+01, 0.133983E+00, 0.988159E+00, &
  !                            -.495074E+01, -.126574E+02, 0.572684E+00, 0.303864E+01, 0.343031E+01 /)
  !         dv_opt = DDS(griewank, dv_ini, dv_range)
  !         -> see also example in test directory

  !     LITERATURE
  !         Tolson, B. A., and C. A. Shoemaker (2007)
  !             Dynamically dimensioned search algorithm for computationally efficient watershed
  !             model calibration, Water Resour. Res., 43, W01413, doi:10.1029/2005WR004723.

  !     HISTORY
  !>        \author Written original Bryan Tolson - DDS v1.1\n
  !>        Modified Rohini Kumar, Matthias Cuntz, Juliane Mai
  !         \date Feb 2007
  !         Modified, Rohini Kumar, Feb 2008
  !         Modified, Matthias Cuntz & Juliane Mai, Jul 2012 - module
  !                   Juliane Mai,                  Aug 2012 - optional argument funcbest added
  !                   Juliane Mai,                  Nov 2012 - masked parameter
  !                   Juliane Mai,                  Dec 2012 - history output

  function DDS(obj_func, pini, prange, r, seed, maxiter, maxit, mask, tmp_file, funcbest, history)

    use mo_kind,    only: i4, i8, dp
    use mo_xor4096, only: xor4096, xor4096g

    implicit none

    INTERFACE
       function obj_func(pp)
         use mo_kind, only: dp
         implicit none
         real(dp), dimension(:), intent(in) :: pp
         real(dp) :: obj_func
       end function obj_func
    END INTERFACE
    real(dp),    dimension(:),             intent(in)  :: pini     ! inital value of decision variables
    real(dp),    dimension(:,:),           intent(in)  :: prange   ! Min/max values of decision variables
    real(dp),                    optional, intent(in)  :: r        ! DDS perturbation parameter (-> 0.2 by default)
    integer(i8),                 optional, intent(in)  :: seed     ! User seed to initialise the random number generator
    integer(i8),                 optional, intent(in)  :: maxiter  ! Maximum number of iteration or function evaluation
    logical,                     optional, intent(in)  :: maxit    ! Maximization or minimization of function
    logical,     dimension(:),   optional, intent(in)  :: mask     ! parameter to be optimized (true or false)
    character(len=*),            optional, intent(in)  :: tmp_file    ! file for temporal output
    real(dp),                    optional, intent(out) :: funcbest ! Best value of the function.
    real(dp),    dimension(:),   optional, intent(out), &
         allocatable                                   :: history  ! History of objective function values
    real(dp),    dimension(size(pini))                 :: DDS      ! Best value of decision variables

    ! Local variables
    integer(i4)                             :: pnum                   ! Total number of decision variables
    integer(i8)                             :: iseed                  ! User given seed
    integer(i8)                             :: imaxiter               ! Maximum number of iteration or function evaluation
    real(dp)                                :: ir                     ! DDS perturbation parameter
    real(dp)                                :: imaxit                 ! Maximization or minimization of function
    real(dp)                                :: of_new, of_best        ! intermediate results
    real(dp)                                :: Pn, new_value          ! intermediate results
    real(dp), dimension(size(pini))         :: pnew                   ! Test value of decision variables
    real(dp)                                :: ranval                 ! random value
    integer(i8)                             :: i                      ! maxiter=i8
    integer(i4)                             :: j, dvn_count, dv       ! pnum=i4
    integer(i4)                             :: idummy                 ! dummy vaiable
    integer, dimension(8)                   :: sdate                  ! date_and_time return
    logical, dimension(size(pini))          :: maske                  ! parameter to be optimized (true or false)
    integer(i4), dimension(:), allocatable  :: truepara               ! parameter to be optimized (their indexes)

    ! Check input
    pnum = size(pini)
    if (size(prange,1) /= pnum) stop 'Error DDS: size(prange,1) /= size(pini)'
    if (size(prange,2) /= 2)    stop 'Error DDS: size(prange,2) /= 2'
    ! r Perturbation parameter
    ir = 0.2_dp
    if (present(r)) ir = r
    if (ir <= 0.0_dp .or. ir > 1.0_dp) stop 'Error DDS: DDS perturbation parameter (0.0, 1.0]'
    ! max. iteration
    imaxiter = 1000
    if (present(maxiter)) imaxiter = maxiter
    if (imaxiter < 6) stop 'Error DDS: max function evals must be minimum 6'
    ! history output
    if (present(history)) then
       allocate(history(imaxiter))
    end if
    ! Min or max objective function
    imaxit = 1.0_dp
    if (present(maxit)) then
       if (maxit) imaxit = -1.0_dp
    endif
    ! Given seed
    iseed = 0
    if (present(seed)) iseed = seed
    iseed = max(iseed, 0_i8)

    if (present(mask)) then
       if (count(mask) .eq. 0_i4) then
          stop 'Input argument mask: At least one element has to be true'
       else
          maske = mask
       end if
    else
       maske = .true.
    endif

    allocate ( truepara(count(maske)) )
    idummy = 0_i4
    do j=1,size(pini,1)
       if ( maske(j) ) then
          idummy = idummy+1_i4
          truepara(idummy) = j
       end if
    end do

    ! Seed random numbers
    if (iseed == 0) then
       call date_and_time(values=sdate)
       iseed = sdate(1)*31536000000_i8 + sdate(2)*2592000000_i8 + sdate(3)*86400000_i8 + &
            sdate(5)*3600000_i8 + sdate(6)*60000_i8 + sdate(7)*1000_i8 + sdate(8)
       call xor4096(iseed,ranval)
       call xor4096g(iseed,ranval)
    else
       call xor4096(iseed,ranval)
       call xor4096g(iseed,ranval)
    endif

    ! Temporal file writing
    if(present(tmp_file)) then
       open(unit=999,file=trim(adjustl(tmp_file)), action='write', status = 'unknown')
       write(999,*) '# settings :: general'
       write(999,*) '# nIterations    iseed'
       write(999,*) imaxiter, iseed
       write(999,*) '# settings :: dds specific'
       write(999,*) '# dds_r'
       write(999,*) ir
       write(999,*) '# iter   bestf   (bestx(j),j=1,nopt)'
       close(999)
    end if

    ! Evaluate initial solution and return objective function value
    ! and Initialise the other variables (e.g. of_best)
    ! imaxit is 1.0 for MIN problems, -1 for MAX problems
    DDS        = pini
    of_new     = imaxit * obj_func(pini)
    of_best    = of_new
    if (present(history)) history(1) = of_new

    file_write: if (present(tmp_file)) then
       open(unit=999,file=trim(adjustl(tmp_file)), action='write', position='append', recl=(pnum+2)*30)
       if (imaxit .lt. 0.0_dp) then
          ! Maximize
          write(999,*) '0', -of_best, pini
       else
          ! Minimize
          write(999,*) '0', of_best, pini
       end if
       close(999)
    end if file_write

    ! Code below is now the DDS algorithm as presented in Figure 1 of Tolson and Shoemaker (2007)

    do i=1, imaxiter-1
       ! Determine Decision Variable (DV) selected for perturbation:
       Pn        = 1.0_dp - log(real(i,dp))/log(real(imaxiter-1,dp)) ! probability each DV selected
       dvn_count = 0                                                 ! counter for how many DVs selected for perturbation
       pnew      = DDS                                               ! define pnew initially as best current solution

       ! Step 3 of Fig 1 of Tolson and Shoemaker (2007)
       do j=1, size(truepara) !pnum
          call xor4096(0_i8,ranval)                           ! selects next uniform random number in sequence
          ! Step 4 of Fig 1 of Tolson and Shoemaker (2007)
          if (ranval < Pn) then                               ! jth DV selected for perturbation
             dvn_count = dvn_count + 1
             ! call 1-D perturbation function to get new DV value (new_value)
             call neigh_value(DDS(truepara(j)), prange(truepara(j),1), prange(truepara(j),2), ir, new_value)
             pnew(truepara(j)) = new_value
          end if
       end do

       ! Step 3 of Fig 1 of Tolson and Shoemaker (2007) in case {N} empty
       if (dvn_count == 0) then                               ! no DVs selected at random, so select one
          call xor4096(0_i8,ranval)                           ! selects next uniform random number in sequence
          dv = truepara(int(( ranval * real(size(truepara),dp))  + 1.0_dp, i4 ))  ! index for one DV
          ! call 1-D perturbation function to get new DV value (new_value):
          call neigh_value(DDS(dv), prange(dv,1), prange(dv,2), ir, new_value)
          pnew(dv) = new_value                                ! change relevant DV value in stest
       end if

       ! Step 5 of Fig 1 of Tolson and Shoemaker (2007)
       ! Evaluate obj function value for test
       of_new = imaxit * obj_func(pnew)                       ! imaxit handles min(=1) and max(=-1) problems
       ! update current best solution
       if (of_new <= of_best) then
          of_best = of_new
          DDS     = pnew
       end if
       if (present(history)) history(i+1) = of_best

       file_write2: if (present(tmp_file)) then
          open(unit=999,file=trim(adjustl(tmp_file)), action='write', position='append', recl=(pnum+2)*30)
          if (imaxit .lt. 0.0_dp) then
             ! Maximize
             write(999,*) i, -of_best, dds
          else
             ! Minimize
             write(999,*) i, of_best, dds
          end if
          close(999)
       end if file_write2

    end do
    if (present(funcbest)) funcbest = of_best

  end function DDS

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

  !     NAME
  !>        \brief MDDS

  !     PURPOSE
  !>        \details Searches Minimum or Maximum of a user-specified function using the
  !>        Modified Dynamically Dimensioned Search (DDS).

  !>        DDS is an n-dimensional continuous global optimization algorithm.
  !>        It is coded as a minimizer but one can give maxit=True in a maximization problem,
  !>        so that the algorithm minimizes the negative of the objective function F=(-1*F).
  !>
  !>        The function to be minimized is the first argument of DDS and must be defined as
  !>        \code
  !>            function func(p)
  !>              use mo_kind, only: dp
  !>              implicit none
  !>              real(dp), dimension(:), intent(in) :: p
  !>              real(dp) :: func
  !>            end function func
  !>        \endcode
  !>
  !>       MDDS extents normal DDS by a continuous reduction of the DDS pertubation parameter r from 0.3 to 0.05,
  !>       and by allowing a larger function value with a certain probablity.

  !     CALLING SEQUENCE
  !         popt = MDDS(obj_func, pini, prange, seed=seed, maxiter=maxiter, maxit=maxit, funcbest=funcbest)

  !     INTENT(IN)
  !>        \param[in] "real(dp) :: obj_func(p)"             Function on which to search the minimum
  !>        \param[in] "real(dp) :: pini(:)"                 inital value of decision variables
  !>        \param[in] "real(dp) :: prange(size(pini),2)"    Min/max range of decision variables

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         None

  !     INTENT(IN), OPTIONAL
  !>        \param[in] "integer(i8), optional        :: seed"              User seed to initialise the random number generator
  !>                                                                       (default: None)
  !>        \param[in] "integer(i8), optional        :: maxiter"           Maximum number of iteration or function evaluation
  !>                                                                       (default: 1000)
  !>        \param[in] "logical, optional            :: maxit"             Maximization (.True.) or
  !>                                                                       minimization (.False.) of function
  !>                                                                       (default: .False.)
  !>        \param[in] "logical, optional            :: mask(size(pini))"  parameter to be optimized (true or false)
  !>                                                                       (default: .True.)
  !>        \param[in]  "character(len=*) , optional :: tmp_file"          file with temporal output

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !>        \param[out] "real(dp), optional              :: funcbest"    the best value of the function.
  !>        \param[out] "real(dp), optional, allocatable :: history(:)"  the history of best function values,
  !                                                                      history(maxiter)=funcbest\n
  !                                          allocatable only to be in correspondance with other optimization routines

  !     RETURN
  !>        \return real(dp) :: MDDS  —  The parameters of the point which is estimated to minimize the function.

  !     RESTRICTIONS
  !         None.

  !     EXAMPLE
  !         dv_range(:,1) = (/ -600.0, -600.0, -600.0, -600.0, -600.0, -600.0, -600.0, -600.0, -600.0, -600.0 /)
  !         dv_range(:,2) = (/ 600.0, 600.0, 600.0, 600.0, 600.0, 600.0, 600.0, 600.0, 600.0, 600.0 /)
  !         dv_ini        = (/ -.226265E+01, -.130187E+01, -.151219E+01, 0.133983E+00, 0.988159E+00, &
  !                            -.495074E+01, -.126574E+02, 0.572684E+00, 0.303864E+01, 0.343031E+01 /)
  !         dv_opt = MDDS(griewank, dv_ini, dv_range)
  !         -> see also example in test directory

  !     LITERATURE
  !         Tolson, B. A., and C. A. Shoemaker (2007)
  !             Dynamically dimensioned search algorithm for computationally efficient watershed
  !             model calibration, Water Resour. Res., 43, W01413, doi:10.1029/2005WR004723.
  !         Huang X-L and Xiong J (2010)
  !             Parameter Optimization of Multi-tank Model with Modified Dynamically Dimensioned
  !             Search Algorithm, Proceedings of the Third International Symposium on Computer
  !             Science and Computational Technology(ISCSCT ''10), Jiaozuo, P. R. China,
  !             14-15 August 2010, pp. 283-288

  !     HISTORY
  !>        \author Written Matthias Cuntz and Juliane Mai
  !         \date Aug 2012
  !         Modified, Juliane Mai,                  Nov 2012 - masked parameter
  !                   Juliane Mai,                  Dec 2012 - history output

  function MDDS(obj_func, pini, prange, seed, maxiter, maxit, mask, tmp_file, funcbest, history)

    use mo_kind,    only: i4, i8, dp
    use mo_xor4096, only: xor4096, xor4096g

    implicit none

    INTERFACE
       function obj_func(pp)
         use mo_kind, only: dp
         implicit none
         real(dp), dimension(:), intent(in) :: pp
         real(dp) :: obj_func
       end function obj_func
    END INTERFACE
    real(dp),    dimension(:),             intent(in)  :: pini     ! inital value of decision variables
    real(dp),    dimension(:,:),           intent(in)  :: prange   ! Min/max values of decision variables
    integer(i8),                 optional, intent(in)  :: seed     ! User seed to initialise the random number generator
    integer(i8),                 optional, intent(in)  :: maxiter  ! Maximum number of iteration or function evaluation
    logical,                     optional, intent(in)  :: maxit    ! Maximization or minimization of function
    logical,     dimension(:),   optional, intent(in)  :: mask     ! parameter to be optimized (true or false)
    character(len=*),            optional, intent(in)  :: tmp_file ! file for temporal output
    real(dp),                    optional, intent(out) :: funcbest ! Best value of the function.
    real(dp),    dimension(:),   optional, intent(out), &
         allocatable                                   :: history  ! History of objective function values
    real(dp),    dimension(size(pini))                 :: MDDS     ! Best value of decision variables

    ! Local variables
    integer(i4)                             :: pnum                   ! Total number of decision variables
    integer(i8)                             :: iseed                  ! User given seed
    integer(i8)                             :: imaxiter               ! Maximum number of iteration or function evaluation
    real(dp)                                :: ir                     ! MDDS perturbation parameter
    real(dp)                                :: imaxit                 ! Maximization or minimization of function
    real(dp)                                :: of_new, of_best        ! intermediate results
    real(dp)                                :: Pn, new_value          ! intermediate results
    real(dp), dimension(size(pini))         :: pnew                   ! Test value of decision variables
    real(dp)                                :: ranval                 ! random value
    integer(i8)                             :: i                      ! maxiter=i8
    integer(i4)                             :: j, dvn_count, dv       ! pnum=i4
    integer(i4)                             :: idummy                 ! dummy vaiable
    integer, dimension(8)                   :: sdate                  ! date_and_time return
    logical, dimension(size(pini))          :: maske                  ! parameter to be optimized (true or false)
    integer(i4), dimension(:), allocatable  :: truepara               ! parameter to be optimized (their indexes)

    ! Check input
    pnum = size(pini)
    if (size(prange,1) /= pnum) stop 'Error MDDS: size(prange,1) /= size(pini)'
    if (size(prange,2) /= 2)    stop 'Error MDDS: size(prange,2) /= 2'
    ! max. iteration
    imaxiter = 1000
    if (present(maxiter)) imaxiter = maxiter
    if (imaxiter < 6) stop 'Error MDDS: max function evals must be minimum 6'
    ! history output
    if (present(history)) then
       allocate(history(imaxiter))
    end if
    ! Min or max objective function
    imaxit = 1.0_dp
    if (present(maxit)) then
       if (maxit) imaxit = -1.0_dp
    endif
    ! Given seed
    iseed = 0
    if (present(seed)) iseed = seed
    iseed = max(iseed, 0_i8)

    ! Seed random numbers
    if (iseed == 0) then
       call date_and_time(values=sdate)
       iseed = sdate(1)*31536000000_i8 + sdate(2)*2592000000_i8 + sdate(3)*86400000_i8 + &
            sdate(5)*3600000_i8 + sdate(6)*60000_i8 + sdate(7)*1000_i8 + sdate(8)
       call xor4096(iseed,ranval)
       call xor4096g(iseed,ranval)
    else
       call xor4096(iseed,ranval)
       call xor4096g(iseed,ranval)
    endif

    ! Masked parameters
    if (present(mask)) then
       if (count(mask) .eq. 0_i4) then
          stop 'Input argument mask: At least one element has to be true'
       else
          maske = mask
       end if
    else
       maske = .true.
    endif

    allocate ( truepara(count(maske)) )
    idummy = 0_i4
    do j=1,size(pini,1)
       if ( maske(j) ) then
          idummy = idummy+1_i4
          truepara(idummy) = j
       end if
    end do

    ! Temporal file writing
    if(present(tmp_file)) then
       open(unit=999,file=trim(adjustl(tmp_file)), action='write', status = 'unknown')
       write(999,*) '# settings :: general'
       write(999,*) '# nIterations    iseed'
       write(999,*) imaxiter, iseed
       write(999,*) '# settings :: mdds specific'
       write(999,*) '# None'
       write(999,*) ''
       write(999,*) '# iter   bestf   (bestx(j),j=1,nopt)'
       close(999)
    end if

    ! Evaluate initial solution and return objective function value
    ! and Initialise the other variables (e.g. of_best)
    ! imaxit is 1.0 for MIN problems, -1 for MAX problems
    MDDS     = pini
    of_new  = imaxit * obj_func(pini)
    of_best = of_new
    if (present(history)) history(1) = of_new

    file_write: if (present(tmp_file)) then
       open(unit=999,file=trim(adjustl(tmp_file)), action='write', position='append', recl=(pnum+2)*30)
       if (imaxit .lt. 0.0_dp) then
          ! Maximize
          write(999,*) '0', -of_best, mdds
       else
          ! Minimize
          write(999,*) '0', of_best, mdds
       end if
       close(999)
    end if file_write

    ! Code below is now the MDDS algorithm as presented in Figure 1 of Tolson and Shoemaker (2007)

    do i=1, imaxiter-1
       ! Determine Decision Variable (DV) selected for perturbation:
       Pn        = 1.0_dp - log(real(i,dp))/log(real(imaxiter-1,dp)) ! probability each DV selected
       dvn_count = 0                                                 ! counter for how many DVs selected for perturbation
       pnew      = MDDS                                               ! define pnew initially as best current solution
       ! Modifications by Huang et al. (2010)
       Pn        = max(Pn, 0.05_dp)
       ir        = max(min(0.3_dp, Pn), 0.05_dp)

       ! Step 3 of Fig 1 of Tolson and Shoemaker (2007)
       do j=1, pnum
          call xor4096(0_i8,ranval)                           ! selects next uniform random number in sequence
          ! Step 4 of Fig 1 of Tolson and Shoemaker (2007)
          if (ranval < Pn) then                               ! jth DV selected for perturbation
             dvn_count = dvn_count + 1
             ! call 1-D perturbation function to get new DV value (new_value)
             call neigh_value(MDDS(truepara(j)), prange(truepara(j),1), prange(truepara(j),2), ir, new_value)
             pnew(truepara(j)) = new_value
          end if
       end do

       ! Step 3 of Fig 1 of Tolson and Shoemaker (2007) in case {N} empty
       if (dvn_count == 0) then                               ! no DVs selected at random, so select one
          call xor4096(0_i8,ranval)                           ! selects next uniform random number in sequence
          dv = truepara(int(( ranval * real(size(truepara),dp))  + 1.0_dp, i4 ))  ! index for one DV
          ! call 1-D perturbation function to get new DV value (new_value):
          call neigh_value(MDDS(dv), prange(dv,1), prange(dv,2), ir, new_value)
          pnew(dv) = new_value                                ! change relevant DV value in stest
       end if

       ! Step 5 of Fig 1 of Tolson and Shoemaker (2007)
       ! Evaluate obj function value for test
       of_new = imaxit * obj_func(pnew)                       ! imaxit handles min(=1) and max(=-1) problems
       ! update current best solution
       if (of_new <= of_best) then
          of_best = of_new
          MDDS    = pnew
       else ! Modifications by Huang et al. (2010)
          call xor4096(0_i8,ranval)
          if (exp(-(of_new-of_best)/of_best) > (1.0_dp-ranval*Pn)) then
             of_best = of_new
             MDDS    = pnew
          endif
       end if
       if (present(history)) then
          if (present(maxit)) then
             if (maxit) then
                history(i+1) = max(history(i),of_best)
             else
                history(i+1) = min(history(i),of_best)
             end if
          else
             history(i+1) = min(history(i),of_best)
          end if
       end if

       file_write2: if (present(tmp_file)) then
          open(unit=999,file=trim(adjustl(tmp_file)), action='write', position='append', recl=(pnum+2)*30)
          if (imaxit .lt. 0.0_dp) then
             ! Maximize
             write(999,*) i, -of_best, mdds
          else
             ! Minimize
             write(999,*) i, of_best, mdds
          end if
          close(999)
       end if file_write2

    end do
    if (present(funcbest)) funcbest = of_best

  end function MDDS

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

  ! Purpose is to generate a neighboring decision variable value for a single
  !  decision variable value being perturbed by the DDS optimization algorithm.
  !  New DV value respects the upper and lower DV bounds.
  !  Coded by Bryan Tolson, Nov 2005.

  ! I/O variable definitions:
  !  x_cur     - current decision variable (DV) value
  !  x_min     - min DV value
  !  x_max     - max DV value
  !  r         - the neighborhood perturbation factor
  !  new_value - new DV variable value (within specified min and max)

  subroutine neigh_value(x_cur, x_min, x_max, r, new_value)

    use mo_kind,    only: i8, dp
    use mo_xor4096, only: xor4096g

    implicit none

    real(dp), intent(in)   :: x_cur, x_min, x_max, r
    real(dp), intent(out)  :: new_value
    real(dp)               :: x_range
    real(dp) :: zvalue

    x_range = x_max - x_min

    ! generate a standard normal random variate (zvalue)
    call xor4096g(0_i8,zvalue)

    ! calculate new decision variable value:
    new_value = x_cur + zvalue*r*x_range

    !  check new value is within bounds. If not, bounds are reflecting.
    if (new_value < x_min) then
       new_value = x_min + (x_min - new_value)
       if (new_value > x_max) then
          ! if reflection goes past x_max then value should be x_min since
          ! without reflection the approach goes way past lower bound.
          ! This keeps x close to lower bound when x_cur is close to lower bound
          ! Practically speaking, this should never happen with r values <0.3.
          new_value = x_min
       end if
    else if (new_value > x_max) then
       new_value = x_max - (new_value - x_max)
       if (new_value < x_min) then
          ! if reflection goes past x_min then value should be x_max for same reasons as above.
          new_value = x_max
       endif
    endif

  end subroutine neigh_value

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

end module mo_dds


!*************************************************
! module mod_subabic
!	RESET(alpha,detc,jdata_lc,jct_lc,jmt_lc)
!	FREEMIN(detf,rsq2_lc,jdata_lc,jct_lc,jmt_lc)
!
!*************************************************

module mod_subabic

	implicit none

contains
!=========
subroutine RESET(alpha_lc,detc,jdata_lc)

	use prm_matrix
	use prm_inv

	implicit none

	real(8), intent(in) :: alpha_lc

	integer, intent(out) :: jdata_lc !, jct_lc, jmt_lc
	real(8), intent(out) :: detc

	integer :: i, k

	jdata_lc = 0

	! E_prior がゼロ（＝使わないデータ）を取り除く作業

	do i = 1, Itotal

		if(E_prior(i) == 0.d0) cycle

		jdata_lc = jdata_lc + 1
		Y(jdata_lc) = Y_data(i)

		do k = 1, Jsp
			Z_HaG(jdata_lc,k) = Z_Green(i,k)
		end do

	end do

	Y(jdata_lc+1:jdata_lc+Jcp) = 0.d0

	! Z_HaG の下に Constrain Matrix * alpha を加える

	do k = 1, Jsp
		do i = 1, Jcp
			Z_HaG(i+jdata_lc,k) = Cs(i,k) * alpha_lc
		end do
	end do

	!jmt_lc = Jsp
	!jct_lc = Jcp
	detc = Detca

return
end subroutine RESET

!=========
subroutine FREEMIN(detf,rsq2_lc,jdata_lc)

	use prm_matrix
	use prm_inv
	use mod_qrdec

	implicit none

	integer, intent(in)  :: jdata_lc !, jct_lc, jmt_lc
	real(8), intent(out) :: rsq2_lc, detf

	integer :: jtotal, jmtt, i
	integer :: lu(Kmp)    ! lu  は QRDEC のアウトプット。特に使用されてない。
	real(8) :: wk1(Kdata) ! wk1 は QRDEC のアウトプット。特に使用されてない。

	jtotal = jdata_lc + Jcp

	CALL QRDEC(Z_HaG,Y, detf, Kdata, jtotal, Jsp, wk1,lu, jmtt,1)

	if(jmtt /= Jsp) then
		print    '(" "," ERROR NO SOLUTION FOR BASIC LSQS/ JMT,JMTT",2I5)', Jsp, jmtt
		write(77,'(" "," ERROR NO SOLUTION FOR BASIC LSQS/ JMT,JMTT",2I5)') Jsp, jmtt
		stop
	end if

	rsq2_lc = 0.d0

	do i = Jsp+1, jtotal
		rsq2_lc = rsq2_lc + Y(i) * Y(i)
	end do

	CALL RINV(X_model,Y,Z_HaG,Kdata,Jsp,0)

return
end subroutine FREEMIN
!=========

end module mod_subabic


program fe_mg

use types, only: dp
use sto, only: stoints2, get_basis2
use utils, only: assert
use radialscf, only: doscf, kinetic_energy
use hfprint, only: printall, printlam
use mesh, only: meshexp
use feutils, only: define_connect, get_quad_pts, get_parent_quad_pts_wts, &
        get_parent_nodes
use fe, only: feints
implicit none

integer, allocatable :: nbfl(:)
real(dp), allocatable :: focc(:, :)

real(dp), allocatable :: S(:, :, :), T(:, :, :), V(:, :, :), slater(:, :)
integer :: n, Z, m, Nscf, Lmax, ndof
real(dp) :: alpha, Etot, tolE, tolP, Ekin
real(dp), allocatable :: H(:, :, :), P_(:, :, :), C(:, :, :), lam(:, :)

real(dp), allocatable :: xin(:)       ! parent basis nodes
real(dp), allocatable :: xe(:)        ! element coordinates
integer, allocatable :: ib(:, :)       ! basis connectivity: ib(i,j) = index of
   ! basis function associated with local basis function i of element j. 0 = no
   ! associated basis fn.
integer, allocatable :: in(:, :)
real(dp), allocatable :: xiq(:)       ! quadrature points
real(dp), allocatable :: wtq(:)       ! quadrature weights
real(dp), allocatable :: xq(:, :)
integer :: p, Ne, Nb, Nq
real(dp) :: rmin, rmax, a
integer :: l, u

Lmax = 1
allocate(nbfl(0:Lmax), focc(7, 0:Lmax))
nbfl = 0
focc = 0
focc(:3, 0) = [2, 2, 2]
focc(:1, 1) = [6]

Z = 12
tolE = 5e-11_dp
tolP = 1e-5_dp
alpha = 0.6_dp
Nscf = 100

rmin = 0
rmax = 30
a = 40
Ne = 3
Nq = 53

allocate(xe(Ne+1))
xe = meshexp(rmin, rmax, a, Ne)

open(newunit=u, file="Etot.txt", status="replace")
close(u)

do p = 4, 25

    print *, "p =", p
    allocate(xin(p+1))
    call get_parent_nodes(2, p, xin)
    allocate(in(p+1, Ne), ib(p+1, Ne))
    call define_connect(1, 1, Ne, p, in, ib)
    Nb = maxval(ib)
    do l = 0, Lmax
        nbfl(l) = Nb
    end do
    print *, "radial DOFs =", Nb
    allocate(xiq(Nq), wtq(Nq), xq(Nq, Ne))
    call get_parent_quad_pts_wts(1, Nq, xiq, wtq)
    call get_quad_pts(xe, xiq, xq)

    n = maxval(nbfl)
    ndof = sum(nbfl)
    print *, "total  DOFs =", ndof
    allocate(S(n, n, 0:Lmax), T(n, n, 0:Lmax), V(n, n, 0:Lmax))
    m = n*(n+1)/2
    allocate(slater(m*(m+1)/2, 0:2*Lmax))
    call feints(Z, xin, xe, ib, xiq, wtq, S, T, V, slater)

    allocate(P_(n, n, 0:Lmax), C(n, n, 0:Lmax), lam(n, 0:Lmax))

    H = T + V

    print *, "SCF cycle:"
    call doscf(nbfl, H, slater, S, focc, Nscf, tolE, tolP, alpha, C, P_, lam, &
        Etot, slater_l_indep=.true., precalcTT=.true.)
    Ekin = kinetic_energy(nbfl, P_, T)
    call printlam(nbfl, lam, Ekin, Etot)

    open(newunit=u, file="Etot.txt", position="append", status="old")
    write(u, "(i4, ' ', i5, ' ', es23.16)") p, ndof, Etot
    close(u)

    deallocate(xin, in, ib, xiq, wtq, xq, S, T, V, slater, P_, C, lam)
end do

end program


C$Procedure ZZMULT ( Safer multiplication )

      DOUBLE PRECISION FUNCTION ZZMULT ( A, B )

C$ Abstract
C
C     Safely calculate the value A*B, avoiding the possibility
C     of floating point exceptions (FPE) due to numeric underflow
C     or numeric overflow.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     MATH
C
C$ Declarations

      IMPLICIT NONE

      DOUBLE PRECISION      A
      DOUBLE PRECISION      B

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     A          I   Multiplier.
C     B          I   Multiplicand.
C
C$ Detailed_Input
C
C     A          Multiplier for the multiplication operation.
C
C     B          Multiplicand for the multiplication operation.
C
C$ Detailed_Output
C
C     ZZMULT      The value A*B.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) SPICE(NUMERICOVERFLOW) signals if the logarithm base 10
C        of the multiplication is greater than EXPNT (defined
C        below).
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     We want to avoid a floating point exception signal from
C     the platform. This routine does not trap exceptions,
C     the intended purpose is to prevent exceptions.
C
C     Given, for the IEEE 754 double-precision binary
C     floating-point format, the order of magnitude of the minimum
C     normal positive double equals -307 and the order of magnitude of
C     the maximum double equals 308.
C
C       -307 <= LOG10(|A|) + LOG10(|B|) <= 308
C
C     or
C
C         -307                   308
C        10     <=  |A|*|B| <= 10
C
C     Satisfying this condition should guarantee no floating
C     point exceptions.
C
C     Underflow returns zero without an error signal as per SPICE
C     convention.
C
C     Important, this routine does not calculate or enforce a
C     precision on the multiplication evaluation. A safe evaluation
C     may result in a result unusable due to precision loss.
C
C     The routine does not depend on platform-specific arithmetic
C     exception handling, even though the bound for the computed
C     ratio is platform-specific.
C
C     The range [-307,308] is valid for IEEE double precision.
C     It may occur this routine runs on a non compliant platform,
C     so calculate the range based on the DPMAX() value.
C
C     Assign a parameter EXPNT such that EXPNT equals the order of
C     DPMAX. The routine uses the range [-(EXPNT-1), EXPNT].
C
C     This routine checks the sum of the base 10 logarithms
C     of A and B to ensure the magnitude of A*B is
C     within the range [-(EXPNT-1), EXPNT].
C
C$ Examples
C
C     Demonstrate the use of ZZMULT with DPMAX and zero as the
C     multiplier and multiplicand.
C
C           PROGRAM ZZMULT_T
C           IMPLICIT NONE
C
C           DOUBLE PRECISION      A
C           DOUBLE PRECISION      B
C           DOUBLE PRECISION      MULT
C
C     C
C     C     SPICE functions.
C     C
C           DOUBLE PRECISION      ZZMULT
C           DOUBLE PRECISION      DPMAX
C
C
C     C
C     C     Set error reporting to REPORT.
C     C
C           CALL ERRACT( 'SET', 'REPORT' )
C
C
C     C
C     C     Standard, safe evaluation.
C     C
C           A = 1.D0
C           B = 10.D0
C
C           MULT = ZZMULT( A, B )
C           WRITE(*,*) 'MULT 1*10         = ', MULT
C
C
C
C     C
C     C     A numeric overflow event as defined in ZZMULT.
C     C
C           A = 1.D0
C           B = DPMAX()
C
C           MULT = ZZMULT( A, B )
C           WRITE(*,*) 'MULT 1*DPMAX()    = ', MULT
C
C
C
C     C
C     C     A numeric overflow event as defined in ZZMULT.
C     C
C           A = 1.D208
C           B = 1.D307
C
C           MULT = ZZMULT( A, B )
C           WRITE(*,*) 'MULT 1.D515       = ', MULT
C
C
C
C     C
C     C     A multiply by zero event.
C     C
C           A = 1.D0
C           B = 0.D0
C
C           MULT = ZZMULT( A, B )
C           WRITE(*,*) 'MULT 1*0          = ', MULT
C
C
C
C     C
C     C     A multiply by zero event.
C     C
C           A = 0.D0
C           B = 0.D0
C
C           MULT = ZZMULT( A, B )
C           WRITE(*,*) 'MULT 0*0          = ', MULT
C
C
C           END
C
C   The program outputs:
C
C   -The function returns the evaluation value. No error.
C
C      MULT 1*10         =    10.000000000000000
C
C
C   -The function signals a NUMERICOVERFLOW error, and sets the
C    return value to zero.
C
C     =================================================================
C
C     Toolkit version: N0064
C
C     SPICE(NUMERICOVERFLOW) --
C
C     Numerical overflow event. Multiplier value, 1.0000000000000E+00,
C     multiplicand value, 1.7976931348623E+308.
C
C     A traceback follows.  The name of the highest level module is
C     first.
C     ZZMULT
C
C     =================================================================
C      MULT 1*DPMAX()   =  0.0000000000000000
C
C
C   -The function signals a NUMERICOVERFLOW error, and sets the
C    return value to zero.
C
C     =================================================================
C
C     Toolkit version: N0064
C
C     SPICE(NUMERICOVERFLOW) --
C
C     Numerical overflow event. Multiplier value, 1.0000000000000E+208,
C     multiplicand value, 1.0000000000000E+307.
C
C     A traceback follows.  The name of the highest level module is
C     first.
C     ZZMULT
C
C     =================================================================
C      MULT 1.D515       =    0.0000000000000000
C
C
C   -The function returns the evaluation value. No error.
C
C      MULT 1*0          =    0.0000000000000000
C
C
C   -The function returns the evaluation value. No error.
C
C      MULT 0*0          =    0.0000000000000000
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     E.D. Wright    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 31-JAN-2014 (EDW)
C
C-&

C$ Index_Entries
C
C     multiplication, avoid floating point exception
C
C-&

C
C     SPICELIB functions
C

      LOGICAL               RETURN
      DOUBLE PRECISION      DPMAX

C
C     Local variables
C

      DOUBLE PRECISION      LOGA
      DOUBLE PRECISION      LOGB

C
C     The bounds on the potential result of the calculation.
C
      DOUBLE PRECISION      EXPNT

C
C     First entry flag.
C
      LOGICAL               FIRST
      SAVE

      DATA                  FIRST / .TRUE. /

C
C     Return on error.
C
      IF ( RETURN() ) THEN
         ZZMULT = 0.D0
         RETURN
      END IF

C
C     Participate in error tracing.
C
      CALL CHKIN ( 'ZZMULT' )

C
C     Calculate the bounds parameter on first entry.
C     The double precision maximum value has the form
C     "d*(10**EXPNT)." The value of interest is "EXPNT."
C
      IF (FIRST) THEN

         FIRST  = .FALSE.

C
C        A "floor" evaluation.
C
         EXPNT = DBLE( INT( LOG10( DPMAX() ) ) )

       END IF

C
C     If either A or B equals zero the multiplication is zero.
C
      IF ( (A .EQ. 0.D0) .OR. (B .EQ. 0.D0) ) THEN

         ZZMULT = 0.D0
         CALL CHKOUT ( 'ZZMULT' )
         RETURN

      END IF

C
C     Calculate base 10 logarithms of the absolute value of the
C     numerator and denominator. Recall the base 10 log of a negative
C     real is a complex number (an irritating reality). Our interest
C     is the magnitude of the result, not the sign.
C
C     An earlier check returned if A or B equal zero.
C
      LOGA = LOG10( DABS(A) )
      LOGB = LOG10( DABS(B) )

C
C     Local possible overflow check.
C
      IF ( (LOGA + LOGB) .GT. EXPNT ) THEN

         ZZMULT = 0.D0
         CALL SETMSG ( 'Numerical overflow event. '
     .              // 'Multiplier value, #1, '
     .              // 'multiplicand value, #2.'  )
         CALL ERRDP  ( '#1', A                    )
         CALL ERRDP  ( '#2', B                    )
         CALL SIGERR ( 'SPICE(NUMERICOVERFLOW)'   )
         CALL CHKOUT ( 'ZZMULT'                   )
         RETURN

      END IF

C
C     Local possible underflow check. Accept this may occur,
C     return a zero.
C
      IF ( (LOGA + LOGB) .LT. -(EXPNT-1.D0) ) THEN

         ZZMULT = 0.D0
         CALL CHKOUT ( 'ZZMULT' )
         RETURN

      END IF

C
C     This operation should be safe. Probably.
C
      ZZMULT = A*B

      CALL CHKOUT ( 'ZZMULT' )

      RETURN
      END


subroutine interp_driver (xiziyi, xozoyo, vari, varo, nxi, &
                          nzi, nyi, nxo, nzo, nyo)
  use shr_kind_mod, only: r8 => shr_kind_r8
  use varspecs_mod, only: varspecs

  implicit none
!
! Input arguments
!
  integer nxi, nzi, nyi
  integer nxo, nzo, nyo

  type(varspecs) :: vari, varo

  real(r8) :: xiziyi(nxi,nzi,nyi)
  real(r8) :: xozoyo(nxo,nzo,nyo)
!
! Local workspace
!
  integer :: i,j,k
  integer :: numxis, numxin
  integer :: numxo
  integer :: jj, jjs, jjn
  integer :: count

  real(r8) :: wgts, wgtn
!
! Intermediate interpolation arrays
!
  real(r8) :: xizoyi(nxi,nzo,nyi)
  real(r8) :: xtemp(nxo,2)
!
! Interpolate in z
!
  if (nzi == 1 .and. nzo == 1) then
    xizoyi(:,1,:) = xiziyi(:,1,:)
  else
    do j=1,nyi
      do i=1,nxi
        call lininterp (xiziyi(i,1,j), nzi, nxi, vari%zpos, &
                        xizoyi(i,1,j), nzo, nxi, varo%zpos, .false.)
      end do
    end do
  end if
!
! Check monotonicity of y-coordinate variable before interpolating.  z and
! x monotonicity is checked inside lininterp.
!
  count = 0
  do j=1,nyi-1
    if (vari%ypos(j) > vari%ypos(j+1)) count = count + 1
  end do
  do j=1,nyo-1
    if (varo%ypos(j) > varo%ypos(j+1)) count = count + 1
  end do

  if (count > 0) then
    call err_exit ('interp_driver: non-monotonic coordinate array(s) found')
  end if
!
! Interpolate in x and y
!
  do j=1,nyo
    numxo = varo%numx(j)

    jjs = -1
    jjn = -1

    if (vari%ypos(1) >= varo%ypos(j)) then
      jjs = 1
      jjn = 1
    else if (vari%ypos(nyi) < varo%ypos(j)) then
      jjs = nyi
      jjn = nyi
    else
      do jj=1,nyi-1
        if (vari%ypos(jj  ) < varo%ypos(j) .and. &
            vari%ypos(jj+1) >= varo%ypos(j)) then
          jjs = jj
          jjn = jj+1
          exit
        end if
      end do
    end if

    if (jjs < 0 .or. jjn < 0) then
      call err_exit ('interp_driver: bad index calculation')
    end if

    numxis = vari%numx(jjs)
    numxin = vari%numx(jjn)

    if (jjs /= jjn) then
      wgts = (vari%ypos(jjn) - varo%ypos(j)) / (vari%ypos(jjn) - vari%ypos(jjs))
      wgtn = (varo%ypos(j) - vari%ypos(jjs)) / (vari%ypos(jjn) - vari%ypos(jjs))
      if (abs ((wgts+wgtn)-1.) > 1.e-6) then
        call err_exit ('interp_driver: bad weight calculation')
      end if
    end if

    do k=1,nzo
!
! X interp
!
      call lininterp (xizoyi(1,k,jjs), numxis, 1, vari%xpos(1,jjs), &
                      xtemp(1,1),      numxo,  1, varo%xpos(1,j), .true.)
      if (jjs == jjn) then
        xozoyo(:numxo,k,j) = xtemp(:numxo,1)
      else
        call lininterp (xizoyi(1,k,jjn), numxin, 1, vari%xpos(1,jjn), &
                        xtemp(1,2),      numxo,  1, varo%xpos(1,j), .true.)
!
! Y interp
!
        xozoyo(:numxo,k,j) = xtemp(:numxo,1)*wgts + xtemp(:numxo,2)*wgtn
      end if
    end do
  end do

  return
end subroutine interp_driver


      SUBROUTINE MF_SMTRX

c     Computation of coefficients used in the differential equations
c     for (r+1)/c.  These are stored in common area S MTX. Derivatives
c     of these coefficients wrt  c=COS(THETA) are computed if IDERIV is
c     set non-zero. The coefficients are derived from the differential
c     equation for the reflection coeffieient matrix given by Budden in
c     Proc. Roy. Soc. (london), A227, pp. 516-537 (1955).

      implicit complex (a-h,o-z)

      real           omega,wavenr

      common/mf_mode/theta,c,s,csq,ssq,omega,wavenr,ideriv
     &      /mf_smtx/a11,a22,b11,b12,b22,c11,c21,c22,d11,d21,d12,d22,
     &               db11,db22,dc11,dc22,dd11,dd21,dd12
     &      /mf_tmtx/t11ovs,t44ovs,t12ovs,t34ovs,t14a,t31,t42,t32mc2,
     &               t41m1

      ds=-c/s
      dcs=s-csq/s

      call MF_TMTRX

      a11= 4.0*t41m1+(4.,0.)
      a22= (4.,0.)
      b11= 2.0*(s*t44ovs-c*t41m1)-(2.,0.)*c
      b12=-2.0*t42
      b22=-(2.,0.)*c
      c11=-2.0*(s*t11ovs+c*t41m1)-(2.,0.)*c
      c21= 2.0*t31
      c22=-(2.,0.)*c
      d11= c*s*(t11ovs-t44ovs)+csq*t41m1-ssq*t14a
      d21=-c*t31+s*t34ovs
      d12= s*t12ovs+c*t42
      d22=-t32mc2

      if (ideriv .eq. 1) then
         db11= 2.0*(ds*t44ovs-t41m1)-(2.,0.)
         db22=-(2.,0.)
         dc11=-2.0*(ds*t11ovs+t41m1)-(2.,0.)
         dc22=-(2.,0.)
         dd11= dcs*(t11ovs-t44ovs)+2.0*c*(t41m1+t14a)
         dd21=-t31+ds*t34ovs
         dd12= ds*t12ovs+t42
      end if
      RETURN
      END      ! MF_SMTRX


!==============================================================================!
  subroutine User_Mod_End_Of_Time_Step(grid, n, time)
!------------------------------------------------------------------------------!
!   This function is called at the beginning of time step.                     !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Grid_Mod
  use Flow_Mod
  use Const_Mod, only: PI
  use Comm_Mod,  only: Comm_Mod_Global_Max_Real, this_proc
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
  integer         :: n     ! time step
  real            :: time  ! physical time
!----------------------------------[Locals]------------------------------------!
  integer           :: c, e, dir
  real              :: lo, xo, yo, zo(2), ro, xc, yc, zc, uc, vc,  &
                       sig_xy, sig_z, rmin, rmax, sg, rp, lx, ly, lz, vmax
  character(len=80) :: file_name
!==============================================================================!

  ! If not time for disturbing the velocity field, return
  if(mod(n-33, 1500) .ne. 0) return

  ! If too late to disturb, get out too
  if(n > 3000) return

  ! Print a message
  if(this_proc < 2) then
    print *, '# Superimposing random eddies on top of velocity field!'
  end if

  ! Minimum and maximum size of eddies
  rmin = 0.2
  rmax = 0.4

  ! Size of the bounding box inside computational domain
  rp = 1.0  ! pipe radius
  lx = 2.0 * rp
  ly = 2.0 * rp
  lz = 4.0

  ! Browse through all eddies
  do e = 1, 80

    ! Random direction of the vortex
    call random_number(sg);
    if(sg < 0.5) then
      sg = -1.0
    else
      sg = +1.0
    end if

    ! Determine random position of a vortex
    call random_number(ro);     ro = rmin + (rmax-rmin)*ro  ! rmin -> rmax
    call random_number(xo);     xo = xo * lx - rp           ! -rp to +rp
    call random_number(yo);     yo = yo * ly - rp           ! -rp to +rp
    call random_number(zo(1));  zo(1) = zo(1) * lz          !  0 to lz

    ! Handle periodicity; that is: copy eddie in periodic direction
    zo(2) = zo(1)
    if(zo(1) > lz/2.0) zo(2) = zo(1) - lz
    if(zo(1) < lz/2.0) zo(2) = zo(1) + lz

    ! Length of the eddy is three times its radius
    lo = ro * 3.0

    sig_xy = ro / 2.0
    sig_z  = lo / 2.0

    ! Superimpose eddies on the velocity field

    ! Work only if eddy happens to be inside the pipe
    if( sqrt(xo**2 + yo**2) < (rp-ro) ) then

      do dir = 1, 2
        do c = 1, grid % n_cells
          xc = grid % xc(c)
          yc = grid % yc(c)
          zc = grid % zc(c)

          ! Calculate non-axial velocity components
          uc = sg * sin( (yc-yo)/ro * PI )
          vc = sg * sin( (xc-xo)/ro * PI )

          ! Damp the velocity components in non-axial directions
          uc = uc / (sig_xy*sqrt(PI+PI))*exp(-0.5*((xc-xo)/sig_xy)**2)
          uc = uc / (sig_xy*sqrt(PI+PI))*exp(-0.5*((yc-yo)/sig_xy)**2)

          vc = vc / (sig_xy*sqrt(PI+PI))*exp(-0.5*((xc-xo)/sig_xy)**2)
          vc = vc / (sig_xy*sqrt(PI+PI))*exp(-0.5*((yc-yo)/sig_xy)**2)

          ! Damp the velocity components in axial direction
          uc = uc / (sig_z*sqrt(PI+PI))*exp(-0.5*((zc-zo(dir))/sig_z)**2)
          vc = vc / (sig_z*sqrt(PI+PI))*exp(-0.5*((zc-zo(dir))/sig_z)**2)

          u % n(c) = u % n(c) + uc
          v % n(c) = v % n(c) + vc

        end do
      end do

    end if  ! inside the pipe

  end do  ! next eddy

  vmax = 0
  do c = 1, grid % n_cells
    vmax = max(vmax, abs(u % n(c)))
    vmax = max(vmax, abs(v % n(c)))
  end do
  call Comm_Mod_Global_Max_Real(vmax)
  do c = 1, grid % n_cells
    u % n(c) = u % n(c) / vmax / 10.0
    v % n(c) = v % n(c) / vmax / 10.0
  end do

  file_name = 'with_random_eddies_000000'
  write(file_name(20:25), '(i6.6)') n

  call Save_Results(grid, file_name)

  end subroutine


      SUBROUTINE MTRBSC
C
COMMENT.  ALL WRITE STATEMENTS WHICH HAVE BEEN COMMENTED OUT, HAVE BEEN
C         LEFT IN THE PROGRAMMING FOR ANY FUTURE DEBUGGING USE.
C
C
C      ************* BASIC BENDING TRIANGLE   ELEMENT ROUTINE **********
C
C     CALLS FROM THIS ROUTINE ARE MADE TO. . .
C
C          MAT    - MATERIAL DATA ROUTINE
C          SMA2B  - INSERTION ROUTINE
C          TRANSD - DOUBLE PRECISION TRANSFORMATION SUPPLIER
C          INVERD - DOUBLE PRECISION INVERSE ROUTINE
C          GMMATD - DOUBLE PRECISION MATRIX MULTIPLY AND TRANSPOSE
C          MESAGE - ERROR MESSAGE WRITER
C
C
C     ******************************************************************
C
      DOUBLE PRECISION        A        ,E        ,XSUBB    ,TEMP
     1                       ,XSUBC    ,D        ,YSUBC    ,XCYC
     2                       ,XCSQ     ,DETERM   ,YCSQ     ,XBSQ
     3                       ,G2X2     ,J2X2     ,HYQ      ,AIJ
     4                       ,BIJ      ,SIIJ     ,SIZERO   ,MBARAA
     5                       ,MAR      ,MRR      ,S
     6                       ,PROD9    ,TEMP9    ,G
     7                       ,YPRODJ   ,XPRODI
     8                       ,FJ       ,FJ2      ,FI       ,FIJ
C
C
      DIMENSION D(9)      ,G(9)      ,G2X2(4)   ,J2X2(4)   , S(18)
     1         ,ECPT(1)   ,HYQ(6)    ,SIIJ(7,7) ,MBARAA(9) , MAR(18)
     2         ,MRR(36)
C     DIMENSION MNAME(9)
C     DIMENSION NASTER(130)
C     DATA (MNAME(I), I = 1,9) /6H1(MAA),6H (MAB),6H (MAC),6H (MBA),
C    $6H (MBB),6H (MBC),6H (MCA),6H (MCB),6H (MCC) /
C     DATA NASTER /130*1H*/
C
      COMMON /SMA2IO/ DUM1(10), IFMGG, DUM2(25)
      COMMON /SMA2CL/  DUM3(2), NPVT
     2,                  DUMCL(7)
     3,                  LINK(10)           ,NOGO
      COMMON /MATIN / MATID,INFLAG,ELTEMP,STRESS,SINTH,COSTH
      COMMON /MATOUT/G11,G12,G13,G22,G23,G33,RHO,ALPHA1,ALPHA2,ALP12,
     1                T SUB 0, G SUB E, SIGTEN, SIGCOM, SIGSHE,
     2                G2X211, G2X212, G2X222, SPACE(2)
C
C     ECPT BLOCK
      COMMON /SMA2ET/
     1                   NECPT(1)      ,NGRID(3)
     2                  ,ANGLE         ,MATID1
     3                  ,EYE           ,MATID2
     4                  ,T2            ,FMU
     5                  ,Z11           ,Z22
     6                  ,DUMMY1        ,X1
     7                  ,Y1            ,Z1
     8                  ,DUMMY2        ,X2
     9                  ,Y2            ,Z2
     1                  ,DUMMY3        ,X3
     2                  ,Y3            ,Z3            ,DUMB(76)
C
      COMMON /SMA2DP/    A(225)        ,PROD9(9)
     1                  ,TEMP9(9)      ,XSUBB
     2                  ,XSUBC         ,YSUBC
     3                  ,E(9)          ,TEMP
     4                  ,XCSQ          ,XBSQ
     5                  ,YCSQ          ,XCYC
     6                  ,AIJ           ,DETERM
     7                  ,BIJ           ,SIZERO
     8                  ,FJ            ,FJ2
     9                  ,FI            ,FIJ
     T                  ,YPRODJ        ,XPRODI
     1
     2                  ,ISING         ,DUMMY(59)
C
      EQUIVALENCE
     1          (D(1),G(1),SIIJ(1,1),A(1))  ,(ECPT(1),NECPT(1))
     2         ,(G2X2(1),A(10))             ,(J2X2(1),A(14))
     3         ,(HYQ(1),A(50))              ,(MBARAA(1),A(136))
     4         ,(MAR(1),A(145))             ,(MRR(1),A(163))
     5         ,(S(1),A(82))
C
C     ECPT LIST FOR BASIC BENDING TRIANGLE             NAME IN
C                                                      THIS
C     ECPT                                             ROUTINE   TYPE
C     ******************************************************************
C     ECPT( 1) = ELEMENT ID                            NECPT(1)  INTEGER
C     ECPT( 2) = GRID POINT A                          NGRID(1)  INTEGER
C     ECPT( 3) = GRID POINT B                          NGRID(2)  INTEGER
C     ECPT( 4) = GRID POINT C                          NGRID(3)  INTEGER
C     ECPT( 5) = THETA = ANGLE OF MATERIAL             ANGLE     REAL
C     ECPT( 6) = MATERIAL ID 1                         MATID1    INTEGER
C     ECPT( 7) = I = MOMENT OF INERTIA                 EYE       REAL
C     ECPT( 8) = MATERIAL ID 2                         MATID2    INTEGER
C     ECPT( 9) = T2                                    T2        REAL
C     ECPT(10) = NON-STRUCTURAL-MASS                   FMU       REAL
C     ECPT(11) = Z1                                    Z11       REAL
C     ECPT(12) = Z2                                    Z22       REAL
C     ECPT(13) = COORD. SYSTEM ID 1                    NECPT(13) INTEGER
C     ECPT(14) = X1                                    X1        REAL
C     ECPT(15) = Y1                                    Y1        REAL
C     ECPT(16) = Z1                                    Z1        REAL
C     ECPT(17) = COORD. SYSTEM ID 2                    NECPT(17) INTEGER
C     ECPT(18) = X2                                    X2        REAL
C     ECPT(19) = Y2                                    Y2        REAL
C     ECPT(20) = Z2                                    Z2        REAL
C     ECPT(21) = COORD. SYSTEM ID 3                    NECPT(21) INTEGER
C     ECPT(22) = X3                                    X3        REAL
C     ECPT(23) = Y3                                    Y3        REAL
C     ECPT(24) = Z3                                    Z3        REAL
C     ECPT(25) = ELEMENT TEMPERATURE                   ELTEMP    REAL
C     ******************************************************************
C
C     SETTING UP G MATRIX
C
      INFLAG = 2
      MATID = MATID1
      CALL MAT( ECPT(1) )
C
C     FILL G-MATRIX WITH OUTPUT FROM MAT ROUTINE
C
      G(1) = G11
      G(2) = G12
      G(3) = G13
      G(4) = G12
      G(5) = G22
      G(6) = G23
      G(7) = G13
      G(8) = G23
      G(9) = G33
C
C     COMPUTATION OF D = I.G-MATRIX (EYE IS INPUT FROM THE ECPT)
C
      DO 50 I = 1,9
   50 D(I) = G(I) * DBLE(EYE)
C
C     F1LL  (HBAR) MATRIX STORING AT A(100). . .A(135)
      XCSQ = XSUBC ** 2
      YCSQ = YSUBC ** 2
      XBSQ = XSUBB ** 2
      XCYC = XSUBC * YSUBC
C
      DO 80 I = 100,135
   80 A(I) = 0.0D0
C
      A(100) = XBSQ
      A(103) = XBSQ * XSUBB
      A(107) = XSUBB
      A(112) = -2.0D0 * XSUBB
      A(115) = -3.0D0 * XBSQ
      A(118) = XCSQ
      A(119) = XCYC
      A(120) = YCSQ
      A(121) = XCSQ * XSUBC
      A(122) = YCSQ * XSUBC
      A(123) = YCSQ * YSUBC
      A(125) = XSUBC
      A(126) = YSUBC * 2.0D0
      A(128) = XCYC  * 2.0D0
      A(129) = YCSQ  * 3.0D0
      A(130) =-2.0D0 * XSUBC
      A(131) =-YSUBC
      A(133) =-3.0D0 * XCSQ
      A(134) =-YCSQ
C
C
C     ******************************************************************
C
      IF( T2 .EQ. 0.0E0 ) GO TO 110
C
C     ALL OF THE FOLLOWING OPERATIONS THROUGH STATEMENT LABEL 110
C     ARE NECESSARY IF T2 IS NON-ZERO.
C
C
C     GET THE G2X2 MATRIX
C
      MATID = MATID2
      INFLAG = 3
      CALL MAT( ECPT(1) )
      IF(G2X211.EQ.0.0E0 .AND. G2X212.EQ.0.0E0 .AND. G2X222.EQ.0.0E0)
     1  GO TO 110
      G2X2(1) = G2X211 * T2
      G2X2(2) = G2X212 * T2
      G2X2(3) = G2X2(2)
      G2X2(4) = G2X222 * T2
C
      DETERM = G2X2(1) * G2X2(4)  -  G2X2(3) * G2X2(2)
      J2X2(1) = G2X2(4) / DETERM
      J2X2(2) =-G2X2(2) / DETERM
      J2X2(3) = J2X2(2)
      J2X2(4) = G2X2(1) / DETERM
C
C
C     (H  ) IS PARTITIONED INTO A LEFT AND RIGHT PORTION AND ONLY THE
C       YQ  RIGHT PORTION IS COMPUTED AND USED AS A  (2X3). THE LEFT
C           2X3 PORTION IS NULL.  THE RIGHT PORTION WILL BE STORED AT
C           A(50)...A(55) UNTIL NOT NEEDED ANY FURTHER.
C
C
C
      TEMP  = 2.0D0 * D(2) + 4.0D0 * D(9)
      HYQ(1) = -6.0D0 * (J2X2(1) * D(1) + J2X2(2) * D(3))
      HYQ(2) = -J2X2(1) * TEMP - 6.0D0 * J2X2(2) * D(6)
      HYQ(3) = -6.0D0 * (J2X2(1) * D(6) + J2X2(2) * D(5))
      HYQ(4) = -6.0D0 * (J2X2(2) * D(1) + J2X2(4) * D(3))
      HYQ(5) = -J2X2(2) * TEMP - 6.0D0 * J2X2(4) * D(6)
      HYQ(6) = -6.0D0 * (J2X2(2) * D(6) + J2X2(4) * D(5))
C
C     ADD TO 6 OF THE (HBAR) ELEMENTS THE RESULT OF (H  )(H  )
C                                                    UY   YQ
C     THE PRODUCT IS FORMED DIRECTLY IN THE ADDITION PROCESS BELOW.
C     NO (H  ) MATRIX IS ACTUALLY COMPUTED DIRECTLY.
C          UY
C
C     THE FOLLOWING IS THEN STEP 6 PAGE 8, FMMS-66
C
      DO 100 I = 1,3
      A(I + 102) = A(I + 102) + XSUBB * HYQ(I)
  100 A(I + 120) = A(I + 120) + XSUBC * HYQ(I)    + YSUBC * HYQ(I + 3)
C
C     THIS ENDS ADDED COMPUTATION FOR CASE OF T2 NOT ZERO
C
C     ******************************************************************
C
  110 CONTINUE
C
C     AT THIS POINT INVERT  (H) WHICH IS STORED AT A(100). . .A(135)
C     STORE INVERSE BACK IN A(100). . A(135)
C     NO NEED TO COMPUTE DETERMINANT SINCE IT IS NOT USED SUBSEQUENTLY.
      ISING = -1
      CALL INVERD(6,A(100),6,A(136),0,DETERM,ISING,A(142))
C
C     CHECK TO SEE IF H WAS SINGULAR
      IF( ISING .NE. 2 ) GO TO 120
C
C
C     ISING = 2 IMPLIES SINGULAR MATRIX THUS ERROR CONDITION.
      CALL MESAGE(30,33,ECPT(1))
C
C  SET FLAG FOR FATAL ERROR WHILE ALLOWING ERROR MESSAGES TO ACCUMULATE
C
      NOGO=1
      RETURN
C
C
CHURN OUT INTEGRAL VALUES I   USED IN REFERENCED M MATRICES
C                          IJ                           SEE P.9, FMMS-66
C
C     THE CALCULATION FOR  (I  ) ARE AS FOLLOWS
C                            IJ
C                                                      ***
C         A1  = XSUBB * YSUBC**(J+1) / ((J+1)*(J+2))      *
C           0J                                            *
C                                                         *
C         B   = XSUBC * YSUBC**(J+1) / (J+2)              *
C           0J                                            ** J=0,6
C                                                         *
C         A   = A1   + B                                  *
C           0J    0J    0J                                *
C                                                         *
C         I   = MU * A1                                   *
C           0J         0J                              ***
C
C                                                            ***
C         A1  = I * XSUBB * A      /(I+J+2)                     *
C           IJ               I-1,J                              *
C                                                               *
C         B   = XSUBC**(I+1) * YSUBC**(J+1) /((I+1)*(I+J+2))    *  I=1,6
C           IJ                                                  ** J=0,6
C                                                               *
C         A   = A1   + B                                        *
C           IJ    IJ    IJ                                      *
C                                                               *
C         I     MU * A1                                         *
C           IJ=        IJ                                       *
C                                                            ***
C      NOTE.. LOOPS FOR PROGRAM BEGIN AT 1 INSTEAD OF 0
C                                      I.E.  I = 1,7
C                                            J = 1,7
C
  120 DO 140 J=1,7
      YPRODJ = YSUBC **J
      FJ  = J
      FJ2 = J+1
      AIJ       = XSUBB * YPRODJ /(FJ * FJ2)
      BIJ       = XSUBC * YPRODJ / FJ2
      SIIJ(1,J) = FMU   * AIJ
      AIJ       = AIJ   + BIJ
      IF(J .EQ. 7) GO TO 140
      K = 8 - J
      DO 130 I = 2,K
          XPRODI = XSUBC **I
          FI     = I
          FIJ    = I + J
          AIJ       = (FI-1.0D0) * XSUBB * AIJ / FIJ
          BIJ       = XPRODI * YPRODJ /(FI * FIJ)
          SIIJ(I,J) = FMU * AIJ
  130     AIJ       = AIJ + BIJ
C
  140 CONTINUE
      SIZERO = SIIJ(1,1) / 3.0D0
C
CHUNK IN NUMBERS FOR (M-BAR-AA)    3X3 MATRIX AS PER MS-48, PAGES 6-10
C
C                    (M  )         3X6 MATRIX
C                      AR
C
C                    (M  )         6X6 MATRIX
C                      RR
C
C     (M-BAR-AA) MATRIX
C
      MBARAA(1) =  SIIJ(1,1)
      MBARAA(2) =  SIIJ(1,2)
      MBARAA(3) = -SIIJ(2,1)
      MBARAA(4) =  SIIJ(1,2)
      MBARAA(5) =  SIIJ(1,3)
      MBARAA(6) = -SIIJ(2,2)
      MBARAA(7) = -SIIJ(2,1)
      MBARAA(8) = -SIIJ(2,2)
      MBARAA(9) =  SIIJ(3,1)
C
C     (M  ) MATRIX
C       AR
      MAR( 1) = SIIJ(3,1)
      MAR( 2) = SIIJ(2,2)
      MAR( 3) = SIIJ(1,3)
      MAR( 4) = SIIJ(4,1)
      MAR( 5) = SIIJ(2,3)
      MAR( 6) = SIIJ(1,4)
      MAR( 7) = SIIJ(3,2)
      MAR( 8) = SIIJ(2,3)
      MAR( 9) = SIIJ(1,4)
      MAR(10) = SIIJ(4,2)
      MAR(11) = SIIJ(2,4)
      MAR(12) = SIIJ(1,5)
      MAR(13) =-SIIJ(4,1)
      MAR(14) =-SIIJ(3,2)
      MAR(15) =-SIIJ(2,3)
      MAR(16) =-SIIJ(5,1)
      MAR(17) =-SIIJ(3,3)
      MAR(18) =-SIIJ(2,4)
C
C     (M  ) MATRIX  A 6X6 SYMMETRIC MATRIX
C       RR
      MRR( 1) = SIIJ(5,1)
      MRR( 2) = SIIJ(4,2)
      MRR( 3) = SIIJ(3,3)
      MRR( 4) = SIIJ(6,1)
      MRR( 5) = SIIJ(4,3)
      MRR( 6) = SIIJ(3,4)
      MRR( 7) = MRR(2)
      MRR( 8) = SIIJ(3,3)
      MRR( 9) = SIIJ(2,4)
      MRR(10) = SIIJ(5,2)
      MRR(11) = SIIJ(3,4)
      MRR(12) = SIIJ(2,5)
      MRR(13) = MRR(3)
      MRR(14) = MRR(9)
      MRR(15) = SIIJ(1,5)
      MRR(16) = SIIJ(4,3)
      MRR(17) = SIIJ(2,5)
      MRR(18) = SIIJ(1,6)
      MRR(19) = MRR( 4)
      MRR(20) = MRR(10)
      MRR(21) = MRR(16)
      MRR(22) = SIIJ(7,1)
      MRR(23) = SIIJ(5,3)
      MRR(24) = SIIJ(4,4)
      MRR(25) = MRR( 5)
      MRR(26) = MRR(11)
      MRR(27) = MRR(17)
      MRR(28) = MRR(23)
      MRR(29) = SIIJ(3,5)
      MRR(30) = SIIJ(2,6)
      MRR(31) = MRR( 6)
      MRR(32) = MRR(12)
      MRR(33) = MRR(18)
      MRR(34) = MRR(24)
      MRR(35) = MRR(30)
      MRR(36) = SIIJ(1,7)
C
      IF(T2 .EQ. 0.0) GO TO 146
      IF(G2X211.EQ.0.0E0 .AND. G2X212.EQ.0.0E0 .AND. G2X222.EQ.0.0E0)
     1   GO TO 146
C
      MAR( 4) = MAR( 4)   + HYQ(1) * SIIJ(2,1) + HYQ(4) * SIIJ(1,2)
      MAR( 5) = MAR( 5)   + HYQ(2) * SIIJ(2,1) + HYQ(5) * SIIJ(1,2)
      MAR( 6) = MAR( 6)   + HYQ(3) * SIIJ(2,1) + HYQ(6) * SIIJ(1,2)
      MAR(10) = MAR(10)   + HYQ(1) * SIIJ(2,2) + HYQ(4) * SIIJ(1,3)
      MAR(11) = MAR(11)   + HYQ(2) * SIIJ(2,2) + HYQ(5) * SIIJ(1,3)
      MAR(12) = MAR(12)   + HYQ(3) * SIIJ(2,2) + HYQ(6) * SIIJ(1,3)
      MAR(16) = MAR(16)   - HYQ(1) * SIIJ(3,1) - HYQ(4) * SIIJ(2,2)
      MAR(17) = MAR(17)   - HYQ(2) * SIIJ(3,1) - HYQ(5) * SIIJ(2,2)
      MAR(18) = MAR(18)   - HYQ(3) * SIIJ(3,1) - HYQ(6) * SIIJ(2,2)
      MRR( 4) = MRR( 4)   + HYQ(1) * SIIJ(4,1) + HYQ(4) * SIIJ(3,2)
      MRR( 5) = MRR( 5)   + HYQ(2) * SIIJ(4,1) + HYQ(5) * SIIJ(3,2)
      MRR( 6) = MRR( 6)   + HYQ(3) * SIIJ(4,1) + HYQ(6) * SIIJ(3,2)
      MRR(10) = MRR(10)   + HYQ(1) * SIIJ(3,2) + HYQ(4) * SIIJ(2,3)
      MRR(11) = MRR(11)   + HYQ(2) * SIIJ(3,2) + HYQ(5) * SIIJ(2,3)
      MRR(12) = MRR(12)   + HYQ(3) * SIIJ(3,2) + HYQ(6) * SIIJ(2,3)
      MRR(16) = MRR(16)   + HYQ(1) * SIIJ(2,3) + HYQ(4) * SIIJ(1,4)
      MRR(17) = MRR(17)   + HYQ(2) * SIIJ(2,3) + HYQ(5) * SIIJ(1,4)
      MRR(18) = MRR(18)   + HYQ(3) * SIIJ(2,3) + HYQ(6) * SIIJ(1,4)
      MRR(19) = MRR( 4)
      MRR(20) = MRR(10)
      MRR(21) = MRR(16)
      MRR(22) = MRR(22)   + HYQ(1) * (HYQ(1) * SIIJ(3,1) + 2.0D0
     1 * (SIIJ(5,1) + HYQ(4) * SIIJ(2,2))) + HYQ(4) * (2.0D0 * SIIJ(4,2)
     2 + HYQ(4) * SIIJ(1,3))
      MRR(23) = MRR(23)   + HYQ(2) * SIIJ(5,1) + HYQ(5) * SIIJ(4,2)
     1 + HYQ(1) * (SIIJ(3,3) + HYQ(2) * SIIJ(3,1) + HYQ(5) * SIIJ(2,2))
     2 + HYQ(4) * (SIIJ(2,4) + HYQ(2) * SIIJ(2,2) + HYQ(5) * SIIJ(1,3))
      MRR(24) = MRR(24)   + HYQ(3) * SIIJ(5,1) + HYQ(6) * SIIJ(4,2)
     1 + HYQ(1) * (SIIJ(2,4) + HYQ(3) * SIIJ(3,1) + HYQ(6) * SIIJ(2,2))
     2 + HYQ(4) * (SIIJ(1,5) + HYQ(3) * SIIJ(2,2) + HYQ(6) * SIIJ(1,3))
      MRR(25) = MRR( 5)
      MRR(26) = MRR(11)
      MRR(27) = MRR(17)
      MRR(28) = MRR(23)
      MRR(29) = MRR(29)   + HYQ(2) * (HYQ(2) * SIIJ(3,1) + 2.0D0
     1 * (SIIJ(3,3) + HYQ(5) * SIIJ(2,2))) + HYQ(5) * (2.0D0 * SIIJ(2,4)
     2 + HYQ(5) * SIIJ(1,3))
      MRR(30) = MRR(30)   + HYQ(3) * SIIJ(3,3) + HYQ(6) * SIIJ(2,4)
     1 + HYQ(2) * (SIIJ(2,4) + HYQ(3) * SIIJ(3,1) + HYQ(6) * SIIJ(2,2))
     2 + HYQ(5) * (SIIJ(1,5) + HYQ(3) * SIIJ(2,2) + HYQ(6) * SIIJ(1,3))
      MRR(31) = MRR( 6)
      MRR(32) = MRR(12)
      MRR(33) = MRR(18)
      MRR(34) = MRR(24)
      MRR(35) = MRR(30)
      MRR(36) = MRR(36)   + HYQ(3) * (HYQ(3) * SIIJ(3,1) + 2.0D0
     1 * (SIIJ(2,4) + HYQ(6) * SIIJ(2,2))) + HYQ(6) * (2.0D0 * SIIJ(1,5)
     2 + HYQ(6) * SIIJ(1,3))
C
  146 CONTINUE
C
C
C     FILL S-MATRIX EQUIVALENCED TO A(82)  (S IS  6X3 )
C
      S( 1) = 1.0D0
      S( 2) = 0.0D0
      S( 3) =-XSUBB
      S( 4) = 0.0D0
      S( 5) = 1.0D0
      S( 6) = 0.0D0
      S( 7) = 0.0D0
      S( 8) = 0.0D0
      S( 9) = 1.0D0
      S(10) = 1.0D0
      S(11) = YSUBC
      S(12) =-XSUBC
      S(13) = 0.0D0
      S(14) = 1.0D0
      S(15) = 0.0D0
      S(16) = 0.0D0
      S(17) = 0.0D0
      S(18) = 1.0D0
C
CAN NOW COMPUTE 9 (3X3) MASS MATRICES (FMMS-66, PAGES 10-11)
C
C
C                -1 T           -1
C     ( M ) = ( H  )  ( M  ) ( H  )
C                        RR
C
C              PARTITION (M)
C                                           ///       ///
C                                           /     *     /
C                                           / MBB * MBC /
C                                           /     *     /
C                                ( M )  =   / ********* /
C                                           /     *     /
C                                           / MCB * MCC /
C                                           /     *     /
C                                           ///       ///
C                                                       4 (3X3) MATRICES
C                        -1
C     ( M  ) = ( M  ) ( H  )
C        AI       AR
C
C              PARTITION (M  )              ///                 ///
C                          AI               /          *          /
C                               ( M  )  =   / M-BAR-AB * M-BAR-AC /
C                                  AI       /          *          /
C                                           ///                 ///
C                                                       2 (3X3) MATRICES
C                               T            T
C     ( MAB )  = (M-BAR-AB) - (S ) (MBB) - (S ) (MCB)
C                               B            C
C
C                               T            T
C     ( MAC )  = (M-BAR-AC) - (S ) (MBC) - (S ) (MCC)
C                               B            C
C
C                               T     T      T      T
C     ( MAA )  = (M-BAR-AA) - (S ) (M  ) - (S ) (MAC )
C                               B    AB      C
C
C                           - (M-BAR-AB) (S ) - (M-BAR-AC) (S )
C                                          B                 C
C
C                    T
C     ( MBA )  = (MAB )
C
C                    T
C     ( MCA )  = (MAC )
C
CHOOSE APPROPRIATE BLOCK OF A-ARRAY FOR STORAGE
C
C     (3X3)    STORED IN      (3X3)     STORED IN     (3X3)    STORED IN
C     (MAA)   A( 1... 9)      (MAB)   A(10)...8)      (MAC)   A(19...27)
C     (MBA)   A(28...36)      (MBB)   A(37)...45)     (MBC)   A(46...54)
C     (MCA)   A(55...63)      (MCB)   A(64...72)      (MCC)   A(73...81)
C
C       -1
C     (H  ) IS STORED AT A(100...135)
C     (S)   EQUIVALENCED A( 81... 99)
C     WORKING STORAGE IS A(181...216)
C     (M-BAR-AB) STORED UNTIL NO LONGER NEEDED IN A(163...171)
C     (M-BAR-AC) STORED UNTIL NO LONGER NEEDED IN A(172...180)
C
C               -1 T          -1
COMPUTE (M) = (H  )  ((M  ) (H  ))
C                       RR
C
      CALL GMMATD(MRR(1),6,6,0,A(100),6,6,0,A(37))
      CALL GMMATD(A(100),6,6,1,A( 37),6,6,0,A( 1))
C
CREATE PARTITION OF 4 (3X3)
      DO 150 I=1,3
        A(I+36) = A(I   )
        A(I+39) = A(I+ 6)
        A(I+42) = A(I+12)
C
        A(I+45) = A(I+ 3)
        A(I+48) = A(I+ 9)
        A(I+51) = A(I+15)
C
        A(I+63) = A(I+18)
        A(I+66) = A(I+24)
        A(I+69) = A(I+30)
C
        A(I+72) = A(I+21)
        A(I+75) = A(I+27)
  150   A(I+78) = A(I+33)
C
COMPUTE                 -1
C       (M  ) = (M  ) (H  )    AND  PARTITION INTO 2 (3X3)  (M-BAR-AB)
C         AI      AR                                    AND (M-BAR-AC)
C
      CALL GMMATD(MAR(1),3,6,0,A(100),6,6,0,A(181))
      DO 160 I=1,3
        A(I+162) = A(I+180)
        A(I+165) = A(I+186)
        A(I+168) = A(I+192)
C
        A(I+171) = A(I+183)
        A(I+174) = A(I+189)
  160   A(I+177) = A(I+195)
COMPUTE (MAB)
      CALL GMMATD(S( 1),3,3,1,A(37),3,3,0,A(181))
      CALL GMMATD(S(10),3,3,1,A(64),3,3,0,A(190))
      DO 170 I=1,9
  170   A(I+9)=A(I+162) - A(I+180) - A(I+189)
COMPUTE (MAC)
      CALL GMMATD(S( 1),3,3,1,A(46),3,3,0,A(181))
      CALL GMMATD(S(10),3,3,1,A(73),3,3,0,A(190))
      DO 180 I=1,9
  180   A(I+18) = A(I+171) - A(I+180) - A(I+189)
COMPUTE (MAA)
      CALL GMMATD(S(  1),3,3,1,A(10),3,3,1,A(181))
      CALL GMMATD(S( 10),3,3,1,A(19),3,3,1,A(190))
      CALL GMMATD(A(163),3,3,0,S( 1),3,3,0,A(199))
      CALL GMMATD(A(172),3,3,0,S(10),3,3,0,A(208))
      DO 190 I=1,9
  190   A(I) = MBARAA(I) - A(I+180) - A(I+189) - A(I+198) - A(I+207)
COMPUTE (MBA) AND (MCA)
      DO 200 I=1,3
        NPT = 3 * I + 7
        A(I+27) = A(NPT)
        A(I+30) = A(NPT + 1)
        A(I+33) = A(NPT + 2)
C
        A(I+54) = A(NPT +  9)
        A(I+57) = A(NPT + 10)
  200   A(I+60) = A(NPT + 11)
C
      RETURN
C
      END


c       this file contains the following user-callable routines:
c
c
c       routine iddr_rsvd computes the SVD, to a specified rank,
c       of a matrix specified by routines for applying the matrix
c       and its transpose to arbitrary vectors.
c       This routine is randomized.
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine iddr_rsvd(m,n,matvect,p1t,p2t,p3t,p4t,
     1                       matvec,p1,p2,p3,p4,krank,u,v,s,ier,w)
c
c       constructs a rank-krank SVD  u diag(s) v^T  approximating a,
c       where matvect is a routine which applies a^T
c       to an arbitrary vector, and matvec is a routine
c       which applies a to an arbitrary vector;
c       u is an m x krank matrix whose columns are orthonormal,
c       v is an n x krank matrix whose columns are orthonormal,
c       and diag(s) is a diagonal krank x krank matrix whose entries
c       are all nonnegative. This routine uses a randomized algorithm.
c
c       input:
c       m -- number of rows in a
c       n -- number of columns in a
c       matvect -- routine which applies the transpose
c                  of the matrix to be SVD'd
c                  to an arbitrary vector; this routine must have
c                  a calling sequence of the form
c
c                  matvect(m,x,n,y,p1t,p2t,p3t,p4t),
c
c                  where m is the length of x,
c                  x is the vector to which the transpose
c                  of the matrix is to be applied,
c                  n is the length of y,
c                  y is the product of the transposed matrix and x,
c                  and p1t, p2t, p3t, and p4t are user-specified
c                  parameters
c       p1t -- parameter to be passed to routine matvect
c       p2t -- parameter to be passed to routine matvect
c       p3t -- parameter to be passed to routine matvect
c       p4t -- parameter to be passed to routine matvect
c       matvec -- routine which applies the matrix to be SVD'd
c                 to an arbitrary vector; this routine must have
c                 a calling sequence of the form
c
c                 matvec(n,x,m,y,p1,p2,p3,p4),
c
c                 where n is the length of x,
c                 x is the vector to which the matrix is to be applied,
c                 m is the length of y,
c                 y is the product of the matrix and x,
c                 and p1, p2, p3, and p4 are user-specified parameters
c       p1 -- parameter to be passed to routine matvec
c       p2 -- parameter to be passed to routine matvec
c       p3 -- parameter to be passed to routine matvec
c       p4 -- parameter to be passed to routine matvec
c       krank -- rank of the SVD being constructed
c
c       output:
c       u -- matrix of orthonormal left singular vectors of a
c       v -- matrix of orthonormal right singular vectors of a
c       s -- array of singular values of a
c       ier -- 0 when the routine terminates successfully;
c              nonzero otherwise
c
c       work:
c       w -- must be at least (krank+1)*(2*m+4*n)+25*krank**2
c            real*8 elements long
c
c       _N.B._: The algorithm used by this routine is randomized.
c
        implicit none
        integer m,n,krank,lw,ilist,llist,iproj,lproj,icol,lcol,
     1          iwork,lwork,ier
        real*8 p1t,p2t,p3t,p4t,p1,p2,p3,p4,u(m,krank),v(n,krank),
     1         s(krank),w((krank+1)*(2*m+4*n)+25*krank**2)
        external matvect,matvec
c
c
c       Allocate memory in w.
c
        lw = 0
c
        ilist = lw+1
        llist = n
        lw = lw+llist
c
        iproj = lw+1
        lproj = krank*(n-krank)
        lw = lw+lproj
c
        icol = lw+1
        lcol = m*krank
        lw = lw+lcol
c
        iwork = lw+1
        lwork = (krank+1)*(m+3*n)+26*krank**2
        lw = lw+lwork
c
c
        call iddr_rsvd0(m,n,matvect,p1t,p2t,p3t,p4t,
     1                  matvec,p1,p2,p3,p4,krank,u,v,s,ier,
     2                  w(ilist),w(iproj),w(icol),w(iwork))
c
c
        return
        end
c
c
c
c
        subroutine iddr_rsvd0(m,n,matvect,p1t,p2t,p3t,p4t,
     1                        matvec,p1,p2,p3,p4,krank,u,v,s,ier,
     2                        list,proj,col,work)
c
c       routine iddr_rsvd serves as a memory wrapper
c       for the present routine (please see routine iddr_rsvd
c       for further documentation).
c
        implicit none
        integer m,n,krank,list(n),ier,k
        real*8 p1t,p2t,p3t,p4t,p1,p2,p3,p4,u(m,krank),v(n,krank),
     1         s(krank),proj(krank*(n-krank)),col(m*krank),
     2         work((krank+1)*(m+3*n)+26*krank**2)
        external matvect,matvec
c
c
c       ID a.
c
        call iddr_rid(m,n,matvect,p1t,p2t,p3t,p4t,krank,list,work)
c
c
c       Retrieve proj from work.
c
        do k = 1,krank*(n-krank)
          proj(k) = work(k)
        enddo ! k
c
c
c       Collect together the columns of a indexed by list into col.
c
        call idd_getcols(m,n,matvec,p1,p2,p3,p4,krank,list,col,work)
c
c
c       Convert the ID to an SVD.
c
        call idd_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work)
c
c
        return
        end