diff --git a/bmad/modules/attribute_mod.f90 b/bmad/modules/attribute_mod.f90 index e0a4ada5df..a732d0763a 100644 --- a/bmad/modules/attribute_mod.f90 +++ b/bmad/modules/attribute_mod.f90 @@ -2268,7 +2268,7 @@ end subroutine string_attrib ! Generally only needed to determine the default value. ! ! Output: -! attrib_val_name -- character(40): Name corresponding to the value. Set to null_name if there is a problem. +! attrib_val_name -- character(40): Name corresponding to the value. Set to null_name$ if there is a problem. ! is_default -- logical, optional: If True then the value of the attiribute ! corresponds to the default value. If this argument is ! present, the ele argument must also be present. @@ -2300,13 +2300,13 @@ function switch_attrib_value_name (attrib_name, attrib_value, ele, is_default, n select case (attrib_name) case ('APERTURE_AT') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, aperture_at_name, lbound(aperture_type_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, aperture_at_name, lbound(aperture_type_name, 1), name_list) if (present(is_default)) then is_default = (ix_attrib_val == exit_end$) endif case ('APERTURE_TYPE') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, aperture_type_name, lbound(aperture_type_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, aperture_type_name, lbound(aperture_type_name, 1), name_list) if (present(is_default)) then if (ele%key == ecollimator$) then is_default = (ix_attrib_val == elliptical$) @@ -2316,19 +2316,19 @@ function switch_attrib_value_name (attrib_name, attrib_value, ele, is_default, n endif case ('CAVITY_TYPE') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, cavity_type_name, lbound(cavity_type_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, cavity_type_name, lbound(cavity_type_name, 1), name_list) if (present(is_default)) then is_default = (ix_attrib_val == default_value(ele, cavity_type$)) endif case ('CSR_METHOD') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, csr_method_name, lbound(csr_method_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, csr_method_name, lbound(csr_method_name, 1), name_list) if (present(is_default)) then is_default = (ix_attrib_val == off$) endif case ('COUPLER_AT') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, end_at_name, lbound(end_at_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, end_at_name, lbound(end_at_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == downstream_end$) case ('DEFAULT_TRACKING_SPECIES') @@ -2336,23 +2336,23 @@ function switch_attrib_value_name (attrib_name, attrib_value, ele, is_default, n if (present(is_default)) is_default = (ix_attrib_val == ref_particle$) case ('ELE_ORIGIN', 'REF_ORIGIN') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, anchor_pt_name, lbound(anchor_pt_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, anchor_pt_name, lbound(anchor_pt_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == anchor_center$) case ('ENERGY_DISTRIBUTION') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, distribution_name, lbound(distribution_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, distribution_name, lbound(distribution_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == gaussian$) case ('EXACT_MULTIPOLES') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, exact_multipoles_name, lbound(exact_multipoles_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, exact_multipoles_name, lbound(exact_multipoles_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == off$) case ('FIDUCIAL_PT') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, fiducial_pt_name, lbound(fiducial_pt_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, fiducial_pt_name, lbound(fiducial_pt_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == none_pt$) case ('FIELD_CALC') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, field_calc_name, lbound(field_calc_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, field_calc_name, lbound(field_calc_name, 1), name_list) if (present(is_default)) then select case (ele%key) case (group$, overlay$, girder$, ramper$); is_default = (ix_attrib_val == no_field$) @@ -2361,25 +2361,25 @@ function switch_attrib_value_name (attrib_name, attrib_value, ele, is_default, n endif case ('FIELD_TYPE') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, em_field_type_name, lbound(em_field_type_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, em_field_type_name, lbound(em_field_type_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == bmad_standard$) case ('MULTIPASS_REF_ENERGY') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, multipass_ref_energy_name, lbound(multipass_ref_energy_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, multipass_ref_energy_name, lbound(multipass_ref_energy_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == first_pass$) case ('NONGRID^FIELD_TYPE') ! This is for the Tao "python" command - call get_this_attrib_name (attrib_val_name, ix_attrib_val, em_field_type_name(1:2), lbound(em_field_type_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, em_field_type_name(1:2), lbound(em_field_type_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == bmad_standard$) case ('FRINGE_AT') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, end_at_name, lbound(end_at_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, end_at_name, lbound(end_at_name, 1), name_list) if (present(is_default)) then is_default = (ix_attrib_val == both_ends$) endif case ('FRINGE_TYPE') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, fringe_type_name, lbound(fringe_type_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, fringe_type_name, lbound(fringe_type_name, 1), name_list) if (present(is_default)) then select case (ele%key) case (sad_mult$) @@ -2392,65 +2392,65 @@ function switch_attrib_value_name (attrib_name, attrib_value, ele, is_default, n endif case ('GEOMETRY') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, geometry_name, lbound(geometry_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, geometry_name, lbound(geometry_name, 1), name_list) case ('GRID_FIELD^GEOMETRY') ! This is for the Tao "python" command - call get_this_attrib_name (attrib_val_name, ix_attrib_val, grid_field_geometry_name, lbound(grid_field_geometry_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, grid_field_geometry_name, lbound(grid_field_geometry_name, 1), name_list) case ('GRID^TYPE') ! This is for the Tao "python" command - call get_this_attrib_name (attrib_val_name, ix_attrib_val, surface_grid_type_name, lbound(surface_grid_type_name, 1)) + attrib_val_name = surface_grid_type_name(ix_attrib_val, name_list) if (present(is_default)) is_default = .false. case ('INTERPOLATION') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, interpolation_name, lbound(interpolation_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, interpolation_name, lbound(interpolation_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == cubic$) case ('KEY') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, key_name, lbound(key_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, key_name, lbound(key_name, 1), name_list) if (present(is_default)) is_default = .false. case ('KICK0') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, kick0_name, lbound(kick0_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, kick0_name, lbound(kick0_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == standard$) case ('LORD_STATUS') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, control_name, lbound(control_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, control_name, lbound(control_name, 1), name_list) if (present(is_default)) is_default = .false. case ('MAT6_CALC_METHOD') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, mat6_calc_method_name, lbound(mat6_calc_method_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, mat6_calc_method_name, lbound(mat6_calc_method_name, 1), name_list) if (present(is_default)) then call default_ele(ele, ele2) is_default = (ix_attrib_val == ele2%mat6_calc_method) endif case ('MATRIX') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, matrix_name, lbound(matrix_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, matrix_name, lbound(matrix_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == standard$) case ('MODE') if (ele%key == diffraction_plate$ .or. ele%key == sample$ .or. ele%key == mask$) then - call get_this_attrib_name (attrib_val_name, ix_attrib_val, mode_name, lbound(mode_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, mode_name, lbound(mode_name, 1), name_list) if (present(is_default)) then is_default = (ix_attrib_val == default_value(ele, mode$)) endif else - call get_this_attrib_name (attrib_val_name, ix_attrib_val, geometry_name, lbound(geometry_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, geometry_name, lbound(geometry_name, 1), name_list) if (present(is_default)) then is_default = (ix_attrib_val == open$) endif endif case ('ORIGIN_ELE_REF_PT') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, ref_pt_name, lbound(ref_pt_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, ref_pt_name, lbound(ref_pt_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == center_pt$) case ('PTC_FRINGE_GEOMETRY') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, ptc_fringe_geometry_name, lbound(ptc_fringe_geometry_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, ptc_fringe_geometry_name, lbound(ptc_fringe_geometry_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == x_invariant$) case ('PHOTON_TYPE') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, photon_type_name, lbound(photon_type_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, photon_type_name, lbound(photon_type_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == incoherent$) case ('PARTICLE', 'REF_SPECIES', 'SPECIES_STRONG') @@ -2464,63 +2464,63 @@ function switch_attrib_value_name (attrib_name, attrib_value, ele, is_default, n endif case ('PHASE_UNITS') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, angle_units_name, lbound(angle_units_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, angle_units_name, lbound(angle_units_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == radians$) case ('PTC_FIELD_GEOMETRY') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, ptc_field_geometry_name, lbound(ptc_field_geometry_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, ptc_field_geometry_name, lbound(ptc_field_geometry_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == sector$) case ('PTC_INTEGRATION_TYPE') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, ptc_integration_type_name, lbound(ptc_integration_type_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, ptc_integration_type_name, lbound(ptc_integration_type_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == matrix_kick$) case ('REF_COORDS') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, ref_coords_name(1:4), 1) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, ref_coords_name(1:4), 1, name_list) if (present(is_default)) is_default = (ix_attrib_val == exit_end$) case ('REF_ORBIT_FOLLOWS') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, ref_orbit_follows_name, lbound(ref_orbit_follows_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, ref_orbit_follows_name, lbound(ref_orbit_follows_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == bragg_diffracted$) case ('SCATTER_METHOD') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, scatter_method_name, lbound(scatter_method_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, scatter_method_name, lbound(scatter_method_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == highland$) case ('SECTION^TYPE') ! This is for the Tao "python" command - call get_this_attrib_name (attrib_val_name, ix_attrib_val, wall3d_section_type_name, lbound(wall3d_section_type_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, wall3d_section_type_name, lbound(wall3d_section_type_name, 1), name_list) if (present(is_default)) is_default = .false. case ('SLAVE_STATUS') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, control_name, lbound(control_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, control_name, lbound(control_name, 1), name_list) if (present(is_default)) is_default = .false. case ('SPACE_CHARGE_METHOD') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, space_charge_method_name, lbound(space_charge_method_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, space_charge_method_name, lbound(space_charge_method_name, 1), name_list) if (present(is_default)) then is_default = (ix_attrib_val == off$) endif case ('SPATIAL_DISTRIBUTION') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, distribution_name, lbound(distribution_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, distribution_name, lbound(distribution_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == gaussian$) case ('SPIN_TRACKING_METHOD') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, spin_tracking_method_name, lbound(spin_tracking_method_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, spin_tracking_method_name, lbound(spin_tracking_method_name, 1), name_list) if (present(is_default)) then call default_ele (ele, ele2) is_default = (ix_attrib_val == ele2%spin_tracking_method) endif case ('TRACKING_METHOD') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, tracking_method_name, lbound(tracking_method_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, tracking_method_name, lbound(tracking_method_name, 1), name_list) if (present(is_default)) then call default_ele (ele, ele2) is_default = (ix_attrib_val == ele2%tracking_method) endif case ('VELOCITY_DISTRIBUTION') - call get_this_attrib_name (attrib_val_name, ix_attrib_val, distribution_name, lbound(distribution_name, 1)) + call get_this_attrib_name (attrib_val_name, ix_attrib_val, distribution_name, lbound(distribution_name, 1), name_list) if (present(is_default)) is_default = (ix_attrib_val == gaussian$) case default @@ -2531,12 +2531,13 @@ function switch_attrib_value_name (attrib_name, attrib_value, ele, is_default, n !--------------------------------------- contains -subroutine get_this_attrib_name (val_name, ix_attrib_val, name_array, min_arr, exceptions) +subroutine get_this_attrib_name (val_name, ix_attrib_val, name_array, min_arr, name_list, exceptions) integer ix_attrib_val, min_arr, i, j, n integer, optional :: exceptions(:) character(*) val_name character(*) name_array(min_arr:) +character(*), optional, allocatable :: name_list(:) ! diff --git a/bmad/modules/bmad_struct.f90 b/bmad/modules/bmad_struct.f90 index 3befff8d3e..9f81a7e83b 100644 --- a/bmad/modules/bmad_struct.f90 +++ b/bmad/modules/bmad_struct.f90 @@ -989,8 +989,6 @@ module bmad_struct end type integer, parameter :: segmented$ = 1, h_misalign$ = 2, displacement$ = 3 -character(16), parameter :: surface_grid_type_name(0:3) = [character(16):: 'GARBAGE!', & - 'Segmented', 'H_Misalign', 'Displacement'] ! Photon statistics at a detector @@ -2525,11 +2523,55 @@ function coord_state_name (coord_state, one_word) result (state_str) case (lost_pos_y$); state_str = 'Lost_Pos_Y' case (lost_pz$); state_str = 'Lost_Pz' case (lost_z$); state_str = 'Lost_Z' -case default; state_str = 'UNKNOWN!' +case default; state_str = null_name$ end select end function coord_state_name + +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ +!+ +! Function surface_grid_type_name(grid_type, name_list) result (type_str) +! +! Routine to return the string representation of ele%photon%grid%type. +! +! Input: +! grid_type -- integer: ele%photon%grid%type value. +! +! Output: +! type_str -- character(16): String rep. +! name_list(:) -- character(*), optional, allocatable: List of possible names. +!- + +function surface_grid_type_name(grid_type, name_list) result (type_str) + +implicit none + +integer grid_type +character(16) :: type_str +character(*), optional, allocatable :: name_list(:) + +! + +select case (grid_type) +case (not_set$); type_str = 'Not_set' +case (segmented$); type_str = 'Segmented' +case (h_misalign$); type_str = 'H_Misalign' +case (displacement$); type_str = 'Displacement' +case default; type_str = null_name$ +end select + +if (present(name_list)) then + if (allocated(name_list)) deallocate(name_list) + allocate(name_list(4)) + ! Important: name_list order matches integer values segmented$ = 1, etc. + name_list = [character(16):: 'Segmented', 'H_Misalign', 'Displacement', 'Not_set'] +endif + +end function surface_grid_type_name + !------------------------------------------------------------------------ !------------------------------------------------------------------------ !------------------------------------------------------------------------ diff --git a/bmad/parsing/bmad_parser_mod.f90 b/bmad/parsing/bmad_parser_mod.f90 index 622566e886..b76d325e50 100644 --- a/bmad/parsing/bmad_parser_mod.f90 +++ b/bmad/parsing/bmad_parser_mod.f90 @@ -1177,7 +1177,8 @@ subroutine parser_set_attribute (how, ele, delim, delim_found, err_flag, pele, c if (attrib_word == 'SURFACE') then if (ele%key == detector$) name = 'PIXEL' elseif (attrib_word /= 'PIXEL') then - call match_word (attrib_word, surface_grid_type_name(1:), ph%grid%type) + who = surface_grid_type_name(1, name_list) + call match_word (attrib_word, name_list, ph%grid%type) endif if (.not. expect_this ('=', .true., .true., 'AFTER ' // quote(attrib_word), ele, delim, delim_found)) return @@ -1226,9 +1227,7 @@ subroutine parser_set_attribute (how, ele, delim, delim_found, err_flag, pele, c select case (word) case ('TYPE') ! This is old style. - call get_switch ('SURFACE GRID TYPE', surface_grid_type_name(1:), ph%grid%type, err_flag2, ele, delim, delim_found) - if (err_flag2) return - bp_com%parse_line = delim // bp_com%parse_line + call parser_error('OLD STYLE GRID TYPE SYNTAX NO LONGER ACCEPTED. PLEASE CORRECT.') case ('ACTIVE') call parser_get_logical (word, ph%grid%active, ele%name, delim, delim_found, err_flag2); if (err_flag2) return diff --git a/tao/code/tao_python_cmd.f90 b/tao/code/tao_python_cmd.f90 index 7885faa467..fc78f29c21 100644 --- a/tao/code/tao_python_cmd.f90 +++ b/tao/code/tao_python_cmd.f90 @@ -3545,7 +3545,7 @@ subroutine tao_python_cmd (input_str) ele => point_to_ele(line, tao_lat%lat, err); if (err) return if (.not. associated(ele%photon)) then - call invalid ('photon not allocated') + call invalid ('photon structure not allocated for element.') return endif @@ -3553,9 +3553,9 @@ subroutine tao_python_cmd (input_str) select case (tail_str) case ('base') nl=incr(nl); write (li(nl), lmt) 'has#pixel;LOGIC;F;', (allocated(ele%photon%pixel%pt)) - nl=incr(nl); write (li(nl), lmt) 'grid#type;LOGIC;F;', surface_grid_type_name(ele%photon%grid%type) nl=incr(nl); write (li(nl), lmt) 'has#material;LOGIC;F;', & (attribute_name(ele, material_type$) == 'MATERIAL_TYPE' .or. ele%key == crystal$) + nl=incr(nl); write (li(nl), amt) 'grid#type;LOGIC;F;', trim(surface_grid_type_name(ele%photon%grid%type)) case ('material') if (ele%key == multilayer_mirror$) then