congen_bstree.f90

Go to the documentation of this file.

! Copyright 2019
!
! For a comprehensive list of the developers that contributed to these codes
! see the UK-AMOR website.
!
! This file is part of UKRmol-in (UKRmol+ suite).
!
!     UKRmol-in is free software: you can redistribute it and/or modify
!     it under the terms of the GNU General Public License as published by
!     the Free Software Foundation, either version 3 of the License, or
!     (at your option) any later version.
!
!     UKRmol-in is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with  UKRmol-in (in source/COPYING). Alternatively, you can also visit
!     <https://www.gnu.org/licenses/>.
 
module congen_bstree
 
    use containers, only: bstree
 
    implicit none
 
    type, extends(bstree) :: det_tree
        integer, pointer :: det(:) => null()
        integer, pointer :: ndo(:) => null()
        integer          :: nelt = 0
    contains
        procedure, public :: init       => init_det_tree
        procedure, public :: compare    => compare_determinats
        procedure, public :: locate_det => locate_in_det_tree
        procedure, public :: dtwrite    => write_determinant
        final :: final_det_tree
    end type det_tree
 
contains
 
    subroutine init_det_tree (this, ndo, nelt)
 
        class(det_tree),  intent(inout) :: this
        integer, pointer, intent(in)    :: ndo(:)
        integer,          intent(in)    :: nelt
 
        this % ndo  => ndo
        this % nelt = nelt
 
        allocate (this % det(nelt))
 
    end subroutine init_det_tree
 
 
    subroutine final_det_tree (this)
 
        type(det_tree), intent(inout) :: this
 
        if (associated(this % det)) then
            deallocate (this % det)
        end if
 
    end subroutine final_det_tree
 
 
    integer function locate_in_det_tree (this, det) result (res)
 
        class(det_tree),                 intent(inout) :: this
        integer, dimension(this % nelt), intent(in)    :: det
 
        this % det = det
 
        res = this % locate(-1)  ! negative id signalizes unary comparison, see "compare_determinats"
 
    end function locate_in_det_tree
 
 
    subroutine write_determinant (this, lu, id)
 
        class(det_tree), intent(in) :: this
        integer,         intent(in) :: lu, id
 
        integer :: i
 
        write (lu, '("[")', advance = 'no')
 
        do i = 1, this % nelt
            write (lu, '(1x,I0)', advance = 'no') this % ndo((id - 1) * this % nelt + i)
        end do
 
        write (lu, '(1x,"]")')
 
    end subroutine write_determinant
 
 
    integer function compare_determinats (this, i, j, data) result (verdict)
 
        use iso_c_binding, only: c_ptr
 
        class(det_tree),       intent(in) :: this
        integer,               intent(in) :: i, j
        type(c_ptr), optional, intent(in) :: data
 
        integer, pointer :: d1(:), d2(:)
        integer :: k
 
        ! get first determinant view
        if (i >= 0) then
            d1 => this % ndo((i - 1) * this % nelt + 1 : i * this % nelt)
        else
            d1 => this % det(1:this % nelt)
        end if
 
        ! get second determinant view
        if (j >= 0) then
            d2 => this % ndo((j - 1) * this % nelt + 1 : j * this % nelt)
        else
            d2 => this % det(1:this % nelt)
        end if
 
        ! compare determinants element by element
        do k = 1, this % nelt
 
            ! is first less?
            if (d1(k) < d2(k)) then
                verdict = -1
                return
            end if
 
            ! is first greater?
            if (d1(k) > d2(k)) then
                verdict =  1
                return
            end if
 
        end do
 
        ! they are equal
        verdict = 0
 
    end function compare_determinats
 
end module congen_bstree