mdtools/libmdCode/do_Forces.F90

!! do_Forces.F90
!! module do_Forces
!! Calculates Long Range forces.

!! @author Charles F. Vardeman II
!! @author Matthew Meineke
!! @version $Id: do_Forces.F90,v 1.24 2003-03-18 16:46:47 gezelter Exp $, $Date: 2003-03-18 16:46:47 $, $Name: not supported by cvs2svn $, $Revision: 1.24 $

module do_Forces
  use force_globals
  use simulation
  use definitions
  use atype_module
  use neighborLists  
  use lj
  use sticky_pair
  use dipole_dipole
  use reaction_field
#ifdef IS_MPI
  use mpiSimulation
#endif

  implicit none
  PRIVATE

#define __FORTRAN90
#include "fForceField.h"

  logical, save :: do_forces_initialized = .false.
  logical, save :: FF_uses_LJ
  logical, save :: FF_uses_sticky
  logical, save :: FF_uses_dipoles
  logical, save :: FF_uses_RF
  logical, save :: FF_uses_GB
  logical, save :: FF_uses_EAM

  public :: init_FF
  public :: do_force_loop

contains

  subroutine init_FF(LJMIXPOLICY, use_RF_c, thisStat)

    integer, intent(in) :: LJMIXPOLICY
    logical, intent(in) :: use_RF_c

    integer, intent(out) :: thisStat   
    integer :: my_status, nMatches
    integer, pointer :: MatchList(:)
    real(kind=dp) :: rcut, rrf, rt, dielect

    !! assume things are copacetic, unless they aren't
    thisStat = 0

    !! Fortran's version of a cast:
    FF_uses_RF = use_RF_c
    
    !! init_FF is called *after* all of the atom types have been 
    !! defined in atype_module using the new_atype subroutine.
    !!
    !! this will scan through the known atypes and figure out what
    !! interactions are used by the force field.     
    
    FF_uses_LJ = .false.
    FF_uses_sticky = .false.
    FF_uses_dipoles = .false.
    FF_uses_GB = .false.
    FF_uses_EAM = .false.
    
    call getMatchingElementList(atypes, "is_LJ", .true., nMatches, MatchList)
    deallocate(MatchList)
    if (nMatches .gt. 0) FF_uses_LJ = .true.
    
    call getMatchingElementList(atypes, "is_DP", .true., nMatches, MatchList)
    deallocate(MatchList)
    if (nMatches .gt. 0) FF_uses_dipoles = .true.
    
    call getMatchingElementList(atypes, "is_Sticky", .true., nMatches, &
         MatchList) 
    deallocate(MatchList)
    if (nMatches .gt. 0) FF_uses_Sticky = .true.
    
    call getMatchingElementList(atypes, "is_GB", .true., nMatches, MatchList)
    deallocate(MatchList)
    if (nMatches .gt. 0) FF_uses_GB = .true.
    
    call getMatchingElementList(atypes, "is_EAM", .true., nMatches, MatchList)
    deallocate(MatchList)
    if (nMatches .gt. 0) FF_uses_EAM = .true.
    
    !! check to make sure the FF_uses_RF setting makes sense
    
    if (FF_uses_dipoles) then
       rrf = getRrf()
       rt = getRt()       
       call initialize_dipole(rrf, rt)
       if (FF_uses_RF) then
          dielect = getDielect()
          call initialize_rf(rrf, rt, dielect)
       endif
    else
       if (FF_uses_RF) then          
          write(default_error,*) 'Using Reaction Field with no dipoles?  Huh?'
          thisStat = -1
          return
       endif
    endif

    if (FF_uses_LJ) then
       
       call getRcut(rcut)

       select case (LJMIXPOLICY)
       case (LB_MIXING_RULE)
          call init_lj_FF(LB_MIXING_RULE, rcut, my_status)             
       case (EXPLICIT_MIXING_RULE)
          call init_lj_FF(EXPLICIT_MIXING_RULE, rcut, my_status)
       case default
          write(default_error,*) 'unknown LJ Mixing Policy!'
          thisStat = -1
          return             
       end select
       if (my_status /= 0) then
          thisStat = -1
          return
       end if
    endif

    if (FF_uses_sticky) then
       call check_sticky_FF(my_status)
       if (my_status /= 0) then
          thisStat = -1
          return
       end if
    endif
    
    
    do_forces_initialized = .true.    
    
  end subroutine init_FF
  

  !! Does force loop over i,j pairs. Calls do_pair to calculates forces.
  !------------------------------------------------------------->
  subroutine do_force_loop(q, A, u_l, f, t, tau, pot, do_pot_c, do_stress_c, &
       error)
    !! Position array provided by C, dimensioned by getNlocal
    real ( kind = dp ), dimension(3,getNlocal()) :: q
    !! Rotation Matrix for each long range particle in simulation.
    real( kind = dp), dimension(9,getNlocal()) :: A    
    !! Unit vectors for dipoles (lab frame)
    real( kind = dp ), dimension(3,getNlocal()) :: u_l
    !! Force array provided by C, dimensioned by getNlocal
    real ( kind = dp ), dimension(3,getNlocal()) :: f
    !! Torsion array provided by C, dimensioned by getNlocal
    real( kind = dp ), dimension(3,getNlocal()) :: t    
    !! Stress Tensor
    real( kind = dp), dimension(9) :: tau   
    real ( kind = dp ) :: pot
    logical ( kind = 2) :: do_pot_c, do_stress_c
    logical :: do_pot
    logical :: do_stress
