diff --git a/src/modules/lambda_function.f90 b/src/modules/lambda_function.f90 index fa672a1f3..58cc79f60 100644 --- a/src/modules/lambda_function.f90 +++ b/src/modules/lambda_function.f90 @@ -10,13 +10,14 @@ module lambda_function generic :: init => lambda_init_0 procedure :: eval => lambda_eval_0 procedure :: lambda_init_0 + final :: lambda_destroy end type abstract interface function lambda0(x) result(y) ! Template for a 0 argument function import DP - real(DP), intent(in) :: x + real(DP), dimension(:), intent(in) :: x real(DP) :: y end function end interface @@ -34,17 +35,23 @@ end subroutine lambda_init_0 function lambda_eval_0(self, x) result(y) implicit none ! Arguments - class(lambda_obj), intent(in) :: self - real(DP), intent(in) :: x + class(lambda_obj), intent(in) :: self + real(DP), dimension(:), intent(in) :: x ! Result real(DP) :: y if (associated(self%lambdaptr)) then y = self%lambdaptr(x) else - error stop "Initialize the object (call init) before computing values (call exec)!" + error stop "Lambda function was not initialized" end if end function lambda_eval_0 + subroutine lambda_destroy(self) + implicit none + type(lambda_obj) :: self + if (associated(self%lambdaptr)) nullify(self%lambdaptr) + end subroutine lambda_destroy + end module lambda_function diff --git a/src/modules/module_symba.f90 b/src/modules/module_symba.f90 index fb77a34fb..74ced777d 100644 --- a/src/modules/module_symba.f90 +++ b/src/modules/module_symba.f90 @@ -105,18 +105,69 @@ MODULE module_symba type, public, extends(lambda_obj) :: symba_vel_lambda_obj procedure(abstract_objective_func), pointer, nopass :: ke_objective_func_ptr => null() + real(DP), dimension(:), allocatable :: m_frag + real(DP), dimension(:,:), allocatable :: v_r_unit + real(DP), dimension(NDIM) :: tau, Gam + real(DP) :: Beta, Lam + contains + generic :: init => ke_objective_func_init + procedure :: eval => ke_objective_func_eval + procedure :: ke_objective_func_init + final :: ke_objective_func_destroy end type symba_vel_lambda_obj abstract interface - function abstract_objective_func(v, m, rhat, t, G, B, L) result(fnorm) + function abstract_objective_func(v_r_mag, m_frag, v_r_unit, tau, Gam, Beta, Lam) result(fnorm) ! Template for the kinetic energy constraint function used for minimizing import DP - real(DP), dimension(:), intent(in) :: v, m, t, G - real(DP), dimension(:,:), intent(in) :: rhat - real(DP), intent(in) :: B, L + real(DP), dimension(:), intent(in) :: v_r_mag, m_frag, tau, Gam + real(DP), dimension(:,:), intent(in) :: v_r_unit + real(DP), intent(in) :: Beta, Lam real(DP) :: fnorm end function end interface + + contains + subroutine ke_objective_func_init(self, lambda, m_frag, v_r_unit, tau, Gam, Beta, Lam) + implicit none + ! Arguments + class(symba_vel_lambda_obj), intent(out) :: self + procedure(abstract_objective_func) :: lambda + real(DP), dimension(:), intent(in) :: m_frag, tau, Gam + real(DP), dimension(:,:), intent(in) :: v_r_unit + real(DP), intent(in) :: Beta, Lam + + self%ke_objective_func_ptr => lambda + allocate(self%m_frag, source=m_frag) + allocate(self%v_r_unit, source=v_r_unit) + self%tau(:) = tau(:) + self%Gam(:) = Gam(:) + self%Beta = Beta + self%Lam = Lam + end subroutine ke_objective_func_init + + subroutine ke_objective_func_destroy(self) + implicit none + type(symba_vel_lambda_obj) :: self + if (allocated(self%m_frag)) deallocate(self%m_frag) + if (allocated(self%v_r_unit)) deallocate(self%v_r_unit) + if (associated(self%ke_objective_func_ptr)) nullify(self%ke_objective_func_ptr) + end subroutine ke_objective_func_destroy + + function ke_objective_func_eval(self, x) result(fnorm) + implicit none + ! Arguments + class(symba_vel_lambda_obj), intent(in) :: self + real(DP), dimension(:), intent(in) :: x + ! Result + real(DP) :: fnorm + + if (associated(self%ke_objective_func_ptr)) then + fnorm = self%ke_objective_func_ptr(x, self%m_frag, self%v_r_unit, self%tau, self%Gam, self%Beta, self%Lam) + else + error stop "KE Objective function was not initialized." + end if + end function ke_objective_func_eval END MODULE module_symba !********************************************************************************************************************************** !