      subroutine clean_radar(ref,ni,nj,nk)

      use mem_namelist, ONLY: grid_spacing_m, ref_base, r_missing_data

      real ref(ni,nj,nk)
      real ref_buf(ni,nj,nk)

      ref_buf(:,:,:) = ref(:,:,:)

      if(grid_spacing_m .gt. 3500.)then
          write(6,*)' Skip radar cleaning step'
          return
      else
          write(6,*)' Clean radar data from small-scale noise'
          if(grid_spacing_m .gt. 750.)then
              ib = 1
          else
              ib = 2
          endif
      endif

      nclean = 0
      rnumbox = float((2*ib+1)**2 - 1)

      do k = 1,nk
      do j = 1+ib,nj-ib
      do i = 1+ib,ni-ib
          sum9 = sum(ref(i-ib:i+ib,j-ib:j+ib,k))
          if(abs(sum9) .le. 1e6)then ! screen out summed missing data values
              sum8 = sum9 - ref(i,j,k)
              ave8 = sum8 / rnumbox
              if(ref(i,j,k) .gt. (ave8 + 20.) .OR.
     1           (ave8 .eq. ref_base .and. grid_spacing_m .le. 750.)
     1                                                             )then
                  ref_buf(i,j,k) = ave8 ! ref_base
                  nclean = nclean + 1
              endif
          endif
      enddo ! i
      enddo ! j
      enddo ! k

      ref(:,:,:) = ref_buf(:,:,:)

      write(6,*)' Number of grid points cleaned is ',nclean

      return
      end


! =============================================================================
!                       Test 3D parcel gradient correction module
!
!         This unit test checks the correction module by initializing
!         the parcels with a small deviation from the optimal position.
!         It then performs 20 relaxation steps.
! =============================================================================
program test_gradient_correction_3d
    use unit_test
    use options, only : parcel
    use constants, only : pi, one, zero, f14, f23, f32, two, four, f12
    use parcel_container
    use parcel_correction
    use parcel_interpl, only : vol2grid
    use parcel_ellipsoid, only : get_abc
    use parcel_init, only : init_regular_positions
    use parameters, only : lower, extent, update_parameters, vcell, nx, ny, nz
    use fields, only : volg
    use timer
    implicit none

    double precision :: final_error, init_error, val, tmp
    integer :: i, n, sk
    integer, allocatable :: seed(:)
    double precision, parameter :: dev = 0.005d0

    call random_seed(size=sk)
    allocate(seed(1:sk))
    seed(:) = 42
    call random_seed(put=seed)

    call parse_command_line

    call register_timer('gradient correction', grad_corr_timer)
    call register_timer('vorticity correction', vort_corr_timer)

    nx = 16
    ny = 32
    nz = 64

    lower  = (/zero, zero, zero/)
    extent = (/one, two, four/)

    call update_parameters

    allocate(volg(-1:nz+1, 0:ny-1, 0:nx-1))

    n_parcels = 27*nx*ny*nz
    call parcel_alloc(n_parcels)

    parcel%n_per_cell = 27
    call init_regular_positions

    ! add some deviation
    do n = 1, n_parcels
        do i = 1, 3
            tmp = dev
            call random_number(val)
            if (val < 0.5) then
                tmp = -dev
            endif
            parcels%position(i, n) = parcels%position(i, n) + tmp
        enddo
    enddo

    volg = zero

    parcels%volume = vcell / 27.0d0

    parcels%B(:, :) = zero

    ! b11
    parcels%B(1, :) = get_abc(parcels%volume) ** f23

    ! b22
    parcels%B(4, :) = parcels%B(1, :)

    call vol2grid

    init_error = sum(abs(volg(0:nz, :, :) / vcell - one)) / (nx * ny * (nz+1))

    if (verbose) then
        write(*,*) 'test gradient correction'
        write(*,*) 'iteration, average error, max absolute error'
        write(*,*) 0, init_error, maxval(abs(volg(0:nz, :, :) / vcell - one))
    endif

    call init_parcel_correction

    do i = 1, 20
        call apply_gradient(1.80d0,0.5d0)
        if (verbose) then
            call vol2grid
            write(*,*) i, sum(abs(volg(0:nz, :, :) / vcell - one)) / (nx * ny * (nz+1)), &
                          maxval(abs(volg(0:nz, :, :) / vcell - one))
        endif
    enddo

    call vol2grid

    final_error = sum(abs(volg(0:nz, :, :) / vcell - one)) / (nx * ny * (nz+1))

    call print_result_dp('Test gradient correction 3D', final_error, init_error)

    deallocate(volg)

end program test_gradient_correction_3d


Subroutine Derivatives(scalar)
use Aero2DCOM
implicit none
integer i,j
real(8) Fw,Fe,Fs,Fn,Xgaw,Xgae,Ygaw,Ygae,Xgks,Xgkn,Ygks,Ygkn,Jgc
real(8),external:: interpl
real(8) F(Ic,Jc),Fwall(Ib1:Ib2),Fx(Ic,Jc),Fy(Ic,Jc)
character(*) scalar
if(scalar=='U') then
 F=U
 Fwall=0
else if(scalar=='V') then
 F=V
 Fwall=0
else if(scalar=='P') then
 F=P
 Fwall=P(Ib1:Ib2,1)
else if(scalar=='dP') then
 F=dP
 Fwall=dP(Ib1:Ib2,1)
else if(scalar=='rho') then
 F=rho
 Fwall=1.5*rho(Ib1:Ib2,1)-0.5*rho(Ib1:Ib2,2)
else if(scalar=='Tn') then
 F=Tn
 Fwall=1.5*Tn(Ib1:Ib2,1)-0.5*Tn(Ib1:Ib2,2)
else if(scalar=='Tk') then
 F=Tk
 Fwall=1.5*Tk(Ib1:Ib2,1)-0.5*Tk(Ib1:Ib2,2)
 !Fwall=Tk(Ib1:Ib2,1)
else if(scalar=='Tw') then
 F=Tw
 Fwall=1.5*Tw(Ib1:Ib2,1)-0.5*Tw(Ib1:Ib2,2)
 !Fwall=Tw(Ib1:Ib2,1)
else if(scalar=='mux') then
 F=(mu+mut)*Ux
 Fwall=1.5*(mu(Ib1:Ib2,1)+mut(Ib1:Ib2,1))*Ux(Ib1:Ib2,1)-0.5*(mu(Ib1:Ib2,2)+mut(Ib1:Ib2,2))*Ux(Ib1:Ib2,2)
else if(scalar=='muy') then
 F=(mu+mut)*Uy
 Fwall=1.5*(mu(Ib1:Ib2,1)+mut(Ib1:Ib2,1))*Uy(Ib1:Ib2,1)-0.5*(mu(Ib1:Ib2,2)+mut(Ib1:Ib2,2))*Uy(Ib1:Ib2,2)
else if(scalar=='mvx') then
 F=(mu+mut)*Vx
 Fwall=1.5*(mu(Ib1:Ib2,1)+mut(Ib1:Ib2,1))*Vx(Ib1:Ib2,1)-0.5*(mu(Ib1:Ib2,2)+mut(Ib1:Ib2,2))*Vx(Ib1:Ib2,2)
else if(scalar=='mvy') then
 F=(mu+mut)*Vy
 Fwall=1.5*(mu(Ib1:Ib2,1)+mut(Ib1:Ib2,1))*Vy(Ib1:Ib2,1)-0.5*(mu(Ib1:Ib2,2)+mut(Ib1:Ib2,2))*Vy(Ib1:Ib2,2)
end if
Fx=0
Fy=0
DO j=1,Jc-1
 DO i=2,Ic-1
  Xgaw=(Xg(i,j+1)-Xg(i,j))/dy
  Ygaw=(Yg(i,j+1)-Yg(i,j))/dy
  Xgae=(Xg(i+1,j+1)-Xg(i+1,j))/dy
  Ygae=(Yg(i+1,j+1)-Yg(i+1,j))/dy
  Xgks=(Xg(i+1,j)-Xg(i,j))/dx
  Ygks=(Yg(i+1,j)-Yg(i,j))/dx
  Xgkn=(Xg(i+1,j+1)-Xg(i,j+1))/dx
  Ygkn=(Yg(i+1,j+1)-Yg(i,j+1))/dx
  Jgc=Jg(i,j)
  Fw=interpl(F(i,j),F(i-1,j),dk(i,j),dk(i-1,j))
  Fe=interpl(F(i,j),F(i+1,j),dk(i,j),dk(i+1,j))
  Fn=interpl(F(i,j),F(i,j+1),da(i,j),da(i,j+1))
  if(j==1.and.(i>=Ib1.and.i<=Ib2)) then
   Fs=Fwall(i)
  else if(j==1) then
   Fs=interpl(F(i,j),F(Ic+1-i,j),da(i,j),da(Ic+1-i,j))
  else
   Fs=interpl(F(i,j),F(i,j-1),da(i,j),da(i,j-1))
  end if
  Fx(i,j)=((Fe*Ygae-Fw*Ygaw)/dx-(Fn*Ygkn-Fs*Ygks)/dy)/Jgc
  Fy(i,j)=(-(Fe*Xgae-Fw*Xgaw)/dx+(Fn*Xgkn-Fs*Xgks)/dy)/Jgc
 end DO
end DO
if(scalar=='U') then
 Ux=Fx
 Uy=Fy
else if(scalar=='V') then
 Vx=Fx
 Vy=Fy
else if(scalar=='P') then
 Px=Fx
 Py=Fy
else if(scalar=='dP') then
 dPx=Fx
 dPy=Fy
else if(scalar=='rho') then
 rhox=Fx
 rhoy=Fy
else if(scalar=='Tn') then
 Tnx=Fx
 Tny=Fy
else if(scalar=='Tk') then
 Tkx=Fx
 Tky=Fy
else if(scalar=='Tw') then
 Twx=Fx
 Twy=Fy
else if(scalar=='mux') then
 muxx=Fx
 muxy=Fy
else if(scalar=='muy') then
 muyx=Fx
else if(scalar=='mvx') then
 mvxy=Fy
else if(scalar=='mvy') then
 mvyx=Fx
 mvyy=Fy
end if
end Subroutine Derivatives


!====================================================================
     MODULE spline_grid
!====================================================================
!
!    defines the values of splines at the gaussian points for each
!    interval of a grid; included in the module is the gaussian data
!    for performing integrations on the grid
!
!--------------------------------------------------------------------

        IMPLICIT NONE
        SAVE

! .. knot sequence, t(1:ns+ks)

        REAL(8), DIMENSION(:), ALLOCATABLE:: t

! .. arrays for spline values in gausian points
!
!    bsp(1:nv+1,1:ks,1:ks), bspd(1:nv+1,1:ks,1:ks,2)
!
!    bsp(i,m,ith)  - values of the i+ith-1 B-spline in interval i
!                    at gausian point m
!    bspd(i,m,ith,1|2)  - corresponding values of first and second
!                         derivatives
!    bsp(nv+1,1,.) and bspd(nv+1,1,.,.) - corresponding values at
!                                         last knot point (rmax)

        REAL(8), DIMENSION(:, :, :), ALLOCATABLE::   bsp, bsq
        REAL(8), DIMENSION(:, :, :, :), ALLOCATABLE:: bspd

! .. arrays for gaussian data
!
!    gr(1:nv;1:ks),  grm(1:nv;1:ks),  grw(1:nv;1:ks)
!
!    gr(i,m)  - gaussian points m in the interval i
!    grm(i,m) - reciprocal value of gr(i,m)
!    grw(i,m) - gaussian weights at corresponding points

        REAL(KIND=8), DIMENSION(:, :), ALLOCATABLE:: gr, grm, grw

     CONTAINS

!====================================================================
        SUBROUTINE allocate_grid
!====================================================================
!
! ... allocates space of the arrays in MODULE spline_grid
!
!--------------------------------------------------------------------

           USE spline_param

           if (Allocated(bsp)) Deallocate (bsp, bsq, bspd, gr, grm, grw)
           ALLOCATE (bsp(nv + 1, ks, ks), bsq(nv + 1, ks, ks), bspd(nv + 1, ks, ks, 2), &
                     gr(nv, ks), grm(nv, ks), grw(nv, ks))
           bsp = 0.d0; bsq = 0.d0; bspd = 0.d0
           gr = 0.d0; grm = 0.d0; grw = 0.d0

        END SUBROUTINE allocate_grid

     END MODULE spline_grid


!=================================================
! SUBROUTINES
!	WHERE1(xx,ix,px,xa,xb,ku0)
!	BSVALI(px,py,bsv,ndeg,nod2)
!	BSPARI(k1,k2,idb,ndeg,kss,ktt)
!
!	no common
!=================================================

module mod_wbb

	implicit none

