mirror of
https://code.it4i.cz/sccs/easyconfigs-it4i.git
synced 2025-04-17 04:00:49 +01:00
1270 lines
50 KiB
Fortran
1270 lines
50 KiB
Fortran
************************************************************************
|
|
module qmmod_moselect
|
|
************************************************************************
|
|
* Handles the various molecular orbital selection schemes of
|
|
* the embedding calculations using 'embedorb' as its interface.
|
|
* Due to the limited number of input reads,
|
|
* it is designed to be as pure as it can be.
|
|
* 2023-05-12 Bence Hégely
|
|
************************************************************************
|
|
use qmmod_handler
|
|
implicit none
|
|
save
|
|
! ###############################################################
|
|
! structures
|
|
! ###############################################################
|
|
type :: Thresholds
|
|
double precision :: mulli
|
|
double precision :: nondeloc_mulli
|
|
double precision :: deloc_mulli
|
|
double precision :: deloc
|
|
double precision :: bpcompo
|
|
double precision :: bpcompv
|
|
end type Thresholds
|
|
!
|
|
type :: MO_select_algorithm
|
|
character(len=8) :: keywd
|
|
contains
|
|
procedure, nopass :: do_setup
|
|
procedure, nopass :: do_calc
|
|
procedure, nopass :: do_select
|
|
procedure, nopass :: do_print
|
|
end type MO_select_algorithm
|
|
!
|
|
type :: MO_select_algo_wrapper
|
|
class(MO_select_algorithm), allocatable :: algo
|
|
end type MO_select_algo_wrapper
|
|
!
|
|
type, extends(MO_select_algorithm) :: Algo_bopu
|
|
contains
|
|
procedure, nopass :: do_setup => setup_bopu
|
|
procedure, nopass :: do_calc => calc_bopu
|
|
procedure, nopass :: do_select => select_bopu
|
|
procedure, nopass :: do_print => print_bopu
|
|
end type Algo_bopu
|
|
!
|
|
type, extends(MO_select_algorithm) :: Algo_amul
|
|
contains
|
|
procedure, nopass :: do_setup => setup_mulli_threshold
|
|
procedure, nopass :: do_calc => calc_amul
|
|
procedure, nopass :: do_select => select_amul
|
|
procedure, nopass :: do_print => print_amul
|
|
end type Algo_amul
|
|
!
|
|
type, extends(MO_select_algorithm) :: Algo_nmul
|
|
contains
|
|
procedure, nopass :: do_setup => setup_mulli_specified
|
|
procedure, nopass :: do_calc => calc_nmul
|
|
procedure, nopass :: do_select => select_nmul
|
|
procedure, nopass :: do_print => print_nmul
|
|
end type Algo_nmul
|
|
!
|
|
type, extends(MO_select_algorithm) :: Algo_spad
|
|
contains
|
|
procedure, nopass :: do_setup => setup_spad_default
|
|
procedure, nopass :: do_calc => calc_spad
|
|
procedure, nopass :: do_select => select_spad
|
|
procedure, nopass :: do_print => print_spad
|
|
end type Algo_spad
|
|
!
|
|
type, extends(MO_select_algorithm) :: Algo_nspad
|
|
contains
|
|
procedure, nopass :: do_setup => setup_spad_specified
|
|
procedure, nopass :: do_calc => calc_nspad
|
|
procedure, nopass :: do_select => select_spad
|
|
procedure, nopass :: do_print => print_nspad
|
|
end type Algo_nspad
|
|
!
|
|
type, extends(MO_select_algorithm) :: Algo_pmul
|
|
integer :: max_deloc_orbs
|
|
integer :: ndeloc_orbs
|
|
integer :: nnondeloc_orbs
|
|
contains
|
|
procedure, nopass :: do_setup => setup_pmul
|
|
procedure, nopass :: do_calc => calc_pmul
|
|
procedure, nopass :: do_select => select_pmul
|
|
procedure, nopass :: do_print => print_pmul
|
|
end type Algo_pmul
|
|
!
|
|
type, extends(MO_select_algorithm) :: Algo_npmul
|
|
integer :: max_deloc_orbs
|
|
integer :: ndeloc_orbs
|
|
integer :: nnondeloc_orbs
|
|
contains
|
|
procedure, nopass :: do_setup => setup_npmul
|
|
procedure, nopass :: do_calc => calc_npmul
|
|
procedure, nopass :: do_select => select_npmul
|
|
procedure, nopass :: do_print => print_npmul
|
|
end type Algo_npmul
|
|
!
|
|
type, extends(MO_select_algorithm) :: Algo_ecore
|
|
contains
|
|
procedure, nopass :: do_setup => setup_ecore
|
|
procedure, nopass :: do_calc => calc_ecore
|
|
procedure, nopass :: do_select => select_ecore
|
|
procedure, nopass :: do_print => print_ecore
|
|
end type Algo_ecore
|
|
!
|
|
type, extends(MO_select_algorithm) :: Algo_serialno
|
|
contains
|
|
procedure, nopass :: do_setup => setup_serialno
|
|
procedure, nopass :: do_calc => calc_serialno
|
|
procedure, nopass :: do_select => select_serialno
|
|
procedure, nopass :: do_print => print_serialno
|
|
end type Algo_serialno
|
|
!
|
|
! ###############################################################
|
|
! parameters
|
|
integer, parameter :: nalgs = 9
|
|
double precision, parameter :: def_mulli = 0.30d0
|
|
double precision, parameter :: def_deloc = 0.95d0
|
|
double precision, parameter :: def_bpcompo = 0.985d0
|
|
double precision, parameter :: def_bpcompv = 0.980d0
|
|
! variables
|
|
character(len=1) :: job
|
|
character(len=8) :: mo_select_alg
|
|
character(len=16) :: orbloce
|
|
integer :: MO_num_specifier
|
|
character(len=buffer_size) :: line_moselect
|
|
integer :: MOs_active
|
|
integer :: nembedatoms
|
|
integer :: fst_ind , lst_ind
|
|
integer :: offset
|
|
logical :: lcorembed
|
|
integer :: initial_stack_size
|
|
! derived types
|
|
type( BP_algorithm ), pointer :: bp
|
|
type(Thresholds) :: th
|
|
! default algorithms
|
|
type(Algo_amul), target :: amul = Algo_amul("amul")
|
|
type(Algo_nmul), target :: nmul = Algo_nmul("nmul")
|
|
type(Algo_spad), target :: spad = Algo_spad("spad")
|
|
type(Algo_nspad), target :: nspad = Algo_nspad("nspad")
|
|
! polymorph-related
|
|
type(MO_select_algo_wrapper), allocatable, target
|
|
$ :: algorithms(:)
|
|
class(MO_select_algorithm), pointer
|
|
$ :: algorithm
|
|
! pointers
|
|
integer, allocatable :: embedatoms(:)
|
|
integer, allocatable :: selected_MO_list(:)
|
|
double precision, allocatable :: mullipop(:)
|
|
integer, allocatable :: indexarr(:)
|
|
! ###############################################################
|
|
contains
|
|
! ###############################################################
|
|
subroutine MO_selection_init
|
|
$ ( job_in , bp_in , embedatoms_list , control_line)
|
|
|
|
implicit none
|
|
character(len=1), intent(in) :: job_in
|
|
type( BP_algorithm ), target :: bp_in
|
|
integer, intent(in) :: embedatoms_list( natoms )
|
|
character(len=buffer_size) :: control_line
|
|
!
|
|
call print_header
|
|
call set_heap_pointers
|
|
call read_keywords
|
|
call set_default_parameters
|
|
call set_algorithms
|
|
call setup_moselect
|
|
! #############################################################
|
|
contains
|
|
! #############################################################
|
|
!
|
|
subroutine print_header
|
|
write(iout,'(a)')
|
|
write(iout,'(a)')
|
|
$' %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%'
|
|
if(job_in.eq.'o') then
|
|
write(iout,*)
|
|
write(iout,'(a)')
|
|
$' Selecting active occupied orbitals '
|
|
write(iout,*)
|
|
else if(job_in.eq.'v') then
|
|
write(iout,*)
|
|
write(iout,'(a)')
|
|
$' Selecting active virtual orbitals '
|
|
write(iout,*)
|
|
endif
|
|
write(iout,'(a)')
|
|
$' %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%'
|
|
if( keywd % scftype .eq. 'uhf' ) then
|
|
write(iout,'(a)')
|
|
if( .not. use_beta ) then
|
|
write(iout,'(a)')
|
|
$' (alpha particles) '
|
|
else
|
|
write(iout,'(a)')
|
|
$' (beta particles) '
|
|
|
|
endif
|
|
write(iout,'(a)')
|
|
endif
|
|
end subroutine print_header
|
|
!
|
|
subroutine set_heap_pointers
|
|
initial_stack_size = smem % get_size()
|
|
bp => bp_in
|
|
call smem % push( natoms )
|
|
embedatoms = smem % top_i()
|
|
embedatoms(1:natoms) = 0
|
|
call smem % push( nbas )
|
|
indexarr = smem % top_i()
|
|
indexarr = 0
|
|
call smem % push( nbas )
|
|
mullipop = smem % top_r()
|
|
mullipop = 0.0d0
|
|
call smem % push( nbas )
|
|
selected_MO_list = smem % top_i()
|
|
selected_MO_list(1:nbas) = 1
|
|
line_moselect = control_line
|
|
job = job_in
|
|
end subroutine set_heap_pointers
|
|
!
|
|
function get_embedatom_serial( embedatoms_list , natoms )
|
|
$ result( embedatoms )
|
|
integer, intent(in) :: natoms
|
|
integer, intent(in) :: embedatoms_list(natoms)
|
|
integer :: embedatoms(natoms)
|
|
integer :: iatom , i
|
|
i = 0
|
|
do iatom = 1, natoms
|
|
if(embedatoms_list( iatom ) .eq. 1 ) then
|
|
i = i + 1
|
|
embedatoms( i ) = iatom
|
|
endif
|
|
enddo
|
|
embedatoms( i + 1 : natoms ) = 0
|
|
end function get_embedatom_serial
|
|
!
|
|
subroutine read_keywords
|
|
if( orbloce .eq. 'special') then
|
|
orbloce = merge( keywd % orbloce_special(2) ,
|
|
$ keywd % orbloce_special(3) ,
|
|
$ job .eq. 'o' )
|
|
endif
|
|
read( keywd % verbosity , * ) iverbosity
|
|
lcorembed = keywd % corembed .ne. 'off '
|
|
end subroutine read_keywords
|
|
!
|
|
subroutine set_default_parameters
|
|
MOs_active = 0
|
|
nembedatoms = sum( embedatoms_list( 1 : natoms ) )
|
|
embedatoms = get_embedatom_serial( embedatoms_list , natoms )
|
|
th % mulli = def_mulli
|
|
th % nondeloc_mulli = def_mulli
|
|
th % deloc_mulli = def_mulli
|
|
th % deloc = def_deloc
|
|
read( keywd % bpcompo , * ) th % bpcompo
|
|
read( keywd % bpcompv , * ) th % bpcompv
|
|
fst_ind = merge( nal + 1 , 1 , job.eq.'v')
|
|
lst_ind = merge( nbas , nal , job.eq.'v')
|
|
if( use_beta ) then
|
|
fst_ind = merge( nbe + 1 , 1 , job.eq.'v')
|
|
lst_ind = merge( nbas , nbe , job.eq.'v')
|
|
endif
|
|
! qsortd is done on 'nbas' number of elements thus
|
|
! the indices have to be shifted to keep all the printings syncronized
|
|
offset = nbas - lst_ind
|
|
end subroutine set_default_parameters
|
|
!
|
|
subroutine setup_moselect
|
|
implicit none
|
|
integer :: i,ialg
|
|
character(len=buffer_size) :: buffer
|
|
! Read the active MO parameter
|
|
buffer = ''
|
|
i = index(line_moselect,' ')
|
|
buffer(1:i) = line_moselect(1:i)
|
|
read(buffer,*) MO_num_specifier
|
|
! Set default values based on the specification
|
|
call set_default_moselect
|
|
! Check for further algorithm specification
|
|
line_moselect(1:i)=' '
|
|
line_moselect = adjustl(line_moselect)
|
|
i = index(line_moselect,' ')
|
|
if( i .ne. 1 ) then
|
|
mo_select_alg = ''
|
|
mo_select_alg(:) = line_moselect(1:i)
|
|
line_moselect(1:i) = ' '
|
|
line_moselect = adjustl(line_moselect)
|
|
ialg = 1
|
|
do while( ialg .le. size(algorithms) .and.
|
|
$ algorithms(ialg) % algo % keywd .ne. mo_select_alg .and.
|
|
$ len_trim(mo_select_alg) .ne. 0)
|
|
ialg = ialg + 1
|
|
enddo
|
|
if( ialg .gt. size(algorithms) ) then
|
|
write(iout,'(2a)')
|
|
$' Illegal MO selection algorithm: ',mo_select_alg
|
|
call mrccend(1)
|
|
endif
|
|
algorithm => algorithms(ialg) % algo
|
|
endif
|
|
end subroutine setup_moselect
|
|
!
|
|
subroutine set_default_moselect
|
|
algorithm => amul
|
|
if( MO_num_specifier .ne. 0 ) algorithm => nmul
|
|
if( ( keywd % orbloce .eq. 'spade' .or.
|
|
$ ( keywd % orbloce_special(1) .eq. 'spade' .and. job .eq.'o')
|
|
$ .or.
|
|
$ ( keywd % orbloce_special(2) .eq. 'spade' .and. job .eq.'o')
|
|
$ .or.
|
|
$ ( keywd % orbloce_special(3) .eq. 'spade' .and. job .eq.'v') )
|
|
$ .and.
|
|
$ .not. lcorembed ) then
|
|
algorithm => spad
|
|
if( MO_num_specifier .ne. 0 ) algorithm => nspad
|
|
endif
|
|
end subroutine set_default_moselect
|
|
!
|
|
end subroutine MO_selection_init
|
|
C#####################################################
|
|
C########### End of MO_selection_init ################
|
|
C#####################################################
|
|
!
|
|
subroutine set_algorithms
|
|
integer :: i
|
|
type(Algo_amul), allocatable :: alg_amul
|
|
type(Algo_nmul), allocatable :: alg_nmul
|
|
type(Algo_spad), allocatable :: alg_spad
|
|
type(Algo_nspad), allocatable :: alg_nspad
|
|
type(Algo_bopu), allocatable :: alg_bopu
|
|
type(Algo_pmul), allocatable :: alg_pmul
|
|
type(Algo_npmul), allocatable :: alg_npmul
|
|
type(Algo_ecore), allocatable :: alg_ecore
|
|
type(Algo_serialno),allocatable :: alg_serialno
|
|
allocate(alg_amul)
|
|
allocate(alg_nmul)
|
|
allocate(alg_spad)
|
|
allocate(alg_nspad)
|
|
allocate(alg_bopu)
|
|
allocate(alg_pmul)
|
|
allocate(alg_npmul)
|
|
allocate(alg_ecore)
|
|
allocate(alg_serialno)
|
|
allocate(algorithms( nalgs ) )
|
|
alg_amul = Algo_amul("amul")
|
|
alg_nmul = Algo_nmul("nmul")
|
|
alg_spad = Algo_spad("spad")
|
|
alg_nspad = Algo_nspad("nspad")
|
|
alg_bopu = Algo_bopu("bopu")
|
|
alg_pmul = Algo_pmul("pmul",0,0,0)
|
|
alg_npmul = Algo_npmul("npmul",0,0,0)
|
|
alg_ecore = Algo_ecore("ecore")
|
|
alg_serialno = Algo_serialno("serialno")
|
|
i = 1
|
|
call move_alloc( alg_amul , algorithms(i) % algo)
|
|
i = i + 1
|
|
call move_alloc( alg_nmul , algorithms(i) % algo)
|
|
i = i + 1
|
|
call move_alloc( alg_spad , algorithms(i) % algo)
|
|
i = i + 1
|
|
call move_alloc( alg_nspad , algorithms(i) % algo)
|
|
i = i + 1
|
|
call move_alloc( alg_bopu , algorithms(i) % algo)
|
|
i = i + 1
|
|
call move_alloc( alg_pmul , algorithms(i) % algo)
|
|
i = i + 1
|
|
call move_alloc( alg_npmul , algorithms(i) % algo)
|
|
i = i + 1
|
|
call move_alloc( alg_ecore , algorithms(i) % algo)
|
|
i = i + 1
|
|
call move_alloc( alg_serialno , algorithms(i) % algo)
|
|
if( i .ne. nalgs ) call illegal_value_error
|
|
$(" The expected number of algorithms of the MO select schemes
|
|
$does not match with the implemented ones", i , nalgs )
|
|
end subroutine set_algorithms
|
|
!
|
|
subroutine MO_selection_clear
|
|
integer :: i
|
|
do while( smem % get_size() .gt. initial_stack_size )
|
|
call smem % pop()
|
|
enddo
|
|
do i = 1 , size(algorithms)
|
|
deallocate( algorithms( i ) % algo )
|
|
enddo
|
|
deallocate( algorithms )
|
|
end subroutine MO_selection_clear
|
|
!
|
|
C#####################################################
|
|
C############### Setup routines ######################
|
|
C#####################################################
|
|
!
|
|
subroutine do_setup
|
|
write(iout,'(3a)') " The setup of MO selection algorithm '",
|
|
$trim(algorithm % keywd),"' is not implemented!"
|
|
call mrccend(1)
|
|
end subroutine do_setup
|
|
!
|
|
subroutine setup_bopu
|
|
integer :: i
|
|
i = index(line_moselect,' ')
|
|
if( i .eq. 1 ) return
|
|
if( job .eq. 'o' ) call read_moselect_parameter('bopu',
|
|
$'MO completeness threshold',th % bpcompo , 0.0d0,1.0d0)
|
|
if( job .eq. 'v' ) call read_moselect_parameter('bopu',
|
|
$'MO completeness threshold',th % bpcompv , 0.0d0,1.0d0)
|
|
end subroutine setup_bopu
|
|
!
|
|
subroutine setup_mulli_threshold
|
|
integer :: i
|
|
i = index(line_moselect,' ')
|
|
if( i .eq. 1 ) return
|
|
call read_moselect_parameter('aMul',
|
|
$'Mulliken population threshold',th % mulli,0.0d0,1.0d0)
|
|
end subroutine setup_mulli_threshold
|
|
!
|
|
subroutine setup_mulli_specified
|
|
integer :: mo_limit
|
|
MOs_active = MO_num_specifier
|
|
mo_limit = merge( nvirtal , nal , job .eq. 'v')
|
|
if( use_beta )
|
|
$ mo_limit = merge( nvirtbe , nbe , job .eq. 'v')
|
|
if( MOs_active .le. 0 .or. MOs_active .gt. mo_limit ) then
|
|
call out_of_range_error
|
|
$(" Illegal specification of the number
|
|
$of MOs for the 'nMul' scheme",mo_limit,.true., 0, .false.)
|
|
endif
|
|
end subroutine setup_mulli_specified
|
|
!
|
|
subroutine setup_pmul
|
|
integer :: i
|
|
i = index(line_moselect,' ')
|
|
if( i .eq. 1 ) return
|
|
call read_moselect_parameter('pMul',
|
|
$'MO delocalization threshold',th % deloc , 0.0d0,1.0d0)
|
|
i = index(line_moselect,' ')
|
|
if( i .eq. 1 ) return
|
|
call read_moselect_parameter('pMul','Mulliken population
|
|
$threshold of delocalized orbitals',th %deloc_mulli,0.0d0,1.0d0)
|
|
i = index(line_moselect,' ')
|
|
if( i .eq. 1 ) return
|
|
call read_moselect_parameter('pMul','Mulliken population
|
|
$threshold of non-delocalized orbitals',th % nondeloc_mulli,
|
|
$0.0d0,1.0d0)
|
|
end subroutine setup_pmul
|
|
!
|
|
subroutine setup_npmul
|
|
integer :: i
|
|
select type (algorithm )
|
|
type is ( Algo_npmul )
|
|
algorithm % ndeloc_orbs = MO_num_specifier
|
|
end select
|
|
i = index(line_moselect,' ')
|
|
if( i .eq. 1 ) return
|
|
call read_moselect_parameter('npMul',
|
|
$'MO delocalization threshold',th % deloc , 0.0d0,1.0d0)
|
|
i = index(line_moselect,' ')
|
|
if( i .eq. 1 ) return
|
|
call read_moselect_parameter('npMul','Mulliken population
|
|
$threshold of non-delocalized orbitals',th %nondeloc_mulli,
|
|
$0.0d0,1.0d0)
|
|
end subroutine setup_npmul
|
|
!
|
|
subroutine setup_ecore
|
|
integer :: mo_limit
|
|
if( orbloce .eq. 'spade' ) then
|
|
write(iout,'(a)') " The spade localization is"//
|
|
$" incompatible with the 'ecore' selection scheme."
|
|
write(iout,'(a)')
|
|
$' The order of the canonical MOs and the SPADE MOs differ.'
|
|
call mrccend(1)
|
|
endif
|
|
if( MO_num_specifier .eq. 0 ) then
|
|
MOs_active = merge( nal - ncore , nvirtal , job .eq. 'o' )
|
|
if( use_beta )
|
|
$ MOs_active = merge( nbe - ncore , nvirtbe , job .eq. 'o' )
|
|
else
|
|
MOs_active = MO_num_specifier
|
|
mo_limit = merge( nvirtal , nal, job.eq.'v')
|
|
if( use_beta )
|
|
$ mo_limit = merge( nvirtbe , nbe, job.eq.'v')
|
|
if( MOs_active .lt. 0 .or. MOs_active .gt. mo_limit ) then
|
|
call out_of_range_error(
|
|
$" Illegal specification of the number of MOs
|
|
$for the 'ecore' scheme",mo_limit,.true., 0, .false.)
|
|
endif
|
|
endif
|
|
end subroutine setup_ecore
|
|
!
|
|
subroutine setup_serialno
|
|
integer :: i
|
|
i = index(line_moselect,' ')
|
|
if( i .eq. 1 ) call io_error
|
|
$(' Cannot found MO indices for manual MO selection',
|
|
$'setup_serial @ qmmod_handler.f)')
|
|
! Double read will be performed.
|
|
! Here, it is checked whether
|
|
! the MO indicies are possible for the specified job
|
|
open(scrfile1,file='manselaux',form='formatted')
|
|
write(scrfile1,'(a)') adjustl(line_moselect)
|
|
backspace(scrfile1)
|
|
selected_MO_list( fst_ind : lst_ind ) = 0
|
|
call readlinelist
|
|
$(nbas,scrfile1,selected_MO_list,iout,'mos ')
|
|
close(scrfile1,status='delete')
|
|
do i=fst_ind , lst_ind
|
|
if( selected_MO_list(i) .eq. 1 .and.
|
|
$ ( i .lt. fst_ind .or. i .gt. lst_ind ) ) then
|
|
call out_of_range_error
|
|
$(" A specified MO index for manual MO selection is out of range.",
|
|
$lst_ind,.true.,fst_ind,.true.)
|
|
endif
|
|
enddo
|
|
end subroutine setup_serialno
|
|
!
|
|
subroutine setup_spad_default
|
|
if ( job .eq. 'o' ) then
|
|
call getvar('nembeda ', MOs_active)
|
|
if( use_beta )
|
|
$ call getvar('nembedb ', MOs_active)
|
|
else if ( job .eq. 'v' ) then
|
|
call getvar('nvembeda ', MOs_active)
|
|
if( use_beta )
|
|
$ call getvar('nvembedb ', MOs_active)
|
|
endif
|
|
end subroutine setup_spad_default
|
|
!
|
|
subroutine setup_spad_specified
|
|
integer :: mo_limit
|
|
MOs_active = MO_num_specifier
|
|
mo_limit = merge( nvirtal , nal , job.eq.'v' )
|
|
if( use_beta )
|
|
$ mo_limit = merge( nvirtbe , nbe , job.eq.'v' )
|
|
if( MOs_active .lt. 0 .or. MOs_active .gt. mo_limit ) then
|
|
call out_of_range_error(
|
|
$" Illegal specification of the number
|
|
$of MOs for the 'nspad' scheme",mo_limit,.true., 0, .false.)
|
|
endif
|
|
end subroutine setup_spad_specified
|
|
!
|
|
subroutine read_moselect_parameter
|
|
$( scheme , str_param , param ,lower , upper )
|
|
character(len=*), intent(in) :: scheme
|
|
character(len=*), intent(in) :: str_param
|
|
double precision, intent(in) :: lower
|
|
double precision, intent(in) :: upper
|
|
double precision, intent(out) :: param
|
|
integer :: i
|
|
character(len=buffer_size) :: buffer
|
|
i = index(line_moselect,' ')
|
|
buffer(1:i) = line_moselect(1:i)
|
|
read(buffer,*,iostat=istat) param
|
|
if( istat .ne. 0 ) then
|
|
call io_error(" Cannot read the parameter of the '"
|
|
$//trim(adjustl(scheme))//"' scheme ("
|
|
$//trim(adjustl(str_param))//").",'bopu.f')
|
|
else if ( param .lt. lower .or. param .gt. upper ) then
|
|
call out_of_range_error(" Parameter of '"//
|
|
$trim(adjustl(scheme))//"' scheme is out of legal range ("
|
|
$//trim(adjustl(str_param))//").",upper,.true.,lower,.true.)
|
|
endif
|
|
line_moselect(1:i) = ' '
|
|
line_moselect = adjustl(line_moselect)
|
|
end subroutine read_moselect_parameter
|
|
!#################################################
|
|
!########## End of setup routines ################
|
|
!#################################################
|
|
!
|
|
!#################################################
|
|
!############# Calculation routines ##############
|
|
!#################################################
|
|
!
|
|
subroutine do_calc
|
|
write(iout,'(3a)') " The calculation routine of MO selection"
|
|
$//"algorithm '",trim(algorithm % keywd),"' is not implemented!"
|
|
call mrccend(1)
|
|
end subroutine do_calc
|
|
!
|
|
subroutine calc_bopu
|
|
call calc_MO_mullipop
|
|
end subroutine calc_bopu
|
|
!
|
|
subroutine calc_amul
|
|
call calc_MO_mullipop
|
|
end subroutine calc_amul
|
|
!
|
|
subroutine calc_nmul
|
|
call calc_MO_mullipop
|
|
end subroutine calc_nmul
|
|
!
|
|
subroutine calc_spad
|
|
call calc_MO_mullipop
|
|
end subroutine calc_spad
|
|
!
|
|
subroutine calc_nspad
|
|
call calc_MO_mullipop
|
|
end subroutine calc_nspad
|
|
!
|
|
subroutine calc_pmul
|
|
call determine_MO_delocalization
|
|
call calc_MO_mullipop
|
|
end subroutine calc_pmul
|
|
!
|
|
subroutine calc_npmul
|
|
call determine_MO_delocalization
|
|
call calc_MO_mullipop
|
|
end subroutine calc_npmul
|
|
!
|
|
subroutine calc_ecore
|
|
end subroutine calc_ecore
|
|
!
|
|
subroutine calc_serialno
|
|
call calc_MO_mullipop
|
|
end subroutine calc_serialno
|
|
!
|
|
subroutine determine_MO_delocalization
|
|
************************************************************************
|
|
* Sort MOs as localized and delocalized MOs
|
|
* (designed for embedding calculations on aromatic systems)
|
|
************************************************************************
|
|
implicit none
|
|
integer :: i, iatom, mu
|
|
integer :: max_deloc_orbs
|
|
double precision :: norm,rsum
|
|
norm = 1.0d0
|
|
max_deloc_orbs = 0
|
|
bp % mocomp(1:nal) = 0.0d0
|
|
if( use_beta )
|
|
$ bp % mocomp(1:nbe) = 0.0d0
|
|
bp% work2d = 0.0d0
|
|
do i = fst_ind , lst_ind
|
|
bp % mocomp( i ) = 0.0d0
|
|
do iatom = 1 , bp%natmo( i )
|
|
do mu = bp%natrange(1, bp%atmo( iatom, i ), 1 )+ 1,
|
|
$ bp%natrange(2, bp%atmo( iatom, i ),1 )
|
|
bp%work2d(iatom,i,1) = bp%work2d(iatom,i,1)
|
|
$ + dabs( bp%c(mu,i+index_offset) * bp%v(mu,i+index_offset) )
|
|
enddo
|
|
enddo
|
|
call qsortd
|
|
$ ( bp % ind , bp%natmo( i ) , bp%work2d(1,i,1) )
|
|
rsum = bp%work2d( bp % ind ( bp%natmo( i ) ) ,i, 1 )
|
|
if( bp%natmo( i ) .gt. 1 )
|
|
$ rsum = rsum + bp%work2d( bp % ind ( bp%natmo( i ) - 1 ),i,1)
|
|
bp % mocomp(i) = (norm-dabs(norm - rsum))/norm
|
|
enddo
|
|
if( iverbosity .ge. 3 ) write(iout,*)
|
|
if( iverbosity .ge. 3 ) write(iout,'(a)')
|
|
$' MO 2-atom completness '
|
|
! Mark delocalized orbitals
|
|
do i= fst_ind , lst_ind
|
|
if( iverbosity .ge. 3 )
|
|
$ write(iout,"(i5,4x,f9.6)") i , bp % mocomp( i )
|
|
if( bp % mocomp( i ) .lt. th % deloc ) then
|
|
max_deloc_orbs = max_deloc_orbs + 1
|
|
endif
|
|
enddo
|
|
select type( algorithm )
|
|
type is ( Algo_npmul )
|
|
algorithm % max_deloc_orbs = max_deloc_orbs
|
|
type is ( Algo_pmul )
|
|
algorithm % max_deloc_orbs = max_deloc_orbs
|
|
end select
|
|
write(iout,*)
|
|
write(iout,'(a,f8.4)')
|
|
$' Completness threshold for delocalized orbitals:', th % deloc
|
|
if(th % deloc .eq. def_deloc ) write(iout,'(a)')
|
|
$" (default parameter)"
|
|
write(iout,'(a)') "(Completness is computed from AOs of the 2"//
|
|
$" most populated atoms)"
|
|
write(iout,'(a,i8)')
|
|
$' Number of delocalized MOs:',max_deloc_orbs
|
|
select type( algorithm )
|
|
type is ( Algo_npmul )
|
|
if( algorithm % ndeloc_orbs .eq. max_deloc_orbs ) then
|
|
write(iout,*)
|
|
write(iout,'(a)')
|
|
$' All delocalized-orbitals will be selected.'
|
|
elseif( max_deloc_orbs .eq. 0 ) then
|
|
write(iout,*)
|
|
write(iout,'(a)')
|
|
$'WARNING! The number of delocalized orbitals is zero.'
|
|
write(iout,'(a)')
|
|
$' MO selection will be based on the'//
|
|
$'automatic Mulliken charge selection scheme.'
|
|
algorithm % ndeloc_orbs = max_deloc_orbs
|
|
elseif( algorithm % ndeloc_orbs .gt. max_deloc_orbs ) then
|
|
write(iout,*)
|
|
write(iout,'(a)')'WARNING! '//
|
|
$'The specified number of delocalized orbitals'//
|
|
$' is larger than the found number of delocalized orbitals.'
|
|
write(iout,*)
|
|
write(iout,'(a)')
|
|
$' Selecting all delocalized-orbitals...'
|
|
algorithm % ndeloc_orbs = max_deloc_orbs
|
|
elseif( algorithm % ndeloc_orbs .eq. 0 ) then
|
|
write(iout,*)
|
|
write(iout,'(a)')
|
|
$' Delocalized orbitals will not be selected.'
|
|
endif
|
|
end select
|
|
end subroutine determine_MO_delocalization
|
|
!
|
|
subroutine calc_MO_mullipop
|
|
! local
|
|
double precision :: rsum
|
|
integer :: q,mu
|
|
integer :: iatom,jatom
|
|
mullipop( 1 : nbas ) = 0.0d0
|
|
do jatom = 1 , nembedatoms
|
|
iatom = embedatoms( jatom )
|
|
do q = fst_ind , lst_ind
|
|
rsum=0.d0
|
|
do mu = bp%natrange(1,iatom,1 )+1,bp%natrange(2,iatom,1)
|
|
rsum = rsum +
|
|
$ bp%c( mu , q + index_offset ) * bp%v( mu , q + index_offset )
|
|
enddo
|
|
mullipop( q ) = mullipop( q ) + rsum
|
|
enddo
|
|
enddo
|
|
! Sort orbitals in ascending order
|
|
mullipop( fst_ind:lst_ind )=abs( mullipop( fst_ind:lst_ind ) )
|
|
call qsortd( indexarr , nbas , mullipop )
|
|
end subroutine calc_MO_mullipop
|
|
!
|
|
!#################################################
|
|
!############ End of calculation routines ########
|
|
!#################################################
|
|
!
|
|
!#################################################
|
|
!########## MO selection routines ################
|
|
!#################################################
|
|
!
|
|
subroutine do_select
|
|
write(iout,'(3a)') " The MO-select subroutine of the
|
|
$MO selection algorithm '",trim(algorithm % keywd),"' is
|
|
$not implemented!"
|
|
call mrccend(1)
|
|
end subroutine do_select
|
|
!
|
|
subroutine select_spad
|
|
write(iout,*)
|
|
write(iout,'(a)')
|
|
$' ########### Using the SPADE orbital selection scheme ##########'
|
|
write(iout,*)
|
|
write(iout,'(a)')
|
|
$' (The selection is based on the difference of MO populations.)'
|
|
selected_MO_list( fst_ind : fst_ind + MOs_active - 1 ) = 0
|
|
end subroutine select_spad
|
|
!
|
|
subroutine select_amul
|
|
integer :: p
|
|
write(iout,*)
|
|
write(iout,'(a)')
|
|
$' ############ Using the aMul orbital selection scheme ##########'
|
|
write(iout,*)
|
|
write(iout,'(a,f8.4)')
|
|
$' Mulliken population threshold for the active orbitals:',th%mulli
|
|
if( th % mulli .eq. def_mulli ) write(iout,'(a)')
|
|
$" (default parameter)"
|
|
do p = fst_ind + offset , lst_ind + offset
|
|
if( mullipop( indexarr( p ) ).gt. th % mulli ) then
|
|
MOs_active = MOs_active + 1
|
|
selected_MO_list( indexarr( p ) ) = 0
|
|
endif
|
|
enddo
|
|
end subroutine select_amul
|
|
!
|
|
subroutine select_nmul
|
|
integer :: p
|
|
write(iout,*)
|
|
write(iout,'(a)')
|
|
$' ############ Using the nMul orbital selection scheme ##########'
|
|
write(iout,*)
|
|
write(iout,"(' Selecting ',i7,' MOs as active orbitals.')")
|
|
$ MOs_active
|
|
write(iout,'(a)') ' (given by the user)'
|
|
do p = ( lst_ind - MOs_active) + 1, lst_ind
|
|
selected_MO_list( indexarr( p + offset ) ) = 0
|
|
enddo
|
|
end subroutine select_nmul
|
|
!
|
|
subroutine select_bopu
|
|
integer :: iatom,jatom
|
|
integer :: imo,mo_ind,atom_match
|
|
double precision :: crit
|
|
write(iout,*)
|
|
write(iout,'(a)')
|
|
$' ####### Using the Boughton-Pulay orbital selection scheme #####'
|
|
write(iout,*)
|
|
crit = merge( th % bpcompo , th % bpcompv , job .eq. 'o' )
|
|
write(iout,'(a,f8.4)')
|
|
$' Boughton-Pulay completeness threshold:', crit
|
|
if(th % bpcompo .eq. def_bpcompo .and. job .eq. 'o'
|
|
$ .or.
|
|
$ th % bpcompv .eq. def_bpcompv .and. job .eq. 'v')
|
|
$ write(iout,'(a)') " (default parameter)"
|
|
MOs_active = 0
|
|
do imo = fst_ind , lst_ind
|
|
atom_match = 0
|
|
do jatom = 1 , bp % natmo( imo )
|
|
do iatom = 1 , nembedatoms
|
|
if(bp%atmo( jatom , imo ).eq.embedatoms( iatom ))
|
|
$ atom_match = atom_match + 1
|
|
enddo
|
|
enddo
|
|
if( atom_match .gt. 0 ) MOs_active = MOs_active + 1
|
|
selected_MO_list( imo ) = merge( 0,1 , atom_match .gt. 0)
|
|
enddo
|
|
end subroutine select_bopu
|
|
!
|
|
subroutine select_ecore
|
|
integer :: imo
|
|
write(iout,*)
|
|
write(iout,'(a)')
|
|
$' ############# Using the Ecore orbital selection scheme ########'
|
|
write(iout,*)
|
|
write(iout,"(' Selecting ',i4,' MOs as active orbitals.')")
|
|
$ MOs_active
|
|
if( job .eq. 'o' ) then
|
|
do imo = fst_ind , lst_ind
|
|
selected_MO_list( imo ) = merge
|
|
$ ( 1,0 , imo .le. lst_ind - MOs_active )
|
|
enddo
|
|
else if ( job .eq. 'v' ) then
|
|
do imo = fst_ind , lst_ind
|
|
selected_MO_list( imo ) = merge
|
|
$ ( 0,1 , imo .lt. fst_ind + MOs_active )
|
|
enddo
|
|
endif
|
|
end subroutine select_ecore
|
|
!
|
|
subroutine select_serialno
|
|
integer :: i,imo
|
|
write(iout,*)
|
|
write(iout,'(a)')
|
|
$' ############# Using the manual selection of orbitals ########'
|
|
write(iout,*)
|
|
i = index(line_moselect,' ')
|
|
if( i .eq. 1 ) call io_error
|
|
$(' Cannot found MO indices for manual MO selection',
|
|
$'setup_serial @ embedorb (bopu.f)')
|
|
open(scrfile1,file='manselaux',form='formatted')
|
|
write(scrfile1,'(a)') adjustl(line_moselect)
|
|
backspace(scrfile1)
|
|
selected_MO_list( fst_ind : lst_ind ) = 0
|
|
call readlinelist
|
|
$(nbas,scrfile1,selected_MO_list,iout,'mos ')
|
|
close(scrfile1,status='delete')
|
|
! Unfortunately, we have to reset the notation: zero indicate an active MO
|
|
do imo = fst_ind , lst_ind
|
|
selected_MO_list( imo ) = merge
|
|
$( 1 , 0, selected_MO_list( imo ).eq.0 )
|
|
if(selected_MO_list( imo ).eq.0) MOs_active = MOs_active + 1
|
|
enddo
|
|
end subroutine select_serialno
|
|
!
|
|
subroutine select_pmul
|
|
integer :: imo
|
|
select type ( algorithm )
|
|
type is ( Algo_pmul )
|
|
write(iout,*)
|
|
write(iout,'(a)')
|
|
$' ############ Using the pMul orbital selection scheme ##########'
|
|
write(iout,*)
|
|
write(iout,'(a,f8.4)')
|
|
$' Mulliken population threshold for the active'//
|
|
$' non-delocalized orbitals:', th % nondeloc_mulli
|
|
if( th % nondeloc_mulli .eq. def_mulli ) write(iout,'(a)')
|
|
$' (default parameter)'
|
|
write(iout,'(a,f8.4)') ' Mulliken population threshold for'//
|
|
$' the active delocalized orbitals:',th % deloc_mulli
|
|
if( th % deloc_mulli .eq. def_mulli ) write(iout,'(a)')
|
|
$' (default parameter)'
|
|
do imo = fst_ind + offset , lst_ind + offset
|
|
if( bp % mocomp( indexarr( imo ) ).ge. th % deloc ) then
|
|
if( mullipop( indexarr( imo ) ) .gt.th % nondeloc_mulli)
|
|
$ then
|
|
algorithm%nnondeloc_orbs =
|
|
$ algorithm%nnondeloc_orbs + 1
|
|
MOs_active = MOs_active + 1
|
|
selected_MO_list ( indexarr( imo ) ) = 0
|
|
endif
|
|
else
|
|
if( mullipop( indexarr( imo ) ) .gt. th % deloc_mulli )
|
|
$ then
|
|
algorithm%ndeloc_orbs = algorithm%ndeloc_orbs + 1
|
|
MOs_active = MOs_active + 1
|
|
selected_MO_list ( indexarr( imo ) ) = 0
|
|
endif
|
|
endif
|
|
enddo
|
|
end select
|
|
end subroutine select_pmul
|
|
!
|
|
subroutine select_npmul
|
|
integer :: imo,deloc_orbs
|
|
select type( algorithm )
|
|
type is ( Algo_npmul )
|
|
write(iout,*)
|
|
write(iout,'(a)')
|
|
$' ############ Using the pMul orbital selection scheme ##########'
|
|
write(iout,*)
|
|
write(iout,'(a,f8.4)')
|
|
$' Mulliken population threshold for the active'//
|
|
$' non-delocalized orbitals:',th % nondeloc_mulli
|
|
if( th % nondeloc_mulli .eq. def_mulli ) write(iout,'(a)')
|
|
$' (default parameter)'
|
|
write(iout,
|
|
$"(' Selecting ',i7,' delocalized MOs as active orbitals.')")
|
|
$ algorithm % ndeloc_orbs
|
|
write(iout,'(a)') ' (given by the user)'
|
|
deloc_orbs = 0
|
|
do imo = fst_ind + offset , lst_ind + offset
|
|
if( bp % mocomp( indexarr( imo ) ).lt. th % deloc ) then
|
|
deloc_orbs = deloc_orbs + 1
|
|
if( deloc_orbs .gt.
|
|
$ algorithm % max_deloc_orbs - algorithm % ndeloc_orbs)
|
|
$ then
|
|
MOs_active = MOs_active + 1
|
|
selected_MO_list ( indexarr( imo ) ) = 0
|
|
endif
|
|
else
|
|
if( mullipop( indexarr( imo ) ).gt.th%nondeloc_mulli )
|
|
$ then
|
|
algorithm % nnondeloc_orbs =
|
|
$ algorithm % nnondeloc_orbs + 1
|
|
MOs_active = MOs_active + 1
|
|
selected_MO_list ( indexarr( imo ) ) = 0
|
|
endif
|
|
endif
|
|
enddo
|
|
end select
|
|
end subroutine select_npmul
|
|
!
|
|
!#################################################
|
|
!####### end of MO selection routines ###########
|
|
!#################################################
|
|
!
|
|
!#################################################
|
|
!########### Printer routines ####################
|
|
!#################################################
|
|
!
|
|
subroutine do_print
|
|
write(iout,'(3a)') " The MO-printer subroutine of the
|
|
$MO selection algorithm '",trim(algorithm % keywd),"' is
|
|
$not implemented!"
|
|
call mrccend(1)
|
|
end subroutine do_print
|
|
!
|
|
subroutine print_bopu
|
|
call print_pop
|
|
call print_active_MO_indices
|
|
end subroutine print_bopu
|
|
!
|
|
subroutine print_amul
|
|
call print_pop
|
|
call print_active_MO_indices
|
|
end subroutine print_amul
|
|
!
|
|
subroutine print_nmul
|
|
call print_pop
|
|
call print_active_MO_indices
|
|
end subroutine print_nmul
|
|
!
|
|
subroutine print_spad
|
|
call print_pop
|
|
call print_active_MO_indices
|
|
end subroutine print_spad
|
|
!
|
|
subroutine print_nspad
|
|
call print_pop
|
|
call print_active_MO_indices
|
|
end subroutine print_nspad
|
|
!
|
|
subroutine print_serialno
|
|
call print_pop
|
|
call print_active_MO_indices
|
|
end subroutine print_serialno
|
|
!
|
|
subroutine print_ecore
|
|
call print_active_MO_indices
|
|
end subroutine print_ecore
|
|
!
|
|
subroutine print_pmul
|
|
call print_deloc_and_nondeloc_pop
|
|
call print_active_MO_indices
|
|
end subroutine print_pmul
|
|
!
|
|
subroutine print_npmul
|
|
call print_deloc_and_nondeloc_pop
|
|
call print_active_MO_indices
|
|
end subroutine print_npmul
|
|
!
|
|
subroutine print_pop
|
|
integer :: imo
|
|
integer :: gap_ind
|
|
double precision :: min_pop,max_pop
|
|
double precision, parameter :: printpop_min = 0.001d0
|
|
write(iout,*)
|
|
if(job.eq.'o') then
|
|
write(iout,'(a)')
|
|
$' Mulliken population of the occupied orbitals on '//
|
|
$'the active atoms:'
|
|
else if(job.eq.'v') then
|
|
write(iout,'(a)')
|
|
$' Mulliken population of the virtual orbitals on '//
|
|
$'the active atoms:'
|
|
endif
|
|
if(iverbosity .lt. 3 ) write(iout,'(a)')
|
|
$" (only MOs at the border are shown)"
|
|
min_pop = merge
|
|
$( th % mulli * printpop_min , 0.0d0 , iverbosity .lt. 3 )
|
|
max_pop = merge
|
|
$( 1.0d0 - min_pop , maxval(mullipop) , iverbosity .lt. 3 )
|
|
write(iout,*)
|
|
write(iout,'(a)') ' MO Natoms Population Atoms'
|
|
gap_ind = lst_ind - MOs_active + 1 + offset
|
|
do imo = fst_ind + offset , lst_ind + offset
|
|
if( imo .eq. gap_ind ) write(iout,*)
|
|
if( mullipop( indexarr( imo ) ) .ge. min_pop
|
|
$ .and.
|
|
$ mullipop( indexarr( imo ) ) .le. max_pop )
|
|
$ write(iout,"(2i5,4x,f9.6,4x,100i4)")
|
|
$ indexarr( imo ) ,
|
|
$ bp % natmo( indexarr( imo ) ) ,
|
|
$ mullipop( indexarr( imo ) ),
|
|
$ bp%atmo( 1 : bp % natmo(indexarr( imo ) ), indexarr( imo ) )
|
|
enddo
|
|
write(iout,*)
|
|
call check_pop_of_marked_MOs( 0 , th % mulli )
|
|
end subroutine print_pop
|
|
!
|
|
subroutine print_deloc_and_nondeloc_pop
|
|
integer :: imo, porb
|
|
integer :: gap_ind
|
|
integer :: max_deloc_orbs
|
|
integer :: ndeloc_orbs
|
|
integer :: nnondeloc_orbs
|
|
double precision :: min_pop,max_pop
|
|
double precision, parameter :: printpop_min = 0.001d0
|
|
select type ( algorithm )
|
|
type is ( Algo_pmul )
|
|
ndeloc_orbs = algorithm % ndeloc_orbs
|
|
nnondeloc_orbs = algorithm % nnondeloc_orbs
|
|
max_deloc_orbs = algorithm % max_deloc_orbs
|
|
type is ( Algo_npmul )
|
|
ndeloc_orbs = algorithm % ndeloc_orbs
|
|
nnondeloc_orbs = algorithm % nnondeloc_orbs
|
|
max_deloc_orbs = algorithm % max_deloc_orbs
|
|
end select
|
|
write(iout,*)
|
|
if( job .eq. 'o' ) then
|
|
write(iout,'(a)') ' Mulliken population of the occupied '//
|
|
$'non-delocalized orbitals on the active atoms:'
|
|
else
|
|
write(iout,'(a)') ' Mulliken population of the virtual '//
|
|
$'non-delocalized orbitals on the active atoms:'
|
|
endif
|
|
if(iverbosity .lt. 3 ) write(iout,'(a)')
|
|
$" (only MOs at the border are shown)"
|
|
min_pop = merge
|
|
$( th % nondeloc_mulli * printpop_min , 0.0d0 , iverbosity .lt. 3 )
|
|
max_pop = merge
|
|
$( 1.0d0 - min_pop , maxval(mullipop) , iverbosity .lt. 3 )
|
|
write(iout,*)
|
|
write(iout,'(a)') ' MO Natoms Population Atoms'
|
|
gap_ind = lst_ind - max_deloc_orbs - nnondeloc_orbs + offset + 1
|
|
do imo = fst_ind + offset , lst_ind + offset
|
|
if( imo .eq. gap_ind ) write(iout,*)
|
|
if( bp % mocomp ( indexarr( imo ) ) .gt. th % deloc
|
|
$ .and.
|
|
$ mullipop( indexarr( imo ) ) .ge. min_pop
|
|
$ .and.
|
|
$ mullipop( indexarr( imo ) ) .le. max_pop )
|
|
$ write(iout,"(2i5,4x,f9.6,4x,100i4)")
|
|
$ indexarr( imo ) ,
|
|
$ bp % natmo( indexarr( imo ) ) ,
|
|
$ mullipop( indexarr( imo ) ),
|
|
$ bp%atmo( 1 : bp % natmo(indexarr( imo ) ), indexarr( imo ) )
|
|
enddo
|
|
call check_pop_of_marked_MOs( 1 , th % nondeloc_mulli )
|
|
write(iout,*)
|
|
if( job .eq. 'o' ) then
|
|
write(iout,'(a)') ' Mulliken population of the occupied '//
|
|
$'non-delocalized orbitals on the active atoms:'
|
|
else
|
|
write(iout,'(a)') ' Mulliken population of the virtual '//
|
|
$'non-delocalized orbitals on the active atoms:'
|
|
endif
|
|
if(iverbosity .lt. 3 ) write(iout,'(a)')
|
|
$" (only MOs at the border are shown)"
|
|
write(iout,*)
|
|
write(iout,'(a)') ' MO Natoms Population Atoms'
|
|
min_pop = merge
|
|
$( th % deloc_mulli * printpop_min , 0.0d0 , iverbosity .lt. 3 )
|
|
max_pop = merge
|
|
$( 1.0d0 - min_pop , maxval(mullipop) , iverbosity .lt. 3 )
|
|
gap_ind = max_deloc_orbs - ndeloc_orbs
|
|
porb = 0
|
|
do imo = fst_ind + offset , lst_ind + offset
|
|
if( bp % mocomp ( indexarr( imo ) ) .lt. th % deloc
|
|
$ .and.
|
|
$ mullipop( indexarr( imo ) ) .ge. min_pop
|
|
$ .and.
|
|
$ mullipop( indexarr( imo ) ) .le. max_pop ) then
|
|
write(iout,"(2i5,4x,f9.6,4x,100i4)")
|
|
$ indexarr( imo ) ,
|
|
$ bp % natmo( indexarr( imo ) ) ,
|
|
$ mullipop( indexarr( imo ) ),
|
|
$ bp%atmo( 1 : bp % natmo(indexarr( imo ) ), indexarr( imo ) )
|
|
porb = porb + 1
|
|
if( porb .eq. gap_ind ) write(iout,*)
|
|
endif
|
|
enddo
|
|
write(iout,*)
|
|
call check_pop_of_marked_MOs( 2 , th % deloc_mulli )
|
|
end subroutine print_deloc_and_nondeloc_pop
|
|
!
|
|
subroutine check_pop_of_marked_MOs( mo_comp_type , th_mulli )
|
|
integer , intent(in) :: mo_comp_type
|
|
double precision, intent(in) :: th_mulli
|
|
integer, allocatable, target :: scr_orbs(:)
|
|
integer,dimension(:),pointer :: low_orbs =>null()
|
|
integer,dimension(:),pointer :: high_orbs =>null()
|
|
integer :: nhighorbs
|
|
integer :: nloworbs
|
|
! mo_comp_type : 0 : nondeloc/deloc , 1 : nondeloc , 2 : deloc
|
|
call smem % push( nbas )
|
|
scr_orbs = smem % top_i()
|
|
low_orbs => scr_orbs
|
|
nloworbs = get_active_MOs_with_low_pop
|
|
$ ( low_orbs, th_mulli , mo_comp_type)
|
|
if( nloworbs .gt. 0 )
|
|
$ call print_active_MOs_with_low_pop(nloworbs,low_orbs)
|
|
high_orbs => scr_orbs
|
|
nhighorbs = get_inactive_MOs_with_high_pop
|
|
$ (high_orbs, th_mulli , mo_comp_type)
|
|
if( nhighorbs .gt. 0 )
|
|
$ call print_inactive_MOs_with_high_pop(nhighorbs,high_orbs)
|
|
call smem % pop()
|
|
end subroutine check_pop_of_marked_MOs
|
|
!
|
|
integer function get_active_MOs_with_low_pop
|
|
$ ( low_orbs, mulli_th, mo_comp_type ) result(nlow_orbs)
|
|
integer, intent(in) :: mo_comp_type
|
|
integer, dimension(:),intent(inout) :: low_orbs
|
|
double precision, intent(in) :: mulli_th
|
|
double precision, parameter :: high_mulli = 1.5d0
|
|
integer :: i,imo
|
|
double precision :: limit
|
|
logical :: check_deloc
|
|
limit = mulli_th * high_mulli
|
|
low_orbs(:) = 0
|
|
nlow_orbs = 0
|
|
do imo = fst_ind , lst_ind
|
|
if( mo_comp_type .eq. 1 )
|
|
$ check_deloc = bp % mocomp( imo ) .gt. th % deloc
|
|
if( mo_comp_type .eq. 2 )
|
|
$ check_deloc = bp % mocomp( imo ) .lt. th % deloc
|
|
if( (mo_comp_type .eq. 0 .or. check_deloc )
|
|
$ .and.
|
|
$ selected_MO_list( imo ) .eq. 0
|
|
$ .and.
|
|
$ mullipop( imo ) .lt. limit
|
|
$ .and.
|
|
$ mullipop( imo ) .ge. mulli_th ) then
|
|
nlow_orbs = nlow_orbs + 1
|
|
low_orbs( nlow_orbs ) = imo
|
|
endif
|
|
enddo
|
|
end function get_active_MOs_with_low_pop
|
|
!
|
|
integer function get_inactive_MOs_with_high_pop
|
|
$ ( high_orbs, mulli_th, mo_comp_type ) result(nhigh_orbs)
|
|
integer, intent(in) :: mo_comp_type
|
|
integer, dimension(:),intent(inout) :: high_orbs
|
|
double precision, intent(in) :: mulli_th
|
|
double precision, parameter :: low_mulli = 0.1d0
|
|
integer :: i,imo
|
|
double precision :: limit
|
|
logical :: check_deloc
|
|
limit = mulli_th * low_mulli
|
|
high_orbs(:) = 0
|
|
nhigh_orbs = 0
|
|
do imo = fst_ind , lst_ind
|
|
if( mo_comp_type .eq. 1 )
|
|
$ check_deloc = bp % mocomp( imo ) .gt. th % deloc
|
|
if( mo_comp_type .eq. 2 )
|
|
$ check_deloc = bp % mocomp( imo ) .lt. th % deloc
|
|
if( (mo_comp_type .eq. 0 .or. check_deloc )
|
|
$ .and.
|
|
$ selected_MO_list( imo ) .eq. 1
|
|
$ .and.
|
|
$ mullipop( imo ) .ge. limit
|
|
$ .and.
|
|
$ mullipop( imo ) .lt. mulli_th ) then
|
|
nhigh_orbs = nhigh_orbs + 1
|
|
high_orbs( nhigh_orbs ) = imo
|
|
endif
|
|
enddo
|
|
end function get_inactive_MOs_with_high_pop
|
|
!
|
|
subroutine print_active_MOs_with_low_pop(nloworbs,low_orbs)
|
|
integer, intent(in) :: nloworbs
|
|
integer, intent(in) :: low_orbs(:)
|
|
integer :: i
|
|
write(iout,"(a)") " Warning!"
|
|
write(iout,"(a)") " There are orbitals in the high-level"//
|
|
$" subsystem with low Mulliken population on the active atoms."
|
|
write(iout,'(a,i4)')
|
|
$' Number of orbitals in the high-level subsystem'//
|
|
$' with low population:', nloworbs
|
|
write(iout,'(a)') ' Orbitals in the high-level subsystem'//
|
|
$' with low population:'
|
|
write(iout,"(14i5)") (low_orbs(i),i=1,nloworbs)
|
|
write(iout,"(a)")
|
|
$" Please reconsider the orbital selection scheme."
|
|
write(iout,*)
|
|
end subroutine print_active_MOs_with_low_pop
|
|
subroutine print_inactive_MOs_with_high_pop(nhighorbs,high_orbs)
|
|
integer, intent(in) :: nhighorbs
|
|
integer, intent(in) :: high_orbs(:)
|
|
integer :: i
|
|
write(iout,"(a)") " Warning!"
|
|
write(iout,"(a)") " There are orbitals of the environment"//
|
|
$" with high Mulliken population on the active atoms."
|
|
write(iout,'(a,i4)')
|
|
$' Number of orbitals in the low-level subsystem'//
|
|
$' with high population:', nhighorbs
|
|
write(iout,'(a)') ' Orbitals in the low-level subsystem'//
|
|
$' with high population:'
|
|
write(iout,"(14i5)") (high_orbs(i),i=1,nhighorbs)
|
|
write(iout,"(a)")
|
|
$" Please reconsider the orbital selection scheme."
|
|
write(iout,*)
|
|
end subroutine print_inactive_MOs_with_high_pop
|
|
!
|
|
subroutine print_active_MO_indices
|
|
integer :: imo
|
|
integer :: n
|
|
indexarr = 0
|
|
n = 0
|
|
do imo = fst_ind , lst_ind
|
|
if( selected_MO_list( imo ) .eq. 0 ) then
|
|
n = n + 1
|
|
indexarr( n ) = imo
|
|
endif
|
|
enddo
|
|
if( n .ne. MOs_active ) then
|
|
write(iout,'(a)')
|
|
$ " Inconsistent number of active orbitals."
|
|
call mrccend(1)
|
|
endif
|
|
write(iout,'(a,i4)')
|
|
$' Number of orbitals in the high-level subsystem:', MOs_active
|
|
write(iout,"(' Orbitals in the high-level subsystem:')")
|
|
write(iout,"(14i5)") (indexarr( imo ), imo = 1 , MOs_active)
|
|
end subroutine print_active_MO_indices
|
|
!
|
|
!#################################################
|
|
!############# End of printer routines ###########
|
|
!#################################################
|
|
!
|
|
end module qmmod_moselect
|
|
C
|