MODULE test_module
!  Purpose:
!    To illustrate the use of assumed-shape arrays.
!
CONTAINS

   SUBROUTINE test_array(array)
   IMPLICIT NONE
   REAL, DIMENSION(:,:) :: array     ! Assumed-shape array
   INTEGER :: i1, i2                 ! Bounds of first dimension
   INTEGER :: j1, j2                 ! Bounds of second dimension

   ! Get details about array.
   i1 = LBOUND(array,1)
   i2 = UBOUND(array,1)
   j1 = LBOUND(array,2)
   j2 = UBOUND(array,2)
   WRITE (*,100) i1, i2, j1, j2
   100 FORMAT (1X,'The bounds are: (',I2,':',I2,',',I2,':',I2,')')
   WRITE (*,110) SHAPE(array)
   110 FORMAT (1X,'The shape is:    ',2I4)
   WRITE (*,120) SIZE(array)
   120 FORMAT (1X,'The size is:     ',I4)
   END SUBROUTINE test_array

END MODULE test_module

PROGRAM assumed_shape
!
!  Purpose:
!    To illustrate the use of assumed-shape arrays.
!
USE test_module
IMPLICIT NONE

! Declare local variables
REAL, DIMENSION(-5:5,-5:5) :: a = 0. ! Array a
REAL, DIMENSION(10,2) :: b = 1.      ! Array b

! Call test_array with array a.
WRITE (*,*) 'Calling test_array with array a:'
CALL test_array(a)

! Call test_array with array b.
WRITE (*,*) 'Calling test_array with array b:'
CALL test_array(b)

END PROGRAM assumed_shape


!
! Author: Henrique Miranda
! Build an octree to find nearest negihbour points
!
module m_octree

  implicit none

  integer,parameter :: dp=8
  real(dp),parameter :: zero=0.0_dp,half=0.5_dp,one=1.0_dp,two=2.0_dp
  real(dp),parameter :: tol12=0.000000000001_dp
  real(dp),protected :: shifts(3,2,8)

  type :: octree_node_t
    type(octree_node_t),pointer :: childs(:) ! if node this is allocated
    integer,allocatable :: ids(:)            ! if leaf this is allocated
  end type octree_node_t

  type :: octree_t
    real(dp) :: hi(3)
    real(dp) :: lo(3)
    integer :: max_npoints
    real(dp),pointer :: points(:,:)
    type(octree_node_t) :: first
  end type octree_t

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

  contains
  type(octree_t) function octree_init(points,max_npoints,lo,hi) result (new)
    integer,intent(in) :: max_npoints
    real(dp), target, intent(in) :: points(:,:)
    real(dp), intent(in) :: lo(3), hi(3)
    real,parameter :: ieps = 0.1
    integer,allocatable :: ids(:)
    integer :: ii, jj, kk, npoints, ioctant

    ! determine shifts
    do ii=0,1
      do jj=0,1
        do kk=0,1
          ioctant = ii*4+jj*2+kk+1
          shifts(:,1,ioctant) = [half*ii,half*jj,half*kk]
          shifts(:,2,ioctant) = shifts(:,1,ioctant) + [half,half,half]
        end do
      end do
    end do

    ! box dimensions
    new%lo = lo
    new%hi = hi

    !first octree contains all the points
    npoints = size(points,2)
    new%points => points
    new%max_npoints = max_npoints
    ids = [(ii,ii=1,npoints)]
    new%first = octree_node_build(new,new%lo,new%hi,npoints,ids)

  end function octree_init

  type(octree_node_t) recursive function octree_node_build(octree,lo,hi,nids,ids) result (new)
    type(octree_t),intent(in) :: octree
    integer,intent(in) :: nids
    integer,intent(in) :: ids(nids)
    integer :: id, counter, ioctant, ipoint
    integer :: octants(nids)
    integer :: new_ids(nids)
    real(dp) :: lo(3), hi(3), new_lo(3), new_hi(3)

    ! check if this is a leaf node
    if (nids<octree%max_npoints) then
      allocate(new%ids(nids))
      new%ids = ids(:nids)
      return
    end if

    !determine the octants of each point
    call get_octants(lo,hi,nids,ids,octree%points,octants)

    allocate(new%childs(8))
    do ioctant=1,8
      ! How many points are in this octant?
      counter = 0
      do id=1,nids
        ipoint = ids(id)
        if (octants(id) /= ioctant) cycle
        counter = counter + 1
        new_ids(counter) = ipoint
      end do
      ! Build this octant
      call get_lo_hi(lo,hi,new_lo,new_hi,ioctant)
      new%childs(ioctant) = octree_node_build(octree,new_lo,new_hi,counter,new_ids)
    end do

  end function octree_node_build

  integer function octree_find(octree,point,dist) result(closest_id)
    ! Find the closest point in the box that contains it
    type(octree_t),target,intent(in) :: octree
    real(dp),intent(in) :: point(3)
    real(dp),intent(out) :: dist
    type(octree_node_t),pointer :: octn
    integer :: id, ipoint, ioctant
    real(dp) :: hi(3),lo(3),hi_out(3),lo_out(3)
    real(dp) :: trial_dist

    closest_id = 0
    dist = huge(dist)
    octn => octree%first
    lo = octree%lo
    hi = octree%hi

    !check if the point is inside the initial box
    trial_dist = box_dist(lo,hi,point)
    if (trial_dist>0) then
      closest_id = -1
      return
    end if

    do
      ! if leaf node
      if (allocated(octn%ids)) then
        do id=1,size(octn%ids)
          ipoint = octn%ids(id)
          trial_dist = dist_points(octree%points(:,ipoint),point)
          if (trial_dist > dist) cycle
          dist = trial_dist
          closest_id = ipoint
        end do
        return
      end if
      ! get octant of this point
      ioctant = get_octant_lohi(lo,hi,point)
      ! point to this node
      octn => octn%childs(ioctant)
      ! get lo and hi
      call get_lo_hi(lo,hi,lo_out,hi_out,ioctant)
      lo = lo_out; hi = hi_out
    end do
  end function octree_find

  integer function octree_find_nearest(octree,point,dist) result(nearest_id)
    ! Find the ids of the points whose distance to point is smaller than max_dist
    ! counter is the number of points found so far
    type(octree_t),target,intent(in) :: octree
    real(dp),intent(in) :: point(3)
    real(dp),intent(inout) :: dist
    !check if the point is inside the initial box
    dist = box_dist(octree%lo,octree%hi,point)
    if (dist>0) then
      nearest_id = -1
      return
    end if
    nearest_id = octn_find_nearest(octree,octree%first,octree%lo,octree%hi,point,dist)
  end function octree_find_nearest

  integer recursive function octn_find_nearest(octree,octn,lo,hi,point,min_dist) result(closest_id)
    ! find the nearest point by recursion
    type(octree_t),intent(in) :: octree
    type(octree_node_t),intent(in) :: octn
    real(dp),intent(in) :: point(3)
    real(dp),intent(in) :: lo(3), hi(3)
    real(dp),intent(inout) :: min_dist
    real(dp) :: new_lo(3), new_hi(3)
    real(dp) :: dist
    integer :: id, ioctant, ipoint, trial_id
    closest_id = 0
    ! compute distance of point to this box (octant)
    dist = box_dist(lo,hi,point)
    ! if the distance is bigger than the closest point so far return
    if (dist>min_dist) return
    ! if this node is a leaf compare point by point
    if (allocated(octn%ids)) then
      do id=1,size(octn%ids)
        ipoint = octn%ids(id)
        dist = dist_points(octree%points(:,ipoint),point)
        if (dist>min_dist) cycle
        min_dist = dist
        closest_id = ipoint
      end do
      return
    end if
    ! if this is a node then find the nearest for all the childs
    do ioctant=1,8
      call get_lo_hi(lo,hi,new_lo,new_hi,ioctant)
      trial_id = octn_find_nearest(octree,octn%childs(ioctant),new_lo,new_hi,point,min_dist)
      if (trial_id==0) cycle
      closest_id = trial_id
    end do
  end function octn_find_nearest

  integer function octree_find_nearest_pbc(octree,point,dist,shift) result(id)
    ! Same as octree find but using periodic boundary conditions
    type(octree_t),target,intent(in) :: octree
    real(dp),intent(in) :: point(3)
    real(dp),intent(inout) :: dist
    real(dp),intent(out) :: shift(3)
    logical :: found
    integer :: trial_id, first_id
    integer :: ii,jj,kk
    real(dp) :: trial_dist
    real(dp) :: first_shift(3), trial_shift(3)
    real(dp) :: po(3)
    ! bring the point inside the box
    po = modulo(point,one)
    ! compute shift
    first_shift = po-point
    first_id = octn_find_nearest(octree,octree%first,octree%lo,octree%hi,po,dist)
    id = first_id
    ! try unitary shifts
    found=.false.
    do ii=-1,1
      do jj=-1,1
        do kk=-1,1
          if (ii==0.and.jj==0.and.kk==0) cycle
          trial_shift = first_shift+[ii,jj,kk]
          ! compute shortest distance
          trial_dist = dist+tol12
          trial_id = octn_find_nearest(octree,octree%first,octree%lo,octree%hi,&
                                       point+trial_shift,trial_dist)
          ! if smaller than previous distance, store this shift and distance
          if (trial_dist>dist) cycle
          found = .true.
          dist  = trial_dist
          id    = trial_id
          shift = trial_shift
        end do
      end do
    end do
    if (.not.found) shift = first_shift
  end function octree_find_nearest_pbc

  integer recursive function octn_free(octn) result(ierr)
    type(octree_node_t) :: octn
    integer :: ioctant
    ! if leaf deallocate ids
    if (allocated(octn%ids)) then
      deallocate(octn%ids,stat=ierr)
    else
      do ioctant=1,8
        ierr = octn_free(octn%childs(ioctant))
      end do
    end if
  end function octn_free

  integer function octree_free(octree) result(ierr)
    ! Free octree datastructure
    type(octree_t),target,intent(in) :: octree
    ierr = octn_free(octree%first)
  end function octree_free

  pure real(dp) function dist_points(p1,p2) result(dist)
    real(dp),intent(in) :: p1(3),p2(3)
    dist = pow2(p1(1)-p2(1))+&
           pow2(p1(2)-p2(2))+&
           pow2(p1(3)-p2(3))
  end function dist_points

  pure logical function box_contains(lo,hi,po) result(inside)
    ! Find box that contains point
    real(dp),intent(in) :: lo(3), hi(3), po(3)
    inside = (po(1)>lo(1).and.po(1)<hi(1).and.&
              po(2)>lo(2).and.po(2)<hi(2).and.&
              po(3)>lo(3).and.po(3)<hi(3))
  end function box_contains

  pure real(dp) function box_dist(lo,hi,po) result(dist)
    ! Find the distance between point and the box
    real(dp),intent(in) :: lo(3), hi(3), po(3)
    dist = zero
    if (po(1)<lo(1)) dist = dist + pow2(po(1)-lo(1))
    if (po(1)>hi(1)) dist = dist + pow2(po(1)-hi(1))
    if (po(2)<lo(2)) dist = dist + pow2(po(2)-lo(2))
    if (po(2)>hi(2)) dist = dist + pow2(po(2)-hi(2))
    if (po(3)<lo(3)) dist = dist + pow2(po(3)-lo(3))
    if (po(3)>hi(3)) dist = dist + pow2(po(3)-hi(3))
  end function box_dist

  pure real(dp) function pow2(x) result(x2)
    real(dp),intent(in) :: x
    x2 = x*x
  end function pow2

  pure integer function get_octant(mi,po) result(ioctant)
    real(dp),intent(in) :: po(3), mi(3)
    integer :: ii,jj,kk
    ii = 0; if (po(1)>=mi(1)) ii = 1
    jj = 0; if (po(2)>=mi(2)) jj = 1
    kk = 0; if (po(3)>=mi(3)) kk = 1
    ioctant = ii*4+jj*2+kk+1
  end function get_octant

  pure integer function get_octant_lohi(lo,hi,po) result(ioctant)
    real(dp),intent(in) :: lo(3),hi(3),po(3)
    real(dp) :: mi(3)
    mi = half*(hi+lo)
    ioctant = get_octant(mi,po)
  end function get_octant_lohi

  pure subroutine get_octants(lo,hi,nids,ids,points,octants)
    ! From a list of points return the corresponding octant
    real(dp),intent(in) :: lo(3), hi(3)
    real(dp),intent(in) :: points(:,:)
    integer,intent(in) :: nids
    integer,intent(in) :: ids(nids)
    integer,intent(out) :: octants(nids)
    real(dp) :: mi(3)
    integer :: id, ipoint
    ! calculate midpoint
    mi = half*(hi+lo)
    do id=1,nids
      ipoint = ids(id)
      octants(id) = get_octant(mi,points(:,ipoint))
    end do
  end subroutine get_octants

  pure subroutine get_lo_hi(lo_in,hi_in,lo_out,hi_out,ioctant)
    ! Subdivide a box in an octant
    integer,intent(in) :: ioctant
    real(dp),intent(in) :: lo_in(3), hi_in(3)
    real(dp),intent(out) :: lo_out(3), hi_out(3)
    real(dp) :: de(3)
    de = hi_in-lo_in
    lo_out = lo_in + shifts(:,1,ioctant)*de
    hi_out = lo_in + shifts(:,2,ioctant)*de
  end subroutine get_lo_hi