contains
!=========
subroutine WHERE1(xx,ix,px,xa,xb,ku0)

	implicit none

	integer, intent(in) :: ku0
	real(8), intent(in) :: xx, xa, xb
	integer, intent(out) :: ix
	real(8), intent(out) :: px

	real(8) :: cx, dx, rx

	dx = (xb - xa) / ku0

	if(xx > xb .or. xx < xa) stop ' WARNING SPECIFIED POINT IS OUT OF REGION'

	rx = xx - xa
	ix = int(rx/dx)
	cx = rx - dble(ix)*dx
	px = cx / dx
	ix = ix + 1

return
end subroutine WHERE1

!==========
subroutine BSVALI(px,py,bsv,ndeg,norder2)

	use mod_bspline

	implicit none

	integer, intent(in) :: ndeg, norder2
	real(8), intent(in) :: px, py
	real(8), intent(out) :: bsv(16)

	integer :: ll, m1, m2
	real(8) :: bx(4), by(4)

	CALL BSPLINE(px, bx, ndeg)
	CALL BSPLINE(py, by, ndeg)

	ll = norder2 + 1

	do m2 = 1, ndeg+1
		do m1 = 1, ndeg+1
			ll = ll - 1
			bsv(ll) = bx(m1) * by(m2)
		end do
	end do

return
end subroutine BSVALI

!==========
subroutine BSPARI(k1,k2,idb,ndeg,kss,ktt)

	implicit none

	integer, intent(in) :: k1, k2, ndeg, kss, ktt
	integer, intent(out) :: idb(16)

	integer :: ll, m1, m2

	ll = 0

	do m2 = k2, k2 + ndeg
		do m1 = k1, k1 + ndeg

			ll = ll + 1
			idb(ll) = 0

			if(m2 > ktt .or. m2 < 1) cycle
			if(m1 > kss .or. m1 < 1) cycle

			idb(ll) = m1 + (m2-1) * kss

		end do
	end do

return
end subroutine BSPARI

end module mod_wbb


! { dg-do compile }
!
! Test the fix for PR40737 as part of the overall fix for PR34640.
!
! Contributed by David Hough  <dh458@oakapple.net>
!
module testmod

integer, parameter :: standard_integer = 1
integer, parameter :: int = KIND( standard_integer)

integer, parameter :: i8  = selected_int_kind(12)
integer, parameter :: i4  = selected_int_kind(8)
integer, parameter :: i2  = selected_int_kind(4)

integer, parameter :: standard_real = 1.
integer, parameter :: std_real = KIND( standard_real)

integer, parameter :: r8  = selected_real_kind(12)
integer, parameter :: r4  = selected_real_kind(6)
integer, parameter :: double  = selected_real_kind(20)

integer, parameter :: name_string_length = 40
integer, parameter :: file_name_length = 60
integer, parameter :: text_string_length = 80
integer, parameter :: max_kwd_lgth = file_name_length

integer(int) :: bytes_per_int  = 4
integer(int) :: bytes_per_real = 8
integer(int) :: workcomm, spincomm

   integer(int), parameter :: nb_directions = 3,  &
                              direction_x = 1,    &
                              direction_y = 2,    &
                              direction_z = 3,    &
                              nb_ghost_cells = 5     ! might be different for the lagrange step?

   integer(int), parameter :: ends = 4,            &
                              lower_ghost = 1,     &
                              lower_interior = 2,  &
                              upper_interior = 3,  &
                              upper_ghost = 4

   ! Neighbors
   integer(int), parameter :: side = 2,       &
                              lower_end = 1,  &
                              upper_end = 2

   integer(int), parameter :: nb_variables = 5,    &
                              ro_var = 1,          &
                              ets_var = 2,         &
                              u_var = 3,           &
                              up1_var = 4,         &
                              up2_var = 5,         &
                              eis_var = 6,         &
                              ecs_var = 7,         &
                              p_var = 8,           &
                              c_var = 9,           &
                              nb_var_sortie = 9

   type :: VARIABLES_LIGNE
      sequence
      real, pointer, dimension( :, :) :: l
   end type VARIABLES_LIGNE

   type VARIABLES_MAILLE
      sequence
      real(r8), dimension( nb_variables) :: cell_var
   end type VARIABLES_MAILLE

   integer(int), dimension( nb_directions) :: &
         first_real_cell,    &  ! without ghost cells
         last_real_cell,     &  !
         nb_real_cells,      &  !
         first_work_cell,    &  ! including ghost cells
         last_work_cell,     &  !
         nb_work_cells,      &  !
         global_nb_cells        ! number of real cells, for the entire grid

   integer(int) :: dim_probleme  ! dimension du probleme (1, 2 ou 3)

   integer(int) :: largest_local_size   ! the largest of the 3 dimensions of the local grid

   ! Hydro variables of the actual domain
   ! There are 3 copies of these, for use according to current work direction
   type (VARIABLES_MAILLE), allocatable, target, dimension( :, :, :) ::  &
            Hydro_vars_XYZ,  &
            Hydro_vars_YZX,  &
            Hydro_vars_ZXY

   ! Pointers to current and next Hydro var arrays
   type (VARIABLES_MAILLE), pointer, dimension( :, :, :) :: Hydro_vars,      &
                                                            Hydro_vars_next

   ! Which of these 3 copies of the 3D arrays has been updated last
   integer(int) :: last_updated_3D_array = 0

   real(r8), pointer, dimension( :) ::        &
         ! Variables "permanentes" (entrant dans la projection)
         Ro,      & ! densite
         Ets,     & ! energie totale specifique
         Um,      & ! vitesse aux mailles, dans la direction de travail
         Xn,      & ! abscisse en fin de pas de temps
         ! Variables en lecture seulement
         Um_p1,   & ! vitesse aux mailles, dans les directions
         Um_p2,   & !                      orthogonales
         Xa,      & ! abscisses des noeuds en debut de pas de temps
         Dxa,     & ! longueur des mailles en debut de pas de temps
         U_dxa      ! inverses des longueurs des mailles

end module testmod

subroutine TF_AD_SPLITTING_DRIVER_PLANE

use testmod

implicit none
save

   real(r8), allocatable, dimension( :) ::  &
         ! Variables maille recalculees a chaque pas de temps
         Eis,     & ! energie interne specifique (seulement pour calculer la pression)
         Vit_son, & ! comme son nom l'indique
         C_f_l,   & ! nombre de Courant
         Pm,      & ! pression aux mailles
         ! Variables aux noeuds
         Un,      & ! vitesse des noeuds
         Pn         ! pression aux noeuds

integer(int) :: i, j, k
integer(int) :: first_cell, last_cell

         Ro => Hydro_vars( first_cell:last_cell, j, k)%cell_var( ro_var)
         Ets => Hydro_vars( first_cell:last_cell, j, k)%cell_var( ets_var)
         Um => Hydro_vars( first_cell:last_cell, j, k)%cell_var( u_var)
         Um_p1 => Hydro_vars( first_cell:last_cell, j, k)%cell_var( up1_var)
         Um_p2 => Hydro_vars( first_cell:last_cell, j, k)%cell_var( up2_var)

end subroutine TF_AD_SPLITTING_DRIVER_PLANE


MODULE m_rhonmt
CONTAINS
  SUBROUTINE rhonmt(atoms,sphhar,we,ne,sym,eigVecCoeffs,denCoeffs,ispin)
    !     *************************************************************
    !     subroutine sets up the coefficients of non-sphereical
    !     muffin-tin density                          c.l.fu
    !     *************************************************************
    USE m_gaunt,ONLY:gaunt1
    USE m_types
    use m_constants
    IMPLICIT NONE
    TYPE(t_sym),          INTENT(IN)    :: sym
    TYPE(t_sphhar),       INTENT(IN)    :: sphhar
    TYPE(t_atoms),        INTENT(IN)    :: atoms
    TYPE(t_eigVecCoeffs), INTENT(IN)    :: eigVecCoeffs
    TYPE(t_denCoeffs),    INTENT(INOUT) :: denCoeffs

    INTEGER,           INTENT(IN)    :: ne, ispin

    REAL,    INTENT(IN) :: we(:)!(nobd)

    !     ..
    !     .. Local Scalars ..
    COMPLEX cconst,cil,cmv
    REAL coef
    INTEGER  :: jmem,l,lcond,lh,llp,llpmax,lm,lmp,lp,lphi,lplow,lplow0,lv
    INTEGER  :: mp,mv,na,natom,nb,nn,ns,nt,m

    !Initialize private variables in gaunt module before parallel region
    !$      coef = gaunt1(0,0,0,0,0,0,atoms%lmaxd)

    DO ns = 1,sym%nsymt
       !$OMP PARALLEL DO DEFAULT(SHARED) &
       !$OMP&  PRIVATE(lv,jmem,mv,cmv,l,lm,mp,m,llpmax,nt,na,nb,lplow0)&
       !$OMP&  PRIVATE(lphi,lplow,lcond,lp,cil,lmp,llp,coef,cconst&
       !$OMP& ,natom,nn)
       DO  lh = 1,sphhar%nlh(ns)
          lv = sphhar%llh(lh,ns)
          DO  jmem = 1,sphhar%nmem(lh,ns)
             mv = sphhar%mlh(jmem,lh,ns)
             cmv = conjg(sphhar%clnu(jmem,lh,ns))
             DO  l = 0,atoms%lmaxd
                m_loop: DO m = -l,l
                   lm = l* (l+1) + m
                   mp = m - mv
                   !     -----> set up the lower and upper limit of lp in such a way that
                   !     -----> lp+l+lv is even, lp<=l, and (lp,l,lv) satisfies the
                   !     -----> triangular relation
                   lplow0 = iabs(l-lv)
                   lphi = l - mod(lv,2)
                   lplow = max(lplow0,iabs(mp))
                   lcond = iabs(lphi-lplow)
                   lplow = lplow + mod(lcond,2)
                   IF (lplow.GT.lphi) CYCLE m_loop
                   DO  lp = lplow,lphi,2
                      cil = ImagUnit** (l-lp)
                      lmp = lp* (lp+1) + mp
                      IF (lmp.GT.lm) CYCLE m_loop
                      llp = (l* (l+1))/2 + lp
                      !     -----> gaunt's coefficient
                      coef = 2.*gaunt1(l,lv,lp,m,mv,mp,atoms%lmaxd)
                      IF (lmp.EQ.lm) coef = coef/2.
                      cconst = coef* (cil*cmv)
                      natom = 0
                      DO  nn = 1,atoms%ntype
                         llpmax = (atoms%lmax(nn)* (atoms%lmax(nn)+3))/2
                         IF (llp.LE.llpmax) THEN
                            nt = natom
                            DO  na = 1,atoms%neq(nn)
                               nt = nt + 1
                               IF (sym%ntypsy(nt).EQ.ns) THEN
                                  DO nb = 1,ne
                                     denCoeffs%uunmt(llp,lh,nn,ispin) = denCoeffs%uunmt(llp,lh,nn,ispin)&
                                          +we(nb)*real(cconst*eigVecCoeffs%acof(nb,lm,nt,ispin)*conjg(eigVecCoeffs%acof(nb,lmp,nt,ispin)))
                                     denCoeffs%ddnmt(llp,lh,nn,ispin) = denCoeffs%ddnmt(llp,lh,nn,ispin) +&
                                          we(nb)*real(cconst*eigVecCoeffs%bcof(nb,lm,nt,ispin)*conjg(eigVecCoeffs%bcof(nb,lmp,nt,ispin)))
                                     denCoeffs%udnmt(llp,lh,nn,ispin) = denCoeffs%udnmt(llp,lh,nn,ispin) +&
                                          we(nb)*real(cconst*eigVecCoeffs%acof(nb,lm,nt,ispin)*conjg(eigVecCoeffs%bcof(nb,lmp,nt,ispin)))
                                     denCoeffs%dunmt(llp,lh,nn,ispin) = denCoeffs%dunmt(llp,lh,nn,ispin) +&
                                          we(nb)*real(cconst*eigVecCoeffs%bcof(nb,lm,nt,ispin)*conjg(eigVecCoeffs%acof(nb,lmp,nt,ispin)))
                                  ENDDO
                               ENDIF
                            ENDDO
                         ENDIF
                         natom = natom + atoms%neq(nn)
                      ENDDO
                   ENDDO
                ENDDO m_loop
             ENDDO
          ENDDO
       ENDDO
       !$OMP END PARALLEL DO
    ENDDO

  END SUBROUTINE rhonmt
END MODULE m_rhonmt


      SUBROUTINE APDB2 (IBUF1,IBUF2,NEXT,LEFT,NSTNS,NLINES,XSIGN,
     1                  LCSTM,ACSTM,NODEX,NODEI,ISILC,XYZB)