#ifdef IS_MPI
    real( kind = DP ) :: pot_local
    integer :: nrow
    integer :: ncol
#endif
    integer :: nlocal
    integer :: natoms    
    logical :: update_nlist   
    integer :: i, j, jbeg, jend, jnab
    integer :: nlist
    real( kind = DP ) ::  rijsq, rlistsq, rcutsq, rlist, rcut
    real(kind=dp),dimension(3) :: d
    real(kind=dp) :: rfpot, mu_i, virial
    integer :: me_i
    logical :: is_dp_i
    integer :: neighborListSize
    integer :: listerror, error
    integer :: localError

    !! initialize local variables  

#ifdef IS_MPI
    nlocal = getNlocal()
    nrow   = getNrow(plan_row)
    ncol   = getNcol(plan_col)
#else
    nlocal = getNlocal()
    natoms = nlocal
#endif

    call getRcut(rcut,rc2=rcutsq)
    call getRlist(rlist,rlistsq)
    
    call check_initialization(localError)
    if ( localError .ne. 0 ) then
       error = -1
       return
    end if
    call zero_work_arrays()

    do_pot = do_pot_c
    do_stress = do_stress_c

    ! Gather all information needed by all force loops:
    
#ifdef IS_MPI    

    call gather(q,q_Row,plan_row3d)
    call gather(q,q_Col,plan_col3d)
        
    if (FF_UsesDirectionalAtoms() .and. SimUsesDirectionalAtoms()) then
       call gather(u_l,u_l_Row,plan_row3d)
       call gather(u_l,u_l_Col,plan_col3d)
       
       call gather(A,A_Row,plan_row_rotation)
       call gather(A,A_Col,plan_col_rotation)
    endif
    
#endif
    
    if (FF_RequiresPrepairCalc() .and. SimRequiresPrepairCalc()) then
       !! See if we need to update neighbor lists
       call checkNeighborList(nlocal, q, rcut, rlist, update_nlist)   
       !! if_mpi_gather_stuff_for_prepair
       !! do_prepair_loop_if_needed
       !! if_mpi_scatter_stuff_from_prepair
       !! if_mpi_gather_stuff_from_prepair_to_main_loop
    else
       !! See if we need to update neighbor lists
       call checkNeighborList(nlocal, q, rcut, rlist, update_nlist)   
    endif
    
#ifdef IS_MPI
    
    if (update_nlist) then
       
       !! save current configuration, construct neighbor list, 
       !! and calculate forces
       call saveNeighborList(q)
       
       neighborListSize = getNeighborListSize()
       nlist = 0       
       
       do i = 1, nrow
          point(i) = nlist + 1
          
          inner: do j = 1, ncol
             
             if (skipThisPair(i,j)) cycle inner
             
             call get_interatomic_vector(q_Row(:,i), q_Col(:,j), d, rijsq)
             
             if (rijsq <  rlistsq) then             
                
                nlist = nlist + 1
                
                if (nlist > neighborListSize) then
                   call expandNeighborList(nlocal, listerror)
                   if (listerror /= 0) then
                      error = -1
                      write(DEFAULT_ERROR,*) "ERROR: nlist > list size and max allocations exceeded."
                      return
                   end if
                endif
                
                list(nlist) = j
                                
                if (rijsq <  rcutsq) then
                   call do_pair(i, j, rijsq, d, do_pot, do_stress, &
                        u_l, A, f, t)
                endif
             endif
          enddo inner
       enddo

       point(nrow + 1) = nlist + 1
       
    else  !! (of update_check)

       ! use the list to find the neighbors
       do i = 1, nrow
          JBEG = POINT(i)
          JEND = POINT(i+1) - 1
          ! check thiat molecule i has neighbors
          if (jbeg .le. jend) then
             
             do jnab = jbeg, jend
                j = list(jnab)

                call get_interatomic_vector(q_Row(:,i), q_Col(:,j), d, rijsq)
                call do_pair(i, j, rijsq, d, do_pot, do_stress, &
                     u_l, A, f, t)

             enddo
          endif
       enddo
    endif
    
