!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! Module dr_misalign_mod ! ! This module contains a routine for assigning random misalignments to ! ellements in a lattice, and a structure for defining the misalignment ! parameters !-------------------------------------------------------------------------- module dr_misalign_mod use bookkeeper_mod ! for intelligent bookkeeping use bsim_cesr_interface implicit none type ma_struct integer key character(40) :: key_name = '' character(40) :: mask = '' integer :: param = 0 character(40) :: attrib_name = '', param_name = '' ! param_name deprecated character(40) :: error_type = 'additive' ! either additive or multiplicative logical :: use_alignment_multiplier = .true. ! use global multiplier? real amp ! logical detector end type ma_struct type dr_misalign_params_struct real(rp) sigma_cutoff, alignment_multiplier logical accumulate_errors, tie_dup_ele end type dr_misalign_params_struct type(dr_misalign_params_struct) dr_misalign_params contains !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! Subroutine dr_misalign_mod(ring, ma_params) ! ! Subroutine to assign random Gaussian errors to elements in a lattice. ! This works by modifying the x_offset, y_offset, etc. parameters in each ! applicable ele_struct. Certain "global" parameters are set in ! dr_misalign_params. ! ! Input: ! ma_params -- dr_misalign_params_struct(:). List of parameters for ! misalignment ! ! Output: ! ring -- lat_struct. Ring whose elements will be misaligned ! %ele(:) -- Modified elements in ring !-------------------------------------------------------------------------- subroutine dr_misalign(ring, ma_params) use bmad_interface use sim_utils implicit none type(lat_struct), intent(inout), target :: ring type(ma_struct), target :: ma_params(:) type (all_pointer_struct) a_ptr logical :: err = .false. type(ele_struct), pointer :: ele type(ma_struct), pointer :: ma integer :: i_param, i_ele real(rp) harvest, multiplier ! Check that the parameters make sense if (dr_misalign_params%alignment_multiplier < 0.) then write(*,*) "dr_misalign: alignment_multiplier must be non-negative" call err_exit end if if (dr_misalign_params%sigma_cutoff <= 0.) then write(*,*) "dr_misalign: sigma_cutoff must be positive" call err_exit end if if (any(len_trim(ma_params(:)%param_name) .ne. 0) .or. all(len_trim(ma_params(:)%attrib_name) .eq. 0)) then write(*,'(a)') ' *** ma_params(:)%param_name deprecated in favor of ma_params(:)%attrib_name! ***' write(*,'(a)') 'Please update your input files. Backwards compatibility will be maintained for now.' ma_params(:)%attrib_name = ma_params(:)%param_name endif do i_param = 1, size(ma_params) !if (ma_params(i_param)%amp == 0) cycle if (len(trim(ma_params(i_param)%key_name)) == 0) cycle ma => ma_params(i_param) ! cast to uppercase, in case user didn't do this already call upcase_string(ma%attrib_name) call upcase_string(ma%key_name) call upcase_string(ma%mask) ! Check a few things if ((ma%key .ne. 0) .and. (len(trim(ma%key_name)) .eq. 0 )) then write(*,*) "ma_struct%key provided instead of ma_struct%key_name! Providing key_name is more robust. Stopping here..." call err_exit endif if ((ma%param .ne. 0) .and. (len(trim(ma%attrib_name)) .eq. 0 )) then write(*,*) "ma_struct%param provided instead of ma_struct%attrib_name! 'param' is deprecated. Stopping here..." call err_exit endif ma%key = key_name_to_key_index(trim(ma%key_name), .true.) if (ma%key .eq. -1) then ! no match from match_word write(*,*) "dr_misalign: key_name ", ma%key_name, " not allowed. Stopping here..." call err_exit endif ! do we use global alignment_multiplier for this misalignment? if (ma%use_alignment_multiplier .eqv. .false.) then multiplier = 1. else ! use multiplier multiplier = dr_misalign_params%alignment_multiplier end if ! Loop over elements do i_ele = 1, ring%n_ele_max ! n_ele_max instead of n_ele_track, to get lord elements ele => ring%ele(i_ele) if (ele%key /= ma%key) cycle if (.not. (ma%mask == "" .or. match_reg(ele%name, ma%mask))) cycle ! make sure element is free to vary: if (ele%slave_status .eq. super_slave$) cycle if (.not. attribute_free(ele, ma%attrib_name, err_print_flag = .false.)) cycle ! Get a random number within the cutoff. If we're tying elements, and this isn't ! the first element, and it's the same as last element, then reuse the old numbers. if ((.not. dr_misalign_params%tie_dup_ele) .or. & (i_ele == 1) .or. (ring%ele(i_ele)%name .ne. ring%ele(i_ele-1)%name)) then harvest = 1000 do while (abs(harvest) >= dr_misalign_params%sigma_cutoff) call ran_gauss(harvest) end do end if call pointer_to_attribute(ele, ma%attrib_name, .true., a_ptr, err) if (err .or. .not. associated(a_ptr%r)) then ! failed to find attribute write(*,*) "Misalignment FAILED! stopping here..." stop endif ! apply the misalignment / error. no special cases here-- always apply the error ! on top of the existing value. if (match_reg('additive',ma%error_type)) then a_ptr%r = a_ptr%r + (ma%amp * harvest * multiplier) elseif (match_reg('multiplicative',ma%error_type)) then a_ptr%r = a_ptr%r * (1.0 + ma%amp * harvest * multiplier) endif ! extra bookkeeping, if using intelligent bookkeeper: call set_flags_for_changed_attribute(ring%ele(i_ele), a_ptr) end do ! eles end do ! ma_params ! more bookkeeping: if (bmad_com%auto_bookkeeper .eqv. .false.) call lattice_bookkeeper(ring) end subroutine dr_misalign end module dr_misalign_mod