C
C     GENERATE GTKA TRANSFORMATION MATRIX FOR SWEPT TURBOPROP
C     BLADES (AERODYNAMIC THEORY NUMBER 7).
C
      EXTERNAL        ANDF
      LOGICAL         MULTI,OMIT,SINGLE,DEBUG
      INTEGER         GM,GO,GTKA,SCR1,SCR2,CORE,IDATA(7),
     1                UM,UO,UR,USG,USB,UL,UA,UF,US,UN,UG,USET1,
     2                GTKG,GKNB,GKM,GKAB,GKF,GKS,GKO,GKN,GSIZE,
     3                ANDF,RD,RDREW,WRT,WRTREW,CLSREW,TGKG(7)
      DIMENSION       ITRL(7),XYZB(4,NSTNS),IZ(1),Z(1),RDATA(7),
     1                TA(3,3),TBL(3),TBLA(3),TBLT(3),TBLR(3),
     2                ACSTM(1),NODEX(1),NODEI(1),ISILC(1)
      COMMON /SYSTEM/ KSYSTM(54),IPREC
      COMMON /TWO   / ITWO(32)
      COMMON /ZZZZZZ/ CORE(1)
      COMMON /ZBLPKX/ AP(4),II
      COMMON /BITPOS/ UM,UO,UR,USG,USB,UL,UA,UF,US,UN,UG
      COMMON /PATX  / LC,N,NO,NY,USET1,IBC(7)
      COMMON /NAMES / RD,RDREW,WRT,WRTREW,CLSREW
      COMMON /APDBUG/ DEBUG
      EQUIVALENCE     (Z(1),CORE(1))
      EQUIVALENCE     (Z(1),IZ(1)), (IDATA(1),RDATA(1))
      DATA    SINGLE, MULTI,OMIT /.TRUE.,.TRUE.,.TRUE./
C
      USET = 102
      GM   = 106
      GO   = 107
      GTKA = 204
      SCR1 = 301
      SCR2 = 302
      GKNB = 303
      GKM  = 304
      GKAB = 305
      ITRL(1) = USET
      CALL RDTRL (ITRL)
      GSIZE = ITRL(3)
      IF (ANDF(ITRL(5),ITWO(UM)) .EQ. 0) MULTI = .FALSE.
      IF (ANDF(ITRL(5),ITWO(US)) .EQ. 0) SINGLE= .FALSE.
      IF (ANDF(ITRL(5),ITWO(UO)) .EQ. 0) OMIT  = .FALSE.
      IF (.NOT.(MULTI .OR. SINGLE .OR. OMIT)) SCR2 = GTKA
      GTKG = SCR2
C
C     OPEN SCR1 TO READ BLADE NODE DATA
C
C                         T
C     OPEN SCR2 TO WRITE G   MATRIX OF ORDER (GSIZE X KSIZE)
C                         KG
C
      CALL GOPEN (SCR1,Z(IBUF1),RDREW)
      CALL GOPEN (GTKG,Z(IBUF2),WRTREW)
      TGKG(1) = GTKG
      TGKG(2) = 0
      TGKG(3) = GSIZE
      TGKG(4) = 2
      TGKG(5) = 1
      TGKG(6) = 0
      TGKG(7) = 0
C
C     SET-UP CALL TO TRANSS VIA PRETRS
C
      IF (LCSTM .GT. 0) CALL PRETRS (ACSTM,LCSTM)
C
C     LOOP ON STREAMLINES
C
      DO 50 NLINE = 1,NLINES
C
C     READ STREAMLINE NODE DATA FROM SCR1
C
      DO 10 NST = 1,NSTNS
      CALL FREAD (SCR1,IDATA,7,0)
      IF (DEBUG) CALL BUG1 ('SCR1 IDATA',10,IDATA,7)
      NODEX(NST) = IDATA(1)
      NODEI(NST) = IDATA(2)
      ISILC(NST) = IDATA(3)
      XYZB(1,NST)= RDATA(4)
      XYZB(2,NST)= RDATA(5)
      XYZB(3,NST)= RDATA(6)
      XYZB(4,NST)= RDATA(7)
   10 CONTINUE
C
C     GENERATE BASIC TO LOCAL TRANSFORMATION MATRIX FOR THIS STREAMLINE
C
      CALL APDB2A (NLINES,NLINE,SCR1,NSTNS,XSIGN,XYZB(2,1),
     1             XYZB(2,NSTNS),TBLT,TBLR)
C
C     SET TRANSFORMATION TO TRANSLATION FIRST
C
      DO 15 NN = 1,3
  15  TBL(NN) = TBLT(NN)
C
C     LOOP FOR TRANSLATION THEN ROTATION
C
      NDEG = 0
      DO 45 NLOOP = 1,2
      IF (DEBUG) CALL BUG1 ('MAT-TBL   ' ,18,TBL,3)
C
C     LOOP ON COMPUTING STATIONS
C
      DO 40 NCS = 1,NSTNS
C
C     LOCATE GLOBAL TO BASIC TRANSFORMATION MATRIX
C
      RDATA(1) = XYZB(1,NCS)
      IF (LCSTM.EQ.0 .OR. IDATA(1).EQ.0) GO TO 20
      CALL TRANSS (XYZB(1,NCS),TA)
      CALL GMMATS (TBL,1,3,0,TA,3,3,0,TBLA)
      GO TO 25
   20 TBLA(1) = TBL(1)
      TBLA(2) = TBL(2)
      TBLA(3) = TBL(3)
   25 CONTINUE
      IF (DEBUG) CALL BUG1 ('MAT-TBLA  ',25,TBLA,3)
C
C     COMPUTE LOCATION IN G-SET USING SIL
C     KODE = 1 FOR GRID POINT
C     KODE = 2 FOR SCALAR POINT (NOT ALLOWED, CHECK WAS MADE BY APDB)
C
      ISIL = ISILC(NCS)/10
      CALL BLDPK (1,1,GTKG,0,0)
C
C     OUTPUT GKG(TRANSPOSE) = GTKG
C     II IS ROW POSITION
C
      DO 30 ICOL = 1,3
      II = ISIL + NDEG
      AP(1) = TBLA(ICOL)
      IF (DEBUG) CALL BUG1 ('ISIL      ',28,ISIL,1)
      IF (DEBUG) CALL BUG1 ('MAT-AP    ',29,AP,1)
      CALL ZBLPKI
      ISIL = ISIL + 1
   30 CONTINUE
      CALL BLDPKN (GTKG,0,TGKG)
   40 CONTINUE
C
C     CHANGE BASIC TO LOCAL TRANSFORMATION TO ROTATION
C
      DO 43 NN = 1,3
   43 TBL(NN) = TBLR(NN)
      NDEG = 3
   45 CONTINUE
   50 CONTINUE
      CALL CLOSE (SCR1,CLSREW)
      CALL CLOSE (GTKG,CLSREW)
      CALL WRTTRL (TGKG)
C
C     CREATE GTKA MATRIX
C
      IF (MULTI .OR. SINGLE .OR. OMIT) GO TO 60
      GO TO 100
   60 CONTINUE
      LC  = KORSZ(CORE)
      GKF = GKNB
      GKS = GKM
      GKO = GKS
      USET1 = USET
C
C     REDUCE TO N-SET IF MULTI POINT CONSTRAINTS
C
      GKN = GTKG
      IF (.NOT.MULTI) GO TO 70
      IF (.NOT.SINGLE .AND. .NOT.OMIT) GKN = GTKA
      CALL CALCV (SCR1,UG,UN,UM,CORE)
      CALL SSG2A (GTKG,GKNB,GKM,SCR1)
      CALL SSG2B (GM,GKM,GKNB,GKN,1,IPREC,1,SCR1)
C
C     PARTITION INTO F-SET IF SINGLE POINT CONSTRAINTS
C
   70 IF (.NOT.SINGLE) GO TO 80
      IF (.NOT.OMIT  ) GKF = GTKA
      CALL CALCV (SCR1,UN,UF,US,CORE)
      CALL SSG2A (GKN,GKF,0,SCR1)
      GO TO 90
C
C     REDUCE TO A-SET IF OMITS
C
   80 GKF = GKN
   90 IF (.NOT.OMIT) GO TO 100
      CALL CALCV (SCR1,UF,UA,UO,CORE)
      CALL SSG2A (GKF,GKAB,GKO,SCR1)
      CALL SSG2B (GO,GKO,GKAB,GTKA,1,IPREC,1,SCR1)
  100 RETURN
      END


!*==clartg.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022

!> \brief \b CLARTG generates a plane rotation with real cosine and complex sine.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CLARTG + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CLARTG( F, G, CS, SN, R )
!
!       .. Scalar Arguments ..
!       REAL               CS
!       COMPLEX            F, G, R, SN
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CLARTG generates a plane rotation so that
!>
!>    [  CS  SN  ]     [ F ]     [ R ]
!>    [  __      ]  .  [   ]  =  [   ]   where CS**2 + |SN|**2 = 1.
!>    [ -SN  CS  ]     [ G ]     [ 0 ]
!>
!> This is a faster version of the BLAS1 routine CROTG, except for
!> the following differences:
!>    F and G are unchanged on return.
!>    If G=0, then CS=1 and SN=0.
!>    If F=0, then CS=0 and SN is chosen so that R is real.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] F
!> \verbatim
!>          F is COMPLEX
!>          The first component of vector to be rotated.
!> \endverbatim
!>
!> \param[in] G
!> \verbatim
!>          G is COMPLEX
!>          The second component of vector to be rotated.
!> \endverbatim
!>
!> \param[out] CS
!> \verbatim
!>          CS is REAL
!>          The cosine of the rotation.
!> \endverbatim
!>
!> \param[out] SN
!> \verbatim
!>          SN is COMPLEX
!>          The sine of the rotation.
!> \endverbatim
!>
!> \param[out] R
!> \verbatim
!>          R is COMPLEX
!>          The nonzero component of the rotated vector.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexOTHERauxiliary
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel
!>
!>  This version has a few statements commented out for thread safety
!>  (machine parameters are computed on each entry). 10 feb 03, SJH.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE CLARTG(F,G,Cs,Sn,R)
      IMPLICIT NONE
!*--CLARTG108
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      REAL Cs
      COMPLEX F , G , R , Sn
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL TWO , ONE , ZERO
      PARAMETER (TWO=2.0E+0,ONE=1.0E+0,ZERO=0.0E+0)
      COMPLEX CZERO
      PARAMETER (CZERO=(0.0E+0,0.0E+0))
!     ..
!     .. Local Scalars ..
!     LOGICAL            FIRST
      INTEGER count , i
      REAL d , di , dr , eps , f2 , f2s , g2 , g2s , safmin , safmn2 ,  &
     &     safmx2 , scale
      COMPLEX ff , fs , gs
!     ..
!     .. External Functions ..
      REAL SLAMCH , SLAPY2
      LOGICAL SISNAN
      EXTERNAL SLAMCH , SLAPY2 , SISNAN
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , AIMAG , CMPLX , CONJG , INT , LOG , MAX , REAL ,  &
     &          SQRT
!     ..
!     .. Statement Functions ..
      REAL ABS1 , ABSSQ
!     ..
!     .. Statement Function definitions ..
      ABS1(ff) = MAX(ABS(REAL(ff)),ABS(AIMAG(ff)))
      ABSSQ(ff) = REAL(ff)**2 + AIMAG(ff)**2
!     ..
!     .. Executable Statements ..
!
      safmin = SLAMCH('S')
      eps = SLAMCH('E')
      safmn2 = SLAMCH('B')**INT(LOG(safmin/eps)/LOG(SLAMCH('B'))/TWO)
      safmx2 = ONE/safmn2
      scale = MAX(ABS1(F),ABS1(G))
      fs = F
      gs = G
      count = 0
      IF ( scale>=safmx2 ) THEN
         DO
            count = count + 1
            fs = fs*safmn2
            gs = gs*safmn2
            scale = scale*safmn2
            IF ( scale<safmx2 .OR. count>=20 ) EXIT
         ENDDO
      ELSEIF ( scale<=safmn2 ) THEN
         IF ( G==CZERO .OR. SISNAN(ABS(G)) ) THEN
            Cs = ONE
            Sn = CZERO
            R = F
            RETURN
         ENDIF
         DO
            count = count - 1
            fs = fs*safmx2
            gs = gs*safmx2
            scale = scale*safmx2
            IF ( scale>safmn2 ) EXIT
         ENDDO
      ENDIF
      f2 = ABSSQ(fs)
      g2 = ABSSQ(gs)
      IF ( f2<=MAX(g2,ONE)*safmin ) THEN
!
!        This is a rare case: F is very small.
!
         IF ( F==CZERO ) THEN
            Cs = ZERO
            R = SLAPY2(REAL(G),AIMAG(G))
!           Do complex/real division explicitly with two real divisions
            d = SLAPY2(REAL(gs),AIMAG(gs))
            Sn = CMPLX(REAL(gs)/d,-AIMAG(gs)/d)
            RETURN
         ENDIF
         f2s = SLAPY2(REAL(fs),AIMAG(fs))