#else
    
    if (update_nlist) then
       
       ! save current configuration, contruct neighbor list, 
       ! and calculate forces
       call saveNeighborList(q)
       
       neighborListSize = getNeighborListSize()
       nlist = 0
       
       do i = 1, natoms-1
          point(i) = nlist + 1
          
          inner: do j = i+1, natoms
             
             if (skipThisPair(i,j)) cycle inner
             
             call get_interatomic_vector(q(:,i), q(:,j), d, rijsq)
           
             if (rijsq <  rlistsq) then
                
                nlist = nlist + 1
                
                if (nlist > neighborListSize) then
                   call expandList(natoms, listerror)
                   if (listerror /= 0) then
                      error = -1
                      write(DEFAULT_ERROR,*) "ERROR: nlist > list size and max allocations exceeded."
                      return
                   end if
                endif
                
                list(nlist) = j
                
                if (rijsq <  rcutsq) then
                   call do_pair(i, j, rijsq, d, do_pot, do_stress, &
                        u_l, A, f, t)
                endif
             endif
          enddo inner
       enddo
       
       point(natoms) = nlist + 1
       
    else !! (update)
       
       ! use the list to find the neighbors
       do i = 1, natoms-1
          JBEG = POINT(i)
          JEND = POINT(i+1) - 1
          ! check thiat molecule i has neighbors
          if (jbeg .le. jend) then
             
             do jnab = jbeg, jend
                j = list(jnab)

                call get_interatomic_vector(q(:,i), q(:,j), d, rijsq)
                call do_pair(i, j, rijsq, d, do_pot, do_stress, &
                     u_l, A, f, t)

             enddo
          endif
       enddo
    endif
    
#endif 
    
    ! phew, done with main loop.
    
#ifdef IS_MPI
    !!distribute forces
    
    call scatter(f_Row,f,plan_row3d)
    call scatter(f_Col,f_temp,plan_col3d)
    do i = 1,nlocal
       f(1:3,i) = f(1:3,i) + f_temp(1:3,i)
    end do
    
    if (FF_UsesDirectionalAtoms() .and. SimUsesDirectionalAtoms()) then
       call scatter(t_Row,t,plan_row3d)
       call scatter(t_Col,t_temp,plan_col3d)
       
       do i = 1,nlocal
          t(1:3,i) = t(1:3,i) + t_temp(1:3,i)
       end do
    endif
    
    if (do_pot) then
       ! scatter/gather pot_row into the members of my column
       call scatter(pot_Row, pot_Temp, plan_row)
       
       ! scatter/gather pot_local into all other procs
       ! add resultant to get total pot
       do i = 1, nlocal
          pot_local = pot_local + pot_Temp(i)
       enddo

       pot_Temp = 0.0_DP

       call scatter(pot_Col, pot_Temp, plan_col)
       do i = 1, nlocal
          pot_local = pot_local + pot_Temp(i)
       enddo
       
    endif    
#endif

    if (FF_RequiresPostpairCalc() .and. SimRequiresPostpairCalc()) then
       
       if (FF_uses_RF .and. SimUsesRF()) then
          
#ifdef IS_MPI
          call scatter(rf_Row,rf,plan_row3d)
          call scatter(rf_Col,rf_Temp,plan_col3d)
          do i = 1,nlocal
             rf(1:3,i) = rf(1:3,i) + rf_Temp(1:3,i)
          end do
#endif
          
          do i = 1, getNlocal()

             rfpot = 0.0_DP
#ifdef IS_MPI
             me_i = atid_row(i)
#else
             me_i = atid(i)
#endif
             call getElementProperty(atypes, me_i, "is_DP", is_DP_i)       
             if ( is_DP_i ) then
                call getElementProperty(atypes, me_i, "dipole_moment", mu_i)
                !! The reaction field needs to include a self contribution 
                !! to the field:
                call accumulate_self_rf(i, mu_i, u_l)             
                !! Get the reaction field contribution to the 
                !! potential and torques:
                call reaction_field_final(i, mu_i, u_l, rfpot, t, do_pot)