end module m_octree

program octree_main

  use m_octree
  implicit none

  type(octree_t) :: oct
  integer,parameter :: n = 100**3
  integer :: id,ipoint
  real(dp) :: points(3,n)
  real(dp) :: start_time,stop_time
  real(dp) :: dist

  test_octree_init: block
    call random_number(points)
    !do ipoint=1,n
    !  write(*,'(i3,3f12.6)') ipoint, points(:,ipoint)
    !end do

    call cpu_time(start_time)
    oct = octree_init(points,2**4,[-one,-one,-one],[two,two,two])
    call cpu_time(stop_time)
    write(*,'(a30,f12.6,a)') 'octree init took:',stop_time-start_time,' [s]'
  end block test_octree_init

  test_octree_find: block
    call cpu_time(start_time)
    do ipoint=1,n
      id = octree_find(oct,points(:,ipoint),dist)
      if (id/=ipoint) call error('wrong point')
    end do
    call cpu_time(stop_time)
    write(*,'(a30,f12.6,a)') 'octree find took:',(stop_time-start_time), ' [s]'
  end block test_octree_find

  test_octree_find_nearest: block
    call cpu_time(start_time)
    do ipoint=1,n
      dist = zero
      ! find nearest point
      id = octree_find_nearest(oct,points(:,ipoint),dist)
      if (id/=ipoint) call error('wrong point')
    end do
    call cpu_time(stop_time)
    write(*,'(a30,f12.6,a)') 'octree find_nearest took:',(stop_time-start_time), ' [s]'
  end block test_octree_find_nearest

  test_octree_find_nearest_pbc: block
    integer :: ii,jj,kk
    integer :: naive_ipoint, iprobe
    real(dp) :: naive_dist, trial_dist
    real(dp) :: naive_shift(3), trial_shift(3), shift(3), point(3)
    call cpu_time(start_time)
    do ipoint=1,n
      dist = tol12
      ! find nearest point
      id = octree_find_nearest_pbc(oct,points(:,ipoint),dist,shift)
      if (id/=ipoint) call error('wrong point')
    end do
    call cpu_time(stop_time)
    write(*,'(a30,f12.6,a)') 'octree find_nearest_pbc took:',(stop_time-start_time), ' [s]'

    ! now compare with a naive approach
    call cpu_time(start_time)
    do iprobe=1,10
      naive_dist = huge(naive_dist)
      naive_ipoint = -1
      ! generate random point between -1 and 1
      call random_number(point)
      point = point*two-one
      ! find nearest point considering periodic boundary conditions
      id = octree_find(oct,point,dist)
      id = octree_find_nearest_pbc(oct,point,dist,shift)
      ! now find it naively
      trial_dist  = huge(trial_dist)
      naive_shift = huge(naive_shift)
      do ii=-2,2
        do jj=-2,2
          do kk=-2,2
            do ipoint=1,size(points,2)
              trial_shift = [ii,jj,kk]
              trial_dist = dist_points(points(:,ipoint),point+trial_shift)
              if (trial_dist>naive_dist) cycle
              naive_dist   = trial_dist
              naive_ipoint = ipoint
              naive_shift  = trial_shift
            end do
          end do
        end do
      end do
      if (id<1)                    call error('did not find point')
      if (id/=naive_ipoint)        call error('wrong point')
      if (any(shift/=naive_shift)) call error('wrong shift')
    end do
    call cpu_time(stop_time)
    write(*,'(a30,f12.6,a)') 'naive took:',(stop_time-start_time), ' [s]'
  end block test_octree_find_nearest_pbc

  test_octree_free: block
    integer :: ierr
    call cpu_time(start_time)
    ierr = octree_free(oct)
    call cpu_time(stop_time)
    write(*,'(a30,f12.6,a)') 'octree free took:',(stop_time-start_time), ' [s]'
  end block test_octree_free

  contains
  subroutine error(msg)
   character(len=*),intent(in) :: msg
   write(*,*) msg
   call exit(1)
  end subroutine
end program octree_main