!        G2 and G2S are accurate
!        G2 is at least SAFMIN, and G2S is at least SAFMN2
         g2s = SQRT(g2)
!        Error in CS from underflow in F2S is at most
!        UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS
!        If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN,
!        and so CS .lt. sqrt(SAFMIN)
!        If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN
!        and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS)
!        Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S
         Cs = f2s/g2s
!        Make sure abs(FF) = 1
!        Do complex/real division explicitly with 2 real divisions
         IF ( ABS1(F)>ONE ) THEN
            d = SLAPY2(REAL(F),AIMAG(F))
            ff = CMPLX(REAL(F)/d,AIMAG(F)/d)
         ELSE
            dr = safmx2*REAL(F)
            di = safmx2*AIMAG(F)
            d = SLAPY2(dr,di)
            ff = CMPLX(dr/d,di/d)
         ENDIF
         Sn = ff*CMPLX(REAL(gs)/g2s,-AIMAG(gs)/g2s)
         R = Cs*F + Sn*G
      ELSE
!
!        This is the most common case.
!        Neither F2 nor F2/G2 are less than SAFMIN
!        F2S cannot overflow, and it is accurate
!
         f2s = SQRT(ONE+g2/f2)
!        Do the F2S(real)*FS(complex) multiply with two real multiplies
         R = CMPLX(f2s*REAL(fs),f2s*AIMAG(fs))
         Cs = ONE/f2s
         d = f2 + g2
!        Do complex/real division explicitly with two real divisions
         Sn = CMPLX(REAL(R)/d,AIMAG(R)/d)
         Sn = Sn*CONJG(gs)
         IF ( count/=0 ) THEN
            IF ( count>0 ) THEN
               DO i = 1 , count
                  R = R*safmx2
               ENDDO
            ELSE
               DO i = 1 , -count
                  R = R*safmn2
               ENDDO
            ENDIF
         ENDIF
      ENDIF
!
!     End of CLARTG
!
      END SUBROUTINE CLARTG


module castro_sums_module

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  public

contains

  subroutine ca_summass(lo,hi,rho,r_lo,r_hi,dx,&
                        vol,v_lo,v_hi,mass) bind(C, name="ca_summass")

    use bl_constants_module

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer, intent(in) :: lo(3), hi(3)
    integer, intent(in) :: r_lo(3), r_hi(3)
    integer, intent(in) :: v_lo(3), v_hi(3)
    real(rt), intent(inout) :: mass
    real(rt), intent(in) :: dx(3)
    real(rt), intent(in) :: rho(r_lo(1):r_hi(1),r_lo(2):r_hi(2),r_lo(3):r_hi(3))
    real(rt), intent(in) :: vol(v_lo(1):v_hi(1),v_lo(2):v_hi(2),v_lo(3):v_hi(3))

    integer          :: i, j, k

    mass = ZERO

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)
             mass = mass + rho(i,j,k) * vol(i,j,k)
          enddo
       enddo
    enddo

  end subroutine ca_summass

  subroutine ca_sumsquared(lo,hi,rho,r_lo,r_hi,dx,&
                           vol,v_lo,v_hi,mass) bind(C, name="ca_sumsquared")

    use bl_constants_module

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer, intent(in) :: lo(3), hi(3)
    integer, intent(in) :: r_lo(3), r_hi(3)
    integer, intent(in) :: v_lo(3), v_hi(3)
    real(rt), intent(inout) :: mass, dx(3)
    real(rt), intent(in) :: rho(r_lo(1):r_hi(1),r_lo(2):r_hi(2),r_lo(3):r_hi(3))
    real(rt), intent(in) :: vol(v_lo(1):v_hi(1),v_lo(2):v_hi(2),v_lo(3):v_hi(3))

    integer          :: i, j, k

    mass = ZERO

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)
             mass = mass + rho(i,j,k)*rho(i,j,k)*vol(i,j,k)
          enddo
       enddo
    enddo

  end subroutine ca_sumsquared

  subroutine ca_sumlocmass(lo,hi,rho,r_lo,r_hi,dx,&
                           vol,v_lo,v_hi,mass,idir) bind(C, name="ca_sumlocmass")

    use prob_params_module, only: problo, center, probhi, dim, physbc_lo, physbc_hi, Symmetry
    use bl_constants_module

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer, intent(in) :: idir
    integer, intent(in) :: lo(3), hi(3)
    integer, intent(in) :: r_lo(3), r_hi(3)
    integer, intent(in) :: v_lo(3), v_hi(3)
    real(rt), intent(inout) :: mass
    real(rt), intent(in) :: dx(3)
    real(rt), intent(in) :: rho(r_lo(1):r_hi(1),r_lo(2):r_hi(2),r_lo(3):r_hi(3))
    real(rt), intent(in) :: vol(v_lo(1):v_hi(1),v_lo(2):v_hi(2),v_lo(3):v_hi(3))

    integer          :: i, j, k
    real(rt)         :: x, y, z
    real(rt)         :: symlo, symhi

    mass = ZERO

    symlo = ZERO
    symhi = ZERO

    if (idir .eq. 0) then
       do i = lo(1), hi(1)
          x = problo(1) + (dble(i)+HALF) * dx(1) - center(1)
          if (physbc_lo(1) .eq. Symmetry) then
             symlo = problo(1) - x
          endif
          if (physbc_hi(1) .eq. Symmetry) then
             symhi = x - probhi(1)
          endif
          x = x + symlo + symhi
          do k = lo(3), hi(3)
             do j = lo(2), hi(2)
                mass = mass + rho(i,j,k) * vol(i,j,k) * x
             enddo
          enddo
       enddo
    else if (idir .eq. 1 .and. dim .ge. 2) then
       do j = lo(2), hi(2)
          y = problo(2) + (dble(j)+HALF) * dx(2) - center(2)
          if (physbc_lo(2) .eq. Symmetry) then
             symlo = problo(2) - y
          endif
          if (physbc_hi(2) .eq. Symmetry) then
             symhi = y - probhi(2)
          endif
          y = y + symlo + symhi
          do k = lo(3), hi(3)
             do i = lo(1), hi(1)
                mass = mass + rho(i,j,k) * vol(i,j,k) * y
             enddo
          enddo
       enddo
    else if (dim .eq. 3) then
       do k = lo(3), hi(3)
          z = problo(3) + (dble(k)+HALF) * dx(3) - center(3)
          if (physbc_lo(3) .eq. Symmetry) then
             symlo = problo(3) - z
          endif
          if (physbc_hi(3) .eq. Symmetry) then
             symhi = z - probhi(3)
          endif
          z = z + symlo + symhi
          do j = lo(2), hi(2)
             do i = lo(1), hi(1)
                mass = mass + rho(i,j,k) * vol(i,j,k) * z
             enddo
          enddo
       enddo
    end if

  end subroutine ca_sumlocmass

  subroutine ca_sumlocmass2d(lo,hi,rho,r_lo,r_hi,dx,&
                             vol,v_lo,v_hi,mass,idir1,idir2) bind(C, name="ca_sumlocmass2d")

    use prob_params_module, only: problo, center, probhi, dim, physbc_lo, physbc_hi, Symmetry
    use bl_constants_module

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer, intent(in) :: idir1, idir2
    integer, intent(in) :: lo(3), hi(3)
    integer, intent(in) :: r_lo(3), r_hi(3)
    integer, intent(in) :: v_lo(3), v_hi(3)
    real(rt), intent(inout) :: mass
    real(rt), intent(in) :: dx(3)
    real(rt), intent(in) :: rho(r_lo(1):r_hi(1),r_lo(2):r_hi(2),r_lo(3):r_hi(3))
    real(rt), intent(in) :: vol(v_lo(1):v_hi(1),v_lo(2):v_hi(2),v_lo(3):v_hi(3))

    integer          :: i, j, k
    real(rt)         :: x, y, z
    real(rt)         :: symlo1, symhi1, symlo2, symhi2

    mass = ZERO

    symlo1 = ZERO
    symlo2 = ZERO
    symhi1 = ZERO
    symhi2 = ZERO

    if (idir1 .eq. 0) then
       do i = lo(1), hi(1)
          x = problo(1) + (dble(i)+HALF) * dx(1) - center(1)
          if (physbc_lo(1) .eq. Symmetry) then
             symlo1 = problo(1) - x
          endif
          if (physbc_hi(1) .eq. Symmetry) then
             symhi1 = x - probhi(1)
          endif
          x = x + symlo1 + symhi1
          if (idir2 .eq. 0) then
             do k = lo(3), hi(3)
                do j = lo(2), hi(2)
                   mass = mass + rho(i,j,k) * vol(i,j,k) * x * x
                enddo
             enddo
          elseif (idir2 .eq. 1 .and. dim .ge. 2) then
             do j = lo(2), hi(2)
                y = problo(2) + (dble(j)+HALF) * dx(2) - center(2)
                if (physbc_lo(2) .eq. Symmetry) then
                   symlo2 = problo(2) - y
                endif
                if (physbc_hi(2) .eq. Symmetry) then
                   symhi2 = y - probhi(2)
                endif
                y = y + symlo2 + symhi2
                do k = lo(3), hi(3)
                   mass = mass + rho(i,j,k) * vol(i,j,k) * x * y
                enddo
             enddo
          elseif (dim .eq. 3) then
             do k = lo(3), hi(3)
                z = problo(3) + (dble(k)+HALF) * dx(3) - center(3)
                if (physbc_lo(3) .eq. Symmetry) then
                   symlo2 = problo(3) - z
                endif
                if (physbc_hi(3) .eq. Symmetry) then
                   symhi2 = z - probhi(3)
                endif
                z = z + symlo2 + symhi2
                do j = lo(2), hi(2)
                   mass = mass + rho(i,j,k) * vol(i,j,k) * x * z
                enddo
             enddo
          endif
       enddo
    else if (idir1 .eq. 1 .and. dim .ge. 2) then
       do j = lo(2), hi(2)
          y = problo(2) + (dble(j)+HALF) * dx(2) - center(2)
          if (physbc_lo(2) .eq. Symmetry) then
             symlo1 = problo(2) - y
          endif
          if (physbc_hi(2) .eq. Symmetry) then
             symhi1 = y - probhi(2)
          endif
          y = y + symlo1 + symhi1
          if (idir2 .eq. 0) then
             do i = lo(1), hi(1)
                x = problo(1) + (dble(i)+HALF) * dx(1) - center(1)
                if (physbc_lo(1) .eq. Symmetry) then
                   symlo2 = problo(1) - x
                endif
                if (physbc_hi(1) .eq. Symmetry) then
                   symhi2 = x - probhi(1)
                endif
                x = x + symlo2 + symhi2
                do k = lo(3), hi(3)
                   mass = mass + rho(i,j,k) * vol(i,j,k) * y * x
                enddo
             enddo
          elseif (idir2 .eq. 1) then
             do i = lo(1), hi(1)
                do k = lo(3), hi(3)
                   mass = mass + rho(i,j,k) * vol(i,j,k) * y * y
                enddo
             enddo
          elseif (dim .eq. 3) then
             do k = lo(3), hi(3)
                z = problo(3) + (dble(k)+HALF) * dx(3) - center(3)
                if (physbc_lo(3) .eq. Symmetry) then
                   symlo2 = problo(3) - z
                endif
                if (physbc_hi(3) .eq. Symmetry) then
                   symhi2 = z - probhi(3)
                endif
                z = z + symlo2 + symhi2
                do i = lo(1), hi(1)
                   mass = mass + rho(i,j,k) * vol(i,j,k) * y * z
                enddo
             enddo
          endif
       enddo
    elseif (dim .eq. 3) then
       do k = lo(3), hi(3)
          z = problo(3) + (dble(k)+HALF) * dx(3) - center(3)
          if (physbc_lo(3) .eq. Symmetry) then
             symlo1 = problo(3) - z
          endif
          if (physbc_hi(3) .eq. Symmetry) then
             symhi1 = z - probhi(3)
          endif
          z = z + symlo1 + symhi1
          if (idir2 .eq. 0) then
             do i = lo(1), hi(1)
                x = problo(1) + (dble(i)+HALF) * dx(1) - center(1)
                if (physbc_lo(1) .eq. Symmetry) then
                   symlo2 = problo(1) - x
                endif
                if (physbc_hi(1) .eq. Symmetry) then
                   symhi2 = x - probhi(1)
                endif
                x = x + symlo2 + symhi2
                do j = lo(2), hi(2)
                   mass = mass + rho(i,j,k) * vol(i,j,k) * z * x
                enddo
             enddo
          elseif (idir2 .eq. 1) then
             do j = lo(2), hi(2)
                y = problo(2) + (dble(j)+HALF) * dx(2) - center(2)
                if (physbc_lo(2) .eq. Symmetry) then
                   symlo2 = problo(2) - y
                endif
                if (physbc_hi(2) .eq. Symmetry) then
                   symhi2 = y - probhi(2)
                endif
                y = y + symlo2 + symhi2
                do i = lo(1), hi(1)
                   mass = mass + rho(i,j,k) * vol(i,j,k) * z * y
                enddo
             enddo
          else
             do j = lo(2), hi(2)
                do i = lo(1), hi(1)
                   mass = mass + rho(i,j,k) * vol(i,j,k) * z * z
                enddo
             enddo
          endif
       enddo
    end if

  end subroutine ca_sumlocmass2d

  subroutine ca_sumlocsquaredmass(lo,hi,rho,r_lo,r_hi,dx,&
                                  vol,v_lo,v_hi,mass,idir) bind(C, name="ca_sumlocsquaredmass")

    use prob_params_module, only: problo, center, dim
    use bl_constants_module

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer, intent(in) :: idir
    integer, intent(in) :: lo(3), hi(3)
    integer, intent(in) :: r_lo(3), r_hi(3)
    integer, intent(in) :: v_lo(3), v_hi(3)
    real(rt), intent(inout) :: mass
    real(rt), intent(in) :: dx(3)
    real(rt), intent(in) :: rho(r_lo(1):r_hi(1),r_lo(2):r_hi(2),r_lo(3):r_hi(3))
    real(rt), intent(in) :: vol(v_lo(1):v_hi(1),v_lo(2):v_hi(2),v_lo(3):v_hi(3))

    integer          :: i, j, k
    real(rt)         :: x, y, z

    mass = ZERO

    if (idir .eq. 0) then
       do i = lo(1), hi(1)
          x = problo(1) + (dble(i)+HALF) * dx(1) - center(1)
          do k = lo(3), hi(3)
             do j = lo(2), hi(2)
                mass = mass + rho(i,j,k) * vol(i,j,k) * (x**2)
             enddo
          enddo
       enddo
    else if (idir .eq. 1 .and. dim .ge. 2) then
       do j = lo(2), hi(2)
          y = problo(2) + (dble(j)+HALF) * dx(2) - center(2)
          do k = lo(3), hi(3)
             do i = lo(1), hi(1)
                mass = mass + rho(i,j,k) * vol(i,j,k) * (y**2)
             enddo
          enddo
       enddo
    else if (dim .eq. 3) then
       do k = lo(3), hi(3)
          z = problo(3) + (dble(k)+HALF) * dx(3) - center(3)
          do j = lo(2), hi(2)
             do i = lo(1), hi(1)
                mass = mass + rho(i,j,k) * vol(i,j,k) * (z**2)
             enddo
          enddo
       enddo
    end if

  end subroutine ca_sumlocsquaredmass

  subroutine ca_sumproduct(lo,hi,f1,f1_lo,f1_hi,f2,f2_lo,f2_hi,dx,&
                           vol,v_lo,v_hi,product) bind(C, name="ca_sumproduct")

    use bl_constants_module

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer, intent(in) :: lo(3), hi(3)
    integer, intent(in) :: f1_lo(3), f1_hi(3)
    integer, intent(in) :: f2_lo(3), f2_hi(3)
    integer, intent(in) :: v_lo(3), v_hi(3)
    real(rt), intent(inout) :: product
    real(rt), intent(in) :: dx(3)
    real(rt), intent(in) :: f1(f1_lo(1):f1_hi(1),f1_lo(2):f1_hi(2),f1_lo(3):f1_hi(3))
    real(rt), intent(in) :: f2(f2_lo(1):f2_hi(1),f2_lo(2):f2_hi(2),f2_lo(3):f2_hi(3))
    real(rt), intent(in) :: vol(v_lo(1):v_hi(1),v_lo(2):v_hi(2),v_lo(3):v_hi(3))

    integer          :: i, j, k

    product = ZERO

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)
             product = product + f1(i,j,k) * f2(i,j,k) * vol(i,j,k)
          enddo
       enddo
    enddo

  end subroutine ca_sumproduct