#ifdef IS_MPI
                pot_local = pot_local + rfpot
#else
                pot = pot + rfpot
#endif
             endif             
          enddo
       endif
    endif


#ifdef IS_MPI

    if (do_pot) then
       pot = pot_local
       !! we assume the c code will do the allreduce to get the total potential
       !! we could do it right here if we needed to...
    endif

    if (do_stress) then
       call mpi_allreduce(tau, tau_Temp,9,mpi_double_precision,mpi_sum, &
            mpi_comm_world,mpi_err)
       call mpi_allreduce(virial, virial_Temp,1,mpi_double_precision,mpi_sum, &
            mpi_comm_world,mpi_err)
    endif

#else

    if (do_stress) then
       tau = tau_Temp
       virial = virial_Temp
    endif

#endif
    
  end subroutine do_force_loop

  subroutine do_pair(i, j, rijsq, d, do_pot, do_stress, u_l, A, f, t)

    real( kind = dp ) :: pot
    real( kind = dp ), dimension(3,getNlocal()) :: u_l
    real (kind=dp), dimension(9,getNlocal()) :: A
    real (kind=dp), dimension(3,getNlocal()) :: f
    real (kind=dp), dimension(3,getNlocal()) :: t

    logical, intent(inout) :: do_pot, do_stress
    integer, intent(in) :: i, j
    real ( kind = dp ), intent(inout)    :: rijsq
    real ( kind = dp )                :: r
    real ( kind = dp ), intent(inout) :: d(3)
    logical :: is_LJ_i, is_LJ_j
    logical :: is_DP_i, is_DP_j
    logical :: is_Sticky_i, is_Sticky_j
    integer :: me_i, me_j

    r = sqrt(rijsq)
    
#ifdef IS_MPI

    me_i = atid_row(i)
    me_j = atid_col(j)

#else

    me_i = atid(i)
    me_j = atid(j)

#endif

    if (FF_uses_LJ .and. SimUsesLJ()) then
       call getElementProperty(atypes, me_i, "is_LJ", is_LJ_i)
       call getElementProperty(atypes, me_j, "is_LJ", is_LJ_j)
       
       if ( is_LJ_i .and. is_LJ_j ) &
            call do_lj_pair(i, j, d, r, rijsq, pot, f, do_pot, do_stress)
    endif
       
    if (FF_uses_dipoles .and. SimUsesDipoles()) then
       call getElementProperty(atypes, me_i, "is_DP", is_DP_i)
       call getElementProperty(atypes, me_j, "is_DP", is_DP_j)
       
       if ( is_DP_i .and. is_DP_j ) then
          
          call do_dipole_pair(i, j, d, r, rijsq, pot, u_l, f, t, &
               do_pot, do_stress)
          
          if (FF_uses_RF .and. SimUsesRF()) then
             
             call accumulate_rf(i, j, r, u_l)
             call rf_correct_forces(i, j, d, r, u_l, f, do_stress)
             
          endif
          
       endif
    endif

    if (FF_uses_Sticky .and. SimUsesSticky()) then

       call getElementProperty(atypes, me_i, "is_Sticky", is_Sticky_i)
       call getElementProperty(atypes, me_j, "is_Sticky", is_Sticky_j)
       
       if ( is_Sticky_i .and. is_Sticky_j ) then
          call do_sticky_pair(i, j, d, r, rijsq, A, pot, f, t, &
               do_pot, do_stress)
       endif
    endif
      
  end subroutine do_pair


  subroutine get_interatomic_vector(q_i, q_j, d, r_sq)
    
    real (kind = dp), dimension(3) :: q_i
    real (kind = dp), dimension(3) :: q_j
    real ( kind = dp ), intent(out) :: r_sq
    real( kind = dp ) :: d(3)

    d(1:3) = q_i(1:3) - q_j(1:3)
    
    ! Wrap back into periodic box if necessary
    if ( SimUsesPBC() ) then
       d(1:3) = d(1:3) - box(1:3) * sign(1.0_dp,box(1:3)) * &
            int(abs(d(1:3)/box(1:3) + 0.5_dp))
    endif
    
    r_sq = dot_product(d,d)
        
  end subroutine get_interatomic_vector

  subroutine check_initialization(error)
    integer, intent(out) :: error
    
    error = 0
    ! Make sure we are properly initialized.
    if (.not. do_forces_initialized) then
       write(default_error,*) "ERROR: do_Forces has not been initialized!"
       error = -1
       return
    endif