program test_convert_ubt_and_wbv
  use mod_orrb
  implicit none
  !
  ! Note: This does not cover large rank cases (e.g. ubw=n-1).
  !
  character(len=40) :: test_name
  character(len=*), parameter :: fmt="(A40, 'Time: ',ES8.2,', lbw: ',I3,', ubw: ', I3,', error: ',ES8.2, ', ', A10)"

  real(kind=dp) :: t0, t1
  integer(kind=int32) :: na, ubwa, lbwa
  type(error_info) :: error
  real(kind=dp), parameter :: tol=3e-15, c=2.0
  !
  real(kind=dp), dimension(:,:), allocatable :: a0_d, a1_d
  complex(kind=dp), dimension(:,:), allocatable :: a0_z, a1_z

  type(d_wbv), allocatable :: wbv_d
  type(z_wbv), allocatable :: wbv_z
  type(d_ubt), allocatable :: ubt_d
  type(z_ubt), allocatable :: ubt_z

  call initialize_errors

  print *
  print *, "--------------------------------"
  print *
  print *, "Real WBV and UBT Conversion Tests:"
  print *
  na=40
  lbwa=5; ubwa=3
  wbv_d=d_random_wbv(na,lbwa,ubwa,error=error)
  a0_d=general(wbv_d,error)
  call cpu_time(t0)
  ubt_d=ubt_of(wbv_d,error)
  call cpu_time(t1)
  a1_d=general(ubt_d,error)
  test_name = "Real WBV to UBT, n=40;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,ubt_d%lbw, &
       ubwa, ubt_d%ubw, t0,t1,c*tol,error)

  na=1
  lbwa=0; ubwa=0
  wbv_d=d_random_wbv(na,lbwa,ubwa,error=error)
  a0_d=general(wbv_d,error)
  call cpu_time(t0)
  ubt_d=ubt_of(wbv_d,error)
  call cpu_time(t1)
  a1_d=general(ubt_d,error)
  test_name = "Real WBV to UBT, n=1;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,ubt_d%lbw, &
       ubwa, ubt_d%ubw, t0,t1,c*tol,error)

  na=2
  lbwa=1; ubwa=1
  wbv_d=d_random_wbv(na,lbwa,ubwa,error=error)
  a0_d=general(wbv_d,error)
  call cpu_time(t0)
  ubt_d=ubt_of(wbv_d,error)
  call cpu_time(t1)
  a1_d=general(ubt_d,error)
  test_name = "Real WBV to UBT, n=2;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,ubt_d%lbw, &
       ubwa, ubt_d%ubw, t0,t1,c*tol,error)

  na=3
  lbwa=1; ubwa=1
  wbv_d=d_random_wbv(na,lbwa,ubwa,error=error)
  a0_d=general(wbv_d,error)
  call cpu_time(t0)
  ubt_d=ubt_of(wbv_d,error)
  call cpu_time(t1)
  a1_d=general(ubt_d,error)
  test_name = "Real WBV to UBT, n=3;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,ubt_d%lbw, &
       ubwa, ubt_d%ubw, t0,t1,c*tol,error)

  na=4
  lbwa=2; ubwa=2
  wbv_d=d_random_wbv(na,lbwa,ubwa,error=error)
  a0_d=general(wbv_d,error)
  call cpu_time(t0)
  ubt_d=ubt_of(wbv_d,error)
  call cpu_time(t1)
  a1_d=general(ubt_d,error)
  test_name = "Real WBV to UBT, n=4;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,ubt_d%lbw, &
       ubwa, ubt_d%ubw, t0,t1,c*tol,error)
  print *

  na=40
  lbwa=5; ubwa=3
  ubt_d=d_random_ubt(na,lbwa,ubwa,error=error)
  a0_d=general(ubt_d,error)
  call cpu_time(t0)
  wbv_d=wbv_of(ubt_d,error)
  call cpu_time(t1)
  a1_d=general(wbv_d,error)
  test_name = "Real UBT to WBV, n=40;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,wbv_d%lbw, &
       ubwa, wbv_d%ubw, t0,t1,c*tol,error)

  na=1
  lbwa=0; ubwa=0
  ubt_d=d_random_ubt(na,lbwa,ubwa,error=error)
  a0_d=general(ubt_d,error)
  call cpu_time(t0)
  wbv_d=wbv_of(ubt_d,error)
  call cpu_time(t1)
  a1_d=general(wbv_d,error)
  test_name = "Real UBT to WBV, n=1;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,wbv_d%lbw, &
       ubwa, wbv_d%ubw, t0,t1,c*tol,error)

  na=2
  lbwa=1; ubwa=1
  ubt_d=d_random_ubt(na,lbwa,ubwa,error=error)
  a0_d=general(ubt_d,error)
  call cpu_time(t0)
  wbv_d=wbv_of(ubt_d,error)
  call cpu_time(t1)
  a1_d=general(wbv_d,error)
  test_name = "Real UBT to WBV, n=2;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,wbv_d%lbw, &
       ubwa, wbv_d%ubw, t0,t1,c*tol,error)

  na=3
  lbwa=1; ubwa=1
  ubt_d=d_random_ubt(na,lbwa,ubwa,error=error)
  a0_d=general(ubt_d,error)
  call cpu_time(t0)
  wbv_d=wbv_of(ubt_d,error)
  call cpu_time(t1)
  a1_d=general(wbv_d,error)
  test_name = "Real UBT to WBV, n=3;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,wbv_d%lbw, &
       ubwa, wbv_d%ubw, t0,t1,c*tol,error)

  na=4
  lbwa=2; ubwa=2
  ubt_d=d_random_ubt(na,lbwa,ubwa,error=error)
  a0_d=general(ubt_d,error)
  call cpu_time(t0)
  wbv_d=wbv_of(ubt_d,error)
  call cpu_time(t1)
  a1_d=general(wbv_d,error)
  test_name = "Real UBT to WBV, n=4;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,wbv_d%lbw, &
       ubwa, wbv_d%ubw, t0,t1,c*tol,error)

  print *
  print *, "--------------------------------"
  print *
  print *, "Complex WBV and UBT Conversion Tests:"
  print *

  na=40
  lbwa=5; ubwa=3
  wbv_z=z_random_wbv(na,lbwa,ubwa,error=error)
  a0_z=general(wbv_z,error)
  call cpu_time(t0)
  ubt_z=ubt_of(wbv_z,error)
  call cpu_time(t1)
  a1_z=general(ubt_z,error)
  test_name = "Complex WBV to UBT, n=40;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,ubt_z%lbw, &
       ubwa, ubt_z%ubw, t0,t1,c*tol,error)

  na=1
  lbwa=0; ubwa=0
  wbv_z=z_random_wbv(na,lbwa,ubwa,error=error)
  a0_z=general(wbv_z,error)
  call cpu_time(t0)
  ubt_z=ubt_of(wbv_z,error)
  call cpu_time(t1)
  a1_z=general(ubt_z,error)
  test_name = "Complex WBV to UBT, n=1;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,ubt_z%lbw, &
       ubwa, ubt_z%ubw, t0,t1,c*tol,error)

  na=2
  lbwa=1; ubwa=1
  wbv_z=z_random_wbv(na,lbwa,ubwa,error=error)
  a0_z=general(wbv_z,error)
  call cpu_time(t0)
  ubt_z=ubt_of(wbv_z,error)
  call cpu_time(t1)
  a1_z=general(ubt_z,error)
  test_name = "Complex WBV to UBT, n=2;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,ubt_z%lbw, &
       ubwa, ubt_z%ubw, t0,t1,c*tol,error)

  na=3
  lbwa=1; ubwa=1
  wbv_z=z_random_wbv(na,lbwa,ubwa,error=error)
  a0_z=general(wbv_z,error)
  call cpu_time(t0)
  ubt_z=ubt_of(wbv_z,error)
  call cpu_time(t1)
  a1_z=general(ubt_z,error)
  test_name = "Complex WBV to UBT, n=3;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,ubt_z%lbw, &
       ubwa, ubt_z%ubw, t0,t1,c*tol,error)

  na=4
  lbwa=2; ubwa=2
  wbv_z=z_random_wbv(na,lbwa,ubwa,error=error)
  a0_z=general(wbv_z,error)
  call cpu_time(t0)
  ubt_z=ubt_of(wbv_z,error)
  call cpu_time(t1)
  a1_z=general(ubt_z,error)
  test_name = "Complex WBV to UBT, n=4;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,ubt_z%lbw, &
       ubwa, ubt_z%ubw, t0,t1,c*tol,error)
  print *

  na=40
  lbwa=5; ubwa=3
  ubt_z=z_random_ubt(na,lbwa,ubwa,error=error)
  a0_z=general(ubt_z,error)
  call cpu_time(t0)
  wbv_z=wbv_of(ubt_z,error)
  call cpu_time(t1)
  a1_z=general(wbv_z,error)
  test_name = "Complex UBT to WBV, n=40;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,wbv_z%lbw, &
       ubwa,wbv_z%ubw,t0,t1,c*tol,error)

  na=1
  lbwa=0; ubwa=0
  ubt_z=z_random_ubt(na,lbwa,ubwa,error=error)
  a0_z=general(ubt_z,error)
  call cpu_time(t0)
  wbv_z=wbv_of(ubt_z,error)
  call cpu_time(t1)
  a1_z=general(wbv_z,error)
  test_name = "Complex UBT to WBV, n=1;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,wbv_z%lbw, &
       ubwa,wbv_z%ubw,t0,t1,c*tol,error)

  na=2
  lbwa=1; ubwa=1
  ubt_z=z_random_ubt(na,lbwa,ubwa,error=error)
  a0_z=general(ubt_z,error)
  call cpu_time(t0)
  wbv_z=wbv_of(ubt_z,error)
  call cpu_time(t1)
  a1_z=general(wbv_z,error)
  test_name = "Complex UBT to WBV, n=2;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,wbv_z%lbw, &
       ubwa,wbv_z%ubw,t0,t1,c*tol,error)

  na=3
  lbwa=1; ubwa=1
  ubt_z=z_random_ubt(na,lbwa,ubwa,error=error)
  a0_z=general(ubt_z,error)
  call cpu_time(t0)
  wbv_z=wbv_of(ubt_z,error)
  call cpu_time(t1)
  a1_z=general(wbv_z,error)
  test_name = "Complex UBT to WBV, n=3;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,wbv_z%lbw, &
       ubwa,wbv_z%ubw,t0,t1,c*tol,error)

  na=4
  lbwa=2; ubwa=2
  ubt_z=z_random_ubt(na,lbwa,ubwa,error=error)
  a0_z=general(ubt_z,error)
  call cpu_time(t0)
  wbv_z=wbv_of(ubt_z,error)
  call cpu_time(t1)
  a1_z=general(wbv_z,error)
  test_name = "Complex UBT to WBV, n=4;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,wbv_z%lbw, &
       ubwa,wbv_z%ubw,t0,t1,c*tol,error)