end module castro_sums_module


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

C=======================================================================
      SUBROUTINE BL_ROTATE (NUM, NPROT, ROTMAT, ROTCEN,
     &   XN, YN, ZN, HZ, VT, PD)
C=======================================================================

C   --*** ROTATE *** (MESH) Rotate 3D coordinates
C   --   Written by Amy Gilkey - revised 09/09/87
C   --
C   --ROTATE rotates the 3D coordinates by subtracting the rotation center
C   --and multipling by the rotation matrix.
C   --
C   --Parameters:
C   --   NUM - IN - the number of nodes to rotate
C   --   NPROT - IN - the node numbers of the nodes to rotate
C   --   ROTMAT - IN - the rotation matrix
C   --   ROTCEN - IN - the center of the rotation
C   --   XN, YN, ZN - IN - the original nodal coordinates
C   --   HZ, VT, PD - OUT - the rotated nodal coordinates

      INTEGER NPROT(NUM)
      REAL ROTMAT(3,3), ROTCEN(3)
      REAL XN(*), YN(*), ZN(*)
      REAL HZ(*), VT(*), PD(*)

      DO 100 IX = 1, NUM
         INP = NPROT(IX)
         X = XN(INP) - ROTCEN(1)
         Y = YN(INP) - ROTCEN(2)
         Z = ZN(INP) - ROTCEN(3)
         HZ(INP) = X*ROTMAT(1,1) + Y*ROTMAT(2,1) + Z*ROTMAT(3,1)
         VT(INP) = X*ROTMAT(1,2) + Y*ROTMAT(2,2) + Z*ROTMAT(3,2)
         PD(INP) = X*ROTMAT(1,3) + Y*ROTMAT(2,3) + Z*ROTMAT(3,3)
  100 CONTINUE

      RETURN
      END


program test1
#if (_DP==0)
 use iso_fortran_env,only:int32,int64,wp=>real32
#else
 use iso_fortran_env,only:int32,int64,wp=>real64
#endif
 use modsparse
 implicit none
 integer(kind=int32)::nrow
 integer(kind=int32)::row
 integer(kind=int32)::col
 integer(kind=int32)::iunit, istat
 real(kind=wp)::val
 logical::lup=.false.
 type(llsparse)::ll
 type(coosparse)::coo
 type(crssparse)::crs,crs1

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !LINKED LINK
 open(newunit=iunit,file='crsinput.ascii',status='old',action='read')
 read(iunit,*) nrow

 ll=llsparse(nrow,lupper=lup)

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

 call ll%printstats()

 call ll%print()
 !call coo%print(lint=.false.)
 call ll%printtofile('ll.dat')

 print*,'size ll: ',ll%nonzero()

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !CSR FROM LL
 crs=ll
 call crs%printstats
 call crs%print()

 call crs%sort()
 call crs%printtofile('crsll.dat')

 call ll%destroy()

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !COO
 open(newunit=iunit,file='crsinput.ascii',status='old',action='read')
 read(iunit,*) nrow

 coo=coosparse(nrow,nel=4_int64,lupper=lup)

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

 call coo%printstats()
 !call coo%print(lint=.false.)
 call coo%print()
 call coo%printtofile('coo.dat')

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !CSR
 crs=coo
 call crs%printstats
 call crs%print()

 call crs%sort()
 call crs%printtofile('crscoo.dat')

 call coo%add(1,1,150._wp)

! crs=coo
! call crs%printstats
! !call crs%print(lint=.false.)
! print*,'*****************not sorted'
! call crs%print()
! print*,'*****************sorted'
! call crs%sort()
! call crs%print()
! call crs%printtofile('crs.dat')
! call crs%printtofile('crs_int.dat',lint=.false.)
!
!
 print*,'aaaaaaaaaaaaaaCOOaaaaaaaaaaaaaaaa'
 print*,'4 3',coo%get(4,3)
 print*,'3 4',coo%get(3,4)
 print*,'3 3',coo%get(3,3)
 print*,'1 4',coo%get(1,4)
 print*,'1 1',coo%get(1,1)

!print*,'aaaaaaaaaaaaaaCSRaaaaaaaaaaaaaaaa'
! print*,'4 3',crs%get(4,3)
! print*,'3 4',crs%get(3,4)
! print*,'3 3',crs%get(3,3)
! print*,'1 4',crs%get(1,4)
! print*,'1 1',crs%get(1,1)
!
 print*,'aaaaaaaaaaaaaaCOOaaaaaaaaaaaaaaaa'
 call coo%printsquare()
!print*,'aaaaaaaaaaaaaaCOOaaaaaaaaaaaaaaaa'
! call crs%printsquare()
! call crs%printsquaretofile('crsquarse.dat')

 print*,'aaaaaaaaaaaaaaCOO modifaaaaaaaaaaaaaaaa'

 call coo%set(4,4,-1._wp)
 call coo%set(3,4,-1._wp)
 call coo%set(4,3,0._wp)

 call coo%print()

 call coo%printsquare()

 print*,'aaaaaaaaaaaaaaCRS modifaaaaaaaaaaaaaaaa'
 crs=coo
 call crs%sort()
 call crs%print()

 print*,'aaaaaaaaaaaaa print COO to stream aaaaaaaaaa'
 call coo%save('coostream.dat')
 call coo%printstats()

 call coo%destroy()

 print*,'aaaaaaaaaaaaa read COO to stream aaaaaaaaaa'
 coo=coosparse('coostream.dat')!,444)
 call coo%printstats()

 call coo%destroy()

 print*,'aaaaaaaaaaaaa add to CRS aaaaaaaaaa'
 call crs%set(4,4,100._wp,row)
 print*,'error: ',row

 call crs%set(1,4,100._wp,row)
 print*,'error: ',row
 call crs%print()

 print*,'dim1',crs%getdim(1)
 print*,'dim2',crs%getdim(2)

 print*,'aaaaaaaaaaaaaaa test load/save aaaaaaaaaaaaaaa'
 call crs%save('crsstream.dat')

 crs1=crssparse('crsstream.dat')
 call crs1%print()

 print*,'aaaaaaaaaaaaaaa test copy aaaaaaaaaaaaaaa'
 call crs%destroy()

 crs=crs1

 print*,'aaaaaaaaaaaaaaaCRSaaaaaaaaaaaaaaa'
 call crs%add(1,1,130._wp)
 call crs%printstats()
 call crs%print()

 print*,'aaaaaaaaaaaaaaaCRS1aaaaaaaaaaaaaaa'
 call crs1%printstats()
 call crs1%print()

 print*,'aaaaaaaaaaaaaaa DIAGONAL COO aaaaaaaaaaaaaaaa'
 coo=crs1

 call coo%printsquare()

 print*,'aaaa',coo%diag()

 crs=coo%diag(-1)

 call crs%printsquare()

 call coo%destroy()

 print*,'aaaaaaaaaaaaaaa DIAGONAL CRS aaaaaaaaaaaaaaaa'
 coo=crs1
 crs=coo
 call crs%printsquare()

 print*,'aaaa',crs%diag()
 crs1=crs%diag(10)
 call crs1%printsquare()

end program


program backTracking

    !...........................!
    !        Declarations       !
    !...........................!

    type Particle
        real :: x_pos
        real :: y_pos
        real :: z_pos
        real :: vx
        real :: vy
        real :: vz
        real :: q_m !Mass-to-charge ratio q/m (質量電荷比)
    end type Particle

    !The unitary volume is a cubic space with a magnetic and electric field.

    type UnitaryVolume
        real ::  E_field_x
        real ::  E_field_y
        real ::  E_field_z
        real ::  B_field_x
        real ::  B_field_y
        real ::  B_field_z
    end type UnitaryVolume

    integer :: x_max, y_max, z_max
    integer :: x_min, y_min, z_min
    integer :: x, y, z, n
    integer :: n_particles !the total number of particles to be simulated

    type(UnitaryVolume), dimension(:,:,:), allocatable :: studySpace
    type(Particle), dimension(:), allocatable :: particles

    type(UnitaryVolume) :: cell

    !------------------Runge Kutta declarations------------------

    ! n_equations:number of equations, nsteps:number of steps, tstep:length of steps
    !         y_rk(1): initial position, y_rk(2):initial velocity
    !         E_factor: Electric field component of the differential equation, B_factor : Magnetic field component of the differential equation
    real t_rk, tstep, y_rk(5), E_factor, B_factor
    integer    n_equations, i, j, nsteps

    !..........................!
    !        Parameters        !
    !..........................!

    !Runge-Kutta global parameters
    n_equations=2
    nsteps=300
    tstep=0.1

    !Let's create a 11x11x11 volume

    x_max = 10
    y_max = 10
    z_max = 10

    x_min = 0
    y_min = 0
    z_min = 0

    n_particles = 1;

    !....................!
    !        Init        !
    !....................!

    allocate ( studySpace(x_min:x_max, y_min:y_max, z_min:z_max) )
    DO x = x_min, x_max
        DO y = y_min, y_max
            DO z = z_min, z_max
                studySpace(x,y,z)%E_field_x = 1
                studySpace(x,y,z)%E_field_y = 0
                studySpace(x,y,z)%E_field_z = 0
                studySpace(x,y,z)%B_field_x = 0
                studySpace(x,y,z)%B_field_y = 0
                studySpace(x,y,z)%B_field_z = 10
            END DO
        END DO
    END DO

    !Let's give our particles an initial position and velocity

    allocate (particles(1:n_particles))
    DO n = 1, n_particles
        particles(n)%x_pos = 10
        particles(n)%y_pos = 10
        particles(n)%z_pos = 10
        particles(n)%vx = 1
        particles(n)%vy = 2
        particles(n)%vz = 0
        particles(n)%q_m = 1
    END DO

    Print *, "BackTracking Initialized!"

    !...........................!
    !        Runge-Kutta        !
    !...........................!

    !    Runge Kutta for set of first order differential equations

    DO n = 1, n_particles
        cell = studySpace(FLOOR(particles(n)%x_pos),FLOOR(particles(n)%y_pos),FLOOR(particles(n)%z_pos))
        !For the x direction
        y_rk(1)=particles(n)%x_pos
        y_rk(2)=particles(n)%vx
        E_factor = particles(n)%q_m * cell%E_field_x
        B_factor = particles(n)%q_m * cell%B_field_z * particles(n)%vy
        call runge_kutta(n_equations, nsteps, tstep, y_rk, E_factor, B_factor)
    END DO
    Print *, "Runge Kutta Finished!"

    STOP

