CACmb/src/mode_merge.f90

module mode_merge
    !This module contains the code needed for merging several .mb files together

    use parameters
    use atoms   
    use io
    use subroutines
    use elements
    use neighbors

    implicit none

    character(len=4) :: dim
    integer :: in_num, new_starts(2)
    real(kind=dp) :: shift_vec(3), replace_vec(3) 
    character(len=100) :: replace_str(3)
    logical :: shift_flag, replace_flag
    real(kind=dp), private, save :: rc_off 

    public 
    contains
    subroutine merge(arg_pos)
        
        integer, intent(out) :: arg_pos 
        integer :: i, j 
        real(kind=dp) :: displace(3), temp_box_bd(6)

        print *, '-----------------------Mode Merge---------------------------'
        
        shift_flag = .false.

        shift_vec(:) = 0.0_dp
        temp_box_bd(:) = 0.0_dp
        !First we parse the merge command
        call parse_command(arg_pos)

        !Now loop over all files and stack them 
        do i = 1, in_num
            displace(:) = 0.0_dp
            
            !The new starts variable dictate where in the atom and element array each new 
            !file starts. This is used for additional options that can be applied to solely 
            !these new atoms/elements that are read in.

            new_starts(1) = atom_num + 1
            new_starts(2) = ele_num + 1

            if ((i==1).or.(trim(adjustl(dim)) == 'none')) then 
                call read_in(i, displace, temp_box_bd)
            else
                select case(trim(adjustl(dim)))
                case('x')
                    displace(1) = box_bd(2)
                case('y')
                    displace(2) = box_bd(4)
                case('z')
                    displace(3) = box_bd(6)
                end select

                call read_in(i, displace, temp_box_bd)
            end if 


            if(shift_flag) call shift(new_starts, i)

            if(replace_flag.and.(i>1)) then 
                !Parse the replace vector
                do j = 1, 3
                    call parse_pos(j, replace_str(j), replace_vec(j))
                end do
                call replace(new_starts, temp_box_bd)
            end if

        end do


        !Now reset tags
        do i = 1, atom_num
            tag_atom(i) = i
        end do
        
        do i = 1, ele_num
            tag_ele(i) = i
        end do

        return
    end subroutine merge

    subroutine parse_command(arg_pos)

        integer, intent(out) :: arg_pos

        character(len=100) :: textholder
        integer :: i, stat, arglen

        !Get dimension to concatenate along
        call get_command_argument(2, dim, arglen)
        if (arglen == 0) STOP "Missing dim in mode_merge command"
        select case(trim(adjustl(dim)))
        case('x','y','z','none')
            continue
        case default
            print *, dim, " not accepted as a dimension in mode_merge"
            stop 3
        end select
        !Get number of files to read in 
        call get_command_argument(3, textholder, arglen)
        if (arglen == 0) STOP "Number of files to read missing in mode_merge command"
        read(textholder, *, iostat = stat) in_num
        if (stat > 0) STOP "Error reading number of files in, must be integer"

        !Now loop and pull out all files 
        do i = 1, in_num
            call get_command_argument(3+i, textholder, arglen)
            if (arglen == 0) STOP "Fewer files to read in then specified"
            !Make sure this file is readable
            call get_in_file(textholder)
        end do

        !Set argpos accordingly
        arg_pos = 3+in_num
        !Now options loop
        !Check for optional keywords
        do while(.true.)
            if(arg_pos > command_argument_count()) exit
            !Pull out the next argument which should either be a keyword or an option
            arg_pos=arg_pos+1
            call get_command_argument(arg_pos, textholder)
            textholder=adjustl(textholder)

            !Choose what to based on what the option string is 
            select case(trim(textholder))
            case('shift')
                shift_flag = .true.
                do i = 1,3 
                    arg_pos = arg_pos + 1
                    call get_command_argument(arg_pos, textholder, arglen)
                    if (arglen==0) stop "Missing vector component for shift command"
                    read(textholder, *) shift_vec(i)
                end do
            case('replace')
                replace_flag = .true.
                do i = 1,3
                    arg_pos = arg_pos + 1
                    call get_command_argument(arg_pos, replace_str(i), arglen)
                    if (arglen==0) stop "Missing vector component for shift command"
                end do
                arg_pos = arg_pos+1
                call get_command_argument(arg_pos, textholder, arglen)
                read(textholder,*) rc_off

            case default
                !If it isn't an available option to mode merge then we just exit
                exit 
            end select
        end do

    end subroutine parse_command

    subroutine shift(array_start, filenum)
        !This subroutine applies a shift to newly added atoms and elements.  

        integer, dimension(2), intent(in) :: array_start
        integer, intent(in) :: filenum

        integer :: i, ibasis, inod
        real(kind=dp), dimension(3) :: current_shift
        character(len=3) :: alldims

        alldims = 'xyz'
        !Calculate the current shift which is the filenum-1 multiplied by the user specified shift
        current_shift = (filenum-1)*shift_vec

        print *, "Atoms/elements from file ", trim(adjustl(infiles(filenum))), " are shifted by ", current_shift

        !First shift all the atoms
        do i = array_start(1), atom_num
            r_atom(:,i) = r_atom(:,i) + current_shift
        end do 

        !Now shift all the elements
        do i = array_start(2), ele_num
            do inod = 1, ng_node(lat_ele(i))
                do ibasis = 1, basisnum(lat_ele(i))
                    r_node(:,ibasis, inod, i) = r_node(:,ibasis, inod, i) + current_shift
                end do
            end do
        end do

        !If we don't include the wrap command then we have to increase the size of the box
        if(.not.(wrap_flag)) then 
            do i = 1,3
                if (alldims(i:i) /= trim(adjustl(dim))) then 
                    if (current_shift(i) < -lim_zero) then 
                        box_bd(2*i-1) = box_bd(2*i-1) - current_shift(i)
                    else if (current_shift(i) > lim_zero) then 
                        box_bd(2*i) = box_bd(2*i) + current_shift(i)
                    end if
                else if (alldims(i:i) == trim(adjustl(dim))) then 
                    box_bd(2*i) = box_bd(2*i) + current_shift(i)
                end if
            end do
        end if

    end subroutine shift

    subroutine replace(array_start, rbox_bd)
        integer, intent(in) :: array_start(2)
        real(kind = dp), intent(in) :: rbox_bd(6)

        integer ::  ibasis, inod, del_num, del_index(atom_num), nump_ele, interp_start
        integer ::  j, ie, type_interp(max_basisnum*max_esize**3), add_atom_num, orig_atom_num, m, n, o, esize, &
                   ele(3,8), new_ele_num, vlat(3), added_points
        real(kind=dp) :: r_interp(3, max_basisnum*max_esize**3), rfill(3,max_basisnum,max_ng_node), ravg(3), ratom(3,max_basisnum)
        logical :: in_bd, lat_points(max_esize, max_esize, max_esize)
        real(kind=dp) :: del_bd(6)
        integer :: i, c(3), ci, cj, ck, num_nei, nei, delete_num

        !These are the variables containing the cell list information
        integer, dimension(3) :: cell_num
        integer, allocatable :: num_in_cell(:,:,:), which_cell(:,:)
        integer, allocatable :: cell_list(:,:,:,:)

        !First apply the replace vec to all new nodes and elements
        do i = array_start(1), atom_num
            r_atom(:,i) = r_atom(:, i) + replace_vec
        end do  

        do i = array_start(2), ele_num
            do inod = 1, ng_node(lat_ele(i))
                do ibasis=1, basisnum(lat_ele(i))
                    r_node(:, ibasis,inod, i) = r_node(:, ibasis,inod, i) + replace_vec 
                end do
            end do

        end do

        !Calculate new boundary
        do i = 1, 6
            del_bd(i) = rbox_bd(i) + replace_vec((i-1)/2 + 1)
        end do
        
        del_num = 0
        del_index=0
        interp_start = atom_num +1
        !Now loop over all old elements, 
        do ie = 1, array_start(2)-1
            !If any element points are within the boundary then we run the refine code
            if(ele_in_bounds(del_bd, type_ele(ie), size_ele(ie), lat_ele(ie), r_node(:,:,:,ie))) then 
                added_points=0
                del_num = del_num + 1
                del_index(del_num) = ie

                !Find all possible elements that we can make while making sure they aren't in the group
                lat_points(1:size_ele(ie),1:size_ele(ie),1:size_ele(ie)) = .true.

                !Now add the leftover lattice points as atoms, only if they aren't within the new boundaries
                do o = 1, size_ele(ie)
                    do n = 1, size_ele(ie)
                        do m = 1, size_ele(ie)
                            if(lat_points(m,n,o)) then 
                                call get_interp_pos(m,n,o, ie, ratom(:,:))
                                do ibasis = 1, basisnum(lat_ele(ie))
                                    call apply_periodic(ratom(:,ibasis))
                                    added_points=added_points + 1
                                    call add_atom(0, basis_type(ibasis,lat_ele(ie)), sbox_ele(ie), ratom(:,ibasis))
                                end do
                            end if
                        end do
                    end do
                end do

                if (added_points /= (size_ele(ie)**3)) then 
                    print *, "Element ", ie, " is refined incorrectly in refinefill"
                end if
            end if
        end do

        !Once all atoms are added we delete all of the elements
        call delete_elements(del_num, del_index)

        !Now delete overlapping atoms
        allocate(which_cell(3,atom_num))

        !First pass the atom list and atom num to the algorithm which builds the cell list
        print *, rc_off
        call build_cell_list(atom_num, r_atom, 4*rc_off, cell_num, num_in_cell, cell_list, which_cell)

        !Now loop over every atom and figure out if it has neighbors within the rc_off
        del_num = 0
        atom_loop: do i = 1, atom_num
            
            !c is the position of the cell that the atom belongs to 
            c = which_cell(:,i)

            !Check to make sure it hasn't already been deleted
            if(all(c /= 0)) then 
                !Now loop over all neighboring cells
                do ci = -1, 1, 1
                    do cj = -1, 1, 1
                        do ck = -1, 1, 1  

                            if (any((c + (/ ck, cj, ci /)) == 0)) cycle 

                            if( (c(1) + ck > cell_num(1)).or.(c(2) + cj > cell_num(2)).or. &
                                (c(3) + ci > cell_num(3))) cycle


                            do num_nei = 1, num_in_cell(c(1) + ck, c(2) + cj, c(3) + ci)
                                nei = cell_list(num_nei,c(1) + ck, c(2) + cj, c(3) + ci)

                                !Check to make sure the atom isn't the same index as the atom we are checking 
                                !and that the neighbor hasn't already been deleted
                                if((nei /= i).and.(nei/= 0)) then 

                                    !Now check to see if it is in the cutoff radius, if it is add it to the delete code
                                    if (norm2(r_atom(:,nei)-r_atom(:,i)) < rc_off) then 
                                        
                                        del_num = del_num + 1

                                        !Make sure to delete the older value
                                        if( (i < array_start(1)).or.(i > interp_start)) then 
                                            del_index(del_num) = i
                                            which_cell(:,i) = 0
                                            cycle atom_loop
                                        else
                                            del_index(del_num) = nei
                                            which_cell(:,nei) = 0 
                                            cell_list(num_nei,c(1) + ck, c(2) + cj, c(3) + ci) = 0
                                        end if
                                    end if
                                end if
                            end do 
                        end do
                    end do 
                end do 
            end if

        end do atom_loop

        print *, "Replace command deletes ", del_num, " atoms"
        !Now delete all the atoms
        call delete_atoms(del_num, del_index(1:del_num))


        return
    end subroutine replace

end module mode_merge