#ifdef IS_MPI
    if (.not. isMPISimSet()) then
       write(default_error,*) "ERROR: mpiSimulation has not been initialized!"
       error = -1
       return
    endif
#endif
    
    return
  end subroutine check_initialization

  
  subroutine zero_work_arrays()
    
#ifdef IS_MPI

    q_Row = 0.0_dp
    q_Col = 0.0_dp   
    
    u_l_Row = 0.0_dp
    u_l_Col = 0.0_dp
    
    A_Row = 0.0_dp
    A_Col = 0.0_dp
    
    f_Row = 0.0_dp
    f_Col = 0.0_dp
    f_Temp = 0.0_dp
      
    t_Row = 0.0_dp
    t_Col = 0.0_dp
    t_Temp = 0.0_dp
 
    pot_Row = 0.0_dp
    pot_Col = 0.0_dp
    pot_Temp = 0.0_dp

    rf_Row = 0.0_dp
    rf_Col = 0.0_dp
    rf_Temp = 0.0_dp

#endif

    rf = 0.0_dp
    tau_Temp = 0.0_dp
    virial_Temp = 0.0_dp
    
  end subroutine zero_work_arrays
  
  function skipThisPair(atom1, atom2) result(skip_it)
    
    integer, intent(in) :: atom1
    integer, intent(in), optional :: atom2
    logical :: skip_it
    integer :: unique_id_1, unique_id_2
    integer :: i

    skip_it = .false. 

    !! there are a number of reasons to skip a pair or a particle
    !! mostly we do this to exclude atoms who are involved in short
    !! range interactions (bonds, bends, torsions), but we also need 
    !! to exclude some overcounted interactions that result from
    !! the parallel decomposition
    
#ifdef IS_MPI
    !! in MPI, we have to look up the unique IDs for each atom
    unique_id_1 = tagRow(atom1)
#else
    !! in the normal loop, the atom numbers are unique
    unique_id_1 = atom1
#endif
    
    !! We were called with only one atom, so just check the global exclude
    !! list for this atom
    if (.not. present(atom2)) then
       do i = 1, nExcludes_global
          if (excludesGlobal(i) == unique_id_1) then
             skip_it = .true.
             return
          end if
       end do
       return 
    end if
    
#ifdef IS_MPI
    unique_id_2 = tagColumn(atom2)
#else
    unique_id_2 = atom2
#endif
    
#ifdef IS_MPI
    !! this situation should only arise in MPI simulations
    if (unique_id_1 == unique_id_2) then
       skip_it = .true.
       return
    end if
    
    !! this prevents us from doing the pair on multiple processors
    if (unique_id_1 < unique_id_2) then
       if (mod(unique_id_1 + unique_id_2,2) == 0) skip_it = .true.
       return
    else                
       if (mod(unique_id_1 + unique_id_2,2) == 1) skip_it = .true.
    endif
#endif

    !! the rest of these situations can happen in all simulations:
    do i = 1, nExcludes_global       
       if ((excludesGlobal(i) == unique_id_1) .or. &
            (excludesGlobal(i) == unique_id_2)) then
          skip_it = .true.
          return
       endif
    enddo
    
    do i = 1, nExcludes_local
       if (excludesLocal(1,i) == unique_id_1) then
          if (excludesLocal(2,i) == unique_id_2) then
             skip_it = .true.
             return
          endif
       else
          if (excludesLocal(1,i) == unique_id_2) then
             if (excludesLocal(2,i) == unique_id_1) then
                skip_it = .true.
                return
             endif
          endif
       endif
    end do
    
    return
  end function skipThisPair

  function FF_UsesDirectionalAtoms() result(doesit)
    logical :: doesit
    doesit = FF_uses_dipoles .or. FF_uses_sticky .or. &
         FF_uses_GB .or. FF_uses_RF
  end function FF_UsesDirectionalAtoms
  
  function FF_RequiresPrepairCalc() result(doesit)
    logical :: doesit
    doesit = FF_uses_EAM
  end function FF_RequiresPrepairCalc
  
  function FF_RequiresPostpairCalc() result(doesit)
    logical :: doesit
    doesit = FF_uses_RF
  end function FF_RequiresPostpairCalc
  
end module do_Forces
Revision:	360
Committed:	Tue Mar 18 16:46:47 2003 UTC (21 years, 5 months ago) by gezelter
File size:	20036 byte(s)
Log Message:	brought force_globals back from the dead to fix circular references