end program BackTracking

!------------------------end of main program------------------------

    !........................!
    !        Routines        !
    !........................!

!Runge-Kutta main routine
SUBROUTINE runge_kutta(n_equations, nsteps, tstep, y_rk, E_factor, B_factor)
    IMPLICIT none

    !       declarations
    real t_rk, tstep, y_rk(5)
    integer    n_equations, i, j, nsteps
    real E_factor, B_factor
    !              open file
    OPEN(90, FILE='rungef.dat')
    WRITE (90,*) 0, y_rk(1), y_rk(2)

    !         do loop n steps of Runga-Kutta algorithm
    DO 60 j = 1, nsteps
    t_rk=j*tstep
    call rk4(t_rk, y_rk, tstep, n_equations, E_factor, B_factor)
    WRITE (90,*) t_rk, y_rk(1), y_rk(2)
    60    CONTINUE
    CLOSE(90)

END

!         fourth-order Runge-Kutta subroutine
SUBROUTINE rk4(t_rk, y_rk, tstep, n_equations, E_factor, B_factor)
    IMPLICIT none

    !        declarations
    real DERIV, h, t_rk, tstep, y_rk(5)
    real k1(5), k2(5),k3(5), k4(5), temp1(5), temp2(5), temp3(5)
    real E_factor, B_factor
    integer i, n_equations
    h=tstep/2.0

    DO 10 i = 1,n_equations
    k1(i) = tstep * DERIV(t_rk, y_rk, i, E_factor, B_factor)
    temp1(i) = y_rk(i) + 0.5*k1(i)
    10    CONTINUE

    DO 20 i = 1,n_equations
    k2(i) = tstep * DERIV(t_rk+h, temp1, i, E_factor, B_factor)
    temp2(i) = y_rk(i) + 0.5*k2(i)
    20    CONTINUE

    DO 30 i = 1,n_equations
    k3(i) = tstep * DERIV(t_rk+h, temp2, i, E_factor, B_factor)
    temp3(i) = y_rk(i) + k3(i)
    30    CONTINUE

    DO 40 i = 1,n_equations
    k4(i) = tstep * DERIV(t_rk+tstep, temp3, i, E_factor, B_factor)
    y_rk(i) = y_rk(i) + (k1(i) + (2.*(k2(i) + k3(i))) + k4(i))/6.0
    40    CONTINUE

    RETURN
END

!        function which returns the derivatives
FUNCTION DERIV(t_rk, temp, i, E_factor, B_factor)
    IMPLICIT none

    !        declarations
    real DERIV, t_rk, temp(5)
    real E_factor, B_factor
    integer i

    IF (i .EQ. 1) DERIV=temp(2) !f1
    IF (i .EQ. 2) DERIV=E_factor + B_factor !f2 = q/m x E   Constant speed => DERIV=0
    RETURN
END


        subroutine idz_reconid(m,krank,col,n,list,proj,approx)
c
c       reconstructs the matrix that the routine idzp_id
c       or idzr_id has decomposed, using the columns col
c       of the reconstructed matrix whose indices are listed in list,
c       in addition to the interpolation matrix proj.
c
c       input:
c       m -- first dimension of cols and approx
c       krank -- first dimension of cols and proj; also,
c                n-krank is the second dimension of proj
c       col -- columns of the matrix to be reconstructed
c       n -- second dimension of approx; also,
c            n-krank is the second dimension of proj
c       list(k) -- index of col(1:m,k) in the reconstructed matrix
c                  when k <= krank; in general, list describes
c                  the permutation required for reconstruction
c                  via cols and proj
c       proj -- interpolation matrix
c
c       output:
c       approx -- reconstructed matrix
c
        implicit none
        integer m,n,krank,j,k,l,list(n)
        complex*16 col(m,krank),proj(krank,n-krank),approx(m,n)
c
c
        do j = 1,m
          do k = 1,n
c
            approx(j,list(k)) = 0
c
c           Add in the contributions due to the identity matrix.
c
            if(k .le. krank) then
              approx(j,list(k)) = approx(j,list(k)) + col(j,k)
            endif
c
c           Add in the contributions due to proj.
c
            if(k .gt. krank) then
              if(krank .gt. 0) then
c
                do l = 1,krank
                  approx(j,list(k)) = approx(j,list(k))
     1                              + col(j,l)*proj(l,k-krank)
                enddo ! l
c
              endif
            endif
c
          enddo ! k
        enddo ! j
c
c
        return
        end
c
c
c
c


module a1
implicit none

interface
module elemental real function pi2tau(pi)
  real, intent(in) :: pi
end function pi2tau

module real function get_pi()
end function get_pi
end interface

end module a1

program hierN

use a1
real :: tau, pi

pi = get_pi()

tau = pi2tau(pi)

print *,'pi=',pi,'tau=',tau

end program


! attributes that can be used with ALLOCATABLE are
! DIMENSION (with deferred shape), PRIVATE, PUBLIC, SAVE, TARGET
! POINTER is often used in conjunction with ALLOCATABLE.
! Attributes compatible with POINTER are
! DIMENSION (with deferred shape), OPTIONAL, SAVE, PUBLIC, PRIVATE
!
MODULE attrs_pointer_array
!
  REAL, ALLOCATABLE, PRIVATE, SAVE, TARGET :: a (:, :)
  LOGICAL, SAVE, TARGET, DIMENSION (:), ALLOCATABLE, PUBLIC :: b
  REAL, SAVE, PRIVATE, POINTER, DIMENSION(:,:) :: gp => NULL()
!
  TYPE :: Rec
    PRIVATE
    LOGICAL, DIMENSION (:), ALLOCATABLE, PUBLIC :: a
    REAL, ALLOCATABLE :: b (:, :)
  END TYPE
!
  CONTAINS
!
  SUBROUTINE MySub(n, m, d, c)
  !
    INTEGER n, m
    REAL, OPTIONAL, DIMENSION(:, :), POINTER :: c
    LOGICAL, POINTER :: d(:)
    ALLOCATE(a(n,n))
    ALLOCATE(b(m))
    IF (PRESENT(c)) THEN
      c => a
    ELSE
      c => gp
    ENDIF
    d => b
  !
  END SUBROUTINE
!
END MODULE

PROGRAM prog
USE attrs_pointer_array
!
REAL, POINTER, DIMENSION(:,:) :: pa
LOGICAL, POINTER :: pb(:)
TYPE(Rec), SAVE, POINTER :: p
CALL MySub(2, 3, pb, pa)
CALL MySub(4, 5, pb)
ALLOCATE(p)
ALLOCATE(p%a(6))
pa(6,7) = 7.8
pb(9) = .true.
!
END


! Copyright (c) 2015 Alex Kramer <kramer.alex.kramer@gmail.com>
! See the LICENSE.txt file at the top-level directory of this distribution.

module setup
  ! Setup params, etc.

  use progvars
  use params, only: assign_params, psi0, psik, ek
  use numerics, only: linspace
  use files, only: ensure_dir

  implicit none

  private
  public init

  contains

    subroutine init
      ! Set parameters, allocate and initialize various arrays
      implicit none

      call assign_params
      call ensure_dir(output_dir)
      call allocate_arrays
      call init_grids
      call init_psi
      call init_ek
    end subroutine init

    subroutine allocate_arrays
      ! Allocate arrays
      implicit none

      allocate(x_range(n_x), psi0_arr(n_x))
      allocate(k_range(n_k), ak_arr(n_k), ek_arr(n_k))
      allocate(t_range(n_t))
      allocate(psik_arr(n_x, n_k))
      allocate(psixt_arr(n_x, n_t))

    end subroutine allocate_arrays

    subroutine init_grids
      ! Setup numerical grids
      implicit none

      call linspace(x_min, x_max, x_range, dx)
      call linspace(k_min, k_max, k_range, dk)
      call linspace(t_min, t_max, t_range, dt)
    end subroutine init_grids

    subroutine init_psi
      ! Setup psi0 and psik arrays
      implicit none

      real(dp) :: x, k
      integer :: i_x, i_k

      do i_x = 1, n_x
         x = x_range(i_x)
         psi0_arr(i_x) = psi0(x)

         do i_k = 1, n_k
            k = k_range(i_k)
            psik_arr(i_x, i_k) = psik(x,k)
         end do

      end do

    end subroutine init_psi

    subroutine init_ek
      ! Setup ek array of energies
      implicit none

      real(dp) :: k
      integer :: i_k

      do i_k = 1, n_k
         k = k_range(i_k)
         ek_arr(i_k) = ek(k)
      end do

    end subroutine init_ek

end module setup


*> \brief \b DCHKQR
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
*                          NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC,
*                          B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT )
*
*       .. Scalar Arguments ..
*       LOGICAL            TSTERR
*       INTEGER            NM, NMAX, NN, NNB, NOUT, NRHS
*       DOUBLE PRECISION   THRESH
*       ..
*       .. Array Arguments ..
*       LOGICAL            DOTYPE( * )
*       INTEGER            IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
*      $                   NXVAL( * )
*       DOUBLE PRECISION   A( * ), AC( * ), AF( * ), AQ( * ), AR( * ),
*      $                   B( * ), RWORK( * ), TAU( * ), WORK( * ),
*      $                   X( * ), XACT( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DCHKQR tests DGEQRF, DORGQR and DORMQR.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] DOTYPE
*> \verbatim
*>          DOTYPE is LOGICAL array, dimension (NTYPES)
*>          The matrix types to be used for testing.  Matrices of type j
*>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
*>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*> \endverbatim
*>
*> \param[in] NM
*> \verbatim
*>          NM is INTEGER
*>          The number of values of M contained in the vector MVAL.
*> \endverbatim
*>
*> \param[in] MVAL
*> \verbatim
*>          MVAL is INTEGER array, dimension (NM)
*>          The values of the matrix row dimension M.
*> \endverbatim
*>
*> \param[in] NN
*> \verbatim
*>          NN is INTEGER
*>          The number of values of N contained in the vector NVAL.
*> \endverbatim
*>
*> \param[in] NVAL
*> \verbatim
*>          NVAL is INTEGER array, dimension (NN)
*>          The values of the matrix column dimension N.
*> \endverbatim
*>
*> \param[in] NNB
*> \verbatim
*>          NNB is INTEGER
*>          The number of values of NB and NX contained in the
*>          vectors NBVAL and NXVAL.  The blocking parameters are used
*>          in pairs (NB,NX).
*> \endverbatim
*>
*> \param[in] NBVAL
*> \verbatim
*>          NBVAL is INTEGER array, dimension (NNB)
*>          The values of the blocksize NB.
*> \endverbatim
*>
*> \param[in] NXVAL
*> \verbatim
*>          NXVAL is INTEGER array, dimension (NNB)
*>          The values of the crossover point NX.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand side vectors to be generated for
*>          each linear system.
*> \endverbatim
*>
*> \param[in] THRESH
*> \verbatim
*>          THRESH is DOUBLE PRECISION
*>          The threshold value for the test ratios.  A result is
*>          included in the output file if RESULT >= THRESH.  To have
*>          every test ratio printed, use THRESH = 0.
*> \endverbatim
*>
*> \param[in] TSTERR
*> \verbatim
*>          TSTERR is LOGICAL
*>          Flag that indicates whether error exits are to be tested.
*> \endverbatim
*>
*> \param[in] NMAX
*> \verbatim
*>          NMAX is INTEGER
*>          The maximum value permitted for M or N, used in dimensioning
*>          the work arrays.
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] AF
*> \verbatim
*>          AF is DOUBLE PRECISION array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] AQ
*> \verbatim
*>          AQ is DOUBLE PRECISION array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] AR
*> \verbatim
*>          AR is DOUBLE PRECISION array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] AC
*> \verbatim
*>          AC is DOUBLE PRECISION array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] B
*> \verbatim
*>          B is DOUBLE PRECISION array, dimension (NMAX*NRHS)
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*>          X is DOUBLE PRECISION array, dimension (NMAX*NRHS)
*> \endverbatim
*>
*> \param[out] XACT
*> \verbatim
*>          XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS)
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*>          TAU is DOUBLE PRECISION array, dimension (NMAX)
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is DOUBLE PRECISION array, dimension (NMAX)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (NMAX)
*> \endverbatim
*>
*> \param[in] NOUT
*> \verbatim
*>          NOUT is INTEGER
*>          The unit number for output.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup double_lin
*
*  =====================================================================
      SUBROUTINE DCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
     $                   NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC,
     $                   B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT )
