Fix bookkeeping when controller controls Cartesian map parameter. (#1196

)

* Fix bookkeeping when controller controls a Cartesian map parameter.

bmad/code/pointer_to_attribute.f90

@@ -1,37 +1,44 @@
 !+
-! Subroutine pointer_to_attribute (ele, attrib_name, do_allocation, a_ptr, err_flag, err_print_flag, ix_attrib)
+! Subroutine pointer_to_attribute (ele, attrib_name, do_allocation, a_ptr, err_flag, err_print_flag, ix_attrib, do_unlink)
 !
 ! Returns a pointer to an attribute of an element ele with attribute name attrib_name.
 ! Note: Use attribute_free to see if the attribute may be varied independently.
 ! Note: This routine will not work on bmad_com components. Rather use pointers_to_attribute.
+!
+! Note: To save memory, ele%cartesian_map (and other field maps), can point to the same memory location as the 
+! Cartesian maps of other elements. This linkage is not desired if the attribute to be pointed to is varied. 
+! In this case, the do_unlink argumnet should be set to True.
+!
 ! Note: Alternatively consider the routines:
 ! pointers_to_attribute
 ! set_ele_attribute
 ! value_of_attribute
 !
 ! Input:
-! ele -- Ele_struct: After this routine finishes Ptr_attrib 
+! ele -- ele_struct: After this routine finishes Ptr_attrib 
 ! will point to a variable within this element.
-! attrib_name -- Character(40): Name of attribute. Must be uppercase.
+! attrib_name -- character(40): Name of attribute. Must be uppercase.
 ! For example: "HKICK".
-! do_allocation -- Logical: If True then do an allocation if needed.
+! do_allocation -- logical: If True then do an allocation if needed.
 ! EG: The multipole An and Bn arrays need to be allocated
 ! before their use.
-! err_print_flag -- Logical, optional: If present and False then suppress
+! err_print_flag -- logical, optional: If present and False then suppress
 ! printing of an error message on error.
+! do_unlink -- logical, optional: Default False. If True and applicable, unlink the structure containing the attribute.
+! See above for details.
 !
 ! Output:
 ! a_ptr -- all_pointer_struct: Pointer to the attribute. 
 ! %r -- pointer to real attribute. Nullified if error or attribute is not real. 
 ! %i -- pointer to integer attribute. Nullified if error or attribute is not integer.
 ! %l -- pointer to logical attribute. Nullified if error or attribute is not logical. 
-! err_flag -- Logical: Set True if attribtute not found. False otherwise.
-! ix_attrib -- Integer, optional: If applicable, this is the index to the 
+! err_flag -- logical: Set True if attribtute not found. False otherwise.
+! ix_attrib -- integer, optional: If applicable, this is the index to the 
 ! attribute in the ele%value(:), ele%control%var(:), ele%a_pole(:) or ele%b_pole(:) arrays.
 ! Set to 0 if not in any of these arrays.
 !-
 
-subroutine pointer_to_attribute (ele, attrib_name, do_allocation, a_ptr, err_flag, err_print_flag, ix_attrib)
+subroutine pointer_to_attribute (ele, attrib_name, do_allocation, a_ptr, err_flag, err_print_flag, ix_attrib, do_unlink)
 
 use bmad_interface, except_dummy => pointer_to_attribute
 