contains

  subroutine d_output_result(name,a0,a1,lbw0,lbw1,ubw0,ubw1,t0,t1,bnd,error)
    character(len=*) :: name
    real(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: lbw0, lbw1, ubw0, ubw1
    type(error_info) :: error

    real(kind=dp) :: berr
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       berr = maxabs(a1-a0)
       if (lbw0==lbw1 .and. ubw0==ubw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, lbw1, ubw1, berr, test_result
    end if
  end subroutine d_output_result

  subroutine z_output_result(name,a0,a1,lbw0,lbw1,ubw0,ubw1,t0,t1,bnd,error)
    character(len=*) :: name
    complex(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: lbw0, lbw1, ubw0, ubw1
    type(error_info) :: error

    real(kind=dp) :: berr
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       berr = maxabs(a1-a0)
       if (lbw0==lbw1 .and. ubw0==ubw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, lbw1, ubw1, berr, test_result
    end if
  end subroutine z_output_result

end program test_convert_ubt_and_wbv


!========================================================================
!
!                   S P E C F E M 2 D  Version 7 . 0
!                   --------------------------------
!
!     Main historical authors: Dimitri Komatitsch and Jeroen Tromp
!                        Princeton University, USA
!                and CNRS / University of Marseille, France
!                 (there are currently many more authors!)
! (c) Princeton University and CNRS / University of Marseille, April 2014
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
! using a spectral-element method (SEM).
!
! This software is governed by the CeCILL license under French law and
! abiding by the rules of distribution of free software. You can use,
! modify and/or redistribute the software under the terms of the CeCILL
! license as circulated by CEA, CNRS and Inria at the following URL
! "http://www.cecill.info".
!
! As a counterpart to the access to the source code and rights to copy,
! modify and redistribute granted by the license, users are provided only
! with a limited warranty and the software's author, the holder of the
! economic rights, and the successive licensors have only limited
! liability.
!
! In this respect, the user's attention is drawn to the risks associated
! with loading, using, modifying and/or developing or reproducing the
! software by the user in light of its specific status of free software,
! that may mean that it is complicated to manipulate, and that also
! therefore means that it is reserved for developers and experienced
! professionals having in-depth computer knowledge. Users are therefore
! encouraged to load and test the software's suitability as regards their
! requirements in conditions enabling the security of their systems and/or
! data to be ensured and, more generally, to use and operate it in the
! same conditions as regards security.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

  subroutine compute_arrays_source(ispec_selected_source,xi_source,gamma_source,sourcearray, &
             Mxx,Mzz,Mxz,xix,xiz,gammax,gammaz,xigll,zigll,nspec)

  use specfem_par, only : AXISYM,is_on_the_axis,xiglj

  implicit none

  include "constants.h"

  integer ispec_selected_source
  integer nspec

  double precision xi_source,gamma_source
  double precision Mxx,Mzz,Mxz

  real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz

  real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ) :: sourcearray

  double precision xixd,xizd,gammaxd,gammazd

! Gauss-Lobatto-Legendre points of integration and weights
  double precision, dimension(NGLLX) :: xigll
  double precision, dimension(NGLLZ) :: zigll

! source arrays
  double precision, dimension(NGLLX,NGLLZ) :: G11,G13,G31,G33
  double precision, dimension(NGLLX) :: hxis,hpxis
  double precision, dimension(NGLLZ) :: hgammas,hpgammas

  integer k,m
  integer ir,iv

! calculate G_ij for general source location
! the source does not necessarily correspond to a Gauss-Lobatto point
  do m=1,NGLLZ
      do k=1,NGLLX

        xixd    = xix(k,m,ispec_selected_source)
        xizd    = xiz(k,m,ispec_selected_source)
        gammaxd = gammax(k,m,ispec_selected_source)
        gammazd = gammaz(k,m,ispec_selected_source)

        G11(k,m) = Mxx*xixd+Mxz*xizd
        G13(k,m) = Mxx*gammaxd+Mxz*gammazd
        G31(k,m) = Mxz*xixd+Mzz*xizd
        G33(k,m) = Mxz*gammaxd+Mzz*gammazd

!!!!        G21(k,m) = Mxy*xixd+Myz*xizd
!!!!        G23(k,m) = Mxy*gammaxd+Myz*gammazd

      enddo
  enddo

! compute Lagrange polynomials at the source location

  if (AXISYM) then
    if(is_on_the_axis(ispec_selected_source)) then ! TODO verify if we have to add : .and. is_proc_source(i)
      call lagrange_any(xi_source,NGLJ,xiglj,hxis,hpxis)
    else
      call lagrange_any(xi_source,NGLLX,xigll,hxis,hpxis)
    endif
  else
    call lagrange_any(xi_source,NGLLX,xigll,hxis,hpxis)
  endif

  call lagrange_any(gamma_source,NGLLZ,zigll,hgammas,hpgammas)

! calculate source array
  do m=1,NGLLZ
    do k=1,NGLLX

      sourcearray(:,k,m) = ZERO

      do iv=1,NGLLZ
        do ir=1,NGLLX

          sourcearray(1,k,m) = sourcearray(1,k,m) + hxis(ir)*hgammas(iv) &
                                 *(G11(ir,iv)*hpxis(k)*hgammas(m) &
                                 +G13(ir,iv)*hxis(k)*hpgammas(m))

!        sourcearray(2,k,m) = sourcearray(2,k,m) + hxis(ir)*hgammas(iv) &
!                               *(G21(ir,iv)*hpxis(k)*hgammas(m) &
!                               +G23(ir,iv)*hxis(k)*hpgammas(m))

          sourcearray(2,k,m) = sourcearray(2,k,m) + hxis(ir)*hgammas(iv) &
                                 *(G31(ir,iv)*hpxis(k)*hgammas(m) &
                                 +G33(ir,iv)*hxis(k)*hpgammas(m))

        enddo
      enddo

    enddo
  enddo

  end subroutine compute_arrays_source

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

 subroutine compute_arrays_adj_source(xi_rec,gamma_rec)

 use constants
 use specfem_par

 implicit none

  double precision xi_rec, gamma_rec
  logical :: st !YY

  integer icomp, itime, i, k
  double precision :: junk
  character(len=3) :: comp(3)

  adj_sourcearray(:,:,:,:) = 0.

  if(seismotype == 1 .or. seismotype == 2 .or. seismotype == 3) then

  comp = (/"BXX","BXY","BXZ"/)

  do icomp = 1,3

   filename = 'SEM/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'

   inquire(file=filename,exist=st) !YY
   ! if file exist  !YY
   if(st) then   !YY

    open(unit = IIN, file = trim(filename), iostat = ios)
    if (ios /= 0) call exit_MPI(' file '//trim(filename)//'does not exist')

    do itime = 1, NSTEP
      read(IIN,*) junk, adj_src_s(itime,icomp)
    enddo
    close(IIN)

   else     !YY
     adj_src_s(:,icomp) = 0.0 !YY
   endif !YY

  enddo

  source_adjointe(irec_local,:,2) = adj_src_s(:,3)

  else if (seismotype == 4 ) then

    filename = 'SEM/'//trim(adj_source_file) // '.PRE.adj'
    open(unit = IIN, file = trim(filename), iostat = ios)
    if (ios /= 0) call exit_MPI(' file '//trim(filename)//'does not exist')

    do itime = 1, NSTEP
      read(IIN,*) junk, adj_src_s(itime,1)
    enddo
    close(IIN)

  else if (seismotype == 6 ) then

    filename = 'SEM/'//trim(adj_source_file) // '.POT.adj'
    open(unit = IIN, file = trim(filename), iostat = ios)
    if (ios /= 0) call exit_MPI(' file '//trim(filename)//'does not exist')

    do itime = 1, NSTEP
      read(IIN,*) junk, adj_src_s(itime,1)
    enddo
    close(IIN)

  endif

  source_adjointe(irec_local,:,1) = adj_src_s(:,1)

  if (AXISYM) then
    if(is_on_the_axis(ispec_selected_rec(irec_local))) then ! TODO verify irec_local...
      call lagrange_any(xi_rec,NGLJ,xiglj,hxir,hpxir)
    else
      call lagrange_any(xi_rec,NGLLX,xigll,hxir,hpxir)
    endif
  else
    call lagrange_any(xi_rec,NGLLX,xigll,hxir,hpxir)
  endif

  call lagrange_any(gamma_rec,NGLLZ,zigll,hgammar,hpgammar)

  do k = 1, NGLLZ
      do i = 1, NGLLX
        adj_sourcearray(:,:,i,k) = sngl(hxir(i) * hgammar(k)) * adj_src_s(:,:)
      enddo
  enddo

end subroutine compute_arrays_adj_source


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C   Copyright (C) 1995-2004, Scientific Computing Division,
C   University Corporation for Atmospheric Research
C   Licensed under the GNU General Public License (GPL)
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id: costmi.f,v 1.2 2006-11-21 01:10:17 haley Exp $
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE DCOSTMI(N,WSAVE,LENSAV,IER)
      DOUBLE PRECISION PI
      DOUBLE PRECISION DT
      DOUBLE PRECISION FK
      INTEGER N,LENSAV,IER
      DOUBLE PRECISION WSAVE(LENSAV)
C
      IER = 0
C
      IF (LENSAV.LT.2*N+INT(LOG(DBLE(N)))+4) THEN
          IER = 2
          CALL DXERFFT('COSTMI',3)
          GO TO 300
      END IF
C
      IF (N.LE.3) RETURN
      NM1 = N - 1
      NP1 = N + 1
      NS2 = N/2
      PI = 4.D0*ATAN(1.D0)
      DT = PI/DBLE(NM1)
      FK = 0.D0
      DO 101 K = 2,NS2
          KC = NP1 - K
          FK = FK + 1.D0
          WSAVE(K) = 2.D0*SIN(FK*DT)
          WSAVE(KC) = 2.D0*COS(FK*DT)
  101 CONTINUE
      LNSV = NM1 + INT(LOG(DBLE(NM1))) + 4
      CALL DRFFTMI(NM1,WSAVE(N+1),LNSV,IER1)
      IF (IER1.NE.0) THEN
          IER = 20
          CALL DXERFFT('COSTMI',-5)
      END IF
  300 CONTINUE
      RETURN
      END


      subroutine rtaylr(delxi,drer0,drir0,jreac,nord,nrct,nrctmx,
     $ nrd1mx,rirec0,rirecp,rrelr0,rrelrp)
c
c     This subroutine evaluates Taylor's series expansions for the
c     inverse rate and the relative rates of all irreversible reactions.
c
c     Compare with:
c
c       EQ6/ataylr.f
c       EQ6/ptaylr.f
c       EQ6/ztaylr.f
c
c     This subroutine is called by:
c
c       EQ6/path.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       delxi  = the step size (in reaction progress)
c       drer0  = the relative rate derivative vector at the base point
c       drir0  = the inverse rate derivative vector at the base point
c       nord   = the order of the truncated Taylor's series
c       nrd1mx = the maximum order of the truncated Taylor's series + 1
c       nrct   = the number of reactants
c       nrctmx = the maximum number of reactants
c       rirec0 = the inverse rate at the base point
c       rrelr0 = the relative rate vector at the base point
c
c     Principal output:
c
c       rirecp = the inverse rate at the new point
c       rrelrp = the relative rate vector at the new point
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer nrctmx,nrd1mx
c
      integer jreac(nrctmx)
c
      integer nord,nrct
c
      real*8 drer0(nrd1mx,nrctmx),drir0(nrd1mx),rrelr0(nrctmx),
     $ rrelrp(nrctmx)
c
      real*8 delxi,rirecp,rirec0
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer n,nrc
c
      real*8 dxp,rx
c
      real*8 fctrl
c
c-----------------------------------------------------------------------
c
      rirecp = rirec0
      dxp = 1.
      do n = 1,nord
        dxp = dxp*delxi
        rirecp = rirecp + ( drir0(n)/fctrl(n) )*dxp
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      do nrc = 1,nrct
        rx = 0.
        if (jreac(nrc) .eq. 0) then
          rx = rrelr0(nrc)
          dxp = 1.
          do n = 1,nord
            dxp = dxp*delxi
            rx = rx + ( drer0(n,nrc)/fctrl(n) )*dxp
          enddo
        endif
        rrelrp(nrc) = rx
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      end


!
!  Copyright 2016 ARTED developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
subroutine hpsi1_RT_stencil(A,B,C,D,E,F)
  use global_variables, only: NL
  use opt_variables,    only: zifdt
  implicit none
  real(8),intent(in)     :: A
  real(8),intent(in)     :: B(0:NL-1)
  real(8),intent(in)     :: C(12)
  real(8),intent(in)     :: D(12)
  complex(8),intent(in)  :: E(0:NL-1)
  complex(8),intent(out) :: F(0:NL-1)
  complex(8),parameter   :: zI = (0.d0, 1.d0)

  integer    :: i,j
  complex(8) :: v,w

#define IDX zifdt

#ifdef __INTEL_COMPILER
!dir$ vector nontemporal(F)
#endif
#ifdef __FUJITSU
!OCL simd
!OCL noalias
#endif
  do i=0,NL-1
    v = 0
    w = 0

    do j=1,12
      v = v + C(j) * (E(IDX(j,i)) + E(IDX(j+12,i)))
      w = w + D(j) * (E(IDX(j,i)) - E(IDX(j+12,i)))
    end do

    F(i) = B(i)*E(i) + A*E(i) - 0.5d0*v - zI*w
  end do
end subroutine


      PROGRAM GAMTST
C------------------------------------------------------------------
C FORTRAN 77 program to test GAMMA or DGAMMA
C
C   Method:
C
C      Accuracy tests compare function values against values
C      generated with the duplication formula.
C
C   Data required
C
C      None
C
C   Subprograms required from this package
C
C     MACHAR - An environmental inquiry program providing
C              information on the floating-point arithmetic
C              system.  Note that the call to MACHAR can
C              be deleted provided the following five
C              parameters are assigned the values indicated
C
C              IBETA  - The radix of the floating-point system
C              IT     - The number of base-ibeta digits in the
C                       significant of a floating-point number
C              EPS    - The smallest positive floating-point
C                       number such that 1.0+EPS .NE. 1.0
C              XMIN   - The smallest non-vanishing floating-point
C                       integral power of the radix
C              XMAX   - The largest finite floating-point number
C
C     REN(K) - A function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C      ABS, DBLE, INT, LOG, MAX, REAL, SQRT
C
C  Reference: "Performance evaluation of programs related
C              to the real gamma function", W. J. Cody,
C              submitted for publication.
C
C  Latest modification: March 12, 1992
C
C  Authors: W. J. Cody and L. Stoltz
C           Mathematics and Computer Science Division
C           Argonne National Laboratory
C           Argonne, IL 60439
C
C--------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,IOUT,IRND,IT,J,JT,K1,K2,K3,
     1        MACHEP,MAXEXP,MINEXP,N,NEGEP,NGRD,NX
CS    REAL  GAMMA,
      DOUBLE PRECISION  DGAMMA,
     1    A,AIT,ALBETA,ALNX,B,BETA,C,CL,CONV,C1,C2,DEL,EPS,
     2    EPSNEG,FUNC,HALF,ONE,REN,R6,R7,TEN,TWO,W,X,XC,XL,
     3    XMAX,XMIN,XMINV,XN,XNUM,XXN,XP,XPH,X99,XP99,Y,Z,ZERO,ZZ
CS    DATA C1,C2/2.8209479177387814347E-1,9.1893853320467274178E-1/,
CS   1     ZERO,HALF,ONE,TWO,TEN/0.0E0,0.5E0,1.0E0,2.0E0,10.0E0/,
CS   2     X99,XP99/-999.0E0,0.99E0/
      DATA C1,C2/2.8209479177387814347D-1,9.1893853320467274178D-1/,
     1     ZERO,HALF,ONE,TWO,TEN/0.0D0,0.5D0,1.0D0,2.0D0,10.0D0/,
     2     X99,XP99/-999.0D0,0.99D0/
      DATA IOUT/6/
C------------------------------------------------------------------
C  Statement functions for conversion
C------------------------------------------------------------------
CS    CONV(I) = REAL(I)
      CONV(I) = DBLE(I)
CS    FUNC(X) = GAMMA(X)
      FUNC(X) = DGAMMA(X)
C------------------------------------------------------------------
C  Determine machine parameters and set constants
C------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      A = ZERO
      B = TWO
      N = 2000
      XN = CONV(N)
      JT = 0
C-----------------------------------------------------------------
C  Determine smallest argument for GAMMA
C-----------------------------------------------------------------
      IF (XMIN*XMAX .LT. ONE) THEN
            XMINV = ONE/XMAX
         ELSE
            XMINV = XMIN
      END IF
C-----------------------------------------------------------------
C  Determine largest argument for GAMMA by Newton iteration
C-----------------------------------------------------------------
      CL = LOG(XMAX)
      XP = HALF * CL
      CL = C2 - CL
   50 X = XP
         ALNX = LOG(X)
         XNUM = (X-HALF)*ALNX - X + CL
         XP = X - XNUM/(ALNX-HALF/X)
         IF (ABS(XP-X)/X .GE. TEN*EPS) GO TO 50
      CL = XP
C-----------------------------------------------------------------
C  Random argument accuracy tests
C-----------------------------------------------------------------
      DO 300 J = 1, 4
         K1 = 0
         K3 = 0
         XC = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
C-----------------------------------------------------------------
C  Use duplication formula for X not close to the zero
C-----------------------------------------------------------------
            XPH = X * HALF + HALF
            XP = XPH - HALF
            X = XP + XP
            NX = INT(X)
            XXN = CONV(NX)
            C = (TWO ** NX) * (TWO ** (X-XXN))
            Z = FUNC(X)
            ZZ = ((C*C1)*FUNC(XP)) * FUNC(XPH)
C--------------------------------------------------------------------
C  Accumulate results
C--------------------------------------------------------------------
            W = (Z - ZZ) / Z
            IF (W .GT. ZERO) THEN
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN
                  K3 = K3 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  XC = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C------------------------------------------------------------------
C  Gather and print statistics for test
C------------------------------------------------------------------
         K2 = N - K3 - K1
         R7 = SQRT(R7/XN)
         WRITE (IOUT,1000)
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(ABS(R6))/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1021) R6,IBETA,W,XC
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(ABS(R7))/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C------------------------------------------------------------------
C  Initialize for next test
C------------------------------------------------------------------
         A = B
         IF (J .EQ. 1) THEN
               B = TEN
            ELSE IF (J .EQ. 2) THEN
               B = CL - HALF
            ELSE
               A = -(TEN-HALF) * HALF
               B = A + HALF
         END IF
  300 CONTINUE
C-----------------------------------------------------------------
C  Special tests
C  First test with special arguments
C-----------------------------------------------------------------
      WRITE (IOUT,1025)
      WRITE (IOUT,1040)
      X = -HALF
      Y = FUNC(X)
      WRITE (IOUT,1041) X, Y
      X = XMINV / XP99
      Y = FUNC(X)
      WRITE (IOUT,1041) X, Y
      X = ONE
      Y = FUNC(X)
      WRITE (IOUT,1041) X, Y
      X = TWO
      Y = FUNC(X)
      WRITE (IOUT,1041) X, Y
      X = CL * XP99
      Y = FUNC(X)
      WRITE (IOUT,1041) X, Y
C-----------------------------------------------------------------
C  Test of error returns
C-----------------------------------------------------------------
      WRITE (IOUT,1050)
      X = -ONE
      WRITE (IOUT,1052) X
      Y = FUNC(X)
      WRITE (IOUT,1061) Y
      X = ZERO
      WRITE (IOUT,1052) X
      Y = FUNC(X)
      WRITE (IOUT,1061) Y
      X = XMINV * (ONE - EPS)
      WRITE (IOUT,1052) X
      Y = FUNC(X)
      WRITE (IOUT,1061) Y
      X = CL * (ONE + EPS)
      WRITE (IOUT,1052) X
      Y = FUNC(X)
      WRITE (IOUT,1061) Y
      WRITE (IOUT,1100)
      STOP
C-----------------------------------------------------------------
 1000 FORMAT('1Test of GAMMA(X) vs Duplication Formula'//)
 1010 FORMAT(I7,' Random arguments were tested from the interval (',
     1    F7.3,',',F7.3,')'//)
 1011 FORMAT(' GAMMA(X) was larger',I6,' times,'/
     1    13X,' agreed',I6,' times, and'/
     2    9X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number'//)
 1021 FORMAT(' The maximum relative error of',E15.4E3,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6E3)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4E3,
     1    ' = ',I4,' **',F7.2)
 1025 FORMAT('1Special Tests'//)
 1040 FORMAT(//' Test of special arguments'//)
 1041 FORMAT(' GAMMA (',E13.6E3,') = ',E13.6E3//)
 1050 FORMAT('1Test of Error Returns'///)
 1052 FORMAT(' GAMMA will be called with the argument',E13.6E3,/
     1    ' This should trigger an error message'//)
 1061 FORMAT(' GAMMA returned the value',E13.6E3///)
 1100 FORMAT(' This concludes the tests')
C---------- Last line of GAMMA test program ----------
      END


      SUBROUTINE CFNOR2 (RIGHT,LEFT,SIZE2,OPTION,RI)
C
C     CFNOR2 IS A DOUBLE-PRECISION ROUTINE (CREATED FOR USE BY
C     THE COMPLEX FEER METHOD) WHICH NORMALIZES A COMPLEX PAIR
C     OF VECTORS TO MAGNITUDE UNITY
C
C     DEFINITION OF INPUT PARAMETERS
C
C     RIGHT    = ORIGINAL RIGHT-HANDED COMPLEX DOUBLE PRECISION VECTOR
C     LEFT     = ORIGINAL LEFT -HANDED COMPLEX DOUBLE PRECISION VECTOR
C     SIZE2    = LENGTH OF EITHER VECTOR IN DOUBLE PRECISION WORDS
C                (I.E., TWICE THE LENGTH OF THE COMPLEX VECTORS)
C     OPTION   = 0  NORMALIZE THE INPUT VECTORS, AND OUTPUT THE
C                   SQUARE ROOT OF THE INNER PRODUCT IN RI(2)
C              = 1  ONLY OUTPUT INNER-PRODUCT, IN RI(2)
C              = 2  ONLY OUTPUT SQUARE ROOT OF INNER-PRODUCT, IN RI(2)
C
C     DEFINITION OF OUTPUT PARAMETERS
C
C     RIGHT    = NORMALIZED RIGHT-HANDED VECTOR
C     LEFT     = NORMALIZED LEFT -HANDED VECTOR
C     RI       = INNER-PRODUCT, OR SQUARE ROOT OF INNER-PRODUCT (SEE
C                OPTION)
C
      LOGICAL          SKIP     ,QPR
      INTEGER          SIZE2    ,OPTION
      DOUBLE PRECISION RIGHT(1) ,LEFT(1)  ,RI(2)    ,RSQRT    ,
     1                 THETA2   ,RJ(2)
      CHARACTER        UFM*23   ,UWM*25
      COMMON  /XMSSG / UFM      ,UWM
      COMMON  /FEERXC/ DUMXC(21),QPR
      COMMON  /SYSTEM/ KSYSTM(65)
      EQUIVALENCE      (KSYSTM(2),NOUT)
C
      SKIP = .FALSE.
C
C     COMPUTE INNER PRODUCT (LEFT*RIGHT)
C
    5 RI(1) = 0.D0
      RI(2) = 0.D0
      DO 10 I = 1,SIZE2,2
      J = I + 1
      RI(1) = RI(1) + LEFT(I)*RIGHT(I) - LEFT(J)*RIGHT(J)
   10 RI(2) = RI(2) + LEFT(J)*RIGHT(I) + LEFT(I)*RIGHT(J)
      IF (OPTION .EQ. 1) GO TO 50
      IF (SKIP) GO TO 200
C
C     COMPUTE MAGNITUDE OF SQUARE ROOT
C
      RSQRT = DSQRT(DSQRT(RI(1)**2 + RI(2)**2))
      IF (RSQRT .GT. 0.D0) GO TO 30
      WRITE  (NOUT,20) UWM
   20 FORMAT (A25,' 3162', //5X,'ATTEMPT TO NORMALIZE NULL VECTOR. ',
     1        'NO ACTION TAKEN.'//)
      GO TO 50
C
C     COMPUTE MODULUS OF SQUARE ROOT
C
   30 THETA2 = .5D0*DATAN2(RI(2),RI(1))
C
C     COMPUTE REAL AND IMAGINARY PARTS OF SQUARE ROOT OF INNER PRODUCT
C
      RI(1) = RSQRT*DCOS(THETA2)
      RI(2) = RSQRT*DSIN(THETA2)
      IF (OPTION .EQ. 2) GO TO 50
      RJ(1) = RI(1)
      RJ(2) = RI(2)
C
C     INVERT THE ABOVE COMPLEX NUMBER (THETA2 IS DUMMY)
C
      THETA2= 1.D0/(RI(1)**2 + RI(2)**2)
      RI(1) = RI(1)*THETA2
      RI(2) =-RI(2)*THETA2
C
C     NORMALIZE THE INPUT VECTORS
C
      DO 40 I = 1,SIZE2,2
      J = I + 1
      THETA2   = RIGHT(I)
      RIGHT(I) = RI(1)*RIGHT(I) - RI(2)*RIGHT(J)
      RIGHT(J) = RI(2)*THETA2   + RI(1)*RIGHT(J)
      THETA2   = LEFT(I)
      LEFT(I)  = RI(1)*LEFT(I)  - RI(2)*LEFT(J)
   40 LEFT(J)  = RI(2)*THETA2   + RI(1)*LEFT(J)
C
C     ----------- SPECIAL PRINT ----------------------------------------
      IF (.NOT.QPR) GO TO 45
      SKIP = .TRUE.
      GO TO 5
  200 THETA2 = DSQRT(RI(1)**2 + RI(2)**2)
      WRITE  (NOUT,300) THETA2,RI
  300 FORMAT (3H --,32(4H----), /,7H CFNOR2,26X,
     1       16HOUTPUT MAGNITUDE,D16.8,8X,2D16.8, /,3H --,32(4H----))
      WRITE  (NOUT,400) (RIGHT(I),I=1,SIZE2)
  400 FORMAT ((1H ,4D25.16))
      WRITE  (NOUT,500)
  500 FORMAT (3H --,32(4H----))
      WRITE  (NOUT,400) (LEFT(I),I=1,SIZE2)
      WRITE  (NOUT,500)
C     ------------------------------------------------------------------
C
   45 RI(1) = RJ(1)
      RI(2) = RJ(2)
   50 RETURN
      END


!*==dgelsd.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  DGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DGELSD + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
!                          WORK, LWORK, IWORK, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
!       DOUBLE PRECISION   RCOND
!       ..
!       .. Array Arguments ..
!       INTEGER            IWORK( * )
!       DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DGELSD computes the minimum-norm solution to a real linear least
!> squares problem:
!>     minimize 2-norm(| b - A*x |)
!> using the singular value decomposition (SVD) of A. A is an M-by-N
!> matrix which may be rank-deficient.
!>
!> Several right hand side vectors b and solution vectors x can be
!> handled in a single call; they are stored as the columns of the
!> M-by-NRHS right hand side matrix B and the N-by-NRHS solution
!> matrix X.
!>
!> The problem is solved in three steps:
!> (1) Reduce the coefficient matrix A to bidiagonal form with
!>     Householder transformations, reducing the original problem
!>     into a "bidiagonal least squares problem" (BLS)
!> (2) Solve the BLS using a divide and conquer approach.
!> (3) Apply back all the Householder transformations to solve
!>     the original least squares problem.
!>
!> The effective rank of A is determined by treating as zero those
!> singular values which are less than RCOND times the largest singular
!> value.
!>
!> The divide and conquer algorithm makes very mild assumptions about
!> floating point arithmetic. It will work on machines with a guard
!> digit in add/subtract, or on those binary machines without guard
!> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!> Cray-2. It could conceivably fail on hexadecimal or decimal machines
!> without guard digits, but we know of none.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of A. M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of A. N >= 0.
!> \endverbatim
!>
!> \param[in] NRHS
!> \verbatim
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices B and X. NRHS >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, A has been destroyed.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          On entry, the M-by-NRHS right hand side matrix B.
!>          On exit, B is overwritten by the N-by-NRHS solution
!>          matrix X.  If m >= n and RANK = n, the residual
!>          sum-of-squares for the solution in the i-th column is given
!>          by the sum of squares of elements n+1:m in that column.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,max(M,N)).
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!>          S is DOUBLE PRECISION array, dimension (min(M,N))
!>          The singular values of A in decreasing order.
!>          The condition number of A in the 2-norm = S(1)/S(min(m,n)).
!> \endverbatim
!>
!> \param[in] RCOND
!> \verbatim
!>          RCOND is DOUBLE PRECISION
!>          RCOND is used to determine the effective rank of A.
!>          Singular values S(i) <= RCOND*S(1) are treated as zero.
!>          If RCOND < 0, machine precision is used instead.
!> \endverbatim
!>
!> \param[out] RANK
!> \verbatim
!>          RANK is INTEGER
!>          The effective rank of A, i.e., the number of singular values
!>          which are greater than RCOND*S(1).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK must be at least 1.
!>          The exact minimum amount of workspace needed depends on M,
!>          N and NRHS. As long as LWORK is at least
!>              12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,
!>          if M is greater than or equal to N or
!>              12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,
!>          if M is less than N, the code will execute correctly.
!>          SMLSIZ is returned by ILAENV and is equal to the maximum
!>          size of the subproblems at the bottom of the computation
!>          tree (usually about 25), and
!>             NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
!>          For good performance, LWORK should generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] IWORK
!> \verbatim
!>          IWORK is INTEGER array, dimension (MAX(1,LIWORK))
!>          LIWORK >= max(1, 3 * MINMN * NLVL + 11 * MINMN),
!>          where MINMN = MIN( M,N ).
!>          On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  the algorithm for computing the SVD failed to converge;
!>                if INFO = i, i off-diagonal elements of an intermediate
!>                bidiagonal form did not converge to zero.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2017
!
!> \ingroup doubleGEsolve
!
!> \par Contributors:
!  ==================
!>
!>     Ming Gu and Ren-Cang Li, Computer Science Division, University of
!>       California at Berkeley, USA \n
!>     Osni Marques, LBNL/NERSC, USA \n
!
!  =====================================================================
      SUBROUTINE DGELSD(M,N,Nrhs,A,Lda,B,Ldb,S,Rcond,Rank,Work,Lwork,   &
     &                  Iwork,Info)
      IMPLICIT NONE
!*--DGELSD213
!
!  -- LAPACK driver routine (version 3.7.1) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2017
!
!     .. Scalar Arguments ..
      INTEGER Info , Lda , Ldb , Lwork , M , N , Nrhs , Rank
      DOUBLE PRECISION Rcond
!     ..
!     .. Array Arguments ..
      INTEGER Iwork(*)
      DOUBLE PRECISION A(Lda,*) , B(Ldb,*) , S(*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE , TWO
      PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
!     ..
!     .. Local Scalars ..
      LOGICAL lquery
      INTEGER iascl , ibscl , ie , il , itau , itaup , itauq , ldwork , &
     &        liwork , maxmn , maxwrk , minmn , minwrk , mm , mnthr ,   &
     &        nlvl , nwork , smlsiz , wlalsd
      DOUBLE PRECISION anrm , bignum , bnrm , eps , sfmin , smlnum
!     ..
!     .. External Subroutines ..
      EXTERNAL DGEBRD , DGELQF , DGEQRF , DLABAD , DLACPY , DLALSD ,    &
     &         DLASCL , DLASET , DORMBR , DORMLQ , DORMQR , XERBLA
!     ..
!     .. External Functions ..
      INTEGER ILAENV
      DOUBLE PRECISION DLAMCH , DLANGE
      EXTERNAL ILAENV , DLAMCH , DLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC DBLE , INT , LOG , MAX , MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments.
!
      Info = 0
      minmn = MIN(M,N)
      maxmn = MAX(M,N)
      mnthr = ILAENV(6,'DGELSD',' ',M,N,Nrhs,-1)
      lquery = (Lwork==-1)
      IF ( M<0 ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Nrhs<0 ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -5
      ELSEIF ( Ldb<MAX(1,maxmn) ) THEN
         Info = -7
      ENDIF
!
      smlsiz = ILAENV(9,'DGELSD',' ',0,0,0,0)
!
!     Compute workspace.
!     (Note: Comments in the code beginning "Workspace:" describe the
!     minimal amount of workspace needed at that point in the code,
!     as well as the preferred amount for good performance.
!     NB refers to the optimal block size for the immediately
!     following subroutine, as returned by ILAENV.)
!
      minwrk = 1
      liwork = 1
      minmn = MAX(1,minmn)
      nlvl = MAX(INT(LOG(DBLE(minmn)/DBLE(smlsiz+1))/LOG(TWO))+1,0)
!
      IF ( Info==0 ) THEN
         maxwrk = 0
         liwork = 3*minmn*nlvl + 11*minmn
         mm = M
         IF ( M>=N .AND. M>=mnthr ) THEN
!
!           Path 1a - overdetermined, with many more rows than columns.
!
            mm = N
            maxwrk = MAX(maxwrk,N+N*ILAENV(1,'DGEQRF',' ',M,N,-1,-1))
            maxwrk = MAX(maxwrk,                                        &
     &               N+Nrhs*ILAENV(1,'DORMQR','LT',M,Nrhs,N,-1))
         ENDIF
         IF ( M>=N ) THEN
!
!           Path 1 - overdetermined or exactly determined.
!
            maxwrk = MAX(maxwrk,3*N+(mm+N)                              &
     &               *ILAENV(1,'DGEBRD',' ',mm,N,-1,-1))
            maxwrk = MAX(maxwrk,                                        &
     &               3*N+Nrhs*ILAENV(1,'DORMBR','QLT',mm,Nrhs,N,-1))
            maxwrk = MAX(maxwrk,3*N+(N-1)                               &
     &               *ILAENV(1,'DORMBR','PLN',N,Nrhs,N,-1))
            wlalsd = 9*N + 2*N*smlsiz + 8*N*nlvl + N*Nrhs + (smlsiz+1)  &
     &               **2
            maxwrk = MAX(maxwrk,3*N+wlalsd)
            minwrk = MAX(3*N+mm,3*N+Nrhs,3*N+wlalsd)
         ENDIF
         IF ( N>M ) THEN
            wlalsd = 9*M + 2*M*smlsiz + 8*M*nlvl + M*Nrhs + (smlsiz+1)  &
     &               **2
            IF ( N>=mnthr ) THEN
!
!              Path 2a - underdetermined, with many more columns
!              than rows.
!
               maxwrk = M + M*ILAENV(1,'DGELQF',' ',M,N,-1,-1)
               maxwrk = MAX(maxwrk,                                     &
     &                  M*M+4*M+2*M*ILAENV(1,'DGEBRD',' ',M,M,-1,-1))
               maxwrk = MAX(maxwrk,                                     &
     &                  M*M+4*M+Nrhs*ILAENV(1,'DORMBR','QLT',M,Nrhs,M,  &
     &                  -1))
               maxwrk = MAX(maxwrk,M*M+4*M+(M-1)                        &
     &                  *ILAENV(1,'DORMBR','PLN',M,Nrhs,M,-1))
               IF ( Nrhs>1 ) THEN
                  maxwrk = MAX(maxwrk,M*M+M+M*Nrhs)
               ELSE
                  maxwrk = MAX(maxwrk,M*M+2*M)
               ENDIF
               maxwrk = MAX(maxwrk,                                     &
     &                  M+Nrhs*ILAENV(1,'DORMLQ','LT',N,Nrhs,M,-1))
               maxwrk = MAX(maxwrk,M*M+4*M+wlalsd)
!     XXX: Ensure the Path 2a case below is triggered.  The workspace
!     calculation should use queries for all routines eventually.
               maxwrk = MAX(maxwrk,4*M+M*M+MAX(M,2*M-4,Nrhs,N-3*M))
            ELSE
!
!              Path 2 - remaining underdetermined cases.
!
               maxwrk = 3*M + (N+M)*ILAENV(1,'DGEBRD',' ',M,N,-1,-1)
               maxwrk = MAX(maxwrk,                                     &
     &                  3*M+Nrhs*ILAENV(1,'DORMBR','QLT',M,Nrhs,N,-1))
               maxwrk = MAX(maxwrk,                                     &
     &                  3*M+M*ILAENV(1,'DORMBR','PLN',N,Nrhs,M,-1))
               maxwrk = MAX(maxwrk,3*M+wlalsd)
            ENDIF
            minwrk = MAX(3*M+Nrhs,3*M+M,3*M+wlalsd)
         ENDIF
         minwrk = MIN(minwrk,maxwrk)
         Work(1) = maxwrk
         Iwork(1) = liwork

         IF ( Lwork<minwrk .AND. .NOT.lquery ) Info = -12
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('DGELSD',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         GOTO 100
      ENDIF
!
!     Quick return if possible.
!
      IF ( M==0 .OR. N==0 ) THEN
         Rank = 0
         RETURN
      ENDIF
!
!     Get machine parameters.
!
      eps = DLAMCH('P')
      sfmin = DLAMCH('S')
      smlnum = sfmin/eps
      bignum = ONE/smlnum
      CALL DLABAD(smlnum,bignum)
!
!     Scale A if max entry outside range [SMLNUM,BIGNUM].
!
      anrm = DLANGE('M',M,N,A,Lda,Work)
      iascl = 0
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
!
!        Scale matrix norm up to SMLNUM.
!
         CALL DLASCL('G',0,0,anrm,smlnum,M,N,A,Lda,Info)
         iascl = 1
      ELSEIF ( anrm>bignum ) THEN
!
!        Scale matrix norm down to BIGNUM.
!
         CALL DLASCL('G',0,0,anrm,bignum,M,N,A,Lda,Info)
         iascl = 2
      ELSEIF ( anrm==ZERO ) THEN
!
!        Matrix all zero. Return zero solution.
!
         CALL DLASET('F',MAX(M,N),Nrhs,ZERO,ZERO,B,Ldb)
         CALL DLASET('F',minmn,1,ZERO,ZERO,S,1)
         Rank = 0
         GOTO 100
      ENDIF
!
!     Scale B if max entry outside range [SMLNUM,BIGNUM].
!
      bnrm = DLANGE('M',M,Nrhs,B,Ldb,Work)
      ibscl = 0
      IF ( bnrm>ZERO .AND. bnrm<smlnum ) THEN
!
!        Scale matrix norm up to SMLNUM.
!
         CALL DLASCL('G',0,0,bnrm,smlnum,M,Nrhs,B,Ldb,Info)
         ibscl = 1
      ELSEIF ( bnrm>bignum ) THEN
!
!        Scale matrix norm down to BIGNUM.
!
         CALL DLASCL('G',0,0,bnrm,bignum,M,Nrhs,B,Ldb,Info)
         ibscl = 2
      ENDIF
!
!     If M < N make sure certain entries of B are zero.
!
      IF ( M<N ) CALL DLASET('F',N-M,Nrhs,ZERO,ZERO,B(M+1,1),Ldb)
!
!     Overdetermined case.
!
      IF ( M>=N ) THEN
!
!        Path 1 - overdetermined or exactly determined.
!
         mm = M
         IF ( M>=mnthr ) THEN
!
!           Path 1a - overdetermined, with many more rows than columns.
!
            mm = N
            itau = 1
            nwork = itau + N
!
!           Compute A=Q*R.
!           (Workspace: need 2*N, prefer N+N*NB)
!
            CALL DGEQRF(M,N,A,Lda,Work(itau),Work(nwork),Lwork-nwork+1, &
     &                  Info)
!
!           Multiply B by transpose(Q).
!           (Workspace: need N+NRHS, prefer N+NRHS*NB)
!
            CALL DORMQR('L','T',M,Nrhs,N,A,Lda,Work(itau),B,Ldb,        &
     &                  Work(nwork),Lwork-nwork+1,Info)
!
!           Zero out below R.
!
            IF ( N>1 ) CALL DLASET('L',N-1,N-1,ZERO,ZERO,A(2,1),Lda)
         ENDIF
!
         ie = 1
         itauq = ie + N
         itaup = itauq + N
         nwork = itaup + N
!
!        Bidiagonalize R in A.
!        (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
!
         CALL DGEBRD(mm,N,A,Lda,S,Work(ie),Work(itauq),Work(itaup),     &
     &               Work(nwork),Lwork-nwork+1,Info)
!
!        Multiply B by transpose of left bidiagonalizing vectors of R.
!        (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
!
         CALL DORMBR('Q','L','T',mm,Nrhs,N,A,Lda,Work(itauq),B,Ldb,     &
     &               Work(nwork),Lwork-nwork+1,Info)
!
!        Solve the bidiagonal least squares problem.
!
         CALL DLALSD('U',smlsiz,N,Nrhs,S,Work(ie),B,Ldb,Rcond,Rank,     &
     &               Work(nwork),Iwork,Info)
         IF ( Info/=0 ) GOTO 100
!
!        Multiply B by right bidiagonalizing vectors of R.
!
         CALL DORMBR('P','L','N',N,Nrhs,N,A,Lda,Work(itaup),B,Ldb,      &
     &               Work(nwork),Lwork-nwork+1,Info)
!
      ELSEIF ( N>=mnthr .AND.                                           &
     &         Lwork>=4*M+M*M+MAX(M,2*M-4,Nrhs,N-3*M,wlalsd) ) THEN
!
!        Path 2a - underdetermined, with many more columns than rows
!        and sufficient workspace for an efficient algorithm.
!
         ldwork = M
         IF ( Lwork>=MAX(4*M+M*Lda+MAX(M,2*M-4,Nrhs,N-3*M),             &
     &        M*Lda+M+M*Nrhs,4*M+M*Lda+wlalsd) ) ldwork = Lda
         itau = 1
         nwork = M + 1
!
!        Compute A=L*Q.
!        (Workspace: need 2*M, prefer M+M*NB)
!
         CALL DGELQF(M,N,A,Lda,Work(itau),Work(nwork),Lwork-nwork+1,    &
     &               Info)
         il = nwork
!
!        Copy L to WORK(IL), zeroing out above its diagonal.
!
         CALL DLACPY('L',M,M,A,Lda,Work(il),ldwork)
         CALL DLASET('U',M-1,M-1,ZERO,ZERO,Work(il+ldwork),ldwork)
         ie = il + ldwork*M
         itauq = ie + M
         itaup = itauq + M
         nwork = itaup + M
!
!        Bidiagonalize L in WORK(IL).
!        (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
!
         CALL DGEBRD(M,M,Work(il),ldwork,S,Work(ie),Work(itauq),        &
     &               Work(itaup),Work(nwork),Lwork-nwork+1,Info)
!
!        Multiply B by transpose of left bidiagonalizing vectors of L.
!        (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
!
         CALL DORMBR('Q','L','T',M,Nrhs,M,Work(il),ldwork,Work(itauq),B,&
     &               Ldb,Work(nwork),Lwork-nwork+1,Info)
!
!        Solve the bidiagonal least squares problem.
!
         CALL DLALSD('U',smlsiz,M,Nrhs,S,Work(ie),B,Ldb,Rcond,Rank,     &
     &               Work(nwork),Iwork,Info)
         IF ( Info/=0 ) GOTO 100
!
!        Multiply B by right bidiagonalizing vectors of L.
!
         CALL DORMBR('P','L','N',M,Nrhs,M,Work(il),ldwork,Work(itaup),B,&
     &               Ldb,Work(nwork),Lwork-nwork+1,Info)
!
!        Zero out below first M rows of B.
!
         CALL DLASET('F',N-M,Nrhs,ZERO,ZERO,B(M+1,1),Ldb)
         nwork = itau + M
!
!        Multiply transpose(Q) by B.
!        (Workspace: need M+NRHS, prefer M+NRHS*NB)
!
         CALL DORMLQ('L','T',N,Nrhs,M,A,Lda,Work(itau),B,Ldb,Work(nwork)&
     &               ,Lwork-nwork+1,Info)
!
      ELSE
!
!        Path 2 - remaining underdetermined cases.
!
         ie = 1
         itauq = ie + M
         itaup = itauq + M
         nwork = itaup + M
!
!        Bidiagonalize A.
!        (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
!
         CALL DGEBRD(M,N,A,Lda,S,Work(ie),Work(itauq),Work(itaup),      &
     &               Work(nwork),Lwork-nwork+1,Info)
!
!        Multiply B by transpose of left bidiagonalizing vectors.
!        (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
!
         CALL DORMBR('Q','L','T',M,Nrhs,N,A,Lda,Work(itauq),B,Ldb,      &
     &               Work(nwork),Lwork-nwork+1,Info)
!
!        Solve the bidiagonal least squares problem.
!
         CALL DLALSD('L',smlsiz,M,Nrhs,S,Work(ie),B,Ldb,Rcond,Rank,     &
     &               Work(nwork),Iwork,Info)
         IF ( Info/=0 ) GOTO 100
!
!        Multiply B by right bidiagonalizing vectors of A.
!
         CALL DORMBR('P','L','N',N,Nrhs,M,A,Lda,Work(itaup),B,Ldb,      &
     &               Work(nwork),Lwork-nwork+1,Info)
!
      ENDIF
!
!     Undo scaling.
!
      IF ( iascl==1 ) THEN
         CALL DLASCL('G',0,0,anrm,smlnum,N,Nrhs,B,Ldb,Info)
         CALL DLASCL('G',0,0,smlnum,anrm,minmn,1,S,minmn,Info)
      ELSEIF ( iascl==2 ) THEN
         CALL DLASCL('G',0,0,anrm,bignum,N,Nrhs,B,Ldb,Info)
         CALL DLASCL('G',0,0,bignum,anrm,minmn,1,S,minmn,Info)
      ENDIF
      IF ( ibscl==1 ) THEN
         CALL DLASCL('G',0,0,smlnum,bnrm,N,Nrhs,B,Ldb,Info)
      ELSEIF ( ibscl==2 ) THEN
         CALL DLASCL('G',0,0,bignum,bnrm,N,Nrhs,B,Ldb,Info)
      ENDIF
!
 100  Work(1) = maxwrk
      Iwork(1) = liwork
!
!     End of DGELSD
!
      END SUBROUTINE DGELSD