*
*  -- LAPACK test routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      LOGICAL            TSTERR
      INTEGER            NM, NMAX, NN, NNB, NOUT, NRHS
      DOUBLE PRECISION   THRESH
*     ..
*     .. Array Arguments ..
      LOGICAL            DOTYPE( * )
      INTEGER            IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
     $                   NXVAL( * )
      DOUBLE PRECISION   A( * ), AC( * ), AF( * ), AQ( * ), AR( * ),
     $                   B( * ), RWORK( * ), TAU( * ), WORK( * ),
     $                   X( * ), XACT( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            NTESTS
      PARAMETER          ( NTESTS = 9 )
      INTEGER            NTYPES
      PARAMETER          ( NTYPES = 8 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
*     ..
*     .. Local Scalars ..
      CHARACTER          DIST, TYPE
      CHARACTER*3        PATH
      INTEGER            I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
     $                   LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
     $                   NRUN, NT, NX
      DOUBLE PRECISION   ANORM, CNDNUM
*     ..
*     .. Local Arrays ..
      INTEGER            ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
      DOUBLE PRECISION   RESULT( NTESTS )
*     ..
*     .. External Functions ..
      LOGICAL            DGENND
      EXTERNAL           DGENND
*     ..
*     .. External Subroutines ..
      EXTERNAL           ALAERH, ALAHD, ALASUM, DERRQR, DGEQRS, DGET02,
     $                   DLACPY, DLARHS, DLATB4, DLATMS, DQRT01,
     $                   DQRT01P, DQRT02, DQRT03, XLAENV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Scalars in Common ..
      LOGICAL            LERR, OK
      CHARACTER*32       SRNAMT
      INTEGER            INFOT, NUNIT
*     ..
*     .. Common blocks ..
      COMMON             / INFOC / INFOT, NUNIT, OK, LERR
      COMMON             / SRNAMC / SRNAMT
*     ..
*     .. Data statements ..
      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
*     ..
*     .. Executable Statements ..
*
*     Initialize constants and the random number seed.
*
      PATH( 1: 1 ) = 'Double precision'
      PATH( 2: 3 ) = 'QR'
      NRUN = 0
      NFAIL = 0
      NERRS = 0
      DO 10 I = 1, 4
         ISEED( I ) = ISEEDY( I )
   10 CONTINUE
*
*     Test the error exits
*
      IF( TSTERR )
     $   CALL DERRQR( PATH, NOUT )
      INFOT = 0
      CALL XLAENV( 2, 2 )
*
      LDA = NMAX
      LWORK = NMAX*MAX( NMAX, NRHS )
*
*     Do for each value of M in MVAL.
*
      DO 70 IM = 1, NM
         M = MVAL( IM )
*
*        Do for each value of N in NVAL.
*
         DO 60 IN = 1, NN
            N = NVAL( IN )
            MINMN = MIN( M, N )
            DO 50 IMAT = 1, NTYPES
*
*              Do the tests only if DOTYPE( IMAT ) is true.
*
               IF( .NOT.DOTYPE( IMAT ) )
     $            GO TO 50
*
*              Set up parameters with DLATB4 and generate a test matrix
*              with DLATMS.
*
               CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
     $                      CNDNUM, DIST )
*
               SRNAMT = 'DLATMS'
               CALL DLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE,
     $                      CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
     $                      WORK, INFO )
*
*              Check error code from DLATMS.
*
               IF( INFO.NE.0 ) THEN
                  CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, N, -1,
     $                         -1, -1, IMAT, NFAIL, NERRS, NOUT )
                  GO TO 50
               END IF
*
*              Set some values for K: the first value must be MINMN,
*              corresponding to the call of DQRT01; other values are
*              used in the calls of DQRT02, and must not exceed MINMN.
*
               KVAL( 1 ) = MINMN
               KVAL( 2 ) = 0
               KVAL( 3 ) = 1
               KVAL( 4 ) = MINMN / 2
               IF( MINMN.EQ.0 ) THEN
                  NK = 1
               ELSE IF( MINMN.EQ.1 ) THEN
                  NK = 2
               ELSE IF( MINMN.LE.3 ) THEN
                  NK = 3
               ELSE
                  NK = 4
               END IF
*
*              Do for each value of K in KVAL
*
               DO 40 IK = 1, NK
                  K = KVAL( IK )
*
*                 Do for each pair of values (NB,NX) in NBVAL and NXVAL.
*
                  DO 30 INB = 1, NNB
                     NB = NBVAL( INB )
                     CALL XLAENV( 1, NB )
                     NX = NXVAL( INB )
                     CALL XLAENV( 3, NX )
                     DO I = 1, NTESTS
                        RESULT( I ) = ZERO
                     END DO
                     NT = 2
                     IF( IK.EQ.1 ) THEN
*
*                       Test DGEQRF
*
                        CALL DQRT01( M, N, A, AF, AQ, AR, LDA, TAU,
     $                               WORK, LWORK, RWORK, RESULT( 1 ) )

*
*                       Test DGEQRFP
*
                        CALL DQRT01P( M, N, A, AF, AQ, AR, LDA, TAU,
     $                               WORK, LWORK, RWORK, RESULT( 8 ) )

                         IF( .NOT. DGENND( M, N, AF, LDA ) )
     $                       RESULT( 9 ) = 2*THRESH
                        NT = NT + 1
                    ELSE IF( M.GE.N ) THEN
*
*                       Test DORGQR, using factorization
*                       returned by DQRT01
*
                        CALL DQRT02( M, N, K, A, AF, AQ, AR, LDA, TAU,
     $                               WORK, LWORK, RWORK, RESULT( 1 ) )
                     END IF
                     IF( M.GE.K ) THEN
*
*                       Test DORMQR, using factorization returned
*                       by DQRT01
*
                        CALL DQRT03( M, N, K, AF, AC, AR, AQ, LDA, TAU,
     $                               WORK, LWORK, RWORK, RESULT( 3 ) )
                        NT = NT + 4
*
*                       If M>=N and K=N, call DGEQRS to solve a system
*                       with NRHS right hand sides and compute the
*                       residual.
*
                        IF( K.EQ.N .AND. INB.EQ.1 ) THEN
*
*                          Generate a solution and set the right
*                          hand side.
*
                           SRNAMT = 'DLARHS'
                           CALL DLARHS( PATH, 'New', 'Full',
     $                                  'No transpose', M, N, 0, 0,
     $                                  NRHS, A, LDA, XACT, LDA, B, LDA,
     $                                  ISEED, INFO )
*
                           CALL DLACPY( 'Full', M, NRHS, B, LDA, X,
     $                                  LDA )
                           SRNAMT = 'DGEQRS'
                           CALL DGEQRS( M, N, NRHS, AF, LDA, TAU, X,
     $                                  LDA, WORK, LWORK, INFO )
*
*                          Check error code from DGEQRS.
*
                           IF( INFO.NE.0 )
     $                        CALL ALAERH( PATH, 'DGEQRS', INFO, 0, ' ',
     $                                     M, N, NRHS, -1, NB, IMAT,
     $                                     NFAIL, NERRS, NOUT )
*
                           CALL DGET02( 'No transpose', M, N, NRHS, A,
     $                                  LDA, X, LDA, B, LDA, RWORK,
     $                                  RESULT( 7 ) )
                           NT = NT + 1
                        END IF
                     END IF
*
*                    Print information about the tests that did not
*                    pass the threshold.
*
                     DO 20 I = 1, NTESTS
                        IF( RESULT( I ).GE.THRESH ) THEN
                           IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
     $                        CALL ALAHD( NOUT, PATH )
                           WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX,
     $                        IMAT, I, RESULT( I )
                           NFAIL = NFAIL + 1
                        END IF
   20                CONTINUE
                     NRUN = NRUN + NTESTS
   30             CONTINUE
   40          CONTINUE
   50       CONTINUE
   60    CONTINUE
   70 CONTINUE
*
*     Print a summary of the results.
*
      CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
 9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=',
     $      I5, ', type ', I2, ', test(', I2, ')=', G12.5 )
      RETURN
*
*     End of DCHKQR
*
      END


MODULE FAST_SELECT
  USE ISO_FORTRAN_ENV, ONLY: REAL64, INT64
  USE SWAP, ONLY: SWAP_I64, SWAP_R64
  IMPLICIT NONE