@@ -41,6 +48,7 @@ subroutine pointer_to_attribute (ele, attrib_name, do_allocation, a_ptr, err_fla
 type (ele_struct), pointer :: slave
 type (wake_lr_mode_struct), allocatable :: lr_mode(:)
 type (cartesian_map_struct), pointer :: ct_map
+type (cartesian_map_term_struct), pointer :: ct_ptr
 type (cartesian_map_term1_struct), pointer :: ct_term
 type (cylindrical_map_struct), pointer :: cl_map
 type (grid_field_struct), pointer :: g_field
@@ -64,7 +72,7 @@ subroutine pointer_to_attribute (ele, attrib_name, do_allocation, a_ptr, err_fla
 character(24) :: r_name = 'pointer_to_attribute'
 
 logical err_flag, do_allocation, do_print, err, out_of_bounds
-logical, optional :: err_print_flag
+logical, optional :: err_print_flag, do_unlink
 
 ! init check
 
@@ -263,6 +271,15 @@ subroutine pointer_to_attribute (ele, attrib_name, do_allocation, a_ptr, err_fla
  n_cc = get_this_index(a_name, 14, err, 1, size(ele%cartesian_map))
  if (err) goto 9140
  ct_map => ele%cartesian_map(n_cc)
+ if (.not. associated(ct_map%ptr)) return
+
+ ct_ptr => ct_map%ptr
+ if (logic_option(.false., do_unlink) .and. ct_map%ptr%n_link > 1) then
+ ct_map%ptr%n_link = ct_map%ptr%n_link - 1
+ allocate(ct_map%ptr)
+ ct_map%ptr = ct_ptr
+ ct_map%ptr%n_link = 1
+ endif
 
  if (a_name(1:3) == '%T(' .or. a_name(1:6) == '%TERM(') then
  nt = get_this_index(a_name, index(a_name, '('), err, 1, size(ct_map%ptr%term))
@@ -306,15 +323,15 @@ subroutine pointer_to_attribute (ele, attrib_name, do_allocation, a_ptr, err_fla
  cl_map => ele%cylindrical_map(n_cc)
 
  select case (a_name)
- case ('%PHI0_FIELDMAP'); a_ptr%r => cl_map%phi0_fieldmap
- case ('%THETA0_AZIMUTH'); a_ptr%r => cl_map%theta0_azimuth
- case ('%FIELD_SCALE'); a_ptr%r => cl_map%field_scale
- case ('%DZ'); a_ptr%r => cl_map%dz
+ case ('%PHI0_FIELDMAP'); a_ptr%r  => cl_map%phi0_fieldmap
+ case ('%THETA0_AZIMUTH'); a_ptr%r  => cl_map%theta0_azimuth
+ case ('%FIELD_SCALE'); a_ptr%r  => cl_map%field_scale
+ case ('%DZ'); a_ptr%r  => cl_map%dz
  case ('%R0'); a_ptr%r1 => cl_map%r0
- case ('%R0(1)'); a_ptr%r => cl_map%r0(1)
- case ('%R0(2)'); a_ptr%r => cl_map%r0(2)
- case ('%R0(3)'); a_ptr%r => cl_map%r0(3)
- case ('%MASTER_PARAMETER'); a_ptr%i => cl_map%master_parameter
+ case ('%R0(1)'); a_ptr%r  => cl_map%r0(1)
+ case ('%R0(2)'); a_ptr%r  => cl_map%r0(2)
+ case ('%R0(3)'); a_ptr%r  => cl_map%r0(3)
+ case ('%MASTER_PARAMETER'); a_ptr%i  => cl_map%master_parameter
  case default; goto 9000
  end select
 

bmad/code/pointers_to_attribute.f90

@@ -1,6 +1,6 @@
 !+
 ! Subroutine pointers_to_attribute (lat, ele_name, attrib_name, do_allocation,
-! ptr_array, err_flag, err_print_flag, eles, ix_attrib)
+! ptr_array, err_flag, err_print_flag, eles, ix_attrib, do_unlink)
 !
 ! Returns an array of pointers to an attribute with name attrib_name within elements with name ele_name.
 !
@@ -43,7 +43,7 @@
 !-
 
 Subroutine pointers_to_attribute (lat, ele_name, attrib_name, do_allocation, &
- ptr_array, err_flag, err_print_flag, eles, ix_attrib)
+ ptr_array, err_flag, err_print_flag, eles, ix_attrib, do_unlink)
 
 use bmad_interface, except_dummy => pointers_to_attribute
 
@@ -65,7 +65,7 @@ Subroutine pointers_to_attribute (lat, ele_name, attrib_name, do_allocation, &
 character(*), parameter :: r_name = 'pointers_to_attribute'
 
 logical err_flag, do_allocation, do_print
-logical, optional :: err_print_flag
+logical, optional :: err_print_flag, do_unlink
 
 ! init
 
@@ -285,7 +285,7 @@ Subroutine pointers_to_attribute (lat, ele_name, attrib_name, do_allocation, &
 call re_allocate (ptrs, n_loc)
 n = 0
 do i = 1, n_loc
- call pointer_to_attribute (eles2(i)%ele, attrib_name, do_allocation, a_ptr, err_flag, .false., ix_a)
+ call pointer_to_attribute (eles2(i)%ele, attrib_name, do_allocation, a_ptr, err_flag, .false., ix_a, do_unlink)
  if (err_flag) cycle
  n = n + 1
  ptrs(n) = a_ptr

bmad/code/set_ele_attribute.f90

@@ -32,9 +32,8 @@
 
 subroutine set_ele_attribute (ele, set_string, err_flag, err_print_flag, set_lords)
 
-use bmad_parser_mod, dummy => set_ele_attribute
-use bmad_interface, dummy2 => set_ele_attribute
-
+use bmad_interface, dummy => set_ele_attribute
+use bmad_parser_struct, only: bp_com, bp_com2, stack_file_struct, bp_common_struct, redef$
 
 implicit none
 

bmad/code/set_ele_real_attribute.f90

@@ -46,7 +46,7 @@ subroutine set_ele_real_attribute (ele, attrib_name, value, err_flag, err_print_
 call str_upcase (a_name, attrib_name)
 if (.not. attribute_free (ele, a_name, err_print_flag, dependent_attribs_free = .true.)) return
 
-call pointer_to_attribute (ele, attrib_name, .true., a_ptr, err_flag)
+call pointer_to_attribute (ele, attrib_name, .true., a_ptr, err_flag, do_unlink = .true.)
 if (associated(a_ptr%r)) then
  a_ptr%r = value
 elseif (associated(a_ptr%i)) then

bmad/low_level/ramper_slave_setup.f90

@@ -105,7 +105,7 @@ recursive subroutine set_this_slave (slave, lord, ix_control, r1, lat, n_slave,
 
 ! Check attribute.
 
-call pointer_to_attribute (slave, r1%attribute, .true., a_ptr, err, .false.)
+call pointer_to_attribute (slave, r1%attribute, .true., a_ptr, err, .false., do_unlink = .true.)
 if (err .or. .not. associated(a_ptr%r)) then
  if (has_wild) return
  call out_io (s_error$, r_name, 'BAD SLAVE ATTRIBUTE FOR RAMPER LORD: ' // lord%name, &

bmad/modules/bmad_routine_interface.f90

@@ -1675,11 +1675,24 @@ subroutine order_super_lord_slaves (lat, ix_lord)
 
 subroutine converter_distribution_parser (ele, delim, delim_found, err_flag)
  import
+ implicit none
  type (ele_struct), target :: ele
  character(*) delim
  logical delim_found, err_flag
 end subroutine
 
+subroutine parser_set_attribute (how, ele, delim, delim_found, err_flag, pele, check_free, heterogeneous_ele_list, set_field_master)
+ use bmad_parser_struct, only: parser_ele_struct
+ import
+ implicit none
+ type (ele_struct), target :: ele
+ type (parser_ele_struct), optional :: pele
+ integer how
+ character(1) delim
+ logical, target :: delim_found, err_flag
+ logical, optional :: check_free, heterogeneous_ele_list, set_field_master
+end subroutine
+
 function particle_is_moving_backwards (orbit) result (is_moving_backwards)
  import
  implicit none
@@ -1739,15 +1752,15 @@ function physical_ele_end (track_end, orbit, ele_orientation, return_stream_end)
  logical, optional :: return_stream_end
 end function
 
-subroutine pointer_to_attribute (ele, attrib_name, do_allocation, a_ptr, err_flag, err_print_flag, ix_attrib)
+subroutine pointer_to_attribute (ele, attrib_name, do_allocation, a_ptr, err_flag, err_print_flag, ix_attrib, do_unlink)
  import
  implicit none
  type (ele_struct), target :: ele
  type (all_pointer_struct) a_ptr
  character(*) attrib_name
  logical err_flag
  logical do_allocation
- logical, optional :: err_print_flag
+ logical, optional :: err_print_flag, do_unlink
  integer, optional :: ix_attrib
 end subroutine
 
@@ -1830,15 +1843,15 @@ function pointer_to_wake_ele (ele, delta_s) result (wake_ele)
 end function
 
 subroutine pointers_to_attribute (lat, ele_name, attrib_name, do_allocation, &
- ptr_array, err_flag, err_print_flag, eles, ix_attrib)
+ ptr_array, err_flag, err_print_flag, eles, ix_attrib, do_unlink)
  import
  implicit none
  type (lat_struct), target :: lat
  type (all_pointer_struct), allocatable :: ptr_array(:)
  character(*) ele_name, attrib_name
  logical err_flag
  logical do_allocation
- logical, optional :: err_print_flag
+ logical, optional :: err_print_flag, do_unlink
  type (ele_pointer_struct), optional, allocatable :: eles(:)
  integer, optional :: ix_attrib
 end subroutine

bmad/modules/bookkeeper_mod.f90

@@ -235,7 +235,7 @@ recursive subroutine group_change_this (ele, attrib_name, ctl, dir, this_lord, t
 
 !
 
-call pointer_to_attribute (ele, attrib_name, .false., a_ptr, err_flag)
+call pointer_to_attribute (ele, attrib_name, .false., a_ptr, err_flag, do_unlink = .true.)
 if (err_flag) then
  if (global_com%exit_on_error) call err_exit
  return
@@ -1080,7 +1080,6 @@ subroutine makeup_super_slave (lat, slave, err_flag)
  T_end(4,1) = ks / 2
  T_end(2,3) = -ks / 2
 
-
  call transfer_ele (slave, sol_quad)
  sol_quad%key = sol_quad$
  sol_quad%value(ks$) = ks
@@ -1661,7 +1660,7 @@ subroutine makeup_control_slave (lat, slave, err_flag)
  return
  endif
 
- call pointer_to_attribute (slave, control%attribute, .true., a_ptr, err_flag)
+ call pointer_to_attribute (slave, control%attribute, .true., a_ptr, err_flag, do_unlink = .true.)
  if (err_flag) then
  if (global_com%exit_on_error) call err_exit
  return

bmad/output/write_lattice_in_elegant_format.f90

@@ -426,9 +426,9 @@ subroutine write_lattice_in_elegant_format (out_file_name, lat, ref_orbit, &
 ! Now write info to the output file...
 ! lat lattice name
 
-write (iu, '(3a)') comment_char, ' File generated by: write_lattice_in_elegant_format', trim(eol_char)
-write (iu, '(4a)') comment_char, ' Bmad Lattice File: ', trim(lat%input_file_name), trim(eol_char)
-if (lat%lattice /= '') write (iu, '(4a)') comment_char, ' Bmad Lattice: ', trim(lat%lattice), trim(eol_char)
+write (iu, '(3a)') comment_char, ' File generated by: write_lattice_in_foreign_format', trim(eol_char)
+write (iu, '(4a)') comment_char, ' Bmad lattice file: ', trim(lat%input_file_name), trim(eol_char)
+if (lat%lattice /= '') write (iu, '(4a)') comment_char, ' Bmad lattice name: ', trim(lat%lattice), trim(eol_char)
 write (iu, '(a)')
 
 ! write element parameters

bmad/output/write_lattice_in_julia.f90

@@ -73,7 +73,8 @@ subroutine write_lattice_in_julia(julia_file, lat, err_flag)
 
 ! Write element defs
 
-write (iu, '(a)') '# Lattice file translated from Bmad.'
+write (iu, '(a)') '# File generated by: write_lattice_in_foreign_format'
+write (iu, '(4a)') '# Bmad lattice file: ', trim(lat%input_file_name)
 write (iu, '(a)')
 
 n_names = 0

bmad/output/write_lattice_in_mad_format.f90

@@ -574,9 +574,9 @@ subroutine write_lattice_in_mad_format (out_type, out_file_name, lat, ref_orbit,
 ! Now write info to the output file...
 ! lat lattice name
 
-write (iu, '(3a)') comment_char, ' File generated by: write_lattice_in_mad_format', trim(eol_char)
-write (iu, '(4a)') comment_char, ' Bmad Lattice File: ', trim(lat%input_file_name), trim(eol_char)
-if (lat%lattice /= '') write (iu, '(4a)') comment_char, ' Bmad Lattice: ', trim(lat%lattice), trim(eol_char)
+write (iu, '(3a)') comment_char, ' File generated by: write_lattice_in_foreign_format', trim(eol_char)
+write (iu, '(4a)') comment_char, ' Bmad lattice file: ', trim(lat%input_file_name), trim(eol_char)
+if (lat%lattice /= '') write (iu, '(4a)') comment_char, ' Bmad lattice name: ', trim(lat%lattice), trim(eol_char)
 write (iu, '(a)')
 
 ! beam definition

bmad/output/write_lattice_in_sad_format.f90

@@ -331,7 +331,10 @@ subroutine write_lattice_in_sad_format (out_file_name, lat, include_apertures, i
  if (ix_pole_max > -1) then
  ab_ele%a_pole = ab_ele%a_pole / 2
  ab_ele%b_pole = ab_ele%b_pole / 2
- if (associated(ele%a_pole)) deallocate (ele%a_pole, ele%b_pole)
+ if (associated(ele%a_pole)) then
+ deallocate (ele%a_pole, ele%b_pole)
+ call attribute_bookkeeper(ele, .true.)
+ endif
  j_count = j_count + 1
  write (ab_ele%name, '(a1, a, i0)') key_name(ele%key), 'MULTIPOLE_', j_count
  call insert_element (lat_out, ab_ele, ix_ele, branch_out%ix_branch)
@@ -430,9 +433,9 @@ subroutine write_lattice_in_sad_format (out_file_name, lat, include_apertures, i
 ! Now write info to the output file...
 ! lat lattice name
 
-write (iu, '(3a)') '! File generated by Bmad from Bmad lattice file:'
-write (iu, '(4x, 2a)') trim(lat%input_file_name), ';'
-if (lat%lattice /= '') write (iu, '(4a)') '! Bmad lattice name: ', trim(lat%lattice), ';'
+write (iu, '(3a)') '! File generated by: write_lattice_in_foreign_format'
+write (iu, '(4a)') '! Bmad lattice file: ', trim(lat%input_file_name)
+if (lat%lattice /= '') write (iu, '(4a)') '! Bmad lattice name: ', trim(lat%lattice)
 write (iu, '(a)')
 
 write (iu, '(3a)') 'MOMENTUM = ', re_str(ele%value(p0c$)), ';'