CONTAINS
  ! ------------------------------------------------------------------
  !                       FastSelect method
  !
  ! Given VALUES list of numbers, rearrange the elements of VALUES
  ! such that the element at index K has rank K (holds its same
  ! location as if all of VALUES were sorted). Symmetrically rearrange
  ! array INDICES to keep track of prior indices.
  !
  ! This algorithm uses the same conceptual approach as Floyd-Rivest,
  ! but instead of standard-deviation based selection of bounds for
  ! recursion, a rank-based method is used to pick the subset of
  ! values that is searched. This simplifies the code and improves
  ! interpretability, while achieving the same tunable performance.
  !
  ! Arguments:
  !
  !   VALUES   --  A 1D array of real numbers.
  !   INDICES  --  A 1D array of original indices for elements of VALUES.
  !   K        --  A positive integer for the rank index about which
  !                VALUES should be rearranged.
  ! Optional:
  !
  !   DIVISOR  --  A positive integer >= 2 that represents the
  !                division factor used for large VALUES arrays.
  !   MAX_SIZE --  An integer >= DIVISOR that represents the largest
  !                sized VALUES for which the worst-case pivot value
  !                selection is tolerable. A worst-case pivot causes
  !                O( SIZE(VALUES)^2 ) runtime. This value should be
  !                determined heuristically based on compute hardware.
  !
  ! Output:
  !
  !   The elements of the array VALUES are rearranged such that the
  !   element at position VALUES(K) is in the same location it would
  !   be if all of VALUES were in sorted order. Also known as,
  !   VALUES(K) has rank K.
  !
  RECURSIVE SUBROUTINE ARGSELECT_R64(VALUES, INDICES, K, DIVISOR, MAX_SIZE)
    ! Arguments
    REAL(KIND=REAL64), INTENT(INOUT), DIMENSION(:) :: VALUES
    INTEGER(KIND=INT64), INTENT(INOUT), DIMENSION(:) :: INDICES
    INTEGER(KIND=INT64), INTENT(IN)                  :: K
    INTEGER(KIND=INT64), INTENT(IN), OPTIONAL        :: DIVISOR, MAX_SIZE
    ! Locals
    INTEGER(KIND=INT64) :: LEFT, RIGHT, L, R, MS, D
    REAL(KIND=REAL64) :: P
    ! Initialize the divisor (for making subsets).
    IF (PRESENT(DIVISOR)) THEN ; D = DIVISOR
    ELSE IF (SIZE(VALUES) .GE. 2**23) THEN ; D = 2**5
    ELSE IF (SIZE(VALUES) .GE. 2**20) THEN ; D = 2**3
    ELSE                                   ; D = 2**2
    END IF
    ! Initialize the max size (before subsets are created).
    IF (PRESENT(MAX_SIZE)) THEN ; MS = MAX_SIZE
    ELSE                        ; MS = 2**10
    END IF
    ! Initialize LEFT and RIGHT to be the entire array.
    LEFT = 1
    RIGHT = SIZE(VALUES)
    ! Loop until done finding the K-th element.
    DO WHILE (LEFT .LT. RIGHT)
       ! Use SELECT recursively to improve the quality of the
       ! selected pivot value for large arrays.
       IF (RIGHT - LEFT .GT. MS) THEN
          ! Compute how many elements should be left and right of K
          ! to maintain the same percentile in a subset.
          L = K - K / D
          R = L + (SIZE(VALUES) / D)
          ! Perform fast select on an array a fraction of the size about K.
          CALL ARGSELECT_R64(VALUES(L:R), INDICES(L:R), K - L + 1, DIVISOR, MAX_SIZE)
       END IF
       ! Pick a partition element at position K.
       P = VALUES(K)
       L = LEFT
       R = RIGHT
       ! Move the partition element to the front of the list.
       CALL SWAP_R64(VALUES(LEFT), VALUES(K))
       CALL SWAP_I64(INDICES(LEFT), INDICES(K))
       ! Pre-swap the left and right elements (temporarily putting a
       ! larger element on the left) before starting the partition loop.
       IF (VALUES(RIGHT) .GT. P) THEN
          CALL SWAP_R64(VALUES(LEFT), VALUES(RIGHT))
          CALL SWAP_I64(INDICES(LEFT), INDICES(RIGHT))
       END IF
       ! Now partition the elements about the pivot value "T".
       DO WHILE (L .LT. R)
          CALL SWAP_R64(VALUES(L), VALUES(R))
          CALL SWAP_I64(INDICES(L), INDICES(R))
          L = L + 1
          R = R - 1
          DO WHILE (VALUES(L) .LT. P) ; L = L + 1 ; END DO
          DO WHILE (VALUES(R) .GT. P) ; R = R - 1 ; END DO
       END DO
       ! Place the pivot element back into its appropriate place.
       IF (VALUES(LEFT) .EQ. P) THEN
          CALL SWAP_R64(VALUES(LEFT), VALUES(R))
          CALL SWAP_I64(INDICES(LEFT), INDICES(R))
       ELSE
          R = R + 1
          CALL SWAP_R64(VALUES(R), VALUES(RIGHT))
          CALL SWAP_I64(INDICES(R), INDICES(RIGHT))
       END IF
       ! adjust left and right towards the boundaries of the subset
       ! containing the (k - left + 1)th smallest element
       IF (R .LE. K) LEFT = R + 1
       IF (K .LE. R) RIGHT = R - 1
    END DO
  END SUBROUTINE ARGSELECT_R64

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

  RECURSIVE SUBROUTINE ARGSELECT_I64(VALUES, INDICES, K, DIVISOR, MAX_SIZE)
    ! Arguments
    INTEGER(KIND=INT64), INTENT(INOUT), DIMENSION(:) :: VALUES
    INTEGER(KIND=INT64), INTENT(INOUT), DIMENSION(:) :: INDICES
    INTEGER(KIND=INT64), INTENT(IN)                  :: K
    INTEGER(KIND=INT64), INTENT(IN), OPTIONAL        :: DIVISOR, MAX_SIZE
    ! Locals
    INTEGER(KIND=INT64) :: LEFT, RIGHT, L, R, MS, D, P
    ! Initialize the divisor (for making subsets).
    IF (PRESENT(DIVISOR)) THEN ; D = DIVISOR
    ELSE IF (SIZE(VALUES) .GE. 2**23) THEN ; D = 2**5
    ELSE IF (SIZE(VALUES) .GE. 2**20) THEN ; D = 2**3
    ELSE                                   ; D = 2**2
    END IF
    ! Initialize the max size (before subsets are created).
    IF (PRESENT(MAX_SIZE)) THEN ; MS = MAX_SIZE
    ELSE                        ; MS = 2**10
    END IF
    ! Initialize LEFT and RIGHT to be the entire array.
    LEFT = 1
    RIGHT = SIZE(VALUES)
    ! Loop until done finding the K-th element.
    DO WHILE (LEFT .LT. RIGHT)
       ! Use SELECT recursively to improve the quality of the
       ! selected pivot value for large arrays.
       IF (RIGHT - LEFT .GT. MS) THEN
          ! Compute how many elements should be left and right of K
          ! to maintain the same percentile in a subset.
          L = K - K / D
          R = L + (SIZE(VALUES) / D)
          ! Perform fast select on an array a fraction of the size about K.
          CALL ARGSELECT_I64(VALUES(L:R), INDICES(L:R), K - L + 1, DIVISOR, MAX_SIZE)
       END IF
       ! Pick a partition element at position K.
       P = VALUES(K)
       L = LEFT
       R = RIGHT
       ! Move the partition element to the front of the list.
       CALL SWAP_I64(VALUES(LEFT), VALUES(K))
       CALL SWAP_I64(INDICES(LEFT), INDICES(K))
       ! Pre-swap the left and right elements (temporarily putting a
       ! larger element on the left) before starting the partition loop.
       IF (VALUES(RIGHT) .GT. P) THEN
          CALL SWAP_I64(VALUES(LEFT), VALUES(RIGHT))
          CALL SWAP_I64(INDICES(LEFT), INDICES(RIGHT))
       END IF
       ! Now partition the elements about the pivot value "T".
       DO WHILE (L .LT. R)
          CALL SWAP_I64(VALUES(L), VALUES(R))
          CALL SWAP_I64(INDICES(L), INDICES(R))
          L = L + 1
          R = R - 1
          DO WHILE (VALUES(L) .LT. P) ; L = L + 1 ; END DO
          DO WHILE (VALUES(R) .GT. P) ; R = R - 1 ; END DO
       END DO
       ! Place the pivot element back into its appropriate place.
       IF (VALUES(LEFT) .EQ. P) THEN
          CALL SWAP_I64(VALUES(LEFT), VALUES(R))
          CALL SWAP_I64(INDICES(LEFT), INDICES(R))
       ELSE
          R = R + 1
          CALL SWAP_I64(VALUES(R), VALUES(RIGHT))
          CALL SWAP_I64(INDICES(R), INDICES(RIGHT))
       END IF
       ! adjust left and right towards the boundaries of the subset
       ! containing the (k - left + 1)th smallest element
       IF (R .LE. K) LEFT = R + 1
       IF (K .LE. R) RIGHT = R - 1
    END DO
  END SUBROUTINE ARGSELECT_I64
  ! ------------------------------------------------------------------

END MODULE FAST_SELECT


c     =================================================
      subroutine cellave2(blockno,xlow,ylow,dx,dy,wl)
c     =================================================
      implicit none

      double precision xlow, ylow, dx, dy, wl
      integer blockno

      integer i, iv

      external fss, zeroin, fdisc
      double precision zeroin, fss, fdisc
      logical fl(5),alll,allr
      double precision x(10),y(10),xx(5),yy(5)
      double precision xc0, yc0, xc1, yc1, ss, area
      common/fsscorn/ xc0,yc0,xc1,yc1
c
c     # compute wl, fraction of cell that lies in left state.
c     # For initial data with two states ql and qr separated by a
c     # discontinuity. The curve along which the discontinuity lies is
c     # specified by the function fdisc, which should return a value that
c     # is negative on the side where ql lies and positive on the qr side.
c
c     # xlow,ylow is the coordinate of the lower left corner of the cell.
c     # dx, dy are grid spacing in x and y.
c
      xx(1) = xlow
      xx(2) = xlow
      xx(3) = xlow+dx
      xx(4) = xlow+dx
      xx(5) = xx(1)
      yy(1) = ylow
      yy(2) = ylow+dy
      yy(3) = ylow+dy
      yy(4) = ylow
      yy(5) = yy(1)
      alll = .true.
      allr = .true.
c
      do 20 i=1,4

         fl(i) = fdisc(blockno,xx(i),yy(i)) .lt. 0.d0
         alll = alll .and. fl(i)
         allr = allr .and. (.not. fl(i))
   20    continue
      fl(5) = fl(1)
c
      if (alll) then
         wl = 1.d0
         return
         endif
      if (allr) then
         wl = 0.d0
         return
         endif
c
      iv = 0
      do 40 i=1,4
          if (fl(i)) then
               iv = iv+1
               x(iv) = xx(i)
               y(iv) = yy(i)
               endif
          if (fl(i).neqv.fl(i+1)) then
               iv = iv+1
               xc0 = xx(i)
               yc0 = yy(i)
               xc1 = xx(i+1)
               yc1 = yy(i+1)
               ss = zeroin(blockno,0.d0, 1.d0, fss, 1d-8)
c              write(27,*) 'xc,yc,ss:',xc0,yc0,xc1,yc1,ss
               x(iv) = xx(i) + ss*(xx(i+1)-xx(i))
               y(iv) = yy(i) + ss*(yy(i+1)-yy(i))
               endif
   40     continue
c
c     # compute area:
c
      if (iv.eq.0) then
         wl = 0.d0
         return
         endif
c
      x(iv+1) = x(1)
      y(iv+1) = y(1)
      area = 0.d0
      do 50 i=1,iv
         area = area + .5d0*(y(i)+y(i+1))*(x(i+1)-x(i))
c        write(27,*) '  x,y:',x(i),y(i)
   50    continue
c
      wl = area / (dx*dy)
c     write(27,*) 'area,wl:',area,wl
c
      return
      end
c
c
c
c
c
c     =================================================
      double precision function fss(blockno,s)
c     =================================================
      implicit none

      double precision xc0, yc0, xc1, yc1, x, y, s, fdisc
      integer blockno
      common/fsscorn/ xc0,yc0,xc1,yc1
c
c     # compute fdisc at distance s between corners (xc0,yc0) and (xc1,yc1)
c
      x = xc0 + s*(xc1-xc0)
      y = yc0 + s*(yc1-yc0)
      fss = fdisc(blockno,x,y)
      return
      end

c     =================================================
      double precision function zeroin(blockno,ax,bx,f,tol)
c     =================================================
      implicit none

      external f
      double precision ax, bx, f, tol, eps, tol1, a, b, fa, fb
      integer blockno
      double precision c, fc, d, e, xm, s, p, q, r
c
c      a zero of the function  f(x)  is computed in the interval ax,bx .
c      (Standard routine from netlib)
c
c  input..
c
c  ax     left endpoint of initial interval
c  bx     right endpoint of initial interval
c  f      function subprogram which evaluates f(x) for any x in
c         the interval  ax,bx
c  tol    desired length of the interval of uncertainty of the
c         final result ( .ge. 0.0)
c
c
c  output..
c
c  zeroin abcissa approximating a zero of  f  in the interval ax,bx
c
c
c      it is assumed  that   f(ax)   and   f(bx)   have  opposite  signs
c  without  a  check.  zeroin  returns a zero  x  in the given interval
c  ax,bx  to within a tolerance  4*macheps*dabs(x) + tol, where macheps
c  is the relative machine precision.
c      this function subprogram is a slightly  modified  translation  of
c  the algol 60 procedure  zero  given in  richard brent, algorithms for
c  minimization without derivatives, prentice - hall, inc. (1973).
c
c
c
c  compute eps, the relative machine precision
c
      eps = 1.d0
   10 eps = eps/2.d0
      tol1 = 1.0 + eps
      if (tol1 .gt. 1.d0) go to 10
c
c initialization
c
      a = ax
      b = bx
      fa = f(blockno,a)
      fb = f(blockno,b)
c
c begin step
c
   20 c = a
      fc = fa
      d = b - a
      e = d
   30 if (dabs(fc) .ge. dabs(fb)) go to 40
      a = b
      b = c
      c = a
      fa = fb
      fb = fc
      fc = fa
c
c convergence test
c
   40 tol1 = 2.d0*eps*abs(b) + 0.5d0*tol
      xm = .5d0*(c - b)
      if (abs(xm) .le. tol1) go to 90
      if (fb .eq. 0.d0) go to 90
c
c is bisection necessary
c
      if (abs(e) .lt. tol1) go to 70
      if (abs(fa) .le. abs(fb)) go to 70
c
c is quadratic interpolation possible
c
      if (a .ne. c) go to 50
c
c linear interpolation
c
      s = fb/fa
      p = 2.0*xm*s
      q = 1.0 - s
      go to 60
c
c inverse quadratic interpolation
c
   50 q = fa/fc
      r = fb/fc
      s = fb/fa
      p = s*(2.d0*xm*q*(q - r) - (b - a)*(r - 1.d0))
      q = (q - 1.d0)*(r - 1.0)*(s - 1.d0)
c
c adjust signs
c
   60 if (p .gt. 0.d0) q = -q
      p = abs(p)
c
c is interpolation acceptable
c
      if ((2.d0*p) .ge. (3.d0*xm*q - abs(tol1*q))) go to 70
      if (p .ge. abs(0.5d0*e*q)) go to 70
      e = d
      d = p/q
      go to 80
c
c bisection
c
   70 d = xm
      e = d
c
c complete step
c
   80 a = b
      fa = fb
      if (abs(d) .gt. tol1) b = b + d
c     # DAC : NO 'sign' function in g95 (11/28/2005)
c      if (abs(d) .le. tol1) b = b + sign(tol1,xm)
      if (abs(d) .le. tol1) then
         if (xm .ge. 0) then
            b = b + tol1
         else
            b = b - xm
         endif
      endif
      fb = f(blockno,b)
      if ((fb*(fc/abs(fc))) .gt. 0.d0) go to 20
      go to 30
c
c done
c
   90 zeroin = b
      return
      end