Index: branches/attic/boschmann_standalone/pri/lib/momentum.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/momentum.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/momentum.f03.pri (revision 8609) @@ -1,145 +0,0 @@ -!!! module: momentum_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-09 13:26:25 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module momentum_module - use parameters_module - implicit none - - type::transversal_momentum_type - real(kind=double),dimension(0:4)::momentum=[gev_pt_max,gev_pt_max,gev2_pt_max,1D0,1D0] - contains - procedure::get_gev_max_scale=>transversal_momentum_get_gev_max_scale - procedure::get_gev2_max_scale=>transversal_momentum_get_gev2_max_scale - procedure::get_gev_scale=>transversal_momentum_get_gev_scale - procedure::get_gev2_scale=>transversal_momentum_get_gev2_scale - procedure::get_unit_scale=>transversal_momentum_get_unit_scale - procedure::get_unit2_scale=>transversal_momentum_get_unit2_scale - procedure::set_gev_max_scale=>transversal_momentum_set_gev_max_scale - procedure::set_gev2_max_scale=>transversal_momentum_set_gev2_max_scale - procedure::set_gev_scale=>transversal_momentum_set_gev_scale - procedure::set_gev2_scale=>transversal_momentum_set_gev2_scale - procedure::set_unit_scale=>transversal_momentum_set_unit_scale - procedure::set_unit2_scale=>transversal_momentum_set_unit2_scale - procedure::print=>transversal_momentum_print - end type transversal_momentum_type - -contains - - elemental function transversal_momentum_get_gev_max_scale(this) result(scale) - class(transversal_momentum_type),intent(in)::this - real(kind=double)::scale - scale=this%momentum(0) - end function transversal_momentum_get_gev_max_scale - - elemental function transversal_momentum_get_gev2_max_scale(this) result(scale) - class(transversal_momentum_type),intent(in)::this - real(kind=double)::scale - scale=this%momentum(0)**2 - end function transversal_momentum_get_gev2_max_scale - - elemental function transversal_momentum_get_gev_scale(this) result(scale) - class(transversal_momentum_type),intent(in)::this - real(kind=double)::scale - scale=this%momentum(1) - end function transversal_momentum_get_gev_scale - - elemental function transversal_momentum_get_gev2_scale(this) result(scale) - class(transversal_momentum_type),intent(in)::this - real(kind=double)::scale - scale=this%momentum(2) - end function transversal_momentum_get_gev2_scale - - elemental function transversal_momentum_get_unit_scale(this) result(scale) - class(transversal_momentum_type),intent(in)::this - real(kind=double)::scale - scale=this%momentum(3) - end function transversal_momentum_get_unit_scale - - elemental function transversal_momentum_get_unit2_scale(this) result(scale) - class(transversal_momentum_type),intent(in)::this - real(kind=double)::scale - scale=this%momentum(4) - end function transversal_momentum_get_unit2_scale - - subroutine transversal_momentum_set_gev_max_scale(this,new_gev_max_scale) - class(transversal_momentum_type),intent(inout)::this - real(kind=double),intent(in) :: new_gev_max_scale - this%momentum(0) = new_gev_max_scale - this%momentum(3) = this%momentum(1)/this%momentum(0) - this%momentum(4) = this%momentum(3)**2 - end subroutine transversal_momentum_set_gev_max_scale - - subroutine transversal_momentum_set_gev2_max_scale(this,new_gev2_max_scale) - class(transversal_momentum_type),intent(inout)::this - real(kind=double),intent(in) :: new_gev2_max_scale - this%momentum(0) = sqrt(new_gev2_max_scale) - this%momentum(3) = this%momentum(1)/this%momentum(0) - this%momentum(4) = this%momentum(3)**2 - end subroutine transversal_momentum_set_gev2_max_scale - - subroutine transversal_momentum_set_gev_scale(this,new_gev_scale) - class(transversal_momentum_type),intent(inout)::this - real(kind=double),intent(in) :: new_gev_scale - this%momentum(1) = new_gev_scale - this%momentum(2) = new_gev_scale**2 - this%momentum(3) = new_gev_scale/this%momentum(0) - this%momentum(4) = this%momentum(3)**2 - end subroutine transversal_momentum_set_gev_scale - - subroutine transversal_momentum_set_gev2_scale(this,new_gev2_scale) - class(transversal_momentum_type),intent(inout)::this - real(kind=double),intent(in) :: new_gev2_scale - this%momentum(1) = sqrt(new_gev2_scale) - this%momentum(2) = new_gev2_scale - this%momentum(3) = this%momentum(1)/this%momentum(0) - this%momentum(4) = this%momentum(3)**2 - end subroutine transversal_momentum_set_gev2_scale - - subroutine transversal_momentum_set_unit_scale(this,new_unit_scale) - class(transversal_momentum_type),intent(inout)::this - real(kind=double),intent(in) :: new_unit_scale - this%momentum(1) = new_unit_scale*this%momentum(0) - this%momentum(2) = this%momentum(1)**2 - this%momentum(3) = new_unit_scale - this%momentum(4) = this%momentum(3)**2 - end subroutine transversal_momentum_set_unit_scale - - subroutine transversal_momentum_set_unit2_scale(this,new_unit2_scale) - class(transversal_momentum_type),intent(inout)::this - real(kind=double),intent(in) :: new_unit2_scale - this%momentum(3) = sqrt(new_unit2_scale) - this%momentum(4) = new_unit2_scale - this%momentum(1) = this%momentum(3)*this%momentum(0) - this%momentum(2) = this%momentum(1)**2 - end subroutine transversal_momentum_set_unit2_scale - - subroutine transversal_momentum_print(this) - class(transversal_momentum_type),intent(in)::this - print ('("Actual energy scale:")') - print ('("Max scale (MeV) :",E20.10)'),this%momentum(0) - print ('("Scale (MeV) :",E20.10)'),this%momentum(1) - print ('("Scale^2 (MeV^2) :",E20.10)'),this%momentum(2) - print ('("Scale normalized :",E20.10)'),this%momentum(3) - print ('("Scale^2 normalized:",E20.10)'),this%momentum(4) - end subroutine transversal_momentum_print - -end module momentum_module Index: branches/attic/boschmann_standalone/pri/lib/aqa.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/aqa.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/aqa.f03.pri (revision 8609) @@ -1,569 +0,0 @@ -!!! module: aqa_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-28 11:18:42 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module aqa_module - use kinds - use basic_types_module - use parameters_module - use misc_module - use lin_approx_tree_module - use fibonacci_tree_module - use tree_conversion_module - implicit none - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Derived Type Definitions !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type,extends(identified_type),abstract :: aqa_class - ! private - logical :: is_deferred_initialised = .false. - logical :: is_error_tree_initialised = .false. - logical :: is_goal_set = .false. - logical :: is_initialised = .false. - logical :: is_run = .false. - logical :: is_goal_reached = .false. - logical :: is_integrated = .false. - integer :: n_nodes = 0 - integer :: max_nodes = 10000 - integer :: dim_integral = 1 - real(kind=double) :: abs_error_goal = 0D0 - real(kind=double) :: rel_error_goal = 0.1D0 - real(kind=double) :: scaled_error_goal = 0.0D0 - real(kind=double) :: integral - real(kind=double) :: integral_error = 0D0 - real(kind=double),dimension(2) :: region = (/0D0,1D0/) - real(kind=double),dimension(:,:),allocatable :: convergence -!time stamps - real(kind=double) :: total_time = 0 - real(kind=double) :: loop_time = 0 - real(kind=double) :: int_time = 0 - real(kind=double) :: cuba_time = 0 - real(kind=double) :: init_time = 0 - real(kind=double) :: cpu_time = 0 -!these variables *must* be initialised before the main loop can be called -!additionaly the nodes and segments should be preprocessed by first_run before the main loop is called - real(kind=double) :: error_goal = 0D0 - class(fibonacci_root_type),pointer :: err_tree => null() - type(lin_approx_tree_type) :: int_tree - class(lin_approx_list_type),pointer :: int_list => null() - contains - ! overridden serializable_class procedures - procedure::write_to_ring=>aqa_write_to_ring - procedure::read_from_ring=>aqa_read_from_ring - procedure::print_to_unit=>aqa_print_to_unit - procedure,nopass::get_type=>aqa_get_type - procedure::deserialize=>aqa_deserialize - ! new procedures - procedure :: aqa_initialize - generic :: initialize => aqa_initialize - procedure :: print_times => aqa_print_times - procedure :: write_convergence => aqa_write_convergence - ! init/ de-init - procedure :: reset => aqa_reset - procedure :: dealloc_trees => aqa_dealloc_trees - procedure :: init_error_tree => aqa_init_error_tree - procedure :: set_rel_goal => aqa_set_rel_goal - procedure :: set_abs_goal => aqa_set_abs_goal - procedure :: set_goal => aqa_set_goal - procedure :: check_init => aqa_check_init - ! calculation - procedure :: main_loop => aqa_main_loop - procedure :: run => aqa_run - procedure :: integrate => aqa_integrate - ! deferred - procedure(evaluate_if),deferred :: evaluate -! procedure(evaluate_ratios_if),deferred :: evaluate_ratios - end type aqa_class - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Interface Definitions !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - interface - subroutine evaluate_if(this,x,y) - use kinds - import aqa_class - class(aqa_class) :: this - real(kind=double), intent(in) :: x - real(kind=double), intent(out) ,dimension(:):: y - end subroutine evaluate_if - -!!$ subroutine evaluate_ratios_if(this,cont) -!!$ use kinds -!!$ use lin_approx_tree_module,only:lin_approx_cont_type -!!$ import aqa_class -!!$ class(aqa_class) :: this -!!$ class(lin_approx_cont_type),intent(inout),pointer :: cont -!!$ end subroutine evaluate_ratios_if - end interface - -contains - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures for aqa_class !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !overridden serializable_class procedures - - SUBROUTINE aqa_write_to_ring(this,ring,status) - CLASS(aqa_class), INTENT(IN) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - class(serializable_class),pointer::ser - call xml_write_begin_tag(ring,"AQA_CLASS") - call identified_write_to_ring(this,ring,status) - call xml_write(ring,"is_deferred_initialised",this%is_deferred_initialised) - call xml_write(ring,"is_error_tree_initialised",this%is_error_tree_initialised) - call xml_write(ring,"is_goal_set",this%is_goal_set) - call xml_write(ring,"is_initialised",this%is_initialised) - call xml_write(ring,"is_run",this%is_run) - call xml_write(ring,"is_goal_reached",this%is_goal_reached) - call xml_write(ring,"is_integrated",this%is_integrated) - call xml_write(ring,"n_nodes",this%n_nodes) - call xml_write(ring,"max_nodes",this%max_nodes) - call xml_write(ring,"dim_integral",this%dim_integral) - call xml_write(ring,"abs_error_goal",this%abs_error_goal) - call xml_write(ring,"rel_error_goal",this%rel_error_goal) - call xml_write(ring,"scaled_error_goa",this%scaled_error_goal) - call xml_write(ring,"error_goal",this%error_goal) - call xml_write(ring,"integral",this%integral) - call xml_write(ring,"integral_error",this%integral_error) - call xml_write(ring,"region",this%region(1:2)) - ser=>this%err_tree - call serialize_pointer(ser,ring,"ERR_TREE") - call this%int_tree%serialize(ring,"INT_TREE") - call xml_write_end_tag(ring,"AQA_CLASS") - end SUBROUTINE aqa_write_to_ring - - SUBROUTINE aqa_read_from_ring(this,ring,status) - CLASS(aqa_class), INTENT(out) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - class(serializable_class),pointer::ser - call xml_verify_begin_tag(ring,"AQA_CLASS",status) - call identified_read_from_ring(this,ring,status) - call xml_read(ring,"is_deferred_initialised",this%is_deferred_initialised,status) - call xml_read(ring,"is_error_tree_initialised",this%is_error_tree_initialised,status) - call xml_read(ring,"is_goal_set",this%is_goal_set,status) - call xml_read(ring,"is_initialised",this%is_initialised,status) - call xml_read(ring,"is_run",this%is_run,status) - call xml_read(ring,"is_goal_reached",this%is_goal_reached,status) - call xml_read(ring,"is_integrated",this%is_integrated,status) - call xml_read(ring,"n_nodes",this%n_nodes,status) - call xml_read(ring,"max_nodes",this%max_nodes,status) - call xml_read(ring,"dim_integral",this%dim_integral,status) - call xml_read(ring,"abs_error_goal",this%abs_error_goal,status) - call xml_read(ring,"rel_error_goal",this%rel_error_goal,status) - call xml_read(ring,"scaled_error_goa",this%scaled_error_goal,status) - call xml_read(ring,"error_goal",this%error_goal,status) - call xml_read(ring,"integral",this%integral,status) - call xml_read(ring,"integral_error",this%integral_error,status) - call xml_read(ring,"region",this%region(1:2),status) - call deserialize_pointer(ser,ring) - if(associated(ser))then - select type(ser) - class is (fibonacci_root_type) - this%err_tree=>ser - class default - nullify(this%err_tree) - end select - end if - call this%int_tree%deserialize(ring) - call this%int_tree%get_left_list(list=this%int_list) - call xml_verify_end_tag(ring,"AQA_CLASS",status) - end SUBROUTINE aqa_read_from_ring - - subroutine aqa_print_to_unit(this,unit,parents,components,peers) - class(aqa_class),intent(in)::this - integer,intent(in)::unit,parents,components,peers - integer::ite - class(serializable_class),pointer::ser - if(parents>0)call identified_print_to_unit(this,unit,parents-1,components,peers) - write(unit,'("Components of aqa_class")') - write(unit,'(a,L1)')"Deferred class initialised: ",this%is_deferred_initialised - write(unit,'(a,L1)')"Error tree initialised: ",this%is_error_tree_initialised - write(unit,'(a,L1)')"Accuracy goal set: ",this%is_goal_set - write(unit,'(a,L1)')"Ready for run: ",this%is_initialised - write(unit,'(a,L1)')"Is run: ",this%is_run - write(unit,'(a,L1)')"Accuracy goal reached: ",this%is_goal_reached - write(unit,'(a,L1)')"Integral calculated: ",this%is_integrated - write(unit,'(a,I10)')"Number of nodes: ",this%n_nodes - write(unit,'(a,I10)')"Maximal number of nodes: ",this%max_nodes - write(unit,'(a,I10)')"Dimension of integral: ",this%dim_integral - write(unit,'(a,E20.10)')"Given abs. error goal: ",this%abs_error_goal - write(unit,'(a,E20.10)')"Given rel. error goal: ",this%rel_error_goal - write(unit,'(a,E20.10)')"Guessed abs error goal:",this%scaled_error_goal - write(unit,'(a,E20.10)')"Actual abs error goal: ",this%error_goal - write(unit,'(a,E20.10)')"Integral ",this%integral - write(unit,'(a,E20.10)')"Estimated abs. error: ",this%integral_error - write(unit,'(a,E20.10)')"Estimated rel. error: ",this%integral_error/this%integral - write(unit,'(a,E10.5,a,E10.5,a)')"Integration region = (",this%region(1)," : ",this%region(2),")" - ser=>this%err_tree - call serialize_print_comp_pointer(ser,unit,parents,components,peers,"error tree") - write(unit,fmt=*)"Printing components of int_tree:" - call this%int_tree%print_to_unit(unit,parents,0,0) - ser=>this%int_list - call serialize_print_comp_pointer(ser,unit,parents,components,peers,"integral list") - end subroutine aqa_print_to_unit - - pure function aqa_get_type() result(type) - character(:),allocatable::type!FC = nagfor - allocate(type,source="AQA_CLASS")!FC = nagfor - character(32)::type!FC = gfortran - type="AQA_CLASS"!FC = gfortran - end function aqa_get_type - - subroutine aqa_deserialize(this,ring) - class(aqa_class),intent(out)::this - class(page_ring_type),intent(inout)::ring - class(serializable_class),pointer::ser - allocate(lin_approx_cont_type::ser) - call serialize_push_reference(ser) - allocate(fibonacci_root_type::ser) - call serialize_push_reference(ser) - allocate(fibonacci_leave_type::ser) - call serialize_push_reference(ser) - allocate(fibonacci_node_type::ser) - call serialize_push_reference(ser) - call serializable_deserialize(this,ring) - call serialize_pop_reference(ser) - deallocate(ser) - call serialize_pop_reference(ser) - deallocate(ser) - call serialize_pop_reference(ser) - deallocate(ser) - call serialize_pop_reference(ser) - deallocate(ser) - end subroutine aqa_deserialize - - ! new procedures - - subroutine aqa_initialize(this,id,name,goal,max_nodes,dim,init) - class(aqa_class),intent(out) :: this - integer,intent(in)::id,max_nodes,dim - character,intent(in)::name - real(kind=double)::goal - real(kind=double),dimension(:),intent(in)::init - call identified_initialize(this,id,name) - this%rel_error_goal = goal!1d-4 - this%max_nodes=max_nodes - call this%init_error_tree(dim,init) - end subroutine aqa_initialize - - subroutine aqa_print_times(this) - class(aqa_class),intent(in) :: this - print '(a,E20.10)',"Initialization time: ",this%init_time - print '(a,E20.10)',"Main loop time: ",this%loop_time - print '(a,E20.10)',"Integration time: ",this%int_time - print '(a,E20.10)',"Overall run time: ",this%total_time - print '(a,E20.10)',"Cuba integration time:",this%cuba_time - end subroutine aqa_print_times - - subroutine aqa_write_convergence(this,unit) - class(aqa_class),intent(in) :: this - integer,intent(in)::unit - integer,dimension(2)::s - integer::node - if(allocated(this%convergence))then - s=shape(this%convergence) - do node=1,s(2) - write(unit,fmt=*)node,this%convergence(1:2,node) - end do - end if - end subroutine aqa_write_convergence - - ! init/ de-init - - subroutine aqa_reset(this) - class(aqa_class) :: this - this%is_deferred_initialised = .false. - this%is_error_tree_initialised = .false. - this%is_goal_set = .false. - this%is_initialised = .false. - this%is_run = .false. - this%is_goal_reached = .false. - this%is_integrated = .false. - this%n_nodes = 0 - this%max_nodes = 10000 - this%dim_integral=1 - this%abs_error_goal = 1D0 - this%rel_error_goal = 0.1D0 - this%scaled_error_goal = 0.0D0 - this%error_goal = 0.0D0 - this%integral = 0D0 - this%integral_error = 0D0 - this%region = (/0D0,1D0/) - this%total_time = 0 - this%loop_time = 0 - this%int_time = 0 - this%init_time = 0 - call this%dealloc_trees() - end subroutine aqa_reset - - subroutine aqa_check_init(this) - class(aqa_class) :: this - this%is_initialised = this%is_error_tree_initialised .and. this%is_deferred_initialised - end subroutine aqa_check_init - - subroutine aqa_dealloc_trees(this) - class(aqa_class) :: this - call this%err_tree%deallocate_all() - call this%int_tree%finalize() - nullify(this%int_list) - end subroutine aqa_dealloc_trees - - subroutine aqa_init_error_tree(this,dim_integral,x_array) - class(aqa_class) :: this - integer,intent(in)::dim_integral - real(kind=double), dimension(:), intent(in) :: x_array - real(kind=double) :: center - real(kind=double), dimension(:),allocatable::l_val,c_val,r_val - class(lin_approx_cont_type),pointer :: left_node => null() - class(lin_approx_cont_type),pointer :: right_node => null() - integer :: x_size,pos -! print '("Entering aqa_init_error_tree...")' - call cpu_time(this%init_time) - this%is_initialised=.false. - this%integral=0D0 - this%dim_integral=dim_integral - x_size = size(x_array) - if (x_size<2) then - write (*,'("aqa_init_error_tree: I need at least two real values")') - else - allocate(l_val(dim_integral)) - allocate(c_val(dim_integral)) - allocate(r_val(dim_integral)) - this%region=(/x_array(1),x_array(x_size)/) - if (x_size<3) then - center=(x_array(2)-x_array(1))/2D0 - call this%evaluate(x_array(1),l_val) - call this%evaluate(center, c_val) - call this%evaluate(x_array(2),r_val) - allocate(left_node) - call left_node%initialize(& - &dim=dim_integral,& - &r_position=center,& - &d_position=center-x_array(1)) - call left_node%set_r_value(c_val) - call left_node%set_d_value(c_val-l_val) - allocate(right_node) - call right_node%initialize(& - &dim=dim_integral,& - &r_position=x_array(2),& - &d_position=x_array(2)-center) - call right_node%set_r_value(r_val) - call right_node%set_d_value(r_val-c_val) - else - call this%evaluate(x_array(1),l_val) - call this%evaluate(x_array(2),c_val) - call this%evaluate(x_array(3),r_val) - allocate(left_node) - call left_node%initialize(& - &dim=dim_integral,& - &r_position=x_array(2),& - &d_position=x_array(2)-x_array(1)) - call left_node%set_r_value(c_val) - call left_node%set_d_value(c_val-l_val) - allocate(right_node) - call right_node%initialize(& - &dim=dim_integral,& - &r_position=x_array(3),& - &d_position=x_array(3)-x_array(2)) - call right_node%set_r_value(r_val) - call right_node%set_d_value(r_val-c_val) - end if - call left_node%update() - call right_node%update() - this%integral=sum(left_node%get_d_integral()+right_node%get_d_integral()) - if (.not. associated(this%err_tree)) then - allocate(this%err_tree) - end if - print *,left_node%measure() - print *,right_node%measure() - call this%err_tree%init_by_content(left_node,right_node) -! call this%err_tree%write_pstricks(11) - if (x_size > 3) then - do pos=4,x_size - print *,"aqa_init_error_tree",pos - l_val=right_node%get_r_value_array() - call this%evaluate(x_array(pos),r_val) - c_val=r_val-l_val - allocate(right_node) - call right_node%initialize(& - &dim=dim_integral,& - &r_position=x_array(pos),& - &d_position=x_array(pos)-x_array(pos-1)) - call right_node%set_r_value(r_val) - call right_node%set_d_value(c_val) - call right_node%update() - call this%err_tree%push_by_content(right_node) -! call this%err_tree%write_pstricks(11) - this%integral=this%integral+sum(right_node%get_d_integral()) - end do - this%n_nodes = x_size - end if - this%is_error_tree_initialised=.true. - end if - call this%set_goal() - this%is_initialised=.true. - call cpu_time(this%cpu_time) - this%init_time=this%cpu_time-this%init_time - this%cuba_time=this%init_time - allocate(this%convergence(2,this%n_nodes:this%max_nodes)) - end subroutine aqa_init_error_tree - - subroutine aqa_set_abs_goal(this,goal) - class(aqa_class) :: this - real(kind=double) :: goal - this%abs_error_goal = goal - call this%set_goal - end subroutine aqa_set_abs_goal - - subroutine aqa_set_rel_goal(this,goal) - class(aqa_class) :: this - real(kind=double) :: goal - this%rel_error_goal = goal - call this%set_goal - end subroutine aqa_set_rel_goal - - subroutine aqa_set_goal(this) - class(aqa_class) :: this - this%scaled_error_goal = this%rel_error_goal*abs(this%integral) - if ((this%scaled_error_goal==0D0).and.(this%abs_error_goal==0D0)) then - this%is_goal_set = .false. - this%error_goal = 0D0 - else - if (this%scaled_error_goal == 0D0) then - this%error_goal = this%abs_error_goal - else - if (this%abs_error_goal == 0D0) then - this%error_goal = this%scaled_error_goal - else - this%error_goal = max(this%scaled_error_goal,this%abs_error_goal) - end if - end if - if (this%error_goal > 0D0) then - this%is_goal_set = .true. - else - this%is_goal_set = .false. - end if - end if - end subroutine aqa_set_goal - - ! calculation - - subroutine aqa_main_loop(this) - class(aqa_class) :: this - class(fibonacci_leave_type), pointer :: rightmost - class(measurable_class), pointer :: content - class(lin_approx_cont_type),pointer :: new_node!,debug - logical :: limit = .false. - real(kind=double) :: loop_goal,center - real(kind=double),dimension(:),allocatable::c_val -! unsafe, when n_nodes=3 - allocate(c_val(this%dim_integral)) - do - call this%err_tree%pop_right(rightmost) - loop_goal = (this%error_goal/this%n_nodes) - if (rightmost < loop_goal) then - this%is_goal_reached = .true. - exit - else - call rightmost%get_content(content) -! print *,associated(content) -! print *,content%get_type() - select type (content) - class is (lin_approx_cont_type) - print ('("nodes: ",I5," error: ",E14.7," goal: ",E14.7," node at: ",E14.7,"-",E14.7)'),this%n_nodes,rightmost%measure(),loop_goal,content%get_l_position(),content%get_r_position() - print *,allocated(this%convergence),shape(this%convergence),this%n_nodes - this%convergence(1,this%n_nodes)=loop_goal - this%convergence(2,this%n_nodes)=rightmost%measure() - ! debug=>content - center = content%get_r_position()-content%get_d_position()/2D0 - call cpu_time(this%cpu_time) - this%cuba_time=this%cuba_time-this%cpu_time - call this%evaluate(center,c_val) -! print *,"examinating: ",content%get_l_position(),content%get_r_position(),content%get_d_position()& -! &,center-content%get_l_position(),content%get_r_position()-center& -! &,(content%get_l_value_element(11)-c_val(11))/c_val(11),c_val(11),(c_val(11)-content%get_r_value_element(11))/c_val(11) - call cpu_time(this%cpu_time) - this%cuba_time=this%cuba_time+this%cpu_time - call content%split(c_val,center,new_node) -! print *,content%get_r_position(),content%get_r_value() -! print *,new_node%get_r_position(),new_node%get_r_value() - call this%err_tree%push_by_leave(rightmost) -! call this%err_tree%write_pstricks(11) - call this%err_tree%push_by_content(new_node) -! call this%err_tree%write_pstricks(11) -! flush(11) - end select - this%n_nodes=this%n_nodes+1 - if (this%n_nodes > this%max_nodes) then - limit = .true. - print *,"EXIT" - exit - end if - end if -! print *,"NEXT" - end do - call this%err_tree%push_by_leave(rightmost) - end subroutine aqa_main_loop - - subroutine aqa_run(this) - class(aqa_class) :: this - call cpu_time(this%total_time) - if (.not. this%is_error_tree_initialised) then - call this%init_error_tree(this%dim_integral,this%region) - end if - this%is_run = .false. - this%is_goal_reached = .false. - call aqa_main_loop(this) - this%is_run = .true. - call cpu_time(this%cpu_time) - this%total_time=this%cpu_time-this%total_time - end subroutine aqa_run - - subroutine aqa_integrate(this) - class(aqa_class) :: this - class(lin_approx_node_class),pointer :: node - real(kind=double) :: sum - this%is_integrated=.false. - this%integral_error=0D0 - if (this%is_run) then - call cpu_time(this%int_time) - call fibonacci_tree_resort_and_convert_to_lin_approx_list(this%err_tree,this%int_list) -! call this%int_list%print_all() -! call this%int_list%integrate(this%integral,this%integral_error) - call lin_approx_list_integrate(this%int_list,this%integral,this%integral_error) - call this%int_tree%finalize() - call this%int_list%to_tree(this%int_tree) - this%is_integrated=.true. - call cpu_time(this%cpu_time) - this%int_time=this%cpu_time-this%int_time - end if - end subroutine aqa_integrate - -end module aqa_module - Index: branches/attic/boschmann_standalone/pri/lib/phase_space_matrices.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/phase_space_matrices.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/phase_space_matrices.f03.pri (revision 8609) @@ -1,365 +0,0 @@ -!!! module: phase_space_matrices_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2009 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2009-10-22 15:28:47 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module phase_space_matrices_module - use kinds - use parameters_module - implicit none - - integer,parameter :: n_boosted_kinds = 1024 - integer,parameter :: n_boosted_pt_bins = 100 - real(kind=double),parameter :: gev2_boost_step = gev2_pt_max**(1D0/n_boosted_pt_bins) - - integer,dimension(-6:6,-6:6),parameter :: type_all_13 = reshape(source=& - &[2,1,1,1,1,1,4,1,1,1,1,1,3,& - & 1,2,1,1,1,1,4,1,1,1,1,3,1,& - & 1,1,2,1,1,1,4,1,1,1,3,1,1,& - & 1,1,1,2,1,1,4,1,1,3,1,1,1,& - & 1,1,1,1,2,1,4,1,3,1,1,1,1,& - & 1,1,1,1,1,2,4,3,1,1,1,1,1,& - & 4,4,4,4,4,4,5,4,4,4,4,4,4,& - & 1,1,1,1,1,3,4,2,1,1,1,1,1,& - & 1,1,1,1,3,1,4,1,2,1,1,1,1,& - & 1,1,1,3,1,1,4,1,1,2,1,1,1,& - & 1,1,3,1,1,1,4,1,1,1,2,1,1,& - & 1,3,1,1,1,1,4,1,1,1,1,2,1,& - & 3,1,1,1,1,1,4,1,1,1,1,1,2]& - &,shape=[13,13]) - integer,dimension(-6:6,-6:6),parameter :: type_1_13 = reshape(source=& - &[0,1,1,1,1,1,0,1,1,1,1,1,0,& - & 1,0,1,1,1,1,0,1,1,1,1,0,1,& - & 1,1,0,1,1,1,0,1,1,1,0,1,1,& - & 1,1,1,0,1,1,0,1,1,0,1,1,1,& - & 1,1,1,1,0,1,0,1,0,1,1,1,1,& - & 1,1,1,1,1,0,0,0,1,1,1,1,1,& - & 0,0,0,0,0,0,0,0,0,0,0,0,0,& - & 1,1,1,1,1,0,0,0,1,1,1,1,1,& - & 1,1,1,1,0,1,0,1,0,1,1,1,1,& - & 1,1,1,0,1,1,0,1,1,0,1,1,1,& - & 1,1,0,1,1,1,0,1,1,1,0,1,1,& - & 1,0,1,1,1,1,0,1,1,1,1,0,1,& - & 0,1,1,1,1,1,0,1,1,1,1,1,0]& - &,shape=[13,13]) - integer,dimension(-6:6,-6:6),parameter :: type_2_13 = reshape(source=& - &[1,0,0,0,0,0,0,0,0,0,0,0,0,& - & 0,1,0,0,0,0,0,0,0,0,0,0,0,& - & 0,0,1,0,0,0,0,0,0,0,0,0,0,& - & 0,0,0,1,0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,1,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,1,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,1,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,1,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,1,0,0,0,& - & 0,0,0,0,0,0,0,0,0,0,1,0,0,& - & 0,0,0,0,0,0,0,0,0,0,0,1,0,& - & 0,0,0,0,0,0,0,0,0,0,0,0,1]& - &,shape=[13,13]) - integer,dimension(-6:6,-6:6),parameter :: type_3_13 = reshape(source=& - &[0,0,0,0,0,0,0,0,0,0,0,0,1,& - & 0,0,0,0,0,0,0,0,0,0,0,1,0,& - & 0,0,0,0,0,0,0,0,0,0,1,0,0,& - & 0,0,0,0,0,0,0,0,0,1,0,0,0,& - & 0,0,0,0,0,0,0,0,1,0,0,0,0,& - & 0,0,0,0,0,0,0,1,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,1,0,0,0,0,0,0,0,& - & 0,0,0,0,1,0,0,0,0,0,0,0,0,& - & 0,0,0,1,0,0,0,0,0,0,0,0,0,& - & 0,0,1,0,0,0,0,0,0,0,0,0,0,& - & 0,1,0,0,0,0,0,0,0,0,0,0,0,& - & 1,0,0,0,0,0,0,0,0,0,0,0,0]& - &,shape=[13,13]) - integer,dimension(-6:6,-6:6),parameter :: type_4_13 = reshape(source=& - &[0,0,0,0,0,0,1,0,0,0,0,0,0,& - & 0,0,0,0,0,0,1,0,0,0,0,0,0,& - & 0,0,0,0,0,0,1,0,0,0,0,0,0,& - & 0,0,0,0,0,0,1,0,0,0,0,0,0,& - & 0,0,0,0,0,0,1,0,0,0,0,0,0,& - & 0,0,0,0,0,0,1,0,0,0,0,0,0,& - & 1,1,1,1,1,1,0,1,1,1,1,1,1,& - & 0,0,0,0,0,0,1,0,0,0,0,0,0,& - & 0,0,0,0,0,0,1,0,0,0,0,0,0,& - & 0,0,0,0,0,0,1,0,0,0,0,0,0,& - & 0,0,0,0,0,0,1,0,0,0,0,0,0,& - & 0,0,0,0,0,0,1,0,0,0,0,0,0,& - & 0,0,0,0,0,0,1,0,0,0,0,0,0]& - &,shape=[13,13]) - integer,dimension(-6:6,-6:6),parameter :: type_5_13 = reshape(source=& - &[0,0,0,0,0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,1,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,0,0,0,0]& - &,shape=[13,13]) - integer,dimension(-4:4,-4:4),parameter :: type_all_9 = reshape(source=& - &[2,1,1,1,4,1,1,1,3,& - & 1,2,1,1,4,1,1,3,1,& - & 1,1,2,1,4,1,3,1,1,& - & 1,1,1,2,4,3,1,1,1,& - & 4,4,4,4,5,4,4,4,4,& - & 1,1,1,3,4,2,1,1,1,& - & 1,1,3,1,4,1,2,1,1,& - & 1,3,1,1,4,1,1,2,1,& - & 3,1,1,1,4,1,1,1,2]& - &,shape=[9,9]) - integer,dimension(-4:4,-4:4),parameter :: type_1_9 = reshape(source=& - &[0,1,1,1,0,1,1,1,0,& - & 1,0,1,1,0,1,1,0,1,& - & 1,1,0,1,0,1,0,1,1,& - & 1,1,1,0,0,0,1,1,1,& - & 0,0,0,0,0,0,0,0,0,& - & 1,1,1,0,0,0,1,1,1,& - & 1,1,0,1,0,1,0,1,1,& - & 1,0,1,1,0,1,1,0,1,& - & 0,1,1,1,0,1,1,1,0]& - &,shape=[9,9]) - integer,dimension(-4:4,-4:4),parameter :: type_2_9 = reshape(source=& - &[1,0,0,0,0,0,0,0,0,& - & 0,1,0,0,0,0,0,0,0,& - & 0,0,1,0,0,0,0,0,0,& - & 0,0,0,1,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,1,0,0,0,& - & 0,0,0,0,0,0,1,0,0,& - & 0,0,0,0,0,0,0,1,0,& - & 0,0,0,0,0,0,0,0,1]& - &,shape=[9,9]) - integer,dimension(-4:4,-4:4),parameter :: type_3_9 = reshape(source=& - &[0,0,0,0,0,0,0,0,1,& - & 0,0,0,0,0,0,0,1,0,& - & 0,0,0,0,0,0,1,0,0,& - & 0,0,0,0,0,1,0,0,0,& - & 0,0,0,0,0,0,0,0,0,& - & 0,0,0,1,0,0,0,0,0,& - & 0,0,1,0,0,0,0,0,0,& - & 0,1,0,0,0,0,0,0,0,& - & 1,0,0,0,0,0,0,0,0]& - &,shape=[9,9]) - integer,dimension(-4:4,-4:4),parameter :: type_4_9 = reshape(source=& - &[0,0,0,0,1,0,0,0,0,& - & 0,0,0,0,1,0,0,0,0,& - & 0,0,0,0,1,0,0,0,0,& - & 0,0,0,0,1,0,0,0,0,& - & 1,1,1,1,0,1,1,1,1,& - & 0,0,0,0,1,0,0,0,0,& - & 0,0,0,0,1,0,0,0,0,& - & 0,0,0,0,1,0,0,0,0,& - & 0,0,0,0,1,0,0,0,0]& - &,shape=[9,9]) - integer,dimension(-4:4,-4:4),parameter :: type_5_9 = reshape(source=& - &[0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,1,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0]& - &,shape=[9,9]) - integer,dimension(1:5,-4:4,-4:4),parameter :: type_array_9 = reshape(source=& - &[0,1,1,1,0,1,1,1,0,& - & 1,0,1,1,0,1,1,0,1,& - & 1,1,0,1,0,1,0,1,1,& - & 1,1,1,0,0,0,1,1,1,& - & 0,0,0,0,0,0,0,0,0,& - & 1,1,1,0,0,0,1,1,1,& - & 1,1,0,1,0,1,0,1,1,& - & 1,0,1,1,0,1,1,0,1,& - & 0,1,1,1,0,1,1,1,0,& - & 1,0,0,0,0,0,0,0,0,& - & 0,1,0,0,0,0,0,0,0,& - & 0,0,1,0,0,0,0,0,0,& - & 0,0,0,1,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,1,0,0,0,& - & 0,0,0,0,0,0,1,0,0,& - & 0,0,0,0,0,0,0,1,0,& - & 0,0,0,0,0,0,0,0,1,& - & 0,0,0,0,0,0,0,0,1,& - & 0,0,0,0,0,0,0,1,0,& - & 0,0,0,0,0,0,1,0,0,& - & 0,0,0,0,0,1,0,0,0,& - & 0,0,0,0,0,0,0,0,0,& - & 0,0,0,1,0,0,0,0,0,& - & 0,0,1,0,0,0,0,0,0,& - & 0,1,0,0,0,0,0,0,0,& - & 1,0,0,0,0,0,0,0,0,& - & 0,0,0,0,1,0,0,0,0,& - & 0,0,0,0,1,0,0,0,0,& - & 0,0,0,0,1,0,0,0,0,& - & 0,0,0,0,1,0,0,0,0,& - & 1,1,1,1,0,1,1,1,1,& - & 0,0,0,0,1,0,0,0,0,& - & 0,0,0,0,1,0,0,0,0,& - & 0,0,0,0,1,0,0,0,0,& - & 0,0,0,0,1,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,1,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0,& - & 0,0,0,0,0,0,0,0,0]& - &,shape=[5,9,9]) - - character(len=14),dimension(1:5),parameter :: traditional_ps_kind_names = & - &["{ut-dt,dt-ut}","{ut-ut,dt-dt}","{q-a,a-q} ","{q-g,g-q} ","{gg} "] - - character(len=10),dimension(1:8),parameter :: traditional_ps_io_kind_names = & - &["q1q2->q1q2","q1q1->q1q1","q1Q1->q2Q2","q1Q1->q1Q1","q1Q1-> g g"," g g->q1Q1"," q g-> q g"," g g-> g g"] - - character(len=3),dimension(1:4,1:5),parameter :: char_coefficients = reshape(source=[& - & "11 ", "12 ", "13 ", "14 ",& - & "21 ", "22 ", "23 ", "24 ",& - & "31 ", "32 ", "33 ", "34 ",& - & "41 ", "42 ", "43 ", "44 ",& - & "51 ", "52 ", "53 ", "54 "],& - &shape=[4,5]) - - real(kind=double),dimension(2,100),parameter :: def_gev2_mc_limits=reshape(source=& -&[0.100000000000000E+01, 0.419970092352589E+06,& -& 0.119371859971209E+01, 0.207815228156096E+06,& -& 0.142496409529860E+01, 0.906725050037473E+05,& -& 0.170100614447985E+01, 0.484190281803226E+05,& -& 0.203052267289016E+01, 0.309288045068057E+05,& -& 0.242387268176610E+01, 0.157605729618980E+05,& -& 0.289342190355822E+01, 0.958745212987780E+04,& -& 0.345393154309181E+01, 0.512036729204403E+04,& -& 0.412302232512099E+01, 0.264927172032184E+04,& -& 0.492172843652513E+01, 0.165428555039233E+04,& -& 0.587515877741196E+01, 0.121121390993519E+04,& -& 0.701328630885842E+01, 0.680072012876755E+03,& -& 0.837189031199046E+01, 0.407126399502265E+03,& -& 0.999368118017249E+01, 0.256387648090949E+03,& -& 0.119296431043646E+02, 0.162331937995442E+03,& -& 0.142406368616071E+02, 0.101812451961423E+03,& -& 0.169993130934461E+02, 0.491785813114255E+02,& -& 0.202923962219759E+02, 0.375906334570974E+02,& -& 0.242234108029000E+02, 0.240296344710502E+02,& -& 0.289159360238886E+02, 0.143573872153931E+02,& -& 0.345174906598008E+02, 0.924925241864252E+01,& -& 0.412041706159927E+02, 0.641350625545023E+01,& -& 0.491861848500209E+02, 0.404576779869092E+01,& -& 0.587144637043471E+02, 0.234907613843891E+01,& -& 0.700885473959998E+02, 0.151587007990613E+01,& -& 0.836660026534075E+02, 0.103017847738417E+01,& -& 0.998736635309339E+02, 0.622885713775126E+00,& -& 0.119221049778263E+03, 0.454714099788122E+00,& -& 0.142316384597514E+03, 0.296807651849801E+00,& -& 0.169885715337832E+03, 0.171613739700982E+00,& -& 0.202795738224164E+03, 0.100757581183094E+00,& -& 0.242081044660529E+03, 0.707502698656873E-01,& -& 0.288976645649008E+03, 0.525901224581242E-01,& -& 0.344956796793631E+03, 0.318349395781125E-01,& -& 0.411781344429662E+03, 0.225864943273356E-01,& -& 0.491551049860139E+03, 0.129885350263119E-01,& -& 0.586773630926055E+03, 0.835325546327550E-02,& -& 0.700442597057031E+03, 0.552849046713415E-02,& -& 0.836131356137620E+03, 0.322569590195272E-02,& -& 0.998105551623974E+03, 0.274993369733707E-02,& -& 0.119145716144944E+04, 0.156140159773291E-02,& -& 0.142226457438237E+04, 0.110694814923807E-02,& -& 0.169778367615183E+04, 0.799227676970086E-03,& -& 0.202667595251002E+04, 0.383030520783189E-03,& -& 0.241928078010043E+04, 0.291772530616855E-03,& -& 0.288794046513186E+04, 0.231924151865629E-03,& -& 0.344738824808910E+04, 0.144798878948581E-03,& -& 0.411521147217284E+04, 0.980446941639118E-04,& -& 0.491240447608131E+04, 0.537800346435237E-04,& -& 0.586402859240720E+04, 0.333946171153554E-04,& -& 0.699999999999999E+04, 0.280471358476841E-04,& -& 0.835603019798464E+04, 0.187959979645862E-04,& -& 0.997474866709019E+04, 0.133371633667763E-04,& -& 0.119070430113590E+05, 0.831622761747754E-05,& -& 0.142136587102311E+05, 0.601511444708171E-05,& -& 0.169671087723626E+05, 0.330354023449625E-05,& -& 0.202539533249075E+05, 0.243471769356382E-05,& -& 0.241775208016427E+05, 0.189570091016092E-05,& -& 0.288611562758469E+05, 0.116158458897545E-05,& -& 0.344520990556758E+05, 0.824182334002945E-06,& -& 0.411261114418837E+05, 0.603229337396528E-06,& -& 0.490930041620089E+05, 0.418427878666838E-06,& -& 0.586032321839332E+05, 0.275323527384256E-06,& -& 0.699557682612074E+05, 0.201547740092446E-06,& -& 0.835075017305522E+05, 0.116020284396503E-06,& -& 0.996844580312499E+05, 0.946982024871626E-07,& -& 0.118995191654122E+06, 0.494112637652128E-07,& -& 0.142046773553831E+06, 0.421366867219254E-07,& -& 0.169563875620300E+06, 0.304203612007242E-07,& -& 0.202411552167220E+06, 0.200083740589384E-07,& -& 0.241622434618605E+06, 0.138960727877386E-07,& -& 0.288429194311948E+06, 0.948157890978974E-08,& -& 0.344303293950146E+06, 0.511334411334428E-08,& -& 0.411001245930430E+06, 0.423033641025070E-08,& -& 0.490619831771998E+06, 0.277129911479888E-08,& -& 0.585662018573852E+06, 0.161628148271262E-08,& -& 0.699115644716536E+06, 0.126157616603832E-08,& -& 0.834547348447841E+06, 0.843053719885486E-09,& -& 0.996214692182597E+06, 0.488058170980222E-09,& -& 0.118920000736482E+07, 0.386759408625841E-09,& -& 0.141957016756915E+07, 0.240331138079750E-09,& -& 0.169456731262370E+07, 0.125647277631235E-09,& -& 0.202283651954305E+07, 0.992989290942340E-10,& -& 0.241469757755542E+07, 0.471612400036933E-10,& -& 0.288246941100763E+07, 0.346373882411254E-10,& -& 0.344085734902097E+07, 0.217668159077060E-10,& -& 0.410741541648238E+07, 0.112565519973968E-10,& -& 0.490309817939921E+07, 0.727883584437003E-11,& -& 0.585291949296334E+07, 0.358776521245826E-11,& -& 0.698673886136781E+07, 0.187006266653940E-11,& -& 0.834020013014604E+07, 0.886784082182197E-12,& -& 0.995585202067655E+07, 0.383495277657388E-12,& -& 0.118844857330628E+08, 0.143152125446264E-12,& -& 0.141867316675701E+08, 0.443063866546396E-13,& -& 0.169349654607030E+08, 0.126182561126791E-13,& -& 0.202155832559230E+08, 0.286557624786894E-14,& -& 0.241317177366237E+08, 0.422688883640659E-15,& -& 0.288064803052099E+08, 0.343139883565735E-16,& -& 0.343868313325691E+08, 0.902471298201908E-18,& -& 0.410482001468503E+08, 0.154824526501128E-20],& - &shape=[2,100]) - - -contains - - function get_traditional_name(partons) - character(len=4)::get_traditional_name - integer,dimension(4),intent(in)::partons - get_traditional_name=traditional_parton_names(partons(1))//traditional_parton_names(partons(2))//& - &traditional_parton_names(partons(3))//traditional_parton_names(partons(4)) - end function get_traditional_name - - -end module phase_space_matrices_module - Index: branches/attic/boschmann_standalone/pri/lib/parameters.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/parameters.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/parameters.f03.pri (revision 8609) @@ -1,1156 +0,0 @@ -!!! module: parameters_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-03-09 12:13:03 CET(+0100) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module parameters_module - use kinds - implicit none - - !process parameters - integer,parameter::hadron_A_kind=2212 ! Proton - integer,parameter::hadron_B_kind=-2212 ! Anti Proton - real(kind=double), parameter :: b_sigma_tot_all = 100 !mb PDG - real(kind=double), parameter :: b_sigma_tot_nd = 0.5*b_sigma_tot_all !phys.rev.d v49 n5 1994 - real(kind=double), parameter :: gev_cme_tot = 14000 !total center of mass energie - real(kind=double), parameter :: gev2_cme_tot = gev_cme_tot**2 !s - real(kind=double), parameter :: gev_pt_max = gev_cme_tot/2D0 - real(kind=double), parameter :: gev2_pt_max = gev2_cme_tot/4D0 - - !model parameters - real(kind=double), parameter :: gev_pt_min = 8D-1 - real(kind=double), parameter :: gev2_pt_min = gev_pt_min**2 - real(kind=double), parameter :: pts_min = gev_pt_min/gev_pt_max - real(kind=double), parameter :: pts2_min = gev2_pt_min/gev2_pt_max - real(kind=double), parameter :: gev_p_t_0 = 2.0 - real(kind=double), parameter :: gev2_p_t_0 = gev_p_t_0**2 - real(kind=double), parameter :: norm_p_t_0 = gev_p_t_0/gev_pt_max - real(kind=double), parameter :: norm2_p_t_0 = gev2_p_t_0/gev2_pt_max - - !fit parameters - real(kind=double), parameter :: xfit_A0 = 8.27348D-2 - real(kind=double), parameter :: xfit_A1 = 1.09642D2 - real(kind=double), parameter :: xfit_L1 = -2.95701D2 - real(kind=double), parameter :: xfit_E1 = 0.42208D0 - real(kind=double), parameter :: xfit_A2 = 5.07545D0 - real(kind=double), parameter :: xfit_L2 = -1.40438D1 - real(kind=double), parameter :: xfit_E2 = 1.58006D-1 - real(kind=double), parameter :: xfit_secure_factor = 1.01D0 - - !pdf parameters -! character, parameter :: pdfname*64 = 'cteq5m.LHgrid'! Standard MSbar scheme hep-ph/9903282 - character, parameter :: pdfname*64 = 'cteq5l.LHgrid' -! character, parameter :: pdfname*64 = 'a02m_nnlo.LHgrid'! Alekhin2002 (NNLO VFN 17 sets) -! character, parameter :: pdfname*64 = 'MSTW2008lo68cl.LHgrid' !2008 -! character, parameter :: pdfname*64 = 'MRST2007lomod.LHgrid' !2007 - integer, parameter :: pdfset = 1 - character, parameter :: pdfverbose*6 = 'SILENT' ! SILENT -! character, parameter :: pdfverbose*6 = 'LOWKEY' ! little -! character, parameter :: pdfverbose*6 = '19' ! a lot - - !parton kind parameters - integer,parameter,public::lha_flavor_at=-6 - integer,parameter,public::lha_flavor_ab=-5 - integer,parameter,public::lha_flavor_ac=-4 - integer,parameter,public::lha_flavor_as=-3 - integer,parameter,public::lha_flavor_au=-2 - integer,parameter,public::lha_flavor_ad=-1 - integer,parameter,public::lha_flavor_g=0 - integer,parameter,public::lha_flavor_d=1 - integer,parameter,public::lha_flavor_u=2 - integer,parameter,public::lha_flavor_s=3 - integer,parameter,public::lha_flavor_c=4 - integer,parameter,public::lha_flavor_b=5 - integer,parameter,public::lha_flavor_t=6 - integer,parameter,public::parton_kind_sea=1 - integer,parameter,public::parton_kind_valence=2 - integer,parameter,public::parton_kind_sea_and_valence=3 - integer,parameter,public::parton_kind_companion=4 - integer,parameter,public::parton_kind_sea_and_companion=5 - integer,parameter,public::parton_kind_valence_and_companion=6 - integer,parameter,public::parton_kind_all=7 - integer,parameter,public::pdf_int_kind_undef=0 - integer,parameter,public::pdf_int_kind_gluon=1 - integer,parameter,public::pdf_int_kind_sea=2 - integer,parameter,public::pdf_int_kind_val_down=3 - integer,parameter,public::pdf_int_kind_val_up=4 - character(len=2),dimension(-6:6),parameter :: integer_parton_names = & - &["-6","-5","-4","-3","-2","-1","00","+1","+2","+3","+4","+5","+6"] - character,dimension(-6:6),parameter :: traditional_parton_names = & - &["T","B","C","S","U","D","g","d","u","s","c","b","t"] - - !epsilon parameters - real, parameter :: unit_epsilon_1 = 1D-8 ! 1-eps^1 is ok, 1-eps^2 is not - real, parameter :: unit_epsilon_2 = 4.64158883361D-6 ! 1-eps^2 is ok, 1-eps^3 is not - real, parameter :: unit_epsilon_3 = 1D-4 ! 1-eps^3 is ok, 1-eps^4 is not - real, parameter :: unit_epsilon_4 = 6.30957344480D-4 ! 1-eps^4 is ok, 1-eps^5 is not - real, parameter :: unit_epsilon_5 = 2.15443469003D-3 ! 1-eps^5 is ok, 1-eps^6 is not - - !process parameters - integer,dimension(4),parameter::parton_kind_of_int_kind=[1,1,2,2] -!!$ integer,dimension(2,-11:11),parameter::pdf_int_11=reshape(source=[& -!!$ &4,4,& -!!$ &4,3,& -!!$ &3,3,& -!!$ &4,2,& -!!$ &3,2,& -!!$ &4,1,& -!!$ &3,1,& -!!$ &2,1,& -!!$ &2,2,& -!!$ &1,1,& -!!$ &0,0,& -!!$ &0,0,& -!!$ &0,0,& -!!$ &1,1,& -!!$ &2,2,& -!!$ &1,2,& -!!$ &1,3,& -!!$ &1,4,& -!!$ &2,3,& -!!$ &2,4,& -!!$ &3,3,& -!!$ &3,4,& -!!$ &4,4],shape=[2,23]) -!!$ integer,parameter :: n_kinds = 217 -!!$ -!!$ integer,dimension(1),parameter::int2=[139] -!!$ integer,dimension(1),parameter::int3=[165] -!!$ integer,dimension(2),parameter::int4=[140,141] -!!$ integer,dimension(22),parameter::int5=[122,123,124,125,126,127,128,129,130,131,132,133,134,135,136,139,140,141,142,143,144,145] -!!$ integer,dimension(2),parameter::int6=[137,138] -!!$ integer,dimension(22),parameter::int7=[146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,163,164,165,166,167,168,169] -!!$ integer,dimension(2),parameter::int8=[161,162] -!!$ integer,dimension(100),parameter::int9=[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,139,140,141,142,143,144,145,165,166,167,168,169,191,192,193,217] -!!$ integer,dimension(16),parameter::int10=[8,9,32,33,56,57,80,81,137,138,161,162,185,186,209,210] -!!$ integer,dimension(9),parameter::int11=[105,106,107,108,109,110,111,112,113] -!!$ -!!$ integer,dimension(2,1),parameter::int1_process_id=reshape([0,0],[2,1]) -!!$ integer,dimension(2,1),parameter::int2_process_id=reshape([139,139],[2,1]) -!!$ integer,dimension(2,1),parameter::int3_process_id=reshape([165,165],[2,1]) -!!$ integer,dimension(2,2),parameter::int4_process_id=reshape([140,163,141,164],[2,2]) -!!$ integer,dimension(2,22),parameter::int5_process_id=reshape(source=[& -!!$ & 122, 10,& -!!$ & 123, 11,& -!!$ & 124, 34,& -!!$ & 125, 35,& -!!$ & 126, 58,& -!!$ & 127, 59,& -!!$ & 128, 82,& -!!$ & 129, 83,& -!!$ & 130, 84,& -!!$ & 131, 85,& -!!$ & 132, 86,& -!!$ & 133, 87,& -!!$ & 134, 88,& -!!$ & 135, 89,& -!!$ & 136, 90,& -!!$ & 139, 139,& -!!$ & 140, 163,& -!!$ & 141, 164,& -!!$ & 142, 187,& -!!$ & 143, 188,& -!!$ & 144, 211,& -!!$ & 145, 212& -!!$ &],shape=[2,22]) -!!$ integer,dimension(2,2),parameter::int6_process_id=reshape([137,114,138,115],[2,2]) -!!$ integer,dimension(2,22),parameter::int7_process_id=reshape([& -!!$ & 146, 12,& -!!$ & 147, 13,& -!!$ & 148, 36,& -!!$ & 149, 37,& -!!$ & 150, 60,& -!!$ & 151, 61,& -!!$ & 152, 62,& -!!$ & 153, 63,& -!!$ & 154, 64,& -!!$ & 155, 65,& -!!$ & 156, 66,& -!!$ & 157, 67,& -!!$ & 158, 68,& -!!$ & 159, 91,& -!!$ & 160, 92,& -!!$ & 163, 140,& -!!$ & 164, 141,& -!!$ & 165, 165,& -!!$ & 166, 189,& -!!$ & 167, 190,& -!!$ & 168, 213,& -!!$ & 169, 214& -!!$ &],[2,22]) -!!$ integer,dimension(2,2),parameter::int8_process_id=reshape([161,116,162,117],[2,2]) -!!$ integer,dimension(2,92),parameter::int9_process_id=reshape([& -!!$ & 1, 1,& -!!$ & 2, 25,& -!!$ & 3, 26,& -!!$ & 4, 49,& -!!$ & 5, 50,& -!!$ & 6, 73,& -!!$ & 7, 74,& -!!$! & 8, 97,& -!!$! & 9, 98,& -!!$ & 10, 122,& -!!$ & 11, 123,& -!!$ & 12, 146,& -!!$ & 13, 147,& -!!$ & 14, 170,& -!!$ & 15, 171,& -!!$ & 16, 194,& -!!$ & 17, 195,& -!!$ & 18, 196,& -!!$ & 19, 197,& -!!$ & 20, 198,& -!!$ & 21, 199,& -!!$ & 22, 200,& -!!$ & 23, 201,& -!!$ & 24, 202,& -!!$ & 27, 27,& -!!$ & 28, 51,& -!!$ & 29, 52,& -!!$ & 30, 75,& -!!$ & 31, 76,& -!!$! & 32, 99,& -!!$! & 33, 100,& -!!$ & 34, 124,& -!!$ & 35, 125,& -!!$ & 36, 148,& -!!$ & 37, 149,& -!!$ & 38, 172,& -!!$ & 39, 173,& -!!$ & 40, 174,& -!!$ & 41, 175,& -!!$ & 42, 176,& -!!$ & 43, 177,& -!!$ & 44, 178,& -!!$ & 45, 179,& -!!$ & 46, 180,& -!!$ & 47, 203,& -!!$ & 48, 204,& -!!$ & 53, 53,& -!!$ & 54, 77,& -!!$ & 55, 78,& -!!$! & 56, 101,& -!!$! & 57, 102,& -!!$ & 58, 126,& -!!$ & 59, 127,& -!!$ & 60, 150,& -!!$ & 61, 151,& -!!$ & 62, 152,& -!!$ & 63, 153,& -!!$ & 64, 154,& -!!$ & 65, 155,& -!!$ & 66, 156,& -!!$ & 67, 157,& -!!$ & 68, 158,& -!!$ & 69, 181,& -!!$ & 70, 182,& -!!$ & 71, 205,& -!!$ & 72, 206,& -!!$ & 79, 79,& -!!$! & 80, 103,& -!!$! & 81, 104,& -!!$ & 82, 128,& -!!$ & 83, 129,& -!!$ & 84, 130,& -!!$ & 85, 131,& -!!$ & 86, 132,& -!!$ & 87, 133,& -!!$ & 88, 134,& -!!$ & 89, 135,& -!!$ & 90, 136,& -!!$ & 91, 159,& -!!$ & 92, 160,& -!!$ & 93, 183,& -!!$ & 94, 184,& -!!$ & 95, 207,& -!!$ & 96, 208,& -!!$ & 139, 139,& -!!$ & 140, 163,& -!!$ & 141, 164,& -!!$ & 142, 187,& -!!$ & 143, 188,& -!!$ & 144, 211,& -!!$ & 145, 212,& -!!$ & 165, 165,& -!!$ & 166, 189,& -!!$ & 167, 190,& -!!$ & 168, 213,& -!!$ & 169, 214,& -!!$ & 191, 191,& -!!$ & 192, 215,& -!!$ & 193, 216,& -!!$ & 217, 217& -!!$ &],[2,92]) -!!$ integer,dimension(2,16),parameter::int10_process_id=reshape([& -!!$ & 8, 97,& -!!$ & 9, 98,& -!!$ & 32, 99,& -!!$ & 33, 100,& -!!$ & 56, 101,& -!!$ & 57, 102,& -!!$ & 80, 103,& -!!$ & 81, 104,& -!!$ & 137, 114,& -!!$ & 138, 115,& -!!$ & 161, 116,& -!!$ & 162, 117,& -!!$ & 185, 118,& -!!$ & 186, 119,& -!!$ & 209, 120,& -!!$ & 210, 121& -!!$ &],[2,16]) -!!$ integer,dimension(2,5),parameter::int11_process_id=reshape([& -!!$ & 109, 109,& -!!$ & 110, 108,& -!!$ & 111, 107,& -!!$ & 112, 106,& -!!$ & 113, 105& -!!$ &],[2,5]) - - !ps polynom coefficients - ! evolution variable is pt2s/(x1*x2) - real(kind=double),dimension(1:4,1:5),parameter :: phase_space_coefficients_in = reshape(source=[& - & 6144D0, -4608D0, +384D0, 0D0,& - & 6144D0, -5120D0, +384D0, 0D0,& - & 6144D0, -2048D0, +128D0, -576D0,& - &13824D0, -9600D0, +1056D0, 0D0,& - &31104D0,-19872D0, +2160D0, +486D0],& - &shape=[4,5]) - - ! evolution variable is pt2s/(x1*x2) - real(kind=double),dimension(1:4,1:8),parameter :: phase_space_coefficients_inout = reshape(source=[& - &3072, -2304, +192, 0, & - &6144, -5120, +384, 0, & - &0, 0, 192, -96, & - &3072, -2048, +192, -96, & - &0, 2048, -2176, +576, & - &0, 288, -306, +81, & - &6912, -4800, +528, 0, & - &31104,-23328, +5832, -486],& - &shape=[4,8]) - -!!$ integer,dimension(5,n_kinds),parameter:: phase_space_kinds_inout=reshape(source=& -!!$ &[-4,-4,-4,-4,+2,&!1 -!!$ &-4,-3,-4,-3,+1,& -!!$ &-4,-3,-3,-4,+1,& -!!$ &-4,-2,-4,-2,+1,& -!!$ &-4,-2,-2,-4,+1,& -!!$ &-4,-1,-4,-1,+1,& -!!$ &-4,-1,-1,-4,+1,& -!!$ &-4,+0,-4,+0,+7,& -!!$ &-4,+0,+0,-4,+7,& -!!$ &-4,+1,-4,+1,+1,&!10 -!!$ &-4,+1,+1,-4,+1,& -!!$ &-4,+2,-4,+2,+1,& -!!$ &-4,+2,+2,-4,+1,& -!!$ &-4,+3,-4,+3,+1,& -!!$ &-4,+3,+3,-4,+1,& -!!$ &-4,+4,-4,+4,+4,& -!!$ &-4,+4,-3,+3,+3,& -!!$ &-4,+4,-2,+2,+3,& -!!$ &-4,+4,-1,+1,+3,& -!!$ &-4,+4,+0,+0,+5,&!20 -!!$ &-4,+4,+1,-1,+3,& -!!$ &-4,+4,+2,-2,+3,& -!!$ &-4,+4,+3,-3,+3,& -!!$ &-4,+4,+4,-4,+4,& -!!$ &-3,-4,-4,-3,+1,& -!!$ &-3,-4,-3,-4,+1,& -!!$ &-3,-3,-3,-3,+2,& -!!$ &-3,-2,-3,-2,+1,& -!!$ &-3,-2,-2,-3,+1,& -!!$ &-3,-1,-3,-1,+1,&!30 -!!$ &-3,-1,-1,-3,+1,& -!!$ &-3,+0,-3,+0,+7,& -!!$ &-3,+0,+0,-3,+7,& -!!$ &-3,+1,-3,+1,+1,& -!!$ &-3,+1,+1,-3,+1,& -!!$ &-3,+2,-3,+2,+1,& -!!$ &-3,+2,+2,-3,+1,& -!!$ &-3,+3,-4,+4,+3,& -!!$ &-3,+3,-3,+3,+4,& -!!$ &-3,+3,-2,+2,+3,&!40 -!!$ &-3,+3,-1,+1,+3,& -!!$ &-3,+3,+0,+0,+5,& -!!$ &-3,+3,+1,-1,+3,& -!!$ &-3,+3,+2,-2,+3,& -!!$ &-3,+3,+3,-3,+4,& -!!$ &-3,+3,+4,-4,+3,& -!!$ &-3,+4,-3,+4,+1,& -!!$ &-3,+4,+4,-3,+1,& -!!$ &-2,-4,-4,-2,+1,& -!!$ &-2,-4,-2,-4,+1,&!50 -!!$ &-2,-3,-3,-2,+1,& -!!$ &-2,-3,-2,-3,+1,& -!!$ &-2,-2,-2,-2,+2,& -!!$ &-2,-1,-2,-1,+1,& -!!$ &-2,-1,-1,-2,+1,& -!!$ &-2,+0,-2,+0,+7,& -!!$ &-2,+0,+0,-2,+7,& -!!$ &-2,+1,-2,+1,+1,& -!!$ &-2,+1,+1,-2,+1,& -!!$ &-2,+2,-4,+4,+3,&!60 -!!$ &-2,+2,-3,+3,+3,& -!!$ &-2,+2,-2,+2,+4,& -!!$ &-2,+2,-1,+1,+3,& -!!$ &-2,+2,+0,+0,+5,& -!!$ &-2,+2,+1,-1,+3,& -!!$ &-2,+2,+2,-2,+4,& -!!$ &-2,+2,+3,-3,+3,& -!!$ &-2,+2,+4,-4,+3,& -!!$ &-2,+3,-2,+3,+1,& -!!$ &-2,+3,+3,-2,+1,&!70 -!!$ &-2,+4,-2,+4,+1,& -!!$ &-2,+4,+4,-2,+1,& -!!$ &-1,-4,-4,-1,+1,& -!!$ &-1,-4,-1,-4,+1,& -!!$ &-1,-3,-3,-1,+1,& -!!$ &-1,-3,-1,-3,+1,& -!!$ &-1,-2,-2,-1,+1,& -!!$ &-1,-2,-1,-2,+1,& -!!$ &-1,-1,-1,-1,+2,& -!!$ &-1,+0,-1,+0,+7,&!80 -!!$ &-1,+0,+0,-1,+7,& -!!$ &-1,+1,-4,+4,+3,& -!!$ &-1,+1,-3,+3,+3,& -!!$ &-1,+1,-2,+2,+3,& -!!$ &-1,+1,-1,+1,+4,& -!!$ &-1,+1,+0,+0,+5,& -!!$ &-1,+1,+1,-1,+4,& -!!$ &-1,+1,+2,-2,+3,& -!!$ &-1,+1,+3,-3,+3,& -!!$ &-1,+1,+4,-4,+3,&!90 -!!$ &-1,+2,-1,+2,+1,& -!!$ &-1,+2,+2,-1,+1,& -!!$ &-1,+3,-1,+3,+1,& -!!$ &-1,+3,+3,-1,+1,& -!!$ &-1,+4,-1,+4,+1,& -!!$ &-1,+4,+4,-1,+1,& -!!$ &+0,-4,-4,+0,+7,& -!!$ &+0,-4,+0,-4,+7,& -!!$ &+0,-3,-3,+0,+7,& -!!$ &+0,-3,+0,-3,+7,&!100 -!!$ &+0,-2,-2,+0,+7,& -!!$ &+0,-2,+0,-2,+7,& -!!$ &+0,-1,-1,+0,+7,& -!!$ &+0,-1,+0,-1,+7,& -!!$ &+0,+0,-4,+4,+6,& -!!$ &+0,+0,-3,+3,+6,& -!!$ &+0,+0,-2,+2,+6,& -!!$ &+0,+0,-1,+1,+6,& -!!$ &+0,+0,+0,+0,+8,& -!!$ &+0,+0,+1,-1,+6,&!110 -!!$ &+0,+0,+2,-2,+6,& -!!$ &+0,+0,+3,-3,+6,& -!!$ &+0,+0,+4,-4,+6,& -!!$ &+0,+1,+0,+1,+7,& -!!$ &+0,+1,+1,+0,+7,& -!!$ &+0,+2,+0,+2,+7,& -!!$ &+0,+2,+2,+0,+7,& -!!$ &+0,+3,+0,+3,+7,& -!!$ &+0,+3,+3,+0,+7,& -!!$ &+0,+4,+0,+4,+7,&!120 -!!$ &+0,+4,+4,+0,+7,& -!!$ &+1,-4,-4,+1,+1,& -!!$ &+1,-4,+1,-4,+1,& -!!$ &+1,-3,-3,+1,+1,& -!!$ &+1,-3,+1,-3,+1,& -!!$ &+1,-2,-2,+1,+1,& -!!$ &+1,-2,+1,-2,+1,& -!!$ &+1,-1,-4,+4,+3,& -!!$ &+1,-1,-3,+3,+3,& -!!$ &+1,-1,-2,+2,+3,&!130 -!!$ &+1,-1,-1,+1,+4,& -!!$ &+1,-1,+0,+0,+5,& -!!$ &+1,-1,+1,-1,+4,& -!!$ &+1,-1,+2,-2,+3,& -!!$ &+1,-1,+3,-3,+3,& -!!$ &+1,-1,+4,-4,+3,& -!!$ &+1,+0,+0,+1,+7,& -!!$ &+1,+0,+1,+0,+7,& -!!$ &+1,+1,+1,+1,+2,& -!!$ &+1,+2,+1,+2,+1,&!140 -!!$ &+1,+2,+2,+1,+1,& -!!$ &+1,+3,+1,+3,+1,& -!!$ &+1,+3,+3,+1,+1,& -!!$ &+1,+4,+1,+4,+1,& -!!$ &+1,+4,+4,+1,+1,& -!!$ &+2,-4,-4,+2,+1,& -!!$ &+2,-4,+2,-4,+1,& -!!$ &+2,-3,-3,+2,+1,& -!!$ &+2,-3,+2,-3,+1,& -!!$ &+2,-2,-4,+4,+3,&!150 -!!$ &+2,-2,-3,+3,+3,& -!!$ &+2,-2,-2,+2,+4,& -!!$ &+2,-2,-1,+1,+3,& -!!$ &+2,-2,+0,+0,+5,& -!!$ &+2,-2,+1,-1,+3,& -!!$ &+2,-2,+2,-2,+4,& -!!$ &+2,-2,+3,-3,+3,& -!!$ &+2,-2,+4,-4,+3,& -!!$ &+2,-1,-1,+2,+1,& -!!$ &+2,-1,+2,-1,+1,&!160 -!!$ &+2,+0,+0,+2,+7,& -!!$ &+2,+0,+2,+0,+7,& -!!$ &+2,+1,+1,+2,+1,& -!!$ &+2,+1,+2,+1,+1,& -!!$ &+2,+2,+2,+2,+2,& -!!$ &+2,+3,+2,+3,+1,& -!!$ &+2,+3,+3,+2,+1,& -!!$ &+2,+4,+2,+4,+1,& -!!$ &+2,+4,+4,+2,+1,& -!!$ &+3,-4,-4,+3,+1,&!170 -!!$ &+3,-4,+3,-4,+1,& -!!$ &+3,-3,-4,+4,+3,& -!!$ &+3,-3,-3,+3,+4,& -!!$ &+3,-3,-2,+2,+3,& -!!$ &+3,-3,-1,+1,+3,& -!!$ &+3,-3,+0,+0,+5,& -!!$ &+3,-3,+1,-1,+3,& -!!$ &+3,-3,+2,-2,+3,& -!!$ &+3,-3,+3,-3,+4,& -!!$ &+3,-3,+4,-4,+3,&!180 -!!$ &+3,-2,-2,+3,+1,& -!!$ &+3,-2,+3,-2,+1,& -!!$ &+3,-1,-1,+3,+1,& -!!$ &+3,-1,+3,-1,+1,& -!!$ &+3,+0,+0,+3,+7,& -!!$ &+3,+0,+3,+0,+7,& -!!$ &+3,+1,+1,+3,+1,& -!!$ &+3,+1,+3,+1,+1,& -!!$ &+3,+2,+2,+3,+1,& -!!$ &+3,+2,+3,+2,+1,&!190 -!!$ &+3,+3,+3,+3,+2,& -!!$ &+3,+4,+3,+4,+1,& -!!$ &+3,+4,+4,+3,+1,& -!!$ &+4,-4,-4,+4,+4,& -!!$ &+4,-4,-3,+3,+3,& -!!$ &+4,-4,-2,+2,+3,& -!!$ &+4,-4,-1,+1,+3,& -!!$ &+4,-4,+0,+0,+5,& -!!$ &+4,-4,+1,-1,+3,& -!!$ &+4,-4,+2,-2,+3,&!200 -!!$ &+4,-4,+3,-3,+3,& -!!$ &+4,-4,+4,-4,+4,& -!!$ &+4,-3,-3,+4,+1,& -!!$ &+4,-3,+4,-3,+1,& -!!$ &+4,-2,-2,+4,+1,& -!!$ &+4,-2,+4,-2,+1,& -!!$ &+4,-1,-1,+4,+1,& -!!$ &+4,-1,+4,-1,+1,& -!!$ &+4,+0,+0,+4,+7,& -!!$ &+4,+0,+4,+0,+7,&!210 -!!$ &+4,+1,+1,+4,+1,& -!!$ &+4,+1,+4,+1,+1,& -!!$ &+4,+2,+2,+4,+1,& -!!$ &+4,+2,+4,+2,+1,& -!!$ &+4,+3,+3,+4,+1,& -!!$ &+4,+3,+4,+3,+1,& -!!$ &+4,+4,+4,+4,+2],shape=[5,n_kinds]) - - !mathematical constants - real, parameter :: pi = 3.14159265 - - !physical constants - real(kind=double), parameter :: gev2_mbarn = 0.389379304D0 - real(kind=double), parameter :: gev_m_d = 0.002D0 - real(kind=double), parameter :: gev_m_u = 0.005D0 - real(kind=double), parameter :: gev_m_s = 0.095D0 - real(kind=double), parameter :: gev_m_c = 1.25D0 - real(kind=double), parameter :: gev_m_b = 4.2D0 - real(kind=double), parameter :: gev_m_t = 171D0 - real(kind=double), parameter :: gev2_m_t = gev_m_t**2 - real(kind=double), parameter :: gev_m_z = 91.1876D0 - real(kind=double), parameter :: gev2_m_z = gev_m_z**2 - real(kind=double), parameter :: alpha_s_mz = 0.1176D0 - real(kind=double), parameter :: gev_lambda_qcd = 0.25D0 - real(kind=double), parameter :: gev2_lambda_qcd = gev_lambda_qcd**2 - real(kind=double), parameter :: const_pref=pi*gev2_mbarn/(gev2_cme_tot*b_sigma_tot_nd) - - !filenames - -! character(len=*),parameter :: data_dir = "data/" -! character(len=*),parameter :: sigma_dir = data_dir//"sigma/" -! character(len=*),parameter :: dp_dir = data_dir//"sigma_dp/" -! character(len=*),parameter :: exp_dir = data_dir//"sigma_exp/" - - character(len=*),parameter :: fibonacci_tree_ext = ".fib.tree" - character(len=*),parameter :: lin_tree_ext = ".lin.tree" - character(len=*),parameter :: lin_list_ext = ".lin.list" - character(len=*),parameter :: aqa_ext = ".aqa" - character(len=*),parameter :: formatted_plot_ext = ".txt.plot" - character(len=*),parameter :: unformatted_plot_ext = ".bin.plot" - - integer,dimension(6,-234:234),parameter::valid_processes=reshape([& -& -6, -6, -6, -6, 2, 2,&!-234 -& -6, -5, -6, -5, 1, 1,&!-233 -& -6, -5, -5, -6, 1, 1,&!-232 -& -6, -4, -6, -4, 1, 1,&!-231 -& -6, -4, -4, -6, 1, 1,&!-230 -& -6, -3, -6, -3, 1, 1,&!-229 -& -6, -3, -3, -6, 1, 1,&!-228 -& -6, -2, -6, -2, 1, 1,&!-227 -& -6, -2, -2, -6, 1, 1,&!-226 -& -6, -1, -6, -1, 1, 1,&!-225 -& -6, -1, -1, -6, 1, 1,&!-224 -& -6, 0, -6, 0, 4, 7,&!-223 -& -6, 0, 0, -6, 4, 7,&!-222 -& -6, 1, -6, 1, 1, 1,&!-221 -& -6, 1, 1, -6, 1, 1,&!-220 -& -6, 2, -6, 2, 1, 1,&!-219 -& -6, 2, 2, -6, 1, 1,&!-218 -& -6, 3, -6, 3, 1, 1,&!-217 -& -6, 3, 3, -6, 1, 1,&!-216 -& -6, 4, -6, 4, 1, 1,&!-215 -& -6, 4, 4, -6, 1, 1,&!-214 -& -6, 5, -6, 5, 1, 1,&!-213 -& -6, 5, 5, -6, 1, 1,&!-212 -& -6, 6, -6, 6, 3, 4,&!-211 -& -6, 6, -5, 5, 3, 3,&!-210 -& -6, 6, -4, 4, 3, 3,&!-209 -& -6, 6, -3, 3, 3, 3,&!-208 -& -6, 6, -2, 2, 3, 3,&!-207 -& -6, 6, -1, 1, 3, 3,&!-206 -& -6, 6, 0, 0, 3, 5,&!-205 -& -6, 6, 1, -1, 3, 3,&!-204 -& -6, 6, 2, -2, 3, 3,&!-203 -& -6, 6, 3, -3, 3, 3,&!-202 -& -6, 6, 4, -4, 3, 3,&!-201 -& -6, 6, 5, -5, 3, 3,&!-200 -& -6, 6, 6, -6, 3, 4,&!-199 -& -5, -6, -6, -5, 1, 1,&!-198 -& -5, -6, -5, -6, 1, 1,&!-197 -& -5, -5, -5, -5, 2, 2,&!-196 -& -5, -4, -5, -4, 1, 1,&!-195 -& -5, -4, -4, -5, 1, 1,&!-194 -& -5, -3, -5, -3, 1, 1,&!-193 -& -5, -3, -3, -5, 1, 1,&!-192 -& -5, -2, -5, -2, 1, 1,&!-191 -& -5, -2, -2, -5, 1, 1,&!-190 -& -5, -1, -5, -1, 1, 1,&!-189 -& -5, -1, -1, -5, 1, 1,&!-188 -& -5, 0, -5, 0, 4, 7,&!-187 -& -5, 0, 0, -5, 4, 7,&!-186 -& -5, 1, -5, 1, 1, 1,&!-185 -& -5, 1, 1, -5, 1, 1,&!-184 -& -5, 2, -5, 2, 1, 1,&!-183 -& -5, 2, 2, -5, 1, 1,&!-182 -& -5, 3, -5, 3, 1, 1,&!-181 -& -5, 3, 3, -5, 1, 1,&!-180 -& -5, 4, -5, 4, 1, 1,&!-179 -& -5, 4, 4, -5, 1, 1,&!-178 -& -5, 5, -6, 6, 3, 3,&!-177 -& -5, 5, -5, 5, 3, 4,&!-176 -& -5, 5, -4, 4, 3, 3,&!-175 -& -5, 5, -3, 3, 3, 3,&!-174 -& -5, 5, -2, 2, 3, 3,&!-173 -& -5, 5, -1, 1, 3, 3,&!-172 -& -5, 5, 0, 0, 3, 5,&!-171 -& -5, 5, 1, -1, 3, 3,&!-170 -& -5, 5, 2, -2, 3, 3,&!-169 -& -5, 5, 3, -3, 3, 3,&!-168 -& -5, 5, 4, -4, 3, 3,&!-167 -& -5, 5, 5, -5, 3, 4,&!-166 -& -5, 5, 6, -6, 3, 3,&!-165 -& -5, 6, -5, 6, 1, 1,&!-164 -& -5, 6, 6, -5, 1, 1,&!-163 -& -4, -6, -6, -4, 1, 1,&!-162 -& -4, -6, -4, -6, 1, 1,&!-161 -& -4, -5, -5, -4, 1, 1,&!-160 -& -4, -5, -4, -5, 1, 1,&!-159 -& -4, -4, -4, -4, 2, 2,&!-158 -& -4, -3, -4, -3, 1, 1,&!-157 -& -4, -3, -3, -4, 1, 1,&!-156 -& -4, -2, -4, -2, 1, 1,&!-155 -& -4, -2, -2, -4, 1, 1,&!-154 -& -4, -1, -4, -1, 1, 1,&!-153 -& -4, -1, -1, -4, 1, 1,&!-152 -& -4, 0, -4, 0, 4, 7,&!-151 -& -4, 0, 0, -4, 4, 7,&!-150 -& -4, 1, -4, 1, 1, 1,&!-149 -& -4, 1, 1, -4, 1, 1,&!-148 -& -4, 2, -4, 2, 1, 1,&!-147 -& -4, 2, 2, -4, 1, 1,&!-146 -& -4, 3, -4, 3, 1, 1,&!-145 -& -4, 3, 3, -4, 1, 1,&!-144 -& -4, 4, -6, 6, 3, 3,&!-143 -& -4, 4, -5, 5, 3, 3,&!-142 -& -4, 4, -4, 4, 3, 4,&!-141 -& -4, 4, -3, 3, 3, 3,&!-140 -& -4, 4, -2, 2, 3, 3,&!-139 -& -4, 4, -1, 1, 3, 3,&!-138 -& -4, 4, 0, 0, 3, 5,&!-137 -& -4, 4, 1, -1, 3, 3,&!-136 -& -4, 4, 2, -2, 3, 3,&!-135 -& -4, 4, 3, -3, 3, 3,&!-134 -& -4, 4, 4, -4, 3, 4,&!-133 -& -4, 4, 5, -5, 3, 3,&!-132 -& -4, 4, 6, -6, 3, 3,&!-131 -& -4, 5, -4, 5, 1, 1,&!-130 -& -4, 5, 5, -4, 1, 1,&!-129 -& -4, 6, -4, 6, 1, 1,&!-128 -& -4, 6, 6, -4, 1, 1,&!-127 -& -3, -6, -6, -3, 1, 1,&!-126 -& -3, -6, -3, -6, 1, 1,&!-125 -& -3, -5, -5, -3, 1, 1,&!-124 -& -3, -5, -3, -5, 1, 1,&!-123 -& -3, -4, -4, -3, 1, 1,&!-122 -& -3, -4, -3, -4, 1, 1,&!-121 -& -3, -3, -3, -3, 2, 2,&!-120 -& -3, -2, -3, -2, 1, 1,&!-119 -& -3, -2, -2, -3, 1, 1,&!-118 -& -3, -1, -3, -1, 1, 1,&!-117 -& -3, -1, -1, -3, 1, 1,&!-116 -& -3, 0, -3, 0, 4, 7,&!-115 -& -3, 0, 0, -3, 4, 7,&!-114 -& -3, 1, -3, 1, 1, 1,&!-113 -& -3, 1, 1, -3, 1, 1,&!-112 -& -3, 2, -3, 2, 1, 1,&!-111 -& -3, 2, 2, -3, 1, 1,&!-110 -& -3, 3, -6, 6, 3, 3,&!-109 -& -3, 3, -5, 5, 3, 3,&!-108 -& -3, 3, -4, 4, 3, 3,&!-107 -& -3, 3, -3, 3, 3, 4,&!-106 -& -3, 3, -2, 2, 3, 3,&!-105 -& -3, 3, -1, 1, 3, 3,&!-104 -& -3, 3, 0, 0, 3, 5,&!-103 -& -3, 3, 1, -1, 3, 3,&!-102 -& -3, 3, 2, -2, 3, 3,&!-101 -& -3, 3, 3, -3, 3, 4,&!-100 -& -3, 3, 4, -4, 3, 3,&! -99 -& -3, 3, 5, -5, 3, 3,&! -98 -& -3, 3, 6, -6, 3, 3,&! -97 -& -3, 4, -3, 4, 1, 1,&! -96 -& -3, 4, 4, -3, 1, 1,&! -95 -& -3, 5, -3, 5, 1, 1,&! -94 -& -3, 5, 5, -3, 1, 1,&! -93 -& -3, 6, -3, 6, 1, 1,&! -92 -& -3, 6, 6, -3, 1, 1,&! -91 -& -2, -6, -6, -2, 1, 1,&! -90 -& -2, -6, -2, -6, 1, 1,&! -89 -& -2, -5, -5, -2, 1, 1,&! -88 -& -2, -5, -2, -5, 1, 1,&! -87 -& -2, -4, -4, -2, 1, 1,&! -86 -& -2, -4, -2, -4, 1, 1,&! -85 -& -2, -3, -3, -2, 1, 1,&! -84 -& -2, -3, -2, -3, 1, 1,&! -83 -& -2, -2, -2, -2, 2, 2,&! -82 -& -2, -1, -2, -1, 1, 1,&! -81 -& -2, -1, -1, -2, 1, 1,&! -80 -& -2, 0, -2, 0, 4, 7,&! -79 -& -2, 0, 0, -2, 4, 7,&! -78 -& -2, 1, -2, 1, 1, 1,&! -77 -& -2, 1, 1, -2, 1, 1,&! -76 -& -2, 2, -6, 6, 3, 3,&! -75 -& -2, 2, -5, 5, 3, 3,&! -74 -& -2, 2, -4, 4, 3, 3,&! -73 -& -2, 2, -3, 3, 3, 3,&! -72 -& -2, 2, -2, 2, 3, 4,&! -71 -& -2, 2, -1, 1, 3, 3,&! -70 -& -2, 2, 0, 0, 3, 5,&! -69 -& -2, 2, 1, -1, 3, 3,&! -68 -& -2, 2, 2, -2, 3, 4,&! -67 -& -2, 2, 3, -3, 3, 3,&! -66 -& -2, 2, 4, -4, 3, 3,&! -65 -& -2, 2, 5, -5, 3, 3,&! -64 -& -2, 2, 6, -6, 3, 3,&! -63 -& -2, 3, -2, 3, 1, 1,&! -62 -& -2, 3, 3, -2, 1, 1,&! -61 -& -2, 4, -2, 4, 1, 1,&! -60 -& -2, 4, 4, -2, 1, 1,&! -59 -& -2, 5, -2, 5, 1, 1,&! -58 -& -2, 5, 5, -2, 1, 1,&! -57 -& -2, 6, -2, 6, 1, 1,&! -56 -& -2, 6, 6, -2, 1, 1,&! -55 -& -1, -6, -6, -1, 1, 1,&! -54 -& -1, -6, -1, -6, 1, 1,&! -53 -& -1, -5, -5, -1, 1, 1,&! -52 -& -1, -5, -1, -5, 1, 1,&! -51 -& -1, -4, -4, -1, 1, 1,&! -50 -& -1, -4, -1, -4, 1, 1,&! -49 -& -1, -3, -3, -1, 1, 1,&! -48 -& -1, -3, -1, -3, 1, 1,&! -47 -& -1, -2, -2, -1, 1, 1,&! -46 -& -1, -2, -1, -2, 1, 1,&! -45 -& -1, -1, -1, -1, 2, 2,&! -44 -& -1, 0, -1, 0, 4, 7,&! -43 -& -1, 0, 0, -1, 4, 7,&! -42 -& -1, 1, -6, 6, 3, 3,&! -41 -& -1, 1, -5, 5, 3, 3,&! -40 -& -1, 1, -4, 4, 3, 3,&! -39 -& -1, 1, -3, 3, 3, 3,&! -38 -& -1, 1, -2, 2, 3, 3,&! -37 -& -1, 1, -1, 1, 3, 4,&! -36 -& -1, 1, 0, 0, 3, 5,&! -35 -& -1, 1, 1, -1, 3, 4,&! -34 -& -1, 1, 2, -2, 3, 3,&! -33 -& -1, 1, 3, -3, 3, 3,&! -32 -& -1, 1, 4, -4, 3, 3,&! -31 -& -1, 1, 5, -5, 3, 3,&! -30 -& -1, 1, 6, -6, 3, 3,&! -29 -& -1, 2, -1, 2, 1, 1,&! -28 -& -1, 2, 2, -1, 1, 1,&! -27 -& -1, 3, -1, 3, 1, 1,&! -26 -& -1, 3, 3, -1, 1, 1,&! -25 -& -1, 4, -1, 4, 1, 1,&! -24 -& -1, 4, 4, -1, 1, 1,&! -23 -& -1, 5, -1, 5, 1, 1,&! -22 -& -1, 5, 5, -1, 1, 1,&! -21 -& -1, 6, -1, 6, 1, 1,&! -20 -& -1, 6, 6, -1, 1, 1,&! -19 -& 0, -6, -6, 0, 4, 7,&! -18 -& 0, -6, 0, -6, 4, 7,&! -17 -& 0, -5, -5, 0, 4, 7,&! -16 -& 0, -5, 0, -5, 4, 7,&! -15 -& 0, -4, -4, 0, 4, 7,&! -14 -& 0, -4, 0, -4, 4, 7,&! -13 -& 0, -3, -3, 0, 4, 7,&! -12 -& 0, -3, 0, -3, 4, 7,&! -11 -& 0, -2, -2, 0, 4, 7,&! -10 -& 0, -2, 0, -2, 4, 7,&! -9 -& 0, -1, -1, 0, 4, 7,&! -8 -& 0, -1, 0, -1, 4, 7,&! -7 -& 0, 0, -6, 6, 5, 6,&! -6 -& 0, 0, -5, 5, 5, 6,&! -5 -& 0, 0, -4, 4, 5, 6,&! -4 -& 0, 0, -3, 3, 5, 6,&! -3 -& 0, 0, -2, 2, 5, 6,&! -2 -& 0, 0, -1, 1, 5, 6,&! -1 -& 0, 0, 0, 0, 5, 8,&! 0 -& 0, 0, 1, -1, 5, 6,&! 1 -& 0, 0, 2, -2, 5, 6,&! 2 -& 0, 0, 3, -3, 5, 6,&! 3 -& 0, 0, 4, -4, 5, 6,&! 4 -& 0, 0, 5, -5, 5, 6,&! 5 -& 0, 0, 6, -6, 5, 6,&! 6 -& 0, 1, 0, 1, 4, 7,&! 7 -& 0, 1, 1, 0, 4, 7,&! 8 -& 0, 2, 0, 2, 4, 7,&! 9 -& 0, 2, 2, 0, 4, 7,&! 10 -& 0, 3, 0, 3, 4, 7,&! 11 -& 0, 3, 3, 0, 4, 7,&! 12 -& 0, 4, 0, 4, 4, 7,&! 13 -& 0, 4, 4, 0, 4, 7,&! 14 -& 0, 5, 0, 5, 4, 7,&! 15 -& 0, 5, 5, 0, 4, 7,&! 16 -& 0, 6, 0, 6, 4, 7,&! 17 -& 0, 6, 6, 0, 4, 7,&! 18 -& 1, -6, -6, 1, 1, 1,&! 19 -& 1, -6, 1, -6, 1, 1,&! 20 -& 1, -5, -5, 1, 1, 1,&! 21 -& 1, -5, 1, -5, 1, 1,&! 22 -& 1, -4, -4, 1, 1, 1,&! 23 -& 1, -4, 1, -4, 1, 1,&! 24 -& 1, -3, -3, 1, 1, 1,&! 25 -& 1, -3, 1, -3, 1, 1,&! 26 -& 1, -2, -2, 1, 1, 1,&! 27 -& 1, -2, 1, -2, 1, 1,&! 28 -& 1, -1, -6, 6, 3, 3,&! 29 -& 1, -1, -5, 5, 3, 3,&! 30 -& 1, -1, -4, 4, 3, 3,&! 31 -& 1, -1, -3, 3, 3, 3,&! 32 -& 1, -1, -2, 2, 3, 3,&! 33 -& 1, -1, -1, 1, 3, 4,&! 34 -& 1, -1, 0, 0, 3, 5,&! 35 -& 1, -1, 1, -1, 3, 4,&! 36 -& 1, -1, 2, -2, 3, 3,&! 37 -& 1, -1, 3, -3, 3, 3,&! 38 -& 1, -1, 4, -4, 3, 3,&! 39 -& 1, -1, 5, -5, 3, 3,&! 40 -& 1, -1, 6, -6, 3, 3,&! 41 -& 1, 0, 0, 1, 4, 7,&! 42 -& 1, 0, 1, 0, 4, 7,&! 43 -& 1, 1, 1, 1, 2, 2,&! 44 -& 1, 2, 1, 2, 1, 1,&! 45 -& 1, 2, 2, 1, 1, 1,&! 46 -& 1, 3, 1, 3, 1, 1,&! 47 -& 1, 3, 3, 1, 1, 1,&! 48 -& 1, 4, 1, 4, 1, 1,&! 49 -& 1, 4, 4, 1, 1, 1,&! 50 -& 1, 5, 1, 5, 1, 1,&! 51 -& 1, 5, 5, 1, 1, 1,&! 52 -& 1, 6, 1, 6, 1, 1,&! 53 -& 1, 6, 6, 1, 1, 1,&! 54 -& 2, -6, -6, 2, 1, 1,&! 55 -& 2, -6, 2, -6, 1, 1,&! 56 -& 2, -5, -5, 2, 1, 1,&! 57 -& 2, -5, 2, -5, 1, 1,&! 58 -& 2, -4, -4, 2, 1, 1,&! 59 -& 2, -4, 2, -4, 1, 1,&! 60 -& 2, -3, -3, 2, 1, 1,&! 61 -& 2, -3, 2, -3, 1, 1,&! 62 -& 2, -2, -6, 6, 3, 3,&! 63 -& 2, -2, -5, 5, 3, 3,&! 64 -& 2, -2, -4, 4, 3, 3,&! 65 -& 2, -2, -3, 3, 3, 3,&! 66 -& 2, -2, -2, 2, 3, 4,&! 67 -& 2, -2, -1, 1, 3, 3,&! 68 -& 2, -2, 0, 0, 3, 5,&! 69 -& 2, -2, 1, -1, 3, 3,&! 70 -& 2, -2, 2, -2, 3, 4,&! 71 -& 2, -2, 3, -3, 3, 3,&! 72 -& 2, -2, 4, -4, 3, 3,&! 73 -& 2, -2, 5, -5, 3, 3,&! 74 -& 2, -2, 6, -6, 3, 3,&! 75 -& 2, -1, -1, 2, 1, 1,&! 76 -& 2, -1, 2, -1, 1, 1,&! 77 -& 2, 0, 0, 2, 4, 7,&! 78 -& 2, 0, 2, 0, 4, 7,&! 79 -& 2, 1, 1, 2, 1, 1,&! 80 -& 2, 1, 2, 1, 1, 1,&! 81 -& 2, 2, 2, 2, 2, 2,&! 82 -& 2, 3, 2, 3, 1, 1,&! 83 -& 2, 3, 3, 2, 1, 1,&! 84 -& 2, 4, 2, 4, 1, 1,&! 85 -& 2, 4, 4, 2, 1, 1,&! 86 -& 2, 5, 2, 5, 1, 1,&! 87 -& 2, 5, 5, 2, 1, 1,&! 88 -& 2, 6, 2, 6, 1, 1,&! 89 -& 2, 6, 6, 2, 1, 1,&! 90 -& 3, -6, -6, 3, 1, 1,&! 91 -& 3, -6, 3, -6, 1, 1,&! 92 -& 3, -5, -5, 3, 1, 1,&! 93 -& 3, -5, 3, -5, 1, 1,&! 94 -& 3, -4, -4, 3, 1, 1,&! 95 -& 3, -4, 3, -4, 1, 1,&! 96 -& 3, -3, -6, 6, 3, 3,&! 97 -& 3, -3, -5, 5, 3, 3,&! 98 -& 3, -3, -4, 4, 3, 3,&! 99 -& 3, -3, -3, 3, 3, 4,&! 100 -& 3, -3, -2, 2, 3, 3,&! 101 -& 3, -3, -1, 1, 3, 3,&! 102 -& 3, -3, 0, 0, 3, 5,&! 103 -& 3, -3, 1, -1, 3, 3,&! 104 -& 3, -3, 2, -2, 3, 3,&! 105 -& 3, -3, 3, -3, 3, 4,&! 106 -& 3, -3, 4, -4, 3, 3,&! 107 -& 3, -3, 5, -5, 3, 3,&! 108 -& 3, -3, 6, -6, 3, 3,&! 109 -& 3, -2, -2, 3, 1, 1,&! 110 -& 3, -2, 3, -2, 1, 1,&! 111 -& 3, -1, -1, 3, 1, 1,&! 112 -& 3, -1, 3, -1, 1, 1,&! 113 -& 3, 0, 0, 3, 4, 7,&! 114 -& 3, 0, 3, 0, 4, 7,&! 115 -& 3, 1, 1, 3, 1, 1,&! 116 -& 3, 1, 3, 1, 1, 1,&! 117 -& 3, 2, 2, 3, 1, 1,&! 118 -& 3, 2, 3, 2, 1, 1,&! 119 -& 3, 3, 3, 3, 2, 2,&! 120 -& 3, 4, 3, 4, 1, 1,&! 121 -& 3, 4, 4, 3, 1, 1,&! 122 -& 3, 5, 3, 5, 1, 1,&! 123 -& 3, 5, 5, 3, 1, 1,&! 124 -& 3, 6, 3, 6, 1, 1,&! 125 -& 3, 6, 6, 3, 1, 1,&! 126 -& 4, -6, -6, 4, 1, 1,&! 127 -& 4, -6, 4, -6, 1, 1,&! 128 -& 4, -5, -5, 4, 1, 1,&! 129 -& 4, -5, 4, -5, 1, 1,&! 130 -& 4, -4, -6, 6, 3, 3,&! 131 -& 4, -4, -5, 5, 3, 3,&! 132 -& 4, -4, -4, 4, 3, 4,&! 133 -& 4, -4, -3, 3, 3, 3,&! 134 -& 4, -4, -2, 2, 3, 3,&! 135 -& 4, -4, -1, 1, 3, 3,&! 136 -& 4, -4, 0, 0, 3, 5,&! 137 -& 4, -4, 1, -1, 3, 3,&! 138 -& 4, -4, 2, -2, 3, 3,&! 139 -& 4, -4, 3, -3, 3, 3,&! 140 -& 4, -4, 4, -4, 3, 4,&! 141 -& 4, -4, 5, -5, 3, 3,&! 142 -& 4, -4, 6, -6, 3, 3,&! 143 -& 4, -3, -3, 4, 1, 1,&! 144 -& 4, -3, 4, -3, 1, 1,&! 145 -& 4, -2, -2, 4, 1, 1,&! 146 -& 4, -2, 4, -2, 1, 1,&! 147 -& 4, -1, -1, 4, 1, 1,&! 148 -& 4, -1, 4, -1, 1, 1,&! 149 -& 4, 0, 0, 4, 4, 7,&! 150 -& 4, 0, 4, 0, 4, 7,&! 151 -& 4, 1, 1, 4, 1, 1,&! 152 -& 4, 1, 4, 1, 1, 1,&! 153 -& 4, 2, 2, 4, 1, 1,&! 154 -& 4, 2, 4, 2, 1, 1,&! 155 -& 4, 3, 3, 4, 1, 1,&! 156 -& 4, 3, 4, 3, 1, 1,&! 157 -& 4, 4, 4, 4, 2, 2,&! 158 -& 4, 5, 4, 5, 1, 1,&! 159 -& 4, 5, 5, 4, 1, 1,&! 160 -& 4, 6, 4, 6, 1, 1,&! 161 -& 4, 6, 6, 4, 1, 1,&! 162 -& 5, -6, -6, 5, 1, 1,&! 163 -& 5, -6, 5, -6, 1, 1,&! 164 -& 5, -5, -6, 6, 3, 3,&! 165 -& 5, -5, -5, 5, 3, 4,&! 166 -& 5, -5, -4, 4, 3, 3,&! 167 -& 5, -5, -3, 3, 3, 3,&! 168 -& 5, -5, -2, 2, 3, 3,&! 169 -& 5, -5, -1, 1, 3, 3,&! 170 -& 5, -5, 0, 0, 3, 5,&! 171 -& 5, -5, 1, -1, 3, 3,&! 172 -& 5, -5, 2, -2, 3, 3,&! 173 -& 5, -5, 3, -3, 3, 3,&! 174 -& 5, -5, 4, -4, 3, 3,&! 175 -& 5, -5, 5, -5, 3, 4,&! 176 -& 5, -5, 6, -6, 3, 3,&! 177 -& 5, -4, -4, 5, 1, 1,&! 178 -& 5, -4, 5, -4, 1, 1,&! 179 -& 5, -3, -3, 5, 1, 1,&! 180 -& 5, -3, 5, -3, 1, 1,&! 181 -& 5, -2, -2, 5, 1, 1,&! 182 -& 5, -2, 5, -2, 1, 1,&! 183 -& 5, -1, -1, 5, 1, 1,&! 184 -& 5, -1, 5, -1, 1, 1,&! 185 -& 5, 0, 0, 5, 4, 7,&! 186 -& 5, 0, 5, 0, 4, 7,&! 187 -& 5, 1, 1, 5, 1, 1,&! 188 -& 5, 1, 5, 1, 1, 1,&! 189 -& 5, 2, 2, 5, 1, 1,&! 190 -& 5, 2, 5, 2, 1, 1,&! 191 -& 5, 3, 3, 5, 1, 1,&! 192 -& 5, 3, 5, 3, 1, 1,&! 193 -& 5, 4, 4, 5, 1, 1,&! 194 -& 5, 4, 5, 4, 1, 1,&! 195 -& 5, 5, 5, 5, 2, 2,&! 196 -& 5, 6, 5, 6, 1, 1,&! 197 -& 5, 6, 6, 5, 1, 1,&! 198 -& 6, -6, -6, 6, 3, 4,&! 199 -& 6, -6, -5, 5, 3, 3,&! 200 -& 6, -6, -4, 4, 3, 3,&! 201 -& 6, -6, -3, 3, 3, 3,&! 202 -& 6, -6, -2, 2, 3, 3,&! 203 -& 6, -6, -1, 1, 3, 3,&! 204 -& 6, -6, 0, 0, 3, 5,&! 205 -& 6, -6, 1, -1, 3, 3,&! 206 -& 6, -6, 2, -2, 3, 3,&! 207 -& 6, -6, 3, -3, 3, 3,&! 208 -& 6, -6, 4, -4, 3, 3,&! 209 -& 6, -6, 5, -5, 3, 3,&! 210 -& 6, -6, 6, -6, 3, 4,&! 211 -& 6, -5, -5, 6, 1, 1,&! 212 -& 6, -5, 6, -5, 1, 1,&! 213 -& 6, -4, -4, 6, 1, 1,&! 214 -& 6, -4, 6, -4, 1, 1,&! 215 -& 6, -3, -3, 6, 1, 1,&! 216 -& 6, -3, 6, -3, 1, 1,&! 217 -& 6, -2, -2, 6, 1, 1,&! 218 -& 6, -2, 6, -2, 1, 1,&! 219 -& 6, -1, -1, 6, 1, 1,&! 220 -& 6, -1, 6, -1, 1, 1,&! 221 -& 6, 0, 0, 6, 4, 7,&! 222 -& 6, 0, 6, 0, 4, 7,&! 223 -& 6, 1, 1, 6, 1, 1,&! 224 -& 6, 1, 6, 1, 1, 1,&! 225 -& 6, 2, 2, 6, 1, 1,&! 226 -& 6, 2, 6, 2, 1, 1,&! 227 -& 6, 3, 3, 6, 1, 1,&! 228 -& 6, 3, 6, 3, 1, 1,&! 229 -& 6, 4, 4, 6, 1, 1,&! 230 -& 6, 4, 6, 4, 1, 1,&! 231 -& 6, 5, 5, 6, 1, 1,&! 232 -& 6, 5, 6, 5, 1, 1,&! 233 -& 6, 6, 6, 6, 2, 2&! 234 -],[6,469]) - - integer,dimension(2,0:16),parameter::double_pdf_kinds=reshape([& - &0,0,& - &1,1,& - &1,2,& - &1,3,& - &1,4,& - &2,1,& - &2,2,& - &2,3,& - &2,4,& - &3,1,& - &3,2,& - &3,3,& - &3,4,& - &4,1,& - &4,2,& - &4,3,& - &4,4& - &],[2,17]) - - integer,parameter,dimension(13)::int_1_ids=& - &[-6, -5, -4, -3, -2, -1, 0, 1, 2, 3, 4, 5, 6] - integer,parameter,dimension(16)::int_2_ids=& - &[-14, -13, -12, -11, -10, -9, -8, -7, 7, 8, 9, 10, 11, 12, 13, 14] - integer,parameter,dimension(2)::int_3_ids=& - &[7, 8] - integer,parameter,dimension(2)::int_4_ids=& - &[9, 10] - integer,parameter,dimension(16)::int_5_ids=& - &[-151, -150, -115, -114, -79, -78, -43, -42, 42, 43, 78, 79, 114, 115, 150, 151] - integer,parameter,dimension(26*8)::int_6_ids=& - &[-158, -157, -156, -155, -154, -153, -152, -149, -148, -147, -146, -145, -144, -143, -142, -141, -140, -139, -138, -137, -136, -135, -134, -133, -132, -131,& - &-122, -121, -120, -119, -118, -117, -116, -113, -112, -111, -110, -109, -108, -107, -106, -105, -104, -103, -102, -101, -100, -99, -98, -97, -96, -95,& - &-86, -85, -84, -83, -82, -81, -80, -77, -76, -75, -74, -73, -72, -71, -70, -69, -68, -67, -66, -65, -64, -63, -62, -61, -60, -59,& - &-50, -49, -48, -47, -46, -45, -44, -41, -40, -39, -38, -37, -36, -35, -34, -33, -32, -31, -30, -29, -28, -27, -26, -25, -24, -23,& - &23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 44, 45, 46, 47, 48, 49, 50,& - &59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 80, 81, 82, 83, 84, 85, 86,& - &95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 116, 117, 118, 119, 120, 121, 122,& - &131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 152, 153, 154, 155, 156, 157, 158] - integer,parameter,dimension(26)::int_7_ids=& - &[-149, -148, -113, -112, -77, -76, -41, -40, -39, -38, -37, -36, -35, -34, -33, -32, -31, -30, -29, 44, 80, 81, 116, 117, 152, 153] - integer,parameter,dimension(26)::int_8_ids=& - &[-147, -146, -111, -110, -75, -74, -73, -72, -71, -70, -69, -68, -67, -66, -65, -64, -63, -28, -27, 45, 46, 82, 118, 119, 154, 155] - integer,parameter,dimension(2)::int_9_ids=& - &[42, 43] - integer,parameter,dimension(26)::int_10_ids=& - &[23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 44, 45, 46, 47, 48, 49, 50] - integer,parameter,dimension(1)::int_11_ids=& - &[44] - integer,parameter,dimension(2)::int_12_ids=& - &[45, 46] - integer,parameter,dimension(2)::int_13_ids=& - &[78, 79] - integer,parameter,dimension(26)::int_14_ids=& - &[59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 80, 81, 82, 83, 84, 85, 86] - integer,parameter,dimension(2)::int_15_ids=& - &[80, 81] - integer,parameter,dimension(1)::int_16_ids=& - &[82] - integer,parameter,dimension(371)::int_all=[& - & -6, -5, -4, -3, -2, -1, 0, 1, 2, 3, 4, 5, 6, -14, -13, -12, -11, -10,& - & -9, -8, -7, 7, 8, 9, 10, 11, 12, 13, 14, 7, 8, 9, 10, -151, -150, -115,& - &-114, -79, -78, -43, -42, 42, 43, 78, 79, 114, 115, 150, 151, -158, -157, -156, -155, -154,& - &-153, -152, -149, -148, -147, -146, -145, -144, -143, -142, -141, -140, -139, -138, -137, -136, -135, -134,& - &-133, -132, -131, -122, -121, -120, -119, -118, -117, -116, -113, -112, -111, -110, -109, -108, -107, -106,& - &-105, -104, -103, -102, -101, -100, -99, -98, -97, -96, -95, -86, -85, -84, -83, -82, -81, -80,& - & -77, -76, -75, -74, -73, -72, -71, -70, -69, -68, -67, -66, -65, -64, -63, -62, -61, -60,& - & -59, -50, -49, -48, -47, -46, -45, -44, -41, -40, -39, -38, -37, -36, -35, -34, -33, -32,& - & -31, -30, -29, -28, -27, -26, -25, -24, -23, 23, 24, 25, 26, 27, 28, 29, 30, 31,& - & 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 44, 45, 46, 47, 48, 49, 50, 59,& - & 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77,& - & 80, 81, 82, 83, 84, 85, 86, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105,& - & 106, 107, 108, 109, 110, 111, 112, 113, 116, 117, 118, 119, 120, 121, 122, 131, 132, 133,& - & 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 152, 153,& - & 154, 155, 156, 157, 158, -149, -148, -113, -112, -77, -76, -41, -40, -39, -38, -37, -36, -35,& - & -34, -33, -32, -31, -30, -29, 44, 80, 81, 116, 117, 152, 153, -147, -146, -111, -110, -75,& - & -74, -73, -72, -71, -70, -69, -68, -67, -66, -65, -64, -63, -28, -27, 45, 46, 82, 118,& - & 119, 154, 155, 42, 43, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35,& - & 36, 37, 38, 39, 40, 41, 44, 45, 46, 47, 48, 49, 50, 44, 45, 46, 78, 79,& - & 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76,& - & 77, 80, 81, 82, 83, 84, 85, 86, 80, 81, 82] - integer,parameter,dimension(16)::int_sizes_all=[13,16,2,2,16,208,26,26,2,26,1,2,2,26,2,1] -end module parameters_module - Index: branches/attic/boschmann_standalone/pri/lib/cplots.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/cplots.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/cplots.f03.pri (revision 8609) @@ -1,268 +0,0 @@ -!!! module: cplots_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-09 13:53:48 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module cplots_module - - use kinds -! use momentum_module - use arguments_module - use common_module - use coordinates_module - use cuba_types_module - use sample_fractions_module - - implicit none - - contains - - subroutine test_int(unit,pts2,trafo,trafo_i,voxel,voxel_i) - integer,intent(in)::unit - real(kind=double),intent(in)::pts2 - procedure(trafo_in)::trafo,trafo_i - procedure(coord_scalar_in)::voxel,voxel_i - integer::i,j - real(kind=double),dimension(3)::arg - arg(3)=pts2 - do i=0,100 - arg(1)=i/1D2 - do j=0,100 - arg(2)=j/1D2 - write(unit,fmt=*)arg,intv(trafo,voxel,voxel_i,arg),intv(trafo_i,voxel_i,voxel,arg) - end do - write(unit,fmt=*)" " - end do - end subroutine test_int - - function intv(trafo1,voxel1,voxel2,arg) - procedure(trafo_in)::trafo1 - procedure(coord_scalar_in)::voxel1,voxel2 - real(kind=double),dimension(3),intent(in)::arg - real(kind=double),dimension(3)::p1,p2,p3 - real(kind=double),dimension(2)::intv - real(kind=double),parameter::eps=1d-8 - real(kind=double),parameter::bor=1d-1+eps - real(kind=double)::v,a,v1,v2,v3,r1,r2 - v1=voxel1(arg+[0D0,eps,0D0]) - v2=voxel1(arg+[-eps,-eps,0D0]) - v3=voxel1(arg+[eps,-eps,0D0]) - if(v1>0D0.and.v2>0D0.and.v3>0D0)then - v=(v1+v2+v3)/3D0 - p1=trafo1(arg+[0D0,eps,0D0]) - p2=trafo1(arg+[-eps,-eps,0D0])-p1 - p3=trafo1(arg+[eps,-eps,0D0])-p1 - a=abs(p2(1)*p3(2)-p2(2)*p3(1))/2D0 - r1=(v*2D0*eps**2)/a - v1=voxel2(p1) - v2=voxel2(p2) - v3=voxel2(p3) - v=(v1+v2+v3)/3D0 - r2=2D0*eps**2/(a*v) - intv=[r1,r2] - else - intv=[1D0,1D0] - end if - end function intv - - subroutine cplot_voxel(unit,voxel,pts2) - integer,intent(in)::unit - procedure(coord_scalar_in)::voxel - real(kind=double),intent(in)::pts2 - integer::i,j - real(kind=double),dimension(3)::arg - arg(3)=pts2 - do i=0,100 - arg(1)=i/1D2 - do j=0,100 - arg(2)=j/1D2 - write(unit,fmt=*)arg(1:2),voxel(arg) - end do - write(unit,fmt=*)" " - end do - end subroutine cplot_voxel - - subroutine plot_cuba_2(dim,unit,cuba,range1,range2,pt) - integer,intent(in)::dim,unit - real(kind=double),dimension(2),intent(in)::range1,range2 - type(transversal_momentum_type),intent(in)::pt - procedure(integrand_interface)::cuba - integer::i,j - real(kind=double),dimension(2)::arg - real(kind=double),dimension(:),allocatable::res - allocate(res(dim)) - do i=1,100 - arg(1)=(i/1D2)*(range1(2)-range1(1))+range1(1) - do j=1,100 - arg(2)=(j/1D2)*(range2(2)-range2(1))+range2(1) - call cuba(2,arg,dim,res,pt) -! print *,unit - write(unit,fmt=*)arg,res - end do - write(unit,fmt=*)" " - end do - end subroutine plot_cuba_2 - - subroutine plot_id(unit,trafo,inverse,pts2) - integer,intent(in)::unit - procedure(trafo_in)::trafo,inverse - real(kind=double),dimension(3)::arg,im,preim,resTI,resIT - integer::i,j - real(kind=double),intent(in)::pts2 - arg(3)=pts2 - do i=0,100 - do j=0,100 - arg(1:2)=[i/1D2,j/1D2] - im=trafo(arg) - preim=inverse(arg) - if(preim(1)>=0D0.and.preim(2)>=0D0)then - resTI=arg-trafo(preim) - else - resTI=[0D0,0D0,pts2] - end if - if(im(1)>=0D0.and.im(2)>=0D0)then - resIT=arg-inverse(im) - else - resIT=[0D0,0D0,pts2] - end if - write(unit,fmt=*)arg,resTI,resIT - end do - write(unit,fmt=*)" " - end do - end subroutine plot_id - - subroutine cplot_coords(unit,trafo,pts2) - real(kind=double),intent(in)::pts2 - integer,intent(in)::unit - procedure(trafo_in)::trafo - integer::i,j - real(kind=double),dimension(3)::arg,res - arg(3)=pts2 - do i=0,10000 - arg(1)=i/1D4 - do j=0,10 - arg(2)=j/1D1 - res=trafo(arg) - write(unit,fmt='(2(F14.7))',ADVANCE="no")res(1:2) - end do - arg(2)=i/1D4 - do j=0,10 - arg(1)=j/1D1 - res=trafo(arg) - write(unit,fmt='(2(F14.7))',ADVANCE="no")res(1:2) - end do - write(unit,fmt=*)"" - flush(unit) - end do - end subroutine cplot_coords - - subroutine find_cut(trafo,pts2) - procedure(trafo_in)::trafo - real(kind=double),intent(in)::pts2 - real(kind=double),dimension(3)::arg,res,old_res - integer::i - arg=[0D0,0D0,pts2] - res=trafo(arg) - do i=1,1000 - arg=[0D0,i/1001D0,pts2] - old_res=res - res=trafo(arg) -! print *,arg,res - if(old_res(1)*res(1)<=0.or.old_res(2)*res(2)<=0.or.(old_res(1)-1D0)*(res(1)-1D0)<=0.or.(old_res(2)-1D0)*(res(2)-1D0)<=0)then - print *,arg,res - exit - end if - end do - arg=[1D0,0D0,pts2] - res=trafo(arg) - do i=1,1000 - arg=[1D0,i/1001D0,pts2] - old_res=res - res=trafo(arg) - if(old_res(1)*res(1)<=0.or.old_res(2)*res(2)<=0.or.(old_res(1)-1D0)*(res(1)-1D0)<=0.or.(old_res(2)-1D0)*(res(2)-1D0)<=0)then - print *,arg,res - exit - end if - end do - arg=[0D0,1D0,pts2] - res=trafo(arg) - do i=1,1000 - arg=[i/1001D0,1D0,pts2] - old_res=res - res=trafo(arg) - if(old_res(1)*res(1)<=0.or.old_res(2)*res(2)<=0.or.(old_res(1)-1D0)*(res(1)-1D0)<=0.or.(old_res(2)-1D0)*(res(2)-1D0)<=0)then - print *,arg,res - exit - end if - end do - arg=[0D0,0D0,pts2] - res=trafo(arg) - do i=1,1000 - arg=[i/1001D0,0D0,pts2] - old_res=res - res=trafo(arg) - if(old_res(1)*res(1)<=0.or.old_res(2)*res(2)<=0.or.(old_res(1)-1D0)*(res(1)-1D0)<=0.or.(old_res(2)-1D0)*(res(2)-1D0)<=0)then - print *,arg,res - exit - end if - end do - end subroutine find_cut - - subroutine plot_denom(unit,pts2,denom) - integer,intent(in)::unit - real(kind=double),intent(in)::pts2 - procedure(coord_scalar_in)::denom - integer::i,j - real(kind=double),dimension(3)::arg - arg(3)=pts2 - do i=0,100 - arg(1)=i/1D2 - do j=0,100 - arg(2)=j/1D2 - write(unit,fmt=*)arg,denom(arg) - end do - write(unit,fmt=*)" " - end do - end subroutine plot_denom - -!!$ subroutine splot_dddsigma_with_params(unit,swap,sample,pts2) -!!$ integer,intent(in)::unit,swap -!!$ class(sample_type),intent(in)::sample -!!$ real(kind=double),intent(in)::pts2 -!!$ real(kind=double),dimension(3)::hyp,cart -!!$ real(kind=double),dimension(:),allocatable::result -!!$ integer::i,j,process_id,subprocess,in_in_kind -!!$ allocate(result(sample%n_subprocesses)) -!!$ in_in_kind=swap*sample%get_id() -!!$ hyp(3)=pts2 -!!$ do i=0,100 -!!$ hyp(1)=i*1D-2 -!!$ do j=0,100 -!!$ hyp(2)=j*1D-2 -!!$ do subprocess=1,sample%n_subprocesses -!!$ process_id=sample%subprocesses_data(1,subprocess) -!!$ call coordinates_dddsigma(process_id,in_in_kind,hyp,cart,result(subprocess)) -!!$ end do -!!$ write(unit,fmt=*)hyp,cart(1:2),result -!!$ end do -!!$ end do -!!$ end subroutine splot_dddsigma_with_params - -end module cplots_module Index: branches/attic/boschmann_standalone/pri/lib/remnant.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/remnant.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/remnant.f03.pri (revision 8609) @@ -1,744 +0,0 @@ -!!! module: remnant_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-17 10:45:38 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! this module is not complete. some missing features dont't provide a warning! - -module remnant_module - use,intrinsic::iso_fortran_env -! use arguments_module - use arguments_module - use kinds - use tao_random_numbers - use basic_types_module - use remnant_interface_module - use parameters_module - use error_stack_module - use common_module - use coordinates_module - implicit none - logical,public::error_flag=.false. - integer,public::remnant_weight_model=1 - integer::gluon_exp=4 - - type companion_quark_type - private - integer::lha_flavour - logical::active - real(kind=double)::twin_momentum=-1D0 - real(kind=double)::norm=-1D0 - class(companion_quark_type),pointer::next=>null() - contains - procedure::unweighted_pdf=>companion_quark_unweighted_pdf - procedure::deallocate=>companion_quark_deallocate - end type companion_quark_type - - type,extends(proton_remnant_class)::proton_remnant_type - contains - ! manipulating parton content - procedure::remove_valence_quark=>proton_remnant_remove_valence_quark - procedure::remove_sea_quark=>proton_remnant_remove_sea_quark - procedure::remove_gluon=>proton_remnant_remove_gluon - procedure::remove_valence_up_quark=>proton_remnant_remove_valence_up_quark - procedure::remove_valence_down_quark=>proton_remnant_remove_valence_down_quark - ! getting pdf - procedure::momentum_kind_pdf=>proton_remnant_momentum_kind_pdf - procedure::momentum_flavor_pdf=>proton_remnant_momentum_flavor_pdf - procedure::momentum_kind_pdf_array=>proton_remnant_momentum_kind_pdf_array - procedure::momentum_flavor_pdf_array=>proton_remnant_momentum_flavor_pdf_array - procedure::parton_kind_pdf=>proton_remnant_parton_kind_pdf - procedure::parton_flavor_pdf=>proton_remnant_parton_flavor_pdf - procedure::parton_kind_pdf_array=>proton_remnant_parton_kind_pdf_array - procedure::parton_flavor_pdf_array=>proton_remnant_parton_flavor_pdf_array - ! getting components - procedure::get_kind_weight=>proton_remnant_get_kind_weight - procedure::get_pdf_int_weight=>proton_remnant_get_pdf_int_weight - procedure::get_valence_weight=>proton_remnant_get_valence_weight - procedure::get_sea_weight=>proton_remnant_get_sea_weight - procedure::get_valence_content=>proton_remnant_get_valence_content - procedure::get_momentum_fraction=>proton_remnant_get_momentum_fraction - ! misc - procedure::finalize=>proton_remnant_deallocate - procedure::reset=>proton_remnant_reset - ! private - procedure,private::calculate_weight=>proton_remnant_calculate_weight - ! overridden serializable_class procedures - procedure::write_to_ring=>proton_remnant_write_to_ring - procedure::read_from_ring=>proton_remnant_read_from_ring - procedure::print_to_unit=>proton_remnant_print_to_unit - procedure,nopass::get_type=>proton_remnant_get_type - end type proton_remnant_type - - type,extends(proton_remnant_type)::proton_remnant_companion_type - private - integer::number_of_active_companions=0 - integer::number_of_inactive_companions=0 - real(kind=double)::companion_norm=0D0 - class(companion_quark_type),pointer::active_companions=>null() - class(companion_quark_type),pointer::removed_companions=>null() - contains - procedure::remove_companion=>proton_remnant_companion_remove_companion - procedure::get_companion_weight=>proton_remnant_companion_get_companion_weight - procedure::get_companion_parton_pdf_array=>proton_remnant_companion_get_companion_parton_pdf_array - procedure::momentum_companion_pdf_array=>proton_remnant_companion_get_companion_momentum_pdf_array - procedure::parton_companion_pdf_array=>proton_remnant_companion_get_companion_parton_pdf_array - procedure::get_number_of_active_companions=>proton_remnant_companion_get_number_of_active_companions - procedure::finalize=>proton_remnant_companion_deallocate - procedure,private::add_companion=>proton_remnant_companion_add_companion - procedure,private::calculate_companion_norm=>proton_remnant_companion_calculate_companion_norm - procedure,private::calculate_weight=>proton_remnant_companion_calculate_weight - end type proton_remnant_companion_type - -contains - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! type bound procedures for companion_quark_type !!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - pure function companion_quark_unweighted_pdf(this,momentum_fraction) result(pdf) - class(companion_quark_type),intent(in)::this - real(kind=double),intent(in)::momentum_fraction - real(kind=double)::pdf - if(momentum_fraction+this%twin_momentum<1D0)then - pdf=remnant_companion_pdf_p(momentum_fraction,this%twin_momentum,gluon_exp) - else - pdf=0D0 - end if - end function companion_quark_unweighted_pdf - - recursive subroutine companion_quark_deallocate(this) - class(companion_quark_type)::this - if(associated(this%next))call this%next%deallocate - end subroutine companion_quark_deallocate - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! type bound procedures for proton_remnant_type !!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! manipulating parton content - - subroutine proton_remnant_remove_valence_quark(this,GeV_scale,momentum_fraction,lha_flavor) - class(proton_remnant_type),intent(inout)::this - real(kind=double),intent(in)::GeV_scale,momentum_fraction - integer,intent(in)::lha_flavor !d=1 u=2 - integer::q!FC = gfortran - if(lha_flavor==1.or.lha_flavor==2)then - associate(q=>this%valence_content(lha_flavor))!FC = nagfor - q=this%valence_content(lha_flavor)!FC = nagfor - if(q>0)then - q=q-1 - else - print('("proton_remnant_remove_valence_quark: Cannot remove parton ",I2,": There are no such partons left.")'),lha_flavor - call this%print_all() - end if - end associate!FC = nagfor - else - print('("proton_remnant_remove_valence_quark: Cannot remove parton ",I2,": There are no such valence partons.")'),lha_flavor - end if - this%momentum_fraction=this%momentum_fraction*(1D0-momentum_fraction) - call this%calculate_weight(GeV_scale) - end subroutine proton_remnant_remove_valence_quark - - subroutine proton_remnant_remove_valence_up_quark(this,GeV_scale,momentum_fraction) - class(proton_remnant_type),intent(inout)::this - real(kind=double),intent(in)::GeV_scale,momentum_fraction - integer::q!FC = gfortran - q=this%valence_content(lha_flavor_u)!FC = gfortran - associate(q=>this%valence_content(lha_flavor_u))!FC = nagfor - if(q>0)then - q=q-1 - else - print('("proton_remnant_remove_valence_up_quark: Cannot remove parton ",I2,": There are no such partons left.")'),lha_flavor_u - call this%print_all - error_flag=.true. - end if - end associate!FC = nagfor - this%momentum_fraction=this%momentum_fraction*(1D0-momentum_fraction) - call this%calculate_weight(GeV_scale) - end subroutine proton_remnant_remove_valence_up_quark - - subroutine proton_remnant_remove_valence_down_quark(this,GeV_scale,momentum_fraction) - class(proton_remnant_type),intent(inout)::this - real(kind=double),intent(in)::GeV_scale,momentum_fraction - integer::q!FC = gfortran - associate(q=>this%valence_content(lha_flavor_d))!FC = nagfor - q=this%valence_content(lha_flavor_d)!FC = gfortran - if(q>0)then - q=q-1 - else - print('("proton_remnant_remove_valence_down_quark: Cannot remove& - & parton ",I2,": There are no such partons left.")')& - &,lha_flavor_d - call this%print_all - error_flag=.true. - end if - end associate!FC = nagfor - this%momentum_fraction=this%momentum_fraction*(1D0-momentum_fraction) - call this%calculate_weight(GeV_scale) - end subroutine proton_remnant_remove_valence_down_quark - - subroutine proton_remnant_remove_sea_quark(this,GeV_scale,momentum_fraction& - &,lha_flavor) - class(proton_remnant_type),intent(inout)::this - real(kind=double),intent(in)::GeV_scale,momentum_fraction - integer,intent(in)::lha_flavor - if(lha_flavor>-6.and.lha_flavor<6.and.(lha_flavor.ne.0))then - this%momentum_fraction=this%momentum_fraction*(1D0-momentum_fraction) -! call this%add_companion(GeV_scale,-lha_flavor,momentum_fraction) - else - call default_error_stack%push(lha_flavor& - &,"proton_remnant_remove_sea_quark: invalid sea quark",this) - end if - end subroutine proton_remnant_remove_sea_quark - - subroutine proton_remnant_remove_gluon(this,GeV_scale,momentum_fraction) - class(proton_remnant_type),intent(inout)::this - real(kind=double),intent(in)::GeV_scale,momentum_fraction - this%momentum_fraction=this%momentum_fraction*(1D0-momentum_fraction) -! print('("proton_remnant_remove_gluon: Not yet implemented")') - end subroutine proton_remnant_remove_gluon - - ! getting pdf - - subroutine proton_remnant_momentum_kind_pdf(this,GeV_scale,momentum& - &,lha_flavor,valence_pdf,sea_pdf) - class(proton_remnant_type),intent(in)::this - real(kind=double),intent(in)::GeV_scale,momentum - integer,intent(in)::lha_flavor !g,u,d,etc. - real(kind=double),intent(out)::valence_pdf,sea_pdf - real(kind=double),dimension(-6:6)::pdf_array - call evolvePDF(momentum,GeV_scale,pdf_array) - select case (lha_flavor) - case(0) !gluon - valence_pdf=0D0 - sea_pdf=pdf_array(0) - case(1) !down - valence_pdf=this%valence_content(1)*(pdf_array(1)-pdf_array(-1)) - sea_pdf=pdf_array(-1) - case(2) !up - valence_pdf=this%valence_content(2)*(pdf_array(2)-pdf_array(-2))/2D0 - sea_pdf=pdf_array(-2) - case default - valence_pdf=0D0 - sea_pdf=pdf_array(lha_flavor) - end select - valence_pdf=valence_pdf*this%get_valence_weight() - sea_pdf=sea_pdf*this%get_sea_weight() - end subroutine proton_remnant_momentum_kind_pdf - - subroutine proton_remnant_momentum_flavor_pdf(this,GeV_scale,momentum& - &,lha_flavor,pdf) - class(proton_remnant_type),intent(in)::this - real(kind=double),intent(in)::GeV_scale,momentum - integer,intent(in)::lha_flavor !g,u,d,etc. - real(kind=double),intent(out)::pdf - real(kind=double)::valence_pdf,sea_pdf - call proton_remnant_momentum_kind_pdf(this,GeV_scale,momentum,lha_flavor& - &,valence_pdf,sea_pdf) - pdf=valence_pdf+sea_pdf - end subroutine proton_remnant_momentum_flavor_pdf - - subroutine PROTON_REMNANT_MOMENTUM_FLAVOR_PDF_ARRAY(this,GeV_scale,momentum& - &,pdf) - class(proton_remnant_type),intent(in)::this - real(kind=double),intent(in)::GeV_scale,momentum - real(kind=double),dimension(-6:6),intent(out)::pdf - real(kind=double),dimension(2)::valence_pdf - call this%momentum_kind_pdf_array(GeV_scale,momentum,valence_pdf,pdf) - pdf(1:2)=pdf(1:2)+valence_pdf - end subroutine PROTON_REMNANT_MOMENTUM_FLAVOR_PDF_ARRAY - - subroutine proton_remnant_momentum_kind_pdf_array(this,GeV_scale,momentum& - &,valence_pdf,sea_pdf) - class(proton_remnant_type),intent(in)::this - real(kind=double),intent(in)::GeV_scale,momentum - real(kind=double),dimension(2),intent(out)::valence_pdf - real(kind=double),dimension(-6:6),intent(out)::sea_pdf - call evolvePDF(momentum,GeV_scale,sea_pdf) - valence_pdf(1)=(sea_pdf(1)-sea_pdf(-1))*this%valence_content(1) - valence_pdf(2)=(sea_pdf(2)-sea_pdf(-2))*(this%valence_content(2)/2D0) - sea_pdf(1)=sea_pdf(-1) - sea_pdf(2)=sea_pdf(-2) - valence_pdf=valence_pdf*this%get_valence_weight() - sea_pdf=sea_pdf*this%get_sea_weight() - end subroutine PROTON_REMNANT_MOMENTUM_KIND_PDF_ARRAY - - subroutine proton_remnant_parton_kind_pdf(this,GeV_scale,momentum& - &,lha_flavor,valence_pdf,sea_pdf) - class(proton_remnant_type),intent(in)::this - real(kind=double),intent(in)::GeV_scale,momentum - integer,intent(in)::lha_flavor !g,u,d,etc. - real(kind=double),intent(out)::valence_pdf,sea_pdf - call this%momentum_kind_pdf(GeV_scale,momentum,lha_flavor,valence_pdf& - &,sea_pdf) - valence_pdf=valence_pdf/momentum - sea_pdf=sea_pdf/momentum - end subroutine proton_remnant_parton_kind_pdf - - subroutine proton_remnant_parton_flavor_pdf(this,GeV_scale,momentum& - &,lha_flavor,pdf) - class(proton_remnant_type),intent(in)::this - real(kind=double),intent(in)::GeV_scale,momentum - integer,intent(in)::lha_flavor !g,u,d,etc. - real(kind=double),intent(out)::pdf - call this%momentum_flavor_pdf(GeV_scale,momentum,lha_flavor,pdf) - pdf=pdf/momentum - end subroutine proton_remnant_parton_flavor_pdf - - subroutine proton_remnant_parton_kind_pdf_array(this,GeV_scale,momentum& - &,valence_pdf,sea_pdf) - class(proton_remnant_type),intent(in)::this - real(kind=double),intent(in)::GeV_scale,momentum - real(kind=double),dimension(2),intent(out)::valence_pdf - real(kind=double),dimension(-6:6),intent(out)::sea_pdf - call evolvePDF(momentum,GeV_scale,sea_pdf) - sea_pdf=sea_pdf/momentum - valence_pdf(1)=(sea_pdf(1)-sea_pdf(-1))*this%valence_content(1) - valence_pdf(2)=(sea_pdf(2)-sea_pdf(-2))*(this%valence_content(2)/2D0) - sea_pdf(1)=sea_pdf(-1) - sea_pdf(2)=sea_pdf(-2) - valence_pdf=valence_pdf*this%get_valence_weight() - sea_pdf=sea_pdf*this%get_sea_weight() - end subroutine proton_remnant_parton_kind_pdf_array - - subroutine proton_remnant_parton_flavor_pdf_array(this,GeV_scale,momentum& - &,pdf) - class(proton_remnant_type),intent(in)::this - real(kind=double),intent(in)::GeV_scale,momentum - real(kind=double),dimension(-6:6),intent(out)::pdf - real(kind=double),dimension(2)::valence_pdf - real(kind=double),dimension(-6:6)::companion_pdf - print('("proton_remnant_flavor_pdf_array: Not yet implemented.")') -!!$ call this%kind_pdf_array(GeV_scale,momentum,valence_pdf,pdf - !!,companion_pdf) -!!$ pdf=pdf+companion_pdf -!!$ pdf(1:2)=pdf(1:2)+valence_pdf - end subroutine proton_remnant_parton_flavor_pdf_array - - ! getting components - - pure function proton_remnant_get_kind_weight(this) result(weight) - class(proton_remnant_type),intent(in)::this - real(kind=double),dimension(3)::weight - weight=this%kind_weight - end function proton_remnant_get_kind_weight - - pure function proton_remnant_get_pdf_int_weight(this) result(weight) - class(proton_remnant_type),intent(in)::this - real(kind=double),dimension(4)::weight - weight=this%pdf_int_weight - end function proton_remnant_get_pdf_int_weight - - elemental function proton_remnant_get_valence_weight(this) result(weight) - class(proton_remnant_type),intent(in)::this - real(kind=double)::weight - weight=this%kind_weight(1) - end function proton_remnant_get_valence_weight - - elemental function proton_remnant_get_sea_weight(this) result(weight) - class(proton_remnant_type),intent(in)::this - real(kind=double)::weight - weight=this%kind_weight(2) - end function proton_remnant_get_sea_weight - - subroutine proton_remnant_get_companion_momentum_pdf_array(this& - &,momentum_fraction,pdf_array) - class(proton_remnant_type),intent(in)::this - real(kind=double),intent(in)::momentum_fraction - real(kind=double),allocatable,dimension(:),intent(out)::pdf_array -! call this%get_companion_parton_pdf_array(momentum_fraction,pdf_array) - pdf_array=pdf_array*momentum_fraction - end subroutine proton_remnant_get_companion_momentum_pdf_array - - pure function proton_remnant_get_valence_content(this) result(valence) - class(proton_remnant_type),intent(in)::this - integer,dimension(2)::valence - valence=this%valence_content - end function proton_remnant_get_valence_content - - elemental function proton_remnant_get_momentum_fraction(this) result(momentum) - class(proton_remnant_type),intent(in)::this - real(kind=double)::momentum - momentum=this%momentum_fraction - end function proton_remnant_get_momentum_fraction - - ! misc - - subroutine proton_remnant_deallocate(this) - class(proton_remnant_type),intent(inout)::this - end subroutine proton_remnant_deallocate - - subroutine proton_remnant_reset(this) - class(proton_remnant_type),intent(inout)::this - call this%finalize - this%kind_weight=[1D0,1D0,1D0] - this%valence_content=[1,2] - this%pdf_int_weight=[1D0,1D0,1D0,1D0] - this%momentum_fraction=1D0 - end subroutine proton_remnant_reset - - ! private - - subroutine proton_remnant_calculate_weight(this,GeV_scale) - class(proton_remnant_type),intent(inout)::this - real(kind=double),intent(in)::GeV_scale - integer,parameter::n_grid=1000 - real(kind=double)::sea_norm - real(kind=double),parameter::d_grid=real(n_grid,kind=double) - real(kind=double),parameter::dx=1D0/d_grid - type(proton_remnant_type)::proton - real(kind=double),dimension(2)::valence_norm - real(kind=double),dimension(-6:6)::sea_pdf - real(kind=double),dimension(1:2)::valence_pdf=0D0 - real(kind=double)::x,actual_valence_norm,weight - integer::ite - sea_norm=0D0 - valence_norm=0D0 - x=dx/2D0 - do ite=1,n_grid - call proton%momentum_kind_pdf_array(GeV_scale,x,valence_pdf,sea_pdf) - sea_norm=sea_norm+sum(sea_pdf) - valence_norm=valence_norm+valence_pdf - x=x+dx - end do - valence_norm=valence_norm*dx - sea_norm=sea_norm*dx - !pdf_rescale=(1D0-n_d_valence*mean_d1-n_u_valence*mean_u2)/(1D0-1*mean_d1 - !-2*mean_u2) !pythia - valence_norm(2)=valence_norm(2)/2D0 - actual_valence_norm=dot_product(this%valence_content,valence_norm) - select case(remnant_weight_model) - case(0) ! no reweighting - this%kind_weight=[1D0,1D0,0D0] - case(2) !pythia-like, only sea - weight=(1D0-actual_valence_norm) /(1D0-dot_product([1,2],valence_norm)) - this%kind_weight=[1D0,weight,0D0] - case(3) !only valence and companion - weight=(1D0-sea_norm) /(actual_valence_norm) - this%kind_weight=[weight,1D0,0D0] - case(4) !only sea and companion - weight=(1D0-actual_valence_norm) /(sea_norm) - this%kind_weight=[1D0,weight,0D0] - case default !equal weight - weight=1D0/(actual_valence_norm+sea_norm) - this%kind_weight=[weight,weight,0D0] - end select - this%pdf_int_weight(1:2)=this%kind_weight(1)*[1D0,0.5D0]*this& - &%valence_content - this%pdf_int_weight(3:4)=this%kind_weight(2) -! print('("New rescale factors are: ",2(I10),7(E14.7))'),this - ! %valence_content,this%weight,this%pdf_int_weight - end subroutine proton_remnant_calculate_weight - - ! overridden - - SUBROUTINE proton_remnant_write_to_ring(this,ring,status) - CLASS(proton_remnant_type),INTENT(IN) :: this - CLASS(page_ring_type), INTENT(INOUT) :: ring - INTEGER,INTENT(OUT)::status - call xml_write(ring,"valence_content",this%valence_content) - call xml_write(ring,"momentum_fraction",this%momentum_fraction) - call xml_write(ring,"kind_weight",this%kind_weight) - call xml_write(ring,"pdf_int_weight",this%pdf_int_weight) - END SUBROUTINE proton_remnant_write_to_ring - - SUBROUTINE proton_remnant_read_from_ring(this,ring,status) - CLASS(proton_remnant_type),INTENT(OUT) :: this - CLASS(page_ring_type), INTENT(INOUT) :: ring - INTEGER,INTENT(OUT)::status - call xml_verify_begin_tag(ring,"proton_remnant_type") - call xml_read(ring,this%valence_content) - call xml_read(ring,this%momentum_fraction) - call xml_read(ring,this%kind_weight) - call xml_read(ring,this%pdf_int_weight) - call xml_verify_end_tag(ring,"proton_remnant_type") - END SUBROUTINE proton_remnant_read_from_ring - - subroutine proton_remnant_print_to_unit(this,unit,parents,components,peers) - class(proton_remnant_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - write(unit,'("Instance of type: ",a)')this%get_type() - write(unit,'("Valence Content: ",I1,":",I1)')this& - &%valence_content - write(unit,'("PDF weights [v,s,c]: ",3(F7.2))')this%kind_weight - write(unit,'("INT weights [d,u,s,g]: ",4(F7.2))')this%pdf_int_weight - write(unit,'("Total Momentum Fraction: ",F7.2)')this%momentum_fraction - end subroutine proton_remnant_print_to_unit - - pure function proton_remnant_get_type() result(type) - character(:),allocatable::type!FC = nagfor - allocate(type,source="proton_remnant_type")!FC = nagfor - character(32)::type!FC = gfortran - type="proton_remnant_type"!FC = gfortran - end function proton_remnant_get_type - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! type bound procedures for proton_remnant_companion_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine proton_remnant_companion_remove_companion(this,companion,GeV_scale) - class(proton_remnant_companion_type),intent(inout)::this - real(kind=double),intent(in)::GeV_scale - class(companion_quark_type),pointer,intent(inout)::companion - class(companion_quark_type),pointer::tmp_companion - if(companion%active)then - if(associated(this%active_companions,companion))then - this%active_companions=>companion%next - else - tmp_companion=>this%active_companions - do while(.not.associated(tmp_companion%next,companion)) - tmp_companion=>tmp_companion%next - end do - tmp_companion%next=>companion%next - end if - companion%active=.false. - companion%next=>this%removed_companions - this%removed_companions=>companion - this%NUMBER_OF_ACTIVE_COMPANIONS=this%NUMBER_OF_ACTIVE_COMPANIONS-1 - this%NUMBER_OF_INACTIVE_COMPANIONS=this%NUMBER_OF_INACTIVE_COMPANIONS+1 - end if -! call this%calculate_companion_norm() - call this%calculate_weight(GeV_scale) - end subroutine proton_remnant_companion_remove_companion - - ! getting pdf - - subroutine proton_remnant_companion_get_companion_parton_pdf_array(this,momentum_fraction,pdf_array) - class(proton_remnant_companion_type),intent(in)::this - real(kind=double),intent(in)::momentum_fraction - real(kind=double),allocatable,dimension(:),intent(out)::pdf_array - class(companion_quark_type),pointer::tmp_companion - integer::ite - allocate(pdf_array(this%number_of_active_companions)) -! allocate(pdf_array(4)) - pdf_array=0D0 - if(this%number_of_active_companions>0)then - tmp_companion=>this%active_companions - ite=0 - do while(associated(tmp_companion)) - ite=ite+1 - pdf_array(ite)=tmp_companion%unweighted_pdf(momentum_fraction)*this%get_companion_weight() - tmp_companion=>tmp_companion%next - end do - end if - end subroutine proton_remnant_companion_get_companion_parton_pdf_array - - subroutine proton_remnant_companion_get_companion_momentum_pdf_array(this,momentum_fraction,pdf_array) - class(proton_remnant_companion_type),intent(in)::this - real(kind=double),intent(in)::momentum_fraction - real(kind=double),allocatable,dimension(:),intent(out)::pdf_array - call this%get_companion_parton_pdf_array(momentum_fraction,pdf_array) - pdf_array=pdf_array*momentum_fraction - end subroutine proton_remnant_companion_get_companion_momentum_pdf_array - - pure function proton_remnant_companion_get_companion_weight(this) result(weight) - class(proton_remnant_companion_type),intent(in)::this - real(kind=double)::weight - weight=this%kind_weight(3) - end function proton_remnant_companion_get_companion_weight - - pure function proton_remnant_companion_get_number_of_active_companions(this) result(number) - class(proton_remnant_companion_type),intent(in)::this - integer::number - number=this%number_of_active_companions - end function proton_remnant_companion_get_number_of_active_companions - - subroutine proton_remnant_companion_add_companion(this,GeV_scale,lha_flavour,twin_momentum) - class(proton_remnant_companion_type),intent(inout)::this - real(kind=double),intent(in)::GeV_scale - integer,intent(in)::lha_flavour - real(kind=double),intent(in)::twin_momentum !momentum of hit parton, not of this parton - class(companion_quark_type),pointer::new_companion - this%number_of_active_companions=this%number_of_active_companions+1 - allocate(new_companion,& - &source=companion_quark_type(& - &lha_flavour,& - &.true.,& - &twin_momentum,& - &remnant_companion_momentum_4(twin_momentum),& - &this%active_companions)) - this%active_companions=>new_companion -! call this%calculate_companion_norm() - call this%calculate_weight(GeV_scale) - end subroutine proton_remnant_companion_add_companion - - subroutine proton_remnant_companion_calculate_companion_norm(this) - class(proton_remnant_companion_type),intent(inout)::this - class(companion_quark_type),pointer::companion - integer::n - if(this%number_of_active_companions>0)then - this%companion_norm=0D0 - companion=>this%active_companions - do while(associated(companion)) - this%companion_norm=this%companion_norm+companion%norm - companion=>companion%next - end do - else - this%companion_norm=0D0 - end if - end subroutine proton_remnant_companion_calculate_companion_norm - - subroutine proton_remnant_companion_deallocate(this) - class(proton_remnant_companion_type),intent(inout)::this - if(associated(this%active_companions))then - call this%active_companions%deallocate - deallocate(this%active_companions) - end if - if(associated(this%removed_companions))then - call this%removed_companions%deallocate - deallocate(this%removed_companions) - end if - this%number_of_active_companions=0 - this%number_of_inactive_companions=0 - this%companion_norm=0D0 - end subroutine proton_remnant_companion_deallocate - - subroutine proton_remnant_companion_calculate_weight(this,GeV_scale) - class(proton_remnant_companion_type),intent(inout)::this - real(kind=double),intent(in)::GeV_scale - integer,parameter::n_grid=1000 - real(kind=double)::sea_norm - real(kind=double),parameter::d_grid=real(n_grid,kind=double) - real(kind=double),parameter::dx=1D0/d_grid - type(proton_remnant_type)::proton - real(kind=double),dimension(2)::valence_norm - real(kind=double),dimension(-6:6)::sea_pdf - real(kind=double),dimension(1:2)::valence_pdf=0D0 - real(kind=double)::x,actual_valence_norm,weight - integer::ite - sea_norm=0D0 - valence_norm=0D0 - x=dx/2D0 - do ite=1,n_grid - call proton%momentum_kind_pdf_array(GeV_scale,x,valence_pdf,sea_pdf) - sea_norm=sea_norm+sum(sea_pdf) - valence_norm=valence_norm+valence_pdf - x=x+dx - end do - valence_norm=valence_norm*dx - sea_norm=sea_norm*dx - !pdf_rescale=(1D0-n_d_valence*mean_d1-n_u_valence*mean_u2)/(1D0-1*mean_d1-2*mean_u2) !pythia - valence_norm(2)=valence_norm(2)/2D0 - actual_valence_norm=dot_product(this%valence_content,valence_norm) - select case(remnant_weight_model) - case(0) ! no reweighting - this%kind_weight=[1D0,1D0,1D0] - case(2) !pythia-like, only sea - weight=(1D0-actual_valence_norm-this%companion_norm)& - &/(1D0-dot_product([1,2],valence_norm)) - this%kind_weight=[1D0,weight,1D0] - case(3) !only valence and companion - weight=(1D0-sea_norm)& - &/(actual_valence_norm+this%companion_norm) - this%kind_weight=[weight,1D0,weight] - case(4) !only sea and companion - weight=(1D0-actual_valence_norm)& - &/(sea_norm+this%companion_norm) - this%kind_weight=[1D0,weight,weight] - case default !equal weight - weight=1D0/(actual_valence_norm+sea_norm+this%companion_norm) - this%kind_weight=[weight,weight,weight] - end select - this%pdf_int_weight(1:2)=this%kind_weight(1)*[1D0,0.5D0]*this%valence_content - this%pdf_int_weight(3:4)=this%kind_weight(2) -! print('("New rescale factors are: ",2(I10),7(E14.7))'),this%valence_content,this%weight,this%pdf_int_weight - end subroutine proton_remnant_companion_calculate_weight - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Non type bound module procedures !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - pure function remnant_dglap_splitting_gqq(z) result(p) - real(kind=double)::p - real(kind=double),intent(in)::z - p=(z**2+(1-z)**2)/2D0 - end function remnant_dglap_splitting_gqq - - pure function remnant_gluon_pdf_approx(x,p) result(g) - real(kind=double)::g - integer,intent(in)::p - real(kind=double),intent(in)::x - g=((1-x)**p)/x - end function remnant_gluon_pdf_approx - - pure function remnant_norm_0(xs) result(c0) - real(kind=double)::c0 - real(kind=double),intent(in)::xs - c0=6*xs/(2-xs*(3-3*xs+2*xs**2)) - end function remnant_norm_0 - - pure function remnant_norm_1(xs) result(c1) - real(kind=double)::c1 - real(kind=double),intent(in)::xs - c1=3*xs/(2-xs**2*(3-xs)+3*xs*log(xs)) - end function remnant_norm_1 - - pure function remnant_norm_4(xs) result(c4) - real(kind=double)::c4 - real(kind=double),intent(in)::xs - real(kind=double)::y - if((1D0-xs)>1D-3)then - c4=3*xs/(1 + 11*xs + 6*xs*log(xs) + 12*xs**3*log(xs) + 18*xs**2*log(xs) + 9*xs**2 - 19*xs**3 - 2*xs**4) - else - y=1D0/(1D0-xs) - c4=& - &1130D0/11907D0& - & -10D0 *y**5& - & -40D0 *y**4/3D0& - & -160D0*y**3/63D0& - & +50D0 *y**2/189D0& - & -565D0*y /3969D0& - & -186170D0*(1D0-xs)/2750517D0 - end if - end function remnant_norm_4 - - pure function remnant_norm(xs,p) result(c) - real(kind=double)::c - real(kind=double),intent(in)::xs - integer,intent(in)::p - select case (p) - case(0) - c=remnant_norm_0(xs) - case(1) - c=remnant_norm_1(xs) - case default - c=remnant_norm_4(xs) - end select - end function remnant_norm - - pure function remnant_companion_pdf_p(x,xs,p) result(qc) - real(kind=double)::qc - real(kind=double),intent(in)::x,xs - integer,intent(in)::p - qc=remnant_norm(xs,p)*remnant_gluon_pdf_approx(xs+x,p)*remnant_dglap_splitting_gqq(xs/(xs+x))/(xs+x) - end function remnant_companion_pdf_p - - elemental function remnant_companion_momentum_4(xs) result(p) - real(kind=double)::p - real(kind=double),intent(in)::xs - if(xs<0.99D0)then - p=(-9*(-1+xs)*xs*(1+xs)*(5+xs*(24+xs))+12*xs*(1+2*xs)*(1+2*xs*(5+2*xs))*Log(xs))/(8*(1+2*xs)*((-1+xs)*(1+xs*(10+xs))-6*xs*(1+xs)*Log(xs))) - else - p=(1-xs)/6-(5*(-1+xs)**2)/63+(5*(-1+xs)**3)/216 - end if - end function remnant_companion_momentum_4 - -end module remnant_module Index: branches/attic/boschmann_standalone/pri/lib/tree_conversion.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/tree_conversion.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/tree_conversion.f03.pri (revision 8609) @@ -1,156 +0,0 @@ -!!! module: tree_conversion_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-01-11 09:56:50 CET(+0100) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -MODULE tree_conversion_module - use kinds - use lin_approx_tree_module - use fibonacci_tree_module - implicit none -contains - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Non Type Bound Module Procedures !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - recursive subroutine fibonacci_tree_resort_and_convert_to_lin_approx_list(fib_tree,lin_list) - ! usually, the tree is sorted by the sum of errors. now it shall be sorted by the right position. - class(fibonacci_node_type),intent(in) :: fib_tree - class(fibonacci_node_type),pointer :: leave - class(lin_approx_list_type),pointer,intent(out) :: lin_list - class(lin_approx_list_type),pointer :: left_list,right_list - class(lin_approx_node_class),pointer :: left_node,right_node,last_node - class(measurable_class),pointer :: content - ! When at least one branch of the tree is itself a tree, i.e. each branch has got at least two leaves, then process each branch and merge the results. - if (fib_tree%depth>1) then - !print *,"3A" - call fibonacci_tree_resort_and_convert_to_lin_approx_list(fib_tree%left,left_list) - call fibonacci_tree_resort_and_convert_to_lin_approx_list(fib_tree%right,right_list) - ! Now we got two sortet lists. Which one's leftmost node has got the lowest value of "r_position"? - ! That one shall be the beginning of the merged list "lin_list". - if(left_list%is_left_of(right_list))then - lin_list => left_list - call left_list%get_right(left_node) - right_node=>right_list - else - lin_list => right_list - left_node=>left_list - call right_list%get_right(right_node) - end if - last_node=>lin_list - ! Everything is prepared for the algorithm: lin_list id the beginning of the sorted list, last_node is it's end. left_node and right_node are the leftmost nodes of the remainders of left_list and right_list. The latter will get stripped from left to right, until one of them ends. - do while(associated(left_node).and.associated(right_node)) - if (left_node%is_left_of(right_node)) then - call last_node%append(left_node) - call last_node%get_right(last_node) - call left_node%get_right(left_node) - else - call last_node%append(right_node) - call last_node%get_right(last_node) - call right_node%get_right(right_node) - end if - end do - ! Either left_list or right_list is completely merged into lin_list. The other one gets appended to lin_list. - if (associated(left_node)) then - call last_node%append(left_node) - else - call last_node%append(right_node) - end if - ! It's done. - !print *,"3E" - else - ! The tree has got two leaves at most. Is it more than one? - if (fib_tree%depth == 0) then - !print *,"1A" - ! Here fib_tree is a single leave with an allocated "content" componet of type lin_approx_cont_type. If "content" is not type compatible with lin_approx_cont_type, then this whole conversion cannot succeed. - ! We allocate a new node of type lin_approx_list_type. This list does not contain the content of fib_tree, it *IS* a copy of the content, for lin_approx_list_type is an extension of lin_approx_cont_type. - select type (fib_tree) - class is (fibonacci_leave_type) - call fib_tree%get_content(content) - select type (content) - class is (lin_approx_cont_type) - call lin_approx_cont_to_node(content,content%get_r_position(),list=lin_list) - class default - print *,"fibonacci_tree_resort_and_convert_to_lin_approx_list: Content of fibonacci_tree is not type compatible to lin_approx_cont_type" - end select - end select - !print *,"1E" - else - !print *,"2A" - ! Each branch of fib_tree is a single leave. We could call this soubroutine for each branch, but we do copy and paste for each branch instead. - leave=>fib_tree%left - select type (leave) - class is (fibonacci_leave_type) - call leave%get_content(content) - select type (content) - class is (lin_approx_cont_type) - call lin_approx_cont_to_node(content,content%get_r_position(),list=left_list) - class default - print *,"fibonacci_tree_resort_and_convert_to_lin_approx_list: Content of fibonacci_tree is not type compatible to lin_approx_cont_type" - end select - end select - leave=>fib_tree%right - select type (leave) - class is (fibonacci_leave_type) - call leave%get_content(content) - select type (content) - class is (lin_approx_cont_type) - call lin_approx_cont_to_node(content,content%get_r_position(),list=right_list) - class default - print *,"fibonacci_tree_resort_and_convert_to_lin_approx_list: Content of fibonacci_tree is not type compatible to lin_approx_cont_type" - end select - end select - ! Finally we append one list to the other, the lowest value of "r_position" comes first. - if (left_list%is_left_of(right_list)) then - call left_list%append(right_list) - lin_list=>left_list - else - call right_list%append(left_list) - lin_list=>right_list - end if - !print *,"2E" - end if - end if - ! call lin_list%print_all() - ! call lin_list%check() - end subroutine fibonacci_tree_resort_and_convert_to_lin_approx_list - -!!$ subroutine fib2list(fib_root,lin_list) -!!$ use fibonacci_tree_module -!!$ class(fibonacci_root_type),target,intent(in) :: fib_root -!!$ class(lin_approx_list_type),pointer,intent(out) :: lin_list -!!$ class(fibonacci_leave_type),pointer :: leave -!!$ class(serializable_class),pointer :: content -!!$ leave=>fib_root%leftmost -!!$ do while(associated(leave)) -!!$ if(associated(leave%content))then -!!$ content=>leave%content -!!$ select type (content) -!!$ class is (lin_approx_cont_type) -!!$ call lin_list%insert_right(leave%value,content,lin_list) -!!$ end select -!!$ end if -!!$ call leave%find_right_leave(leave) -!!$ end do -!!$ end subroutine fib2list - -end MODULE tree_conversion_module - Index: branches/attic/boschmann_standalone/pri/lib/basic_types.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/basic_types.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/basic_types.f03.pri (revision 8609) @@ -1,2397 +0,0 @@ -!!! module: basic_types_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-29 09:02:23 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -MODULE basic_types_module - use,intrinsic::iso_fortran_env - use kinds - implicit none - private - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Intrinsic Type Module Component Declaration !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - integer,public,parameter::serialize_ok=0000 - integer,public,parameter::serialize_syntax_error=1001 - integer,public,parameter::serialize_wrong_tag=1002 - integer,public,parameter::serialize_wrong_id=1003 - integer,public,parameter::serialize_wrong_type=1004 - integer,public,parameter::serialize_wrong_class=1005 - integer,public,parameter::serialize_string_to_short=1006 - integer,public,parameter::serialize_null=1010 - - integer,parameter::page_size=16 - - logical,public,parameter::serialize_default_indent=.false. - logical,public,parameter::serialize_default_line_break=.true. - - integer,private::last_id=0 - integer,private::number_of_instances=0 - integer,private::xml_indentation=0 - - character(*),parameter::async_read="NO" - character(*),parameter::async_write="NO" - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Derived Type Definition !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type,public,abstract::serializable_class - contains - procedure(ser_write_if),deferred::write_to_ring - procedure(ser_read_if),deferred::read_from_ring - procedure(ser_unit),deferred::print_to_unit - procedure(ser_type),deferred,nopass::get_type - procedure,non_overridable::print=>serializable_print - procedure,non_overridable::print_all=>serializable_print_all - procedure,non_overridable::print_little=>serializable_print_little - procedure,non_overridable::print_parents=>serializable_print_parents - procedure,non_overridable::print_components& - &=>serializable_print_components - procedure,non_overridable::print_peers=>serializable_print_peers - procedure::serialize_unit=>serializable_serialize_unit - procedure::serialize_ring=>serializable_serialize_ring - procedure::serialize_target=>serializable_serialize_target -! procedure::serialize_allocatable=>serializable_serialize_allocatable -! procedure::serialize_pointer=>serializable_serialize_pointer - procedure::deserialize=>serializable_deserialize - procedure::deserialize_target=>serializable_deserialize_target -! procedure::deserialize_allocatable=>serializable_deserialize_allocatable -! procedure::deserialize_pointer=>serializable_deserialize_pointer - generic::serialize=>serialize_unit,serialize_ring - end type serializable_class - - type,private::serializable_ref_type - integer::id - class(serializable_class),pointer::ref=>null() - class(serializable_ref_type),pointer::next=>null() - contains - procedure,public::finalize=>serializable_ref_finalize - end type serializable_ref_type - - type,public,abstract,extends(serializable_class)::measurable_class - contains - procedure(measure_int),deferred::measure - end type measurable_class - - type,public,extends(serializable_class)::identified_type - private - integer::id - character(len=:),allocatable::name !FC = nagfor - character(32)::name !FC = gfortran - contains - procedure::identified_initialize - procedure::finalize=>identified_finalize - procedure::get_id=>identified_get_id - procedure::get_name=>identified_get_name - generic::initialize=>identified_initialize - !overridden serializable_class procedures - procedure::write_to_ring=>identified_write_to_ring - procedure::read_from_ring=>identified_read_from_ring -! procedure::write_formatted=>identified_write_formatted - ! procedure::read_formatted=>identified_read_formatted - procedure::print_to_unit=>identified_print_to_unit - procedure,nopass::get_type=>identified_get_type - end type identified_type - - type,public,extends(identified_type)::unique_type - integer::unique_id - contains - procedure::identified_initialize=>unique_initialize - procedure::get_unique_id=>unique_get_unique_id - procedure,nopass::get_type=>unique_get_type - procedure::write_to_ring=>unique_write_to_ring - procedure::read_from_ring=>unique_read_from_ring - procedure::print_to_unit=>unique_print_to_unit -! procedure::write_formatted=>unique_write_formatted -! procedure::read_formatted=>unique_read_formatted - end type unique_type - - type::position_stack_type - integer,dimension(2)::position - class(position_stack_type),pointer::next=>null() - contains - procedure::push_head=>position_stack_push_head - procedure::push_given=>position_stack_push_given - procedure::position_stack_pop - procedure::position_stack_drop - procedure::nth_position=>position_stack_nth_position - procedure::first=>position_stack_first - procedure::last=>position_stack_last - procedure::range=>position_stack_range - generic::push=>push_head,push_given - generic::pop=>position_stack_pop,position_stack_drop - end type position_stack_type - - type,public::page_ring_type - integer::ring_size=2 - integer::unit=-1 - integer::action=0 - integer::eof_int=-1 - integer,dimension(2)::active_pages=[0,-1] - integer,dimension(2)::eof_pos=[-1,-1] - character(page_size),dimension(:),allocatable::ring - type(position_stack_type)::position_stack - contains - procedure :: open=>page_ring_open - procedure :: close=>page_ring_close - procedure :: read_page=>page_ring_read_page - procedure :: enlarge=>page_ring_enlarge - procedure :: print_to_unit=>page_ring_print_to_unit - procedure :: print_ring=>page_ring_print_ring - procedure :: page_ring_find - procedure :: page_ring_find_default - procedure :: find_pure => page_ring_find_pure - procedure :: push_string=>page_ring_push_string - procedure :: push_integer=>page_ring_push_integer - procedure :: push_integer_array=>page_ring_push_integer_array - procedure :: push_double=>page_ring_push_double - procedure :: push_double_array=>page_ring_push_double_array - procedure :: pop_string=>page_ring_pop_string - procedure :: pop_integer=>page_ring_pop_integer - procedure :: pop_integer_array=>page_ring_pop_integer_array - procedure :: pop_double=>page_ring_pop_double - procedure :: pop_double_array=>page_ring_pop_double_array - procedure :: pop_key=>page_ring_pop_key - procedure :: page=>page_ring_page - procedure :: put=>page_ring_put - procedure :: set_position=>page_ring_set_position - procedure :: break=>page_ring_break - procedure :: turn_page=>page_ring_turn_page - procedure :: activate_next_page=>page_ring_activate_next_page - procedure :: flush=>page_ring_flush - procedure :: substring=>page_ring_substring - procedure :: substring_by_keys=>page_ring_substring_by_keys - procedure :: proceed=>page_ring_proceed - procedure :: print_position=>page_ring_print_position - procedure :: ring_index=>page_ring_ring_index - procedure :: push_actual_position=>page_ring_ring_push_actual_position - procedure :: push_given_position=>page_ring_ring_push_given_position - procedure :: pop_actual_position=>page_ring_ring_pop_actual_position - procedure :: pop_given_position=>page_ring_ring_pop_given_position - procedure :: page_ring_get_position1 - procedure :: page_ring_get_position2 - procedure :: actual_index=>page_ring_actual_index - procedure :: actual_page=>page_ring_actual_page - procedure :: actual_offset=>page_ring_actual_offset - procedure :: actual_position=>page_ring_actual_position -! procedure :: get_int=>page_ring_ - generic::find=>page_ring_find,page_ring_find_default - generic::push=>push_string,push_integer,push_double - generic::push_array=>push_integer_array,push_double_array - generic::pop=>pop_string,pop_integer,pop_double - generic::pop_array=>pop_integer_array,pop_double_array - generic::push_position=>push_actual_position,push_given_position - generic::pop_position=>pop_actual_position,pop_given_position - generic::get_position=>page_ring_get_position1,page_ring_get_position2 - end type page_ring_type - - !!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Interface Definition !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!! - - abstract interface - elemental function measure_int(this) - use kinds - import measurable_class - class(measurable_class),intent(in)::this - real(kind=double)::measure_int - end function measure_int - end interface - - interface operator(<) - module procedure measurable_less_measurable - module procedure measurable_less_double - end interface - interface operator(<=) - module procedure measurable_less_or_equal_measurable - module procedure measurable_less_or_equal_double - end interface - interface operator(==) - module procedure measurable_equal_measurable - module procedure measurable_equal_double - end interface - interface operator(>=) - module procedure measurable_equal_or_greater_measurable - module procedure measurable_equal_or_greater_double - end interface - interface operator(>) - module procedure measurable_greater_measurable - module procedure measurable_greater_double - end interface - interface - subroutine ser_write_if(this,ring,status) - import serializable_class - import page_ring_type - class(serializable_class),intent(in)::this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - end subroutine ser_write_if - end interface - interface - subroutine ser_read_if(this,ring,status) - import serializable_class - import page_ring_type - class(serializable_class),intent(out)::this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - end subroutine ser_read_if - end interface - interface - subroutine ser_DTV_WF(dtv,unit,iotype,v_list,iostat,iomsg) - import serializable_class - CLASS(serializable_class),INTENT(IN) :: dtv - INTEGER, INTENT(IN) :: unit - CHARACTER (LEN=*), INTENT(IN) :: iotype - INTEGER, INTENT(IN) :: v_list(:) - INTEGER, INTENT(OUT) :: iostat - CHARACTER (LEN=*), INTENT(INOUT) :: iomsg - end subroutine ser_DTV_WF - subroutine ser_DTV_RF(dtv,unit,iotype,v_list,iostat,iomsg) - import serializable_class - CLASS(serializable_class),INTENT(INOUT) :: dtv - INTEGER, INTENT(IN) :: unit - CHARACTER (LEN=*), INTENT(IN) :: iotype - INTEGER, INTENT(IN) :: v_list(:) - INTEGER, INTENT(OUT) :: iostat - CHARACTER (LEN=*), INTENT(INOUT) :: iomsg - end subroutine ser_DTV_RF - subroutine ser_unit(this,unit,parents,components,peers) - import serializable_class - class(serializable_class),intent(in)::this - integer,intent(in)::unit,parents,components,peers - end subroutine ser_unit - end interface - abstract interface - function ser_type() result(type) - character(:),allocatable::type !FC = nagfor - character(32)::type !FC = gfortran - end function ser_type - end interface - - interface xml_read - module procedure xml_read_string,xml_read_logical, xml_read_integer& - &,xml_read_integer_dim,xml_read_integer_dim2, xml_read_double& - &,xml_read_double_dim,xml_read_double_dim2, xml_verify_string& - &,xml_verify_double,xml_verify_double_dim,xml_verify_double_dim2& - &,xml_verify_logical, xml_verify_integer,xml_verify_integer_dim - end interface - - interface xml_write - module procedure xml_write_string,xml_write_logical,xml_write_integer& - &,xml_write_integer_dim,xml_write_double,xml_write_double_dim& - &,xml_write_double_dim2 - end interface - - interface page_ring_position_is_before - module procedure & - page_ring_position_is_before_int_pos,& - page_ring_position_is_before_pos_pos,& - page_ring_position_is_before_pos_int - end interface - - public operator(<),operator(<=),operator(>=),operator(>) - public serialize_pointer,serialize_allocatable,deserialize_pointer& - &,deserialize_allocatable - public serialize_push_reference,serialize_pop_reference& - &,serialize_remove_reference - public serialize_push_heap,serialize_pop_heap,reset_heap_stack - public xml_write_begin_tag,xml_write_end_tag,xml_verify_begin_tag& - &,xml_verify_end_tag - public xml_write_instance_begin,xml_write_instance_end - public xml_read,xml_write - public xml_write_null_component,xml_verify_null_component& - &,xml_write_null_instance,xml_verify_null_instance - public serialize_print_comp_pointer,serialize_print_peer_pointer& - &,serialize_print_allocatable - public identified_initialize,identified_finalize,identified_print_to_unit& - &,identified_read_from_ring,identified_write_to_ring& - &,serializable_deserialize,serializable_serialize_unit& - &,serializable_serialize_ring - public xml_read_integer_dim - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Derived Type Module Component Declaration !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - class(serializable_ref_type),pointer,private::reference_stack=>null() - class(serializable_ref_type),pointer,public::heap_stack=>null() - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Module Procedure Definition !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -contains - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! type bound procedures for serializable_class !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine serializable_print(this,parents,components,peers,unit) - class(serializable_class),intent(in)::this - integer,intent(in)::parents,components,peers - integer,optional::unit - if(present(unit))then - write(unit,'("")') - write(unit,'("Instance of type: ",a)')this%get_type() - call this%print_to_unit(unit,parents,components,peers) - else - write(output_unit,'("")') - write(output_unit,'("Instance of type: ",a)')this%get_type() - call this%print_to_unit(output_unit,parents,components,peers) - end if - end subroutine serializable_print - - subroutine serializable_print_all(this,unit) - class(serializable_class),intent(in)::this - integer,optional::unit - if(present(unit))then - write(unit,'("")') - write(unit,'("Instance of type: ",a)')this%get_type() - call this%print_to_unit(unit,huge(1),huge(1),huge(1)) - else - write(output_unit,'("")') - write(output_unit,'("Instance of type: ",a)')this%get_type() - call this%print_to_unit(output_unit,huge(1),huge(1),huge(1)) - end if - end subroutine serializable_print_all - - subroutine serializable_print_little(this,unit) - class(serializable_class),intent(in)::this - integer,optional::unit - if(present(unit))then - write(unit,'("")') - write(unit,'("Instance of type: ",a)')this%get_type() - call this%print_to_unit(unit,0,0,0) - else - write(output_unit,'("")') - write(output_unit,'("Instance of type: ",a)')this%get_type() - call this%print_to_unit(output_unit,0,0,0) - end if - end subroutine serializable_print_little - - subroutine serializable_print_parents(this) - class(serializable_class),intent(in)::this - write(output_unit,'("")') - write(output_unit,'("Instance of type: ",a)')this%get_type() - call this%print_to_unit(output_unit,huge(1),0,0) - end subroutine serializable_print_parents - - subroutine serializable_print_components(this) - class(serializable_class),intent(in)::this - write(output_unit,'("")') - write(output_unit,'("Instance of type: ",a)')this%get_type() - call this%print_to_unit(output_unit,0,huge(1),0) - end subroutine serializable_print_components - - subroutine serializable_print_peers(this) - class(serializable_class),intent(in)::this - write(output_unit,'("")') - write(output_unit,'("Instance of type: ",a)')this%get_type() - call this%print_to_unit(output_unit,0,0,huge(1)) - end subroutine serializable_print_peers - - subroutine serializable_print_error(this) - class(serializable_class),intent(in)::this - call this%print_to_unit(error_unit,0,0,0) - end subroutine serializable_print_error - - SUBROUTINE serializable_serialize_unit(this,unit,name) - class(serializable_class),intent(in)::this - INTEGER, INTENT(IN) :: unit - CHARACTER (LEN=*), INTENT(IN) :: name -! call xml_write_instance(this,unit,name) - END SUBROUTINE serializable_serialize_unit - - SUBROUTINE serializable_serialize_ring(this,ring,name) - class(serializable_class),intent(in)::this - class(page_ring_type),intent(inout)::ring - CHARACTER (LEN=*), INTENT(IN) :: name - call xml_write_instance(this,ring,name) - END SUBROUTINE serializable_serialize_ring - - subroutine serializable_serialize_target(this,ring,name) - class(serializable_class),target,intent(in)::this - class(page_ring_type),intent(inout)::ring - CHARACTER (LEN=*), INTENT(IN) :: name - number_of_instances=number_of_instances+1 - call serialize_push_heap(this,number_of_instances) - call xml_write_instance(this,ring,name,target=number_of_instances) - end subroutine serializable_serialize_target - - recursive subroutine serialize_pointer(this,ring,name) - class(serializable_class),pointer,intent(in)::this - class(page_ring_type),intent(inout)::ring - CHARACTER (LEN=*), INTENT(IN) :: name - integer::p - if(associated(this))then -! call ser%print_all() - call find_serializable_by_reference(heap_stack,this,p) -! call ser%print_all() - if(p>0)then - call xml_write_instance_begin(ring,trim(this%get_type()),name& - &,pointer=p) - call xml_write_instance_end(ring) - else - call this%serialize_target(ring,name) - end if - else - call xml_write_null_instance(ring,name) - end if - end subroutine serialize_pointer - - recursive subroutine serialize_allocatable(this,ring,name) - class(serializable_class),allocatable,intent(in)::this - class(page_ring_type),intent(inout)::ring - CHARACTER (LEN=*), INTENT(IN) :: name - if(allocated(this))then - call this%serialize_ring(ring,name) - else - call xml_write_null_instance(ring,name) - end if - end subroutine serialize_allocatable - - SUBROUTINE serializable_deserialize(this,ring) - class(serializable_class),intent(inout)::this - class(page_ring_type),intent(inout)::ring - call xml_read_instance(this,ring) - END SUBROUTINE serializable_deserialize - - subroutine serializable_deserialize_target(this,ring) - class(serializable_class),target,intent(out)::this - class(page_ring_type),intent(inout)::ring - integer::t - call xml_read_instance(this,ring,target=t) - !print *,"serializable_deserialize_target ",t,number_of_instances - !print *,t,number_of_instances - call serialize_push_heap(this,t) - number_of_instances=max(number_of_instances,t+1) - end subroutine serializable_deserialize_target - - recursive subroutine deserialize_allocatable(this,ring) - class(serializable_class),allocatable,intent(out)::this - class(page_ring_type),intent(inout)::ring - class(serializable_class),pointer::ref - character(32)::type,name!FC = gfortran - character(:),allocatable::type,name!FC = nagfor - integer::t,p,status - call xml_read_instance_begin(ring,type,name,t,p) - if(.not.type=="NULL")then - call find_serializable_by_name(reference_stack,type,ref) - if(associated(ref))then - allocate(this,source=ref) - call this%read_from_ring(ring,status) - else - if(.not.allocated(this))print *,"xml_read_allocatable_by_reference:& - & Type ",type," not found." - end if - end if - call xml_verify_instance_end(ring,status) - end subroutine deserialize_allocatable - - recursive subroutine deserialize_pointer(this,ring) - class(serializable_class),pointer,intent(out)::this - class(page_ring_type),intent(inout)::ring - class(serializable_class),pointer::ref - character(32)::type,name!FC = gfortran - character(:),allocatable::type,name!FC = nagfor - integer::t,p,status - nullify(this) - call xml_read_instance_begin(ring,type,name,t,p) - if(.not.type=="NULL")then - if(p>0)then - print *,"points to: ",p - call find_serializable_by_id(heap_stack,p,this) - if(.not.associated(this))then - print *,"xml_read_pointer_by_reference: Target ",p," was not& - & found on heap_stack." - STOP - end if - else - call find_serializable_by_name(reference_stack,type,ref) - if(associated(ref))then - allocate(this,source=ref) - call this%read_from_ring(ring,status) - if(t>0)then -! print *,"target: ",t - call serialize_push_heap(this,t) - end if - else - if(.not.associated(this))print *,"xml_read_pointer_by_reference:& - & Type ",type," not found." - end if - end if - end if - call xml_verify_instance_end(ring,status) - end subroutine deserialize_pointer - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! type bound procedures for serializable_ref_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine serializable_ref_finalize(this) - class(serializable_ref_type),intent(inout)::this - class(serializable_ref_type),pointer::next - do while (associated(this%next)) - next=>this%next - this%next=>next%next - nullify(next%ref) - deallocate(next) - end do - if(associated(this%ref))nullify(this%ref) - end subroutine serializable_ref_finalize - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! type bound procedures for identified_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine identified_initialize(this,id,name) - class(identified_type),intent(out)::this - integer,intent(in)::id - character(len=*),intent(in)::name - allocate(this%name,source=name)!FC = nagfor - this%name=name!FC = gfortran - this%id=id - end subroutine identified_initialize - - subroutine identified_finalize(this) - class(identified_type),intent(inout)::this - if(allocated(this%name))deallocate(this%name)!FC = nagfor - end subroutine identified_finalize - - elemental function identified_get_id(this) result(id) - class(identified_type),intent(in)::this - integer::id - id=this%id - end function identified_get_id - - pure function identified_get_name(this) - class(identified_type),intent(in)::this - character(len(this%name))::identified_get_name - identified_get_name=this%name - end function identified_get_name - - subroutine identified_write_to_ring(this,ring,status) - class(identified_type),intent(in)::this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - call xml_write_begin_tag(ring,"IDENTIFIED_TYPE") - call xml_write_string(ring,"NAME",this%get_name()) - call xml_write_integer(ring,"ID",this%get_id()) - call xml_write_end_tag(ring,"IDENTIFIED_TYPE") - end subroutine identified_write_to_ring - - subroutine identified_read_from_ring(this,ring,status) - class(identified_type),intent(out)::this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - call xml_verify_begin_tag(ring,"IDENTIFIED_TYPE") - call xml_read_string(ring,this%name) - call xml_read_integer(ring,this%id) - call xml_verify_end_tag(ring,"IDENTIFIED_TYPE") - end subroutine identified_read_from_ring - - SUBROUTINE identified_write_formatted(dtv,unit,iotype,v_list,iostat,iomsg) - ! the derived-type value/variable - CLASS(identified_type),INTENT(IN) :: dtv - INTEGER, INTENT(IN) :: unit - ! the edit descriptor string - CHARACTER (LEN=*), INTENT(IN) :: iotype - INTEGER, INTENT(IN) :: v_list(:) - INTEGER, INTENT(OUT) :: iostat - CHARACTER (LEN=*), INTENT(INOUT) :: iomsg -!!$ call xml_write_begin_tag(unit,"IDENTIFIED_TYPE") -!!$ call xml_write_string(unit,"NAME",dtv%get_name()) -!!$ call xml_write_integer(unit,"ID",dtv%get_id()) -!!$ call xml_write_end_tag(unit,"IDENTIFIED_TYPE") - END SUBROUTINE identified_write_formatted - - SUBROUTINE identified_read_formatted(dtv,unit,iotype,v_list,iostat,iomsg) - ! the derived-type value/variable - CLASS(identified_type),INTENT(INOUT) :: dtv - INTEGER, INTENT(IN) :: unit - ! the edit descriptor string - CHARACTER (LEN=*), INTENT(IN) :: iotype - INTEGER, INTENT(IN) :: v_list(:) - INTEGER, INTENT(OUT) :: iostat - CHARACTER (LEN=*), INTENT(INOUT) :: iomsg - character(len=:),allocatable::type!FC = nagfor - character(32)::type !FC = gfortran - if(allocated(dtv%name))deallocate(dtv%name)!FC = nagfor -!!$ call xml_verify_begin_tag(unit,"IDENTIFIED_TYPE") -!!$! if(iostat==0)then -!!$ call xml_read_string(unit,dtv%name) -!!$ call xml_read_integer(unit,dtv%id) -!!$! end if -!!$ call xml_verify_end_tag(unit,"IDENTIFIED_TYPE") - END SUBROUTINE identified_read_formatted - - subroutine identified_print_to_unit(this,unit,parents,components,peers) - class(identified_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - write(unit,'("Components of identified_type:")') - if(allocated(this%name))then !FC = nagfor - write(unit,'("Name: ",a)')this%get_name() - else !FC = nagfor - write(unit,'("Name: not allocated")')!FC = nagfor - end if !FC = nagfor - write(unit,'("ID: ",I10)')this%get_id() - end subroutine identified_print_to_unit - - pure function identified_get_type() result(t) - character(:),allocatable::t !FC = nagfor - character(32)::t !FC = gfortran - allocate(t,source="identified_type")!FC = nagfor - t="identified_type"!FC = gfortran - end function identified_get_type - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! type bound procedures for unique_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine unique_initialize(this,id,name) - class(unique_type),intent(out)::this - integer,intent(in)::id - character(len=*),intent(in)::name - call identified_initialize(this,id,name) - last_id=last_id+1 - this%unique_id=last_id - end subroutine unique_initialize - - subroutine unique_print_to_unit(this,unit,parents,components,peers) - class(unique_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - if(parents>0)call identified_print_to_unit(this,unit,parents-1,components& - &,peers) - write(unit,'("Unique ID: ",I10)')this%get_unique_id() - end subroutine unique_print_to_unit - - elemental function unique_get_unique_id(this) - class(unique_type),intent(in)::this - integer::unique_get_unique_id - unique_get_unique_id=this%unique_id - end function unique_get_unique_id - - pure function unique_get_type() result(t) - character(:),allocatable::t !FC = nagfor - character(32)::t !FC = gfortran - allocate(t,source="UNIQUE_TYPE")!FC = nagfor - t="UNIQUE_TYPE"!FC = gfortran - end function unique_get_type - - subroutine unique_write_to_ring(this,ring,status) - class(unique_type),intent(in)::this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - call xml_write_begin_tag(ring,"UNIQUE_TYPE") - call identified_write_to_ring(this,ring,status) - call xml_write_integer(ring,"UNIQUE_ID",this%get_unique_id()) - call xml_write_end_tag(ring,"UNIQUE_TYPE") - end subroutine unique_write_to_ring - - subroutine unique_read_from_ring(this,ring,status) - class(unique_type),intent(out)::this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - call xml_verify_begin_tag(ring,"UNIQUE_TYPE") - call identified_read_from_ring(this,ring,status) - call xml_read_integer(ring,this%unique_id) - call xml_verify_end_tag(ring,"UNIQUE_TYPE") - end subroutine unique_read_from_ring - - SUBROUTINE unique_read_formatted(dtv,unit,iotype,v_list,iostat,iomsg) - ! the derived-type value/variable - CLASS(unique_type),INTENT(INOUT) :: dtv - INTEGER, INTENT(IN) :: unit - ! the edit descriptor string - CHARACTER (LEN=*), INTENT(IN) :: iotype - INTEGER, INTENT(IN) :: v_list(:) - INTEGER, INTENT(OUT) :: iostat - CHARACTER (LEN=*), INTENT(INOUT) :: iomsg -!!$ call xml_verify_begin_tag(unit,"UNIQUE_TYPE") -!!$ call identified_read_formatted(dtv,unit,iotype,v_list,iostat,iomsg) -!!$ call xml_read_integer(unit,dtv%unique_id) -!!$ call xml_verify_end_tag(unit,"UNIQUE_TYPE") - END SUBROUTINE unique_read_formatted - - SUBROUTINE unique_write_formatted(dtv,unit,iotype,v_list,iostat,iomsg) - ! the derived-type value/variable - CLASS(unique_type),INTENT(IN) :: dtv - INTEGER, INTENT(IN) :: unit - ! the edit descriptor string - CHARACTER (LEN=*), INTENT(IN) :: iotype - INTEGER, INTENT(IN) :: v_list(:) - INTEGER, INTENT(OUT) :: iostat - CHARACTER (LEN=*), INTENT(INOUT) :: iomsg -!!$ call xml_write_begin_tag(unit,"UNIQUE_TYPE") -!!$ call identified_write_formatted(dtv,unit,iotype,v_list,iostat,iomsg) -!!$ call xml_write_integer(unit,"UNIQUE_ID",dtv%get_id()) -!!$ call xml_write_end_tag(unit,"UNIQUE_TYPE") - END SUBROUTINE unique_write_formatted - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! type bound procedures for position_stack_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine position_stack_push_head(this) - class(position_stack_type)::this - class(position_stack_type),pointer::new - allocate(new) - new%next=>this%next - new%position=this%position - this%next=>new - end subroutine position_stack_push_head - - subroutine position_stack_push_given(this,position) - class(position_stack_type)::this - integer,dimension(2),intent(in)::position - class(position_stack_type),pointer::new - allocate(new) - new%next=>this%next - new%position=position - this%next=>new - end subroutine position_stack_push_given - - subroutine position_stack_pop(this) - class(position_stack_type)::this - class(position_stack_type),pointer::old - if(associated(this%next))then - old=>this%next - this%next=>old%next - this%position=old%position - deallocate(old) - end if - end subroutine position_stack_pop - - subroutine position_stack_drop(this,position) - class(position_stack_type)::this - integer,dimension(2),intent(out)::position - class(position_stack_type),pointer::old - if(associated(this%next))then - old=>this%next - this%next=>old%next - position=old%position - deallocate(old) - else - position=[0,0] - end if - end subroutine position_stack_drop - - function position_stack_nth_position(this,n) result(position) - class(position_stack_type),intent(in)::this - integer,intent(in)::n - integer,dimension(2)::position - class(position_stack_type),pointer::tmp - integer::pos - tmp=>this%next - pos=n - do while(associated(tmp).and.pos>0) - tmp=>tmp%next - pos=pos-1 - end do - if(associated(tmp))then - position=tmp%position - else - position=[0,0] - end if - end function position_stack_nth_position - - function position_stack_first(this) result(position) - class(position_stack_type),intent(in)::this - integer,dimension(2)::position,tmp_position - class(position_stack_type),pointer::tmp_stack - tmp_position=this%position - tmp_stack=>this%next - do while(associated(tmp_stack)) - if(page_ring_position_is_before(tmp_stack%position,tmp_position))then - tmp_position=tmp_stack%position - end if - tmp_stack=>tmp_stack%next - end do - end function position_stack_first - - function position_stack_last(this) result(position) - class(position_stack_type),intent(in)::this - integer,dimension(2)::position,tmp_position - class(position_stack_type),pointer::tmp_stack - tmp_position=this%position - tmp_stack=>this%next - do while(associated(tmp_stack)) - if(page_ring_position_is_before(tmp_position,tmp_stack%position))then - tmp_position=tmp_stack%position - end if - tmp_stack=>tmp_stack%next - end do - end function position_stack_last - - pure function position_stack_range(this) result(position) - class(position_stack_type),intent(in)::this - integer,dimension(2)::position - class(position_stack_type),pointer::tmp - end function position_stack_range - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! non type bound procedures !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - elemental function measurable_less_measurable(mea1,mea2) - class(measurable_class),intent(in)::mea1,mea2 - logical::measurable_less_measurable - measurable_less_measurable=mea1%measure()=mea2%measure() - end function measurable_equal_or_greater_measurable - - elemental function measurable_equal_or_greater_double(mea1,dou) - class(measurable_class),intent(in)::mea1 - real(kind=double),intent(in)::dou - logical::measurable_equal_or_greater_double - measurable_equal_or_greater_double=mea1%measure()>=dou - end function measurable_equal_or_greater_double - - elemental function measurable_greater_measurable(mea1,mea2) - class(measurable_class),intent(in)::mea1,mea2 - logical::measurable_greater_measurable - measurable_greater_measurable=mea1%measure()>mea2%measure() - end function measurable_greater_measurable - - elemental function measurable_greater_double(mea1,dou) - class(measurable_class),intent(in)::mea1 - real(kind=double),intent(in)::dou - logical::measurable_greater_double - measurable_greater_double=mea1%measure()>dou - end function measurable_greater_double - - subroutine reset_heap_stack() - if(associated(heap_stack))then - call heap_stack%finalize() - deallocate(heap_stack) - end if - end subroutine reset_heap_stack - - subroutine find_serializable_by_id(stack,id,ser) - class(serializable_ref_type),pointer,intent(in)::stack - integer,intent(in)::id - class(serializable_class),pointer,intent(out)::ser - class(serializable_ref_type),pointer::ref - ref=>stack - do while(associated(ref)) -! print *,id,ref%id,ref%ref%get_type() - if(id==ref%id)then - ser=>ref%ref - exit - end if - ref=>ref%next - end do - end subroutine find_serializable_by_id - - subroutine find_serializable_by_name(stack,type,ser) - class(serializable_ref_type),pointer,intent(in)::stack - character(*),intent(in)::type - class(serializable_class),pointer,intent(out)::ser - class(serializable_ref_type),pointer::tmp_ref - class(serializable_class),pointer::tmp_ser - tmp_ref=>stack - nullify(ser) - do while(associated(tmp_ref)) - tmp_ser=>tmp_ref%ref - if(type==tmp_ser%get_type())then - ser=>tmp_ref%ref - exit - end if - tmp_ref=>tmp_ref%next - end do - end subroutine find_serializable_by_name - - subroutine find_serializable_by_reference(stack,ser,id) - class(serializable_ref_type),pointer,intent(in)::stack - integer,intent(out)::id - class(serializable_class),pointer,intent(in)::ser - class(serializable_ref_type),pointer::ref - ref=>stack - id=0 - do while(associated(ref)) - !print *,ref%id - if(associated(ser,ref%ref))then - id=ref%id - exit - end if - ref=>ref%next - end do - end subroutine find_serializable_by_reference - - subroutine serialize_push_reference(ser) - class(serializable_class),target,intent(in)::ser - class(serializable_ref_type),pointer::new_ref - allocate(new_ref) - new_ref%next=>reference_stack - new_ref%ref=>ser - reference_stack=>new_ref - end subroutine serialize_push_reference - - subroutine serialize_pop_reference(ser) - class(serializable_class),pointer,intent(out)::ser - class(serializable_ref_type),pointer::old_ref - if(associated(reference_stack))then - old_ref=>reference_stack - ser=>old_ref%ref - reference_stack=>reference_stack%next - deallocate(old_ref) - else - print('("serialize_pop_reference: reference_stack is not& - & associated.")') - end if - end subroutine serialize_pop_reference - - subroutine serialize_remove_reference(ser) - class(serializable_class),target,intent(in)::ser - class(serializable_ref_type),pointer::ref1,ref2 - if(associated(reference_stack))then - ref1=>reference_stack - if(associated(reference_stack%ref,ser))then - reference_stack=>reference_stack%next - deallocate(ref1) - else - do while (associated(ref1%next)) - ref2=>ref1%next - if(associated(ref2%ref,ser))then - ref1%next=>ref2%next - deallocate(ref2) - else - ref2=>ref2%next - ref1=>ref1%next - end if - end do - end if - end if - end subroutine serialize_remove_reference - - subroutine serialize_push_heap(ser,id) - class(serializable_class),target,intent(in)::ser - integer,intent(in)::id - class(serializable_ref_type),pointer::new_ref - !print *,"serialize_push_heap",id - allocate(new_ref) - new_ref%next=>heap_stack - new_ref%ref=>ser - new_ref%id=id - heap_stack=>new_ref - end subroutine serialize_push_heap - - subroutine serialize_pop_heap(ser) - class(serializable_class),pointer,intent(out)::ser - class(serializable_ref_type),pointer::old_ref - if(associated(heap_stack))then - old_ref=>heap_stack - ser=>old_ref%ref - heap_stack=>heap_stack%next - deallocate(old_ref) - else - print('("serialize_pop_heap: heap_stack is not associated.")') - end if - end subroutine serialize_pop_heap - - subroutine xml_write_instance(ser,ring,name,target,pointer) - class(serializable_class),intent(in)::ser - class(page_ring_type),intent(inout)::ring - CHARACTER (LEN=*), INTENT(IN) :: name - integer,intent(in),optional::target,pointer - integer::status - call xml_write_instance_begin(ring,trim(ser%get_type()),name,target& - &,pointer) - call ser%write_to_ring(ring,status) - call xml_write_instance_end(ring) - end subroutine xml_write_instance - - subroutine xml_read_instance(ser,ring,target,pointer) - class(serializable_class),intent(out)::ser - class(page_ring_type),intent(inout)::ring - character(32)::type,name!FC = gfortran - character(:),allocatable::type,name!FC = nagfor - integer,optional,intent(out)::target,pointer - integer::status - print *,"xml_read_instance" - call xml_read_instance_begin(ring,type,name,target,pointer) - if(type==ser%get_type())then - call ser%read_from_ring(ring,status) - else - print *,"xml_read_instance: type mismatch. ",type,ser%get_type() - STOP - end if - call xml_verify_instance_end(ring,status) - end subroutine xml_read_instance - - subroutine xml_indent(ring,step) - class(page_ring_type),intent(inout)::ring - integer,optional::step - integer::n - if(serialize_default_line_break)call ring%push(new_line(" ")) - if(serialize_default_indent)then - if(present(step))xml_indentation=xml_indentation+step - do n=1,xml_indentation - call ring%push(" ") - end do - end if - end subroutine xml_indent - - subroutine xml_skip_indentation(ring) - class(page_ring_type),intent(inout)::ring -! call ring%proceed(xml_indentation) - end subroutine xml_skip_indentation - - subroutine xml_write_string(ring,name,content) - class(page_ring_type),intent(inout)::ring - character(*),intent(in)::name,content - call xml_indent(ring) - call ring%push("<"//name//">"//trim(content)//"") - end subroutine xml_write_string - - subroutine xml_read_name_and_string(ring,name,content) - class(page_ring_type),intent(inout)::ring - character(*),intent(out)::name,content!FC = gfortran - character(:),intent(out),allocatable::name,content!FC = nagfor - integer,dimension(2)::p1,p2 - call xml_read_begin_tag(ring,name) - call ring%get_position(p1) - call ring%find("<",skip=.false.,proceed=.true.,pos=p2) - allocate(content,source=ring%substring(p1,p2))!FC = nagfor - content=ring%substring(p1,p2)!FC = gfortran - print *,"xml_read_name_and_string" - print *,"name=",name - print *,"content=",content - call xml_verify_end_tag(ring,name) - end subroutine xml_read_name_and_string - - subroutine xml_read_string(ring,content) - class(page_ring_type),intent(inout)::ring - character(*),intent(out)::content!FC = gfortran - character(:),allocatable,intent(out)::content!FC = nagfor - character(32)::name!FC = gfortran - character(:),allocatable::name!FC = nagfor - call xml_read_name_and_string(ring,name,content) - print *,"xml_read_string:" - print *,"name:",name - print *,"content:",content - end subroutine xml_read_string - - subroutine xml_verify_string(ring,name,content,match) - class(page_ring_type),intent(inout)::ring - character(*),intent(in)::name - character(*),intent(out)::content!FC = gfortran - character(:),allocatable,intent(out)::content!FC = nagfor - integer,intent(out)::match - character(len(name))::read_name!FC = gfortran - character(:),allocatable::read_name!FC = nagfor - call xml_read_name_and_string(ring,read_name,content) - if(name==read_name)then - match=serialize_ok - else - match=serialize_wrong_tag - end if - end subroutine xml_verify_string - - subroutine xml_write_logical(ring,name,content) - class(page_ring_type),intent(inout)::ring - logical,intent(in)::content - character(*),intent(in)::name - call xml_indent(ring) - call ring%push("<"//name//">") - if(content)then - call ring%push("T") - else - call ring%push("F") - end if - call ring%push("") - end subroutine xml_write_logical - - subroutine xml_read_logical(ring,content) - class(page_ring_type),intent(inout)::ring - logical,intent(out)::content - character(1)::str!FC = gfortran - character(:),allocatable::str!FC = nagfor - call xml_read_string(ring,str) - print *,"xml_read_logical:" - read(str,fmt=*)content - print *,content - end subroutine xml_read_logical - - subroutine xml_verify_logical(ring,name,content,match) - class(page_ring_type),intent(inout)::ring - character(*),intent(in)::name - logical,intent(out)::content - integer,intent(out)::match - character(len(name))::read_name!FC = gfortran - character(:),allocatable::read_name!FC = nagfor - character(1)::read_content!FC = gfortran - character(:),allocatable::read_content!FC = nagfor - call xml_read_name_and_string(ring,read_name,read_content) - read(read_content,fmt=*)content - if(name==read_name)then - match=serialize_ok - else - match=serialize_wrong_tag - end if - end subroutine xml_verify_logical - - subroutine xml_write_integer(ring,name,content) - class(page_ring_type),intent(inout)::ring - integer,intent(in)::content - character(*),intent(in)::name - call xml_indent(ring) - call ring%push("<"//name//">") - call ring%push(content) - call ring%push("") - end subroutine xml_write_integer - - subroutine xml_write_integer_dim(ring,name,content) - class(page_ring_type),intent(inout)::ring - integer,intent(in),dimension(:)::content - character(*),intent(in)::name - integer::n - call xml_indent(ring) - call ring%push("<"//name//">") - call ring%push_integer_array(content) - call ring%push("") - end subroutine xml_write_integer_dim - - subroutine xml_read_integer(ring,content) - class(page_ring_type),intent(inout)::ring - integer,intent(out)::content - character(11)::str!FC = gfortran - character(:),allocatable::str!FC = nagfor - call xml_read_string(ring,str) - read(str,fmt=*)content - end subroutine xml_read_integer - - subroutine xml_read_integer_dim(ring,content) - class(page_ring_type),intent(inout)::ring - integer,dimension(:),intent(out)::content - end subroutine xml_read_integer_dim - - subroutine xml_read_integer_dim2(ring,content) - class(page_ring_type),intent(inout)::ring - integer,dimension(:,:),intent(out)::content - end subroutine xml_read_integer_dim2 - - subroutine xml_verify_integer(ring,name,content,match) - class(page_ring_type),intent(inout)::ring - character(*),intent(in)::name - integer,intent(out)::content - integer,intent(out)::match - character(len(name))::read_name!FC = gfortran - character(11)::read_content!FC = gfortran - character(:),allocatable::read_name,read_content!FC = nagfor - call xml_read_name_and_string(ring,read_name,read_content) - read(read_content,fmt=*)content - if(name==read_name)then - match=serialize_ok - else - match=serialize_wrong_tag - end if - end subroutine xml_verify_integer - -!!$ subroutine xml_verify_integer_dim(ring,name,content,match) -!!$ class(page_ring_type),intent(inout)::ring -!!$ character(*),intent(in)::name -!!$ integer,intent(out),dimension(:)::content -!!$ integer,intent(out)::match -!!$ character(len(name))::read_name -!!$ character(20*size(content))::read_content -!!$ call xml_read_name_and_string(ring,read_name,read_content) -!!$ print *,ring,name,size(content),len(read_content) -!!$ print *,read_content -!!$ read(read_content,fmt=*)content -!!$ if(name==read_name)then -!!$ match=serialize_ok -!!$ else -!!$ match=serialize_wrong_tag -!!$ end if -!!$ end subroutine xml_verify_integer_dim - - subroutine xml_verify_integer_dim(ring,tag,content,match) - class(page_ring_type),intent(inout)::ring - character(*),intent(in)::tag - integer,intent(out),dimension(:)::content - integer,intent(out)::match - end subroutine xml_verify_integer_dim - - subroutine xml_write_double(ring,name,content) - class(page_ring_type),intent(inout)::ring - real(kind=double),intent(in)::content - character(*),intent(in)::name - call xml_write_begin_tag(ring,name) - call ring%push(content) - call xml_write_end_tag(ring,name) - end subroutine xml_write_double - - subroutine xml_write_double_dim(ring,name,content) - class(page_ring_type),intent(inout)::ring - real(kind=double),dimension(:),intent(in)::content - character(*),intent(in)::name - call xml_write_begin_tag(ring,name) - call ring%push_array(content) - call xml_write_end_tag(ring,name) - end subroutine xml_write_double_dim - - subroutine xml_write_double_dim2(ring,name,content) - class(page_ring_type),intent(inout)::ring - real(kind=double),dimension(:,:),intent(in)::content - character(*),intent(in)::name - integer::n - integer,dimension(2)::s - s=shape(content) - call xml_write_begin_tag(ring,name) - do n=1,s(2) - call ring%push_array(content(:,n)) - end do - call xml_write_end_tag(ring,name) - end subroutine xml_write_double_dim2 - - subroutine xml_read_double(ring,content) - class(page_ring_type),intent(inout)::ring - real(kind=double),intent(out)::content - integer,dimension(2)::pos - call ring%find(">",.true.,.true.,pos) - call ring%pop(content) - call ring%find(">",.true.,.true.,pos) -! print *,"xml_read_double is not yet implemented" -! STOP - end subroutine xml_read_double - - subroutine xml_verify_double(ring,name,content,match) - class(page_ring_type),intent(inout)::ring - character(*),intent(in)::name - real(kind=double),intent(out)::content - integer,intent(out)::match - call xml_verify_begin_tag(ring,name,match) - call ring%pop(content) - call xml_verify_end_tag(ring,name,match) - end subroutine xml_verify_double - - subroutine xml_verify_double_dim(ring,name,content,status) - class(page_ring_type),intent(inout)::ring - character(*),intent(in)::name - real(kind=double),dimension(:),intent(out)::content - integer,intent(out)::status - call xml_verify_begin_tag(ring,name,status) - call ring%pop_double_array(content) - call xml_verify_end_tag(ring,name,status) - end subroutine xml_verify_double_dim - - subroutine xml_verify_double_dim2(ring,name,content,status) - class(page_ring_type),intent(inout)::ring - character(*),intent(in)::name - real(kind=double),dimension(:,:),intent(out)::content - integer,intent(out)::status - integer::n - integer,dimension(2)::s - s=shape(content) - call xml_verify_begin_tag(ring,name,status) - do n=1,s(2) - call ring%pop_double_array(content(:,n)) - end do - call xml_verify_end_tag(ring,name,status) - end subroutine xml_verify_double_dim2 - - subroutine xml_read_double_dim(ring,content) - class(page_ring_type),intent(inout)::ring - real(kind=double),dimension(:),intent(out)::content - integer,dimension(2)::pos - call ring%find(">",.true.,.true.,pos) - call ring%pop_array(content) - call ring%find(">",.true.,.true.,pos) - print *,"xml_read_double_dim_is not yet implemented" - STOP - end subroutine xml_read_double_dim - - subroutine xml_read_double_dim2(ring,content) - class(page_ring_type),intent(inout)::ring - real(kind=double),dimension(:,:),intent(out)::content - integer,dimension(2)::pos,s - integer::n - s=shape(content) - call ring%find(">",.true.,.true.,pos) - do n=1,s(2) - call ring%pop_array(content(:,n)) - end do - call ring%find(">",.true.,.true.,pos) - print *,"xml_read_double_dim2_is not yet implemented" - STOP - end subroutine xml_read_double_dim2 - - subroutine xml_write_instance_begin(ring,type,name,target,pointer) - class(page_ring_type),intent(inout)::ring - integer,intent(in),optional::target,pointer - character(*),intent(in)::type,name - call xml_indent(ring) - call ring%push("") - xml_indentation=xml_indentation+1 - end subroutine xml_write_instance_begin - - subroutine xml_write_instance_end(ring) - class(page_ring_type),intent(inout)::ring - xml_indentation=xml_indentation-1 - call xml_indent(ring) - call ring%push("") - end subroutine xml_write_instance_end - - subroutine xml_write_begin_tag(ring,name) - class(page_ring_type),intent(inout)::ring - character(*),intent(in)::name - call xml_indent(ring) - call ring%push("<"//name//">") - xml_indentation=xml_indentation+1 - end subroutine xml_write_begin_tag - - subroutine xml_write_end_tag(ring,name) - class(page_ring_type),intent(inout)::ring - character(*),intent(in)::name - xml_indentation=xml_indentation-1 - call xml_indent(ring) - call ring%push("") - end subroutine xml_write_end_tag - - subroutine xml_write_null_instance(ring,name) - class(page_ring_type),intent(inout)::ring - character(*),intent(in)::name - call xml_indent(ring) - call ring%push("") - end subroutine xml_write_null_instance - - subroutine xml_write_null_component(ring,name) - class(page_ring_type),intent(inout)::ring - character(*),intent(in)::name - call xml_write(ring,name,"NULL") - end subroutine xml_write_null_component - - subroutine xml_read_null_component(ring,status) - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - character(4)::null!FC = gfortran - character(:),allocatable::null!FC = nagfor - call xml_read_string(ring,null) - if(null=="NULL")then - status=serialize_null - else - status=serialize_ok - end if - end subroutine xml_read_null_component - - subroutine xml_verify_null_component(ring,name,status) - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - character(len=*),intent(in)::name - character(4)::null!FC = gfortran - character(:),allocatable::null!FC = nagfor - integer,dimension(2)::p - call ring%push_position() - call xml_read_string(ring,null) - if(null=="NULL")then - status=serialize_null - call ring%pop_position() - else - status=serialize_ok - call ring%pop_position(p) - end if - end subroutine xml_verify_null_component - - subroutine xml_verify_null_instance(ring,name,status) - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - character(len=*),intent(in)::name - character(4)::null!FC = gfortran - character(:),allocatable::null!FC = nagfor - call xml_read_string(ring,null) - if(null=="NULL")then - status=serialize_null - else - status=serialize_ok - end if - end subroutine xml_verify_null_instance - - subroutine xml_read_begin_tag(ring,name) - class(page_ring_type),intent(inout)::ring - character(:),allocatable,intent(out)::name !FC = nagfor - character(32),intent(out)::name !FC = gfortran - integer,dimension(2)::p1,p2 - print *,"xml_read_begin_tag" - call ring%find("<",skip=.true.,proceed=.true.,pos=p1) - call ring%find(">",skip=.false.,proceed=.false.,pos=p2) - allocate(name,source=ring%substring(p1,p2))!FC = nagfor - name=ring%substring(p1,p2)!FC = gfortran - xml_indentation=xml_indentation+1 - print *,"end xml_read_begin_tag(",name,")" - call ring%set_position(p2) - call ring%proceed(1) - call ring%print_position() - end subroutine xml_read_begin_tag - - subroutine xml_read_end_tag(ring,name) - class(page_ring_type),intent(inout)::ring - character(:),allocatable,intent(out)::name !FC = nagfor - character(32),intent(out)::name !FC = gfortran - integer,dimension(2)::p1,p2 - xml_indentation=xml_indentation-1 - call ring%find("",skip=.false.,proceed=.false.,pos=p2) - allocate(name,source=ring%substring(p1,p2))!FC = nagfor - name=ring%substring(p1,p2)!FC = gfortran - print *,"end xml_read_end_tag(",name,")" - call ring%set_position(p2) - call ring%proceed(1) - call ring%print_position() - end subroutine xml_read_end_tag - - subroutine xml_verify_begin_tag(ring,type,iostat) - class(page_ring_type),intent(inout)::ring - character(len=*),intent(in)::type - integer,optional,intent(out)::iostat - character(len=len(type))::read_type!FC = gfortran - character(:),allocatable::read_type!FC = nagfor - print *,"xml_verify_begin_tag(ring,",type,")" - call xml_read_begin_tag(ring,read_type) - if(present(iostat))then - if(type==read_type)then - iostat=0 - else - iostat=serialize_wrong_tag - end if - else - if(.not.type==read_type)then - print *,"xml_verify_begin_tag: Type mismatch: ",type," ",read_type - end if - end if - call ring%print_position() - end subroutine xml_verify_begin_tag - - subroutine xml_verify_end_tag(ring,type,iostat) - class(page_ring_type),intent(inout)::ring - character(len=*),intent(in)::type - integer,optional,intent(out)::iostat - character(len=len(type))::read_type!FC = gfortran - character(:),allocatable::read_type!FC = nagfor - call xml_read_end_tag(ring,read_type) - if(present(iostat))then - if(type==read_type)then - iostat=0 - else - iostat=serialize_wrong_tag - end if - else - if(.not.type==read_type)then - print *,"xml_verify_end_tag: Type mismatch: ",type," ",read_type - end if - end if - call ring%print_position() - end subroutine xml_verify_end_tag - - subroutine xml_read_instance_begin(ring,type,name,target,pointer) - class(page_ring_type),intent(inout)::ring - character(:),allocatable,intent(out)::type,name !FC = nagfor - character(32),intent(out)::type,name !FC = gfortran - integer,optional,intent(out)::target,pointer - integer,dimension(2)::min,max - integer::l - character(11)::int!FC = gfortran - character(:),allocatable::int!FC = nagfor - print *,"xml_read_instance_begin" - call ring%find(exp="0)then - read(int,fmt=*)target - print *,"target=",target - else - target=0 - ! print *,"no target" - end if - end if - if(present(pointer))then - call ring%substring_by_keys(" POINTER=""","""",min,max,inclusive=.false.,length=l,string=int) - if(l>0)then - read(int,fmt=*)pointer - print *,"pointer=",pointer - else - pointer=0 - ! print *,"no target" - end if - end if - call ring%substring_by_keys(" TYPE=""","""",min,max,inclusive=.false.,length=l,string=type) - print *,l - if(l>0)print *,"TYPE=",type - call ring%substring_by_keys(" NAME=""","""",min,max,inclusive=.false.,length=l,string=name) - print *,l - if(l>0)print *,"NAME=",name - xml_indentation=xml_indentation+1 - call ring%set_position(max) - end subroutine xml_read_instance_begin - - subroutine xml_verify_instance_end(ring,iostat) - class(page_ring_type),intent(inout)::ring - integer,intent(out)::iostat - character(4)::line - integer,dimension(2)::pos - xml_indentation=xml_indentation-1 - call ring%find("<",.true.,.true.,pos=pos) - call ring%pop(line) - if(line=="/SER>")then - iostat=serialize_ok - else - iostat=serialize_syntax_error - end if - end subroutine xml_verify_instance_end - - subroutine serialize_print_comp_pointer(ser,unit,parents,components,peers,name) - class(serializable_class),pointer,intent(in)::ser - integer,intent(in)::unit,parents,components,peers - character(len=*),intent(in)::name - if(associated(ser))then - write(unit,fmt=*)name," is associated." - if(components>0)then - write(unit,fmt=*)"Printing components of ",name - call ser%print_to_unit(unit,parents,components-1,peers) - else - write(unit,fmt=*)"Skipping components of ",name - end if - else - write(unit,fmt=*)name," is not associated." - end if - end subroutine serialize_print_comp_pointer - - recursive subroutine serialize_print_peer_pointer(ser,ring,parents,components,peers,name) - class(serializable_class),pointer,intent(in)::ser - integer,intent(in)::ring,parents,components,peers - character(len=*),intent(in)::name - if(associated(ser))then - write(ring,fmt=*)name," is associated." - if(peers>0)then - write(ring,fmt=*)"Printing components of ",name - call ser%print_to_unit(ring,parents,components,peers-1) - else - write(ring,fmt=*)"Skipping components of ",name - end if - else - write(ring,fmt=*)name," is not associated." - end if - end subroutine serialize_print_peer_pointer - - subroutine serialize_print_allocatable(ser,ring,parents,components,peers,name) - class(serializable_class),allocatable,intent(in)::ser - integer,intent(in)::ring,parents,components,peers - character(len=*),intent(in)::name - if(allocated(ser))then - write(ring,fmt=*)name," is allocated." - if(components>0)then - write(ring,fmt=*)"Printing components of ",name - call ser%print_to_unit(ring,parents,components-1,peers) - else - write(ring,fmt=*)"Skipping components of ",name - end if - else - write(ring,fmt=*)name," is not allocated." - end if - end subroutine serialize_print_allocatable - - subroutine page_ring_open(this,file,action,status) - class(page_ring_type),intent(inout)::this - character(*),intent(in)::file,action - character(*),intent(in),optional::status - logical::is_open - integer,dimension(2)::pos - print *,"page_ring_open(",file,",",action,",",status,")" - if(this%unit<0)call generate_unit(this%unit,100,1000) - inquire(this%unit,opened=is_open) - if(is_open)then - print *,"page_ring_open: unit ",this%unit," is already opened. Cannot open file ",file - else - this%ring_size=2 - call this%set_position([0,1]) - this%active_pages=[0,-1] - open(unit=this%unit,file=file,access="stream",asynchronous="yes",action=action,status=status) - if(allocated(this%ring))deallocate(this%ring) - allocate(this%ring(0:this%ring_size-1)) - end if - select case (action) - case("write") - this%action=1 - print *,"activate_next_page" - call this%activate_next_page() - call this%push('') - call xml_indent(this) - call this%push('') - flush(this%unit) - case("read") - this%action=2 - print *,"read" - inquire(this%unit,size=this%eof_int) - this%eof_pos=page_ring_position(this%eof_int) - print *,this%eof_int,this%eof_pos - call this%read_page() - call this%find('',skip=.true.,proceed=.true.,pos=pos) - call this%find('>',skip=.true.,proceed=.true.,pos=pos) - case default - print *,"page_ring_open: Action ",action," is not supported." - STOP - end select - print *,"leaving page_ring_open" - end subroutine page_ring_open - - subroutine page_ring_close(this) - class(page_ring_type),intent(inout)::this - if(this%action==1)then - call this%flush() - call xml_write_end_tag(this,"file") - print *,this%position_stack%position - write(this%unit,asynchronous=async_write)& - &this%ring(this%actual_index())(:this%actual_offset()) - end if - close(this%unit) - end subroutine page_ring_close - - subroutine page_ring_read_page(this) - class(page_ring_type),intent(inout)::this - integer::iostat -! print *,"page_ring_read_page" - call page_ring_activate_next_page(this) - if(this%active_pages(2)==this%eof_pos(1))then - read(this%unit,iostat=iostat)this%ring(mod(this%active_pages(2),this%ring_size))(:this%eof_pos(2)) - else - read(this%unit,iostat=iostat)this%ring(mod(this%active_pages(2),this%ring_size)) - end if - if(iostat==iostat_end)then - print *,"End of file" - end if - end subroutine page_ring_read_page - - subroutine page_ring_enlarge(this) - class(page_ring_type),intent(inout)::this - character(page_size),dimension(:),allocatable::tmp_ring - integer::n -! print *,"page_ring_enlarge" - call move_alloc(this%ring,tmp_ring) - allocate(this%ring(0:this%ring_size*2-1)) - do n=this%active_pages(1),this%active_pages(2) -! print *,"n=",n -! print *,mod(n-1,this%ring_size*2)+1,"->",mod(n-1,this%ring_size)+1 - this%ring(mod(n,this%ring_size*2))=tmp_ring(mod(n,this%ring_size)) - end do - this%ring_size=this%ring_size*2 - end subroutine page_ring_enlarge - - subroutine page_ring_print_to_unit(this,unit,parents,components,peers) - class(page_ring_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - write(unit,'("Components of page_ring_type:")') - print *,"ring_size: ",this%ring_size - print *,"unit: ",this%unit - print *,"position: ",this%position_stack%position - print *,"active_pages: ",this%active_pages - if(allocated(this%ring))then - print *,"Ring is allocated." - else - print *,"Ring is not allocated." - end if - end subroutine page_ring_print_to_unit - - subroutine page_ring_print_ring(this,unit) - class(page_ring_type),intent(in)::this - integer,intent(in)::unit - integer::n - write(unit,fmt=*)"Begin of page ring" - do n=this%active_pages(1),this%active_pages(2) - write(unit=unit,fmt="('(',I0,')',a)")n,this%ring(mod(n,this%ring_size)) - end do - write(unit,fmt=*)"End of page ring" - end subroutine page_ring_print_ring - - recursive subroutine page_ring_push_string(this,string) - class(page_ring_type),intent(inout)::this - character(*),intent(in)::string - integer::cut -! print *,"page_ring_push: ",this%position,this%active_pages,string - if(len(string)<=page_size-this%actual_offset()+1)then - this%ring(this%page())(this%actual_offset():this%actual_offset()+len(string))=string - if(len(string)==page_size-this%actual_offset()+1)then - call this%break() - call this%flush() - else - call this%proceed(len(string)) - end if - else - cut=page_size-this%actual_offset()+1 - call this%push_string(string(:cut)) - call this%push_string(string(cut+1:)) - end if - end subroutine page_ring_push_string - - recursive subroutine page_ring_push_integer(this,int) - class(page_ring_type),intent(inout)::this - integer,intent(in)::int - integer::int1 - if(int<0)then - call this%push("-") - call page_ring_push_integer(this,-int) - else - if(int>9)then - call this%push(int/10) - else - int1=mod(int,10) - select case (int1) - case (0) - call this%push("0") - case (1) - call this%push("1") - case (2) - call this%push("2") - case (3) - call this%push("3") - case (4) - call this%push("4") - case (5) - call this%push("5") - case (6) - call this%push("6") - case (7) - call this%push("7") - case (8) - call this%push("8") - case (9) - call this%push("9") - end select - end if - end if - end subroutine page_ring_push_integer - - subroutine page_ring_pop_integer(this,int) - class(page_ring_type),intent(inout)::this - integer,intent(out)::int - integer::int1 - integer::sign - character::c - int=0 - sign=1 - c=" " - do while(c==" ") - call this%pop(c) - end do - if(c=="-")then - sign=-1 - call this%pop(c) - else - parse:do - select case (c) - case ("0") - call this%push("0") - case ("1") - call this%push("1") - case ("2") - call this%push("2") - case ("3") - call this%push("3") - case ("4") - call this%push("4") - case ("5") - call this%push("5") - case ("6") - call this%push("6") - case ("7") - call this%push("7") - case ("8") - call this%push("8") - case ("9") - call this%push("9") - case default - exit parse - end select - end do parse - end if - end subroutine page_ring_pop_integer - - subroutine page_ring_push_integer_array(this,int) - class(page_ring_type),intent(inout)::this - integer,dimension(:),intent(in)::int - integer::n - do n=1,size(int)-1 - call page_ring_push_integer(this,int(n)) - call this%push(" ") - end do - call page_ring_push_integer(this,int(n)) - end subroutine page_ring_push_integer_array - - subroutine page_ring_pop_integer_array(this,int) - class(page_ring_type),intent(inout)::this - integer,dimension(:),intent(out)::int - integer::n - do n=1,size(int)-1 - call page_ring_push_integer(this,int(n)) - call this%push(" ") - end do - call page_ring_push_integer(this,int(n)) - end subroutine page_ring_pop_integer_array - - subroutine page_ring_push_double(this,dou) - class(page_ring_type),intent(inout)::this - real(kind=double),intent(in)::dou - character(len=23)::douc - write(douc,fmt="(E23.15)")dou - call this%push(douc) - end subroutine page_ring_push_double - - subroutine page_ring_push_double_array(this,dou) - class(page_ring_type),intent(inout)::this - real(kind=double),dimension(:),intent(in)::dou - integer::n - call this%push_double(dou(1)) - do n=2,size(dou) - call this%push(" ") - call this%push(dou(n)) - end do - end subroutine page_ring_push_double_array - - subroutine page_ring_pop_double(this,dou) - class(page_ring_type),intent(inout)::this - real(kind=double),intent(out)::dou - character(len=23)::douc - print *,"page_ring_pop_double:" - call this%pop(douc) - print *,douc - read(douc,fmt="(E23.15)")dou - end subroutine page_ring_pop_double - - subroutine page_ring_pop_double_array(this,dou) - class(page_ring_type),intent(inout)::this - real(kind=double),dimension(:),intent(out)::dou - integer::n - call this%pop_double(dou(1)) - do n=2,size(dou) - call this%proceed(1) - call this%pop_double(dou(n)) - end do - end subroutine page_ring_pop_double_array - - recursive subroutine page_ring_pop_string(this,res) - class(page_ring_type),intent(inout)::this - character(len=*),intent(out)::res - integer::n,cut - print *,"page_ring_pop_string",this%actual_position(),len(res),this%active_pages,this%eof_pos - n=len(res) -! if(this%position(1)>this%active_pages(2))then -! if(n+page_ring_ordinal(this%position)0)then - if(skip)then - pos=[start(1),start(2)+ind+len(exp)-1] - else - pos=[start(1),start(2)+ind-1] - end if - if(proceed)call this%set_position(pos) - print *,"exp= ",exp - print *,"start= ",start - print *,"limit= ",limit - print *,"proceed= ",proceed - print *,"skip= ",skip - print *,"pos= ",pos - print *,"position=",this%actual_position() - else - print *,"page_ring_find: limit reached." - pos=[-1,-1] - end if - else - ind=index(this%ring(page)(start(2):),exp) - ! print *,"First page:" - ! print *,this%ring(page) - if(ind>0)then - if(skip)then - pos=[start(1),start(2)+ind+len(exp)-1] - else - pos=[start(1),start(2)+ind-1] - end if - if(proceed)call this%set_position(pos) - print *,"exp= ",exp - print *,"start= ",start - print *,"limit= ",limit - print *,"proceed= ",proceed - print *,"skip= ",skip - print *,"pos= ",pos - print *,"position=",this%actual_position() - else - ! print *,"start=",start,"pages=",this%active_pages - if(start(1)+1>this%active_pages(2))then - call this%read_page() - ! call this%print_to_unit(output_unit,huge(1),huge(1),huge(1)) - ! print *,"enlarge: start=",start,"pages=",this%active_pages - page=this%ring_index(start(1)) - end if - page2=this%ring_index(start(1)+1) - ! print *,page,page2,this%ring(page)(page_size-len(exp):)//this%ring(page2)(:len(exp)) - ind=index(this%ring(page)(page_size-len(exp):)//this%ring(page2)(:len(exp)),exp) - if(ind>0)then - if(skip)then - pos=[start(1)+1,ind-1] - else - pos=[start(1),page_size-len(exp)+ind-1] - end if - if(pos(2)>page_size)then - pos(1)=pos(1)+1 - pos(2)=pos(2)-page_size - end if - if(proceed)call this%set_position(pos) - print *,"exp= ",exp - print *,"start= ",start - print *,"limit= ",limit - print *,"proceed= ",proceed - print *,"skip= ",skip - print *,"pos= ",pos - print *,"position=",this%actual_position() - else - if(proceed)this%active_pages(1)=this%active_pages(2) - call page_ring_find(this,exp,[start(1)+1,1],limit,skip,proceed,pos) -! print *,"page_ring_find: Expression ",exp," not found." -! if(present(start))print *,"Start position is: ",start -! if(present(limit))print *,"End position is: ",limit -! if(present(skip))print *,"Skip is: ",skip -! if(present(proceed))print *,"Proceed is: ",proceed - end if - end if - end if - end subroutine page_ring_find - - recursive pure function page_ring_find_pure(this,exp,start,limit,skip) result(pos) - class(page_ring_type),intent(in)::this - integer,dimension(2),intent(in)::start - integer,dimension(2),optional,intent(in)::limit - character(*),intent(in)::exp - logical,optional,intent(in)::skip - integer,dimension(2)::pos - integer::page,page2,ind - page=mod(start(1),this%ring_size) - ind=index(this%ring(page)(start(2):),exp) - if(ind>0)then - if(present(skip))then - if(skip)then - pos=[start(1),start(2)+ind+len(exp)-1] - else - pos=[start(1),start(2)+ind-1] - end if - else - pos=[start(1),start(2)+ind] - end if - else - if(start(1)+1>this%active_pages(2))then - pos=[0,0] - else - page2=mod(start(1)+1,this%ring_size) - ind=index(this%ring(page)(page_size-len(exp):)//this%ring(page2)(:len(exp)),exp) - if(ind>0)then - if(present(skip))then - if(skip)then - pos=[start(1)+1,ind-1] - else - pos=[start(1),page_size-len(exp)+ind-1] - end if - else - pos=[start(1),page_size-len(exp)+ind] - end if - else - pos=page_ring_find_pure(this,exp,[start(1)+1,1],limit,skip) - end if - end if - end if - end function page_ring_find_pure - - recursive subroutine page_ring_substring_by_keys(this,exp1,exp2,start,limit,inclusive,length,string) - class(page_ring_type),intent(in)::this - character(*),intent(in)::exp1,exp2 - integer,dimension(2),intent(in)::start,limit - logical,optional,intent(in)::inclusive - integer,intent(out),optional::length - character(*),intent(out)::string!FC = gfortran - character(:),allocatable,intent(out)::string!FC = nagfor - integer,dimension(2)::pos1,pos2 - integer::page,page2,ind - pos1=this%find_pure(exp1,start,limit,.not.inclusive) - print *,pos1 - if(present(length))then - length=0 - end if - if(pos1(2)>0)then - pos2=this%find_pure(exp2,pos1,limit,inclusive) - print *,pos2 - if(pos2(2)>0)then - string=this%substring(pos1,pos2)!FC = gfortran - allocate(string,source=this%substring(pos1,pos2))!FC = nagfor - if(present(length))then - length=(pos2(1)-pos1(1))*page_size+(pos2(2)-pos1(2)) - end if - end if - end if - end subroutine page_ring_substring_by_keys - - subroutine page_ring_pop_key(this,start,stop,inclusive,res) - class(page_ring_type),intent(inout)::this - character(*),intent(in),optional::start - character(*),intent(in)::stop - logical,optional,intent(in)::inclusive - character(len=*),intent(out)::res - integer,dimension(2)::i1,i2 - call this%find(start,.not.inclusive,.not.inclusive,i1) - call this%find(stop,inclusive,.false.,i2) - res=this%substring(i1,i2) - call this%set_position(i2) - end subroutine page_ring_pop_key - - subroutine page_ring_break(this) - class(page_ring_type),intent(inout)::this -! print *,"page_ring_break" - if(this%actual_page()>=this%active_pages(2))call this%activate_next_page() - call this%turn_page() - end subroutine page_ring_break - - subroutine page_ring_turn_page(this) - class(page_ring_type),intent(inout)::this - this%position_stack%position(1)=this%position_stack%position(1)+1 - this%position_stack%position(2)=1 - end subroutine page_ring_turn_page - - subroutine page_ring_flush(this) - class(page_ring_type),intent(inout)::this - integer::page - do while(this%active_pages(1)=this%ring_size)call this%enlarge - this%active_pages(2)=this%active_pages(2)+1 - end subroutine page_ring_activate_next_page - - subroutine page_ring_set_position(this,pos) - class(page_ring_type),intent(inout)::this - integer,dimension(2),intent(in)::pos - this%position_stack%position=pos - end subroutine page_ring_set_position - - subroutine page_ring_put(this) - class(page_ring_type),intent(inout)::this - end subroutine page_ring_put - - integer function page_ring_page(this) - class(page_ring_type),intent(in)::this - page_ring_page=mod(this%position_stack%position(1),this%ring_size) - end function page_ring_page - - subroutine page_ring_proceed(this,n) - class(page_ring_type),intent(inout)::this - integer,intent(in)::n - integer::offset -! print *,"page_ring_proceed ",n,this%actual_position() - offset=this%position_stack%position(2)+n - do while (offset>=page_size) - if(this%position_stack%position(1)>=this%active_pages(2))call this%activate_next_page() - this%position_stack%position(1)=this%position_stack%position(1)+1 - offset=offset-page_size - end do - this%position_stack%position(2)=offset -! print *,"end page_ring_proceed ",n,this%actual_position() - end subroutine page_ring_proceed - - subroutine page_ring_print_position(this) - class(page_ring_type),intent(inout)::this - print *,this%ring(this%actual_index())(:this%actual_offset()-1),"|",this%ring(this%actual_index())(this%actual_offset():) - end subroutine page_ring_print_position - - elemental integer function page_ring_ring_index(this,n) - class(page_ring_type),intent(in)::this - integer,intent(in)::n - page_ring_ring_index=mod(n,this%ring_size) - end function page_ring_ring_index - - subroutine page_ring_ring_push_given_position(this,pos) - class(page_ring_type),intent(inout)::this - integer,dimension(2),intent(in)::pos - call this%position_stack%push(pos) - end subroutine page_ring_ring_push_given_position - - subroutine page_ring_ring_pop_actual_position(this) - class(page_ring_type),intent(inout)::this - call this%position_stack%pop() - end subroutine page_ring_ring_pop_actual_position - - subroutine page_ring_ring_push_actual_position(this) - class(page_ring_type),intent(inout)::this - call this%position_stack%push() - end subroutine page_ring_ring_push_actual_position - - subroutine page_ring_ring_pop_given_position(this,pos) - class(page_ring_type),intent(inout)::this - integer,dimension(2),intent(out)::pos - call this%position_stack%pop(pos) - end subroutine page_ring_ring_pop_given_position - - pure subroutine page_ring_get_position1(this,pos) - class(page_ring_type),intent(in)::this - integer,intent(out)::pos - pos=page_ring_ordinal(this%position_stack%position) - end subroutine page_ring_get_position1 - - pure subroutine page_ring_get_position2(this,pos) - class(page_ring_type),intent(in)::this - integer,dimension(2),intent(out)::pos - pos=this%position_stack%position - end subroutine page_ring_get_position2 - - elemental integer function page_ring_actual_index(this) - class(page_ring_type),intent(in)::this - page_ring_actual_index=mod(this%position_stack%position(1),this%ring_size) - end function page_ring_actual_index - - elemental integer function page_ring_actual_page(this) - class(page_ring_type),intent(in)::this - page_ring_actual_page=this%position_stack%position(1) - end function page_ring_actual_page - - elemental integer function page_ring_actual_offset(this) - class(page_ring_type),intent(in)::this - page_ring_actual_offset=this%position_stack%position(2) - end function page_ring_actual_offset - - pure function page_ring_actual_position(this) - class(page_ring_type),intent(in)::this - integer,dimension(2)::page_ring_actual_position - page_ring_actual_position=this%position_stack%position - end function page_ring_actual_position - - - pure function page_ring_position(n) - integer,intent(in)::n - integer,dimension(2)::page_ring_position - page_ring_position(2)=mod(n,page_size) - page_ring_position(1)=(n-page_ring_position(2))/page_size - end function page_ring_position - - pure integer function page_ring_ordinal(pos) - integer,dimension(2),intent(in)::pos - page_ring_ordinal=pos(1)*page_size+pos(2) - end function page_ring_ordinal - - pure logical function page_ring_position_is_before_int_pos(m,n) - integer,intent(in)::m - integer,dimension(2),intent(in)::n - if(mn(1))then - page_ring_position_is_before_pos_pos=.false. - else - if(m(2) -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-29 16:11:41 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module arguments_module - use,intrinsic::iso_fortran_env - use kinds - use,intrinsic::ieee_arithmetic!FC = nagfor - implicit none - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Intrinsic Type Module Component Declaration !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - integer,private,parameter::char_len=128!FC = gfortran - integer,private,parameter::indent_len=30 - logical::arguments_stop_at_unrecognized_argument=.true. - logical::arguments_stop_at_invalid_argument=.true. - logical::arguments_stop_at_unrecognized_option=.true. - logical::arguments_stop_at_invalid_option=.true. - logical::arguments_revert_invalid_to_default=.true. - character(*),private,parameter::whitespace=" " - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Derived Type Definition !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type::string_filo_stack_type - character(:),allocatable::value!FC = nagfor - character(char_len)::value=""!FC = gfortran - integer::value_length=0!FC = gfortran - class(string_filo_stack_type),pointer::next=>null() - contains - procedure::push_string=>string_filo_stack_push_string - procedure::push_filo_stack=>string_filo_stack_push_filo_stack - procedure::finalize=>string_filo_stack_finalize - procedure::contains=>string_filo_stack_contains - procedure::write_contents=>string_filo_stack_write_contents - procedure::write_tail=>string_filo_stack_write_tail - procedure::assign=>string_filo_stack_assign - generic::push=>push_string,push_filo_stack - end type string_filo_stack_type - - type,extends(string_filo_stack_type)::string_list_type - class(string_filo_stack_type),pointer::last=>null() - contains - procedure::push_string=>string_list_push_string - procedure::push_filo_stack=>string_list_push_filo_stack - procedure::initialize=>string_list_initialize - procedure::finalize=>string_list_finalize - procedure::string_list_append_string - procedure::string_list_append_filo_stack - procedure::string_list_append_list - procedure::get_rightmost=>string_list_get_rightmost - generic::append=>string_list_append_string,string_list_append_filo_stack - end type string_list_type - - type,abstract :: argument_class - private - character::short_form="" - character(:),allocatable::long_form,named_option!FC = nagfor - character(char_len)::long_form,named_option!FC = gfortran - class(string_list_type),pointer::description=>null() - integer::long_form_length=0 - integer::named_option_length=0 - logical::is_given_comp=.false. - logical::is_default=.true. - logical::is_valid=.true. - logical::with_option=.false. - logical::has_short_form=.false. - logical::has_long_form=.false. - contains - procedure::is_given=>argument_is_given - procedure::get_a_form=>argument_get_a_form - procedure::compare_short=>argument_compare_short - procedure::compare_long=>argument_compare_long - procedure::argument_initialize - procedure::argument_finalize - procedure::write_description=>argument_write_description - procedure(read_option_interface),deferred::read_option - procedure::write_to_unit=>argument_write_to_unit - end type argument_class - - type::argument_list_type - class(argument_list_type),pointer::next=>null() - class(argument_class),pointer::argument=>null() - contains - procedure::push=>argument_list_push - procedure::finalize=>argument_list_finalize - procedure::process=>argument_list_process - procedure::process_long=>argument_list_process_long - procedure::process_short=>argument_list_process_short - procedure::write_description=>argument_list_write_description - end type argument_list_type - - type,extends(argument_class) :: switch_argument_type - logical::default_value=.true. - logical::actual_value=.true. - class(switch_argument_type),pointer::disable_arg=>null() - contains - procedure::read_option=>switch_argument_read_option - procedure::switch_argument_initialize - procedure::compare_short=>switch_argument_compare_short - procedure::compare_long=>switch_argument_compare_long - procedure::negates=>switch_argument_negates - generic::initialize=>argument_initialize,switch_argument_initialize - end type switch_argument_type - - type,extends(argument_class) :: real_argument_type - real(kind=double)::default_value=0D0 - real(kind=double)::actual_value=0D0 - real(kind=double)::min_value=0D0 - real(kind=double)::max_value=1D0 - real(kind=double),dimension(:),allocatable::value_range - contains - procedure::get_actual_value=>real_argument_get_actual_value - procedure::read_option=>real_argument_read_option - procedure::write_description=>real_argument_write_description - procedure::real_argument_initialize - generic::initialize=>argument_initialize,real_argument_initialize - end type real_argument_type - - type,extends(argument_class) :: integer_argument_type - private - integer::default_value=0 - integer::actual_value=0 - integer::min_value - integer::max_value - integer,dimension(:),allocatable::value_range - contains - procedure::get_actual_value=>integer_argument_get_actual_value - procedure::read_option=>integer_argument_read_option - procedure::write_description=>integer_argument_write_description - procedure::integer_argument_initialize - generic::initialize=>argument_initialize,integer_argument_initialize - end type integer_argument_type - - type,extends(argument_class) :: string_argument_type - private - integer::actual_length=0 - integer::default_length=0 - character(:),allocatable::actual_value!FC = nagfor - character(char_len)::actual_value!FC = gfortran - type(string_filo_stack_type)::value_range - contains - procedure::get_default_value=>string_argument_get_default_value - procedure::get_actual_value=>string_argument_get_actual_value - procedure::assign=>string_argument_assign - procedure::push=>string_argument_push - procedure::read_option=>string_argument_read_option - procedure::string_argument_initialize - procedure::finalize=>string_argument_finalize - procedure::write_description=>string_argument_write_description - generic::initialize=>string_argument_initialize - end type string_argument_type - - type,extends(argument_class) :: plain_argument_type - contains - procedure::read_option=>plain_argument_read_option - generic::initialize=>argument_initialize - end type plain_argument_type - - !!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Interface Definition !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!! - - interface - subroutine read_option_interface(this,index) - import argument_class - class(argument_class),intent(inout)::this - integer,intent(inout)::index - end subroutine read_option_interface - end interface - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Module Procedure Definition !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -contains - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures for argument_list_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine argument_list_push(this,argument) - class(argument_list_type),intent(inout)::this - class(argument_class),intent(in),target::argument - class(argument_list_type),pointer::new_list - print *,"argument_list_push(this,",argument%get_a_form() - if(associated(this%argument))then - allocate(new_list) - new_list%argument=>argument - new_list%next=>this%next - this%next=>new_list - else - this%argument=>argument - end if - end subroutine argument_list_push - - recursive subroutine argument_list_finalize(this) - class(argument_list_type),intent(out)::this - if(associated(this%next))call this%next%finalize() - deallocate(this%next) - nullify(this%argument) - end subroutine argument_list_finalize - - subroutine argument_list_process(this) - class(argument_list_type),intent(inout)::this - character(2)::arg_kind - integer::arg_length,arg_index,short_index - character(:),allocatable::long_arg!FC = nagfor - character(char_len)::long_arg!FC = gfortran - character::short_arg - arg_index=0 - arg_loop:do - arg_index=arg_index+1 - call get_command_argument(arg_index,arg_kind,arg_length) - if(arg_kind(1:1)=="-")then - if(arg_kind(2:2)=="-")then - if(arg_length>2)then - allocate(character(arg_length)::long_arg)!FC = nagfor - call get_command_argument(arg_index,long_arg,arg_length) - print *, "process_long ",long_arg - call this%process_long(long_arg(3:arg_length),arg_index) - deallocate(long_arg)!FC = nagfor - else - print *,arg_kind,"XD is no valid argument." - if(arguments_stop_at_invalid_argument)stop - end if - else - if(arg_length>1)then - allocate(character(arg_length)::long_arg)!FC = nagfor - call get_command_argument(arg_index,long_arg,arg_length) - short:do short_index=2,arg_length - short_arg=long_arg(short_index:short_index) - print *, "process_short ",short_arg - call this%process_short(short_arg,arg_index) - end do short - else - print *,arg_kind," is no valid argument." - if(arguments_stop_at_invalid_argument)stop - end if - end if - else - exit - end if - end do arg_loop - end subroutine argument_list_process - - recursive subroutine argument_list_process_short(this,short,index) - class(argument_list_type),intent(inout)::this - character,intent(in)::short - integer,intent(inout)::index - logical::match - if(associated(this%argument))then - call this%argument%compare_short(short,index,match) - if(.not.match)then - if(associated(this%next))then - call this%next%process_short(short,index) - else - print *,"-",short," is no recognized argument." - if(arguments_stop_at_unrecognized_argument)stop - end if - end if - else - print *,"argument_list_process_short: No Argument assigned." - end if - end subroutine argument_list_process_short - - recursive subroutine argument_list_process_long(this,long,index) - class(argument_list_type),intent(inout)::this - character(*),intent(in)::long - integer,intent(inout)::index - logical::match - if(associated(this%argument))then - call this%argument%compare_long(long,index,match) - if(.not.match)then - if(associated(this%next))then - call this%next%process_long(long,index) - else - print *,"--",long," is no recognized argument." - if(arguments_stop_at_unrecognized_argument)stop - end if - end if - else - print *,"argument_list_process_long: No Argument assigned." - end if - end subroutine argument_list_process_long - - recursive subroutine argument_list_write_description(this,unit) - class(argument_list_type),intent(in)::this - integer,intent(in)::unit - if(associated(this%argument))call this%argument%write_description(unit) - if(associated(this%next))call this%next%write_description(unit) - end subroutine argument_list_write_description - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures for string_filo_stack_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine string_filo_stack_assign(this,string) - class(string_filo_stack_type),intent(inout)::this - character(*),intent(in)::string - if(allocated(this%value))deallocate(this%value)!FC = nagfor - allocate(character(len(string))::this%value)!FC = nagfor - this%value=string - this%value_length=len(string)!FC = gfortran - end subroutine string_filo_stack_assign - - subroutine string_filo_stack_push_string(this,string) - class(string_filo_stack_type),intent(inout)::this - character(*),intent(in)::string - class(string_filo_stack_type),pointer::new_entry - allocate(new_entry) - call new_entry%assign(string) - new_entry%next=>this%next - this%next=>new_entry - end subroutine string_filo_stack_push_string - - subroutine string_filo_stack_push_filo_stack(this,stack) - class(string_filo_stack_type),intent(inout)::this - class(string_filo_stack_type),intent(inout),target::stack - stack%next=>this%next - this%next=>stack - end subroutine string_filo_stack_push_filo_stack - - recursive subroutine string_filo_stack_finalize(this) - class(string_filo_stack_type),intent(out)::this - if(associated(this%next))then - call this%next%finalize - deallocate(this%next) - end if - if(allocated(this%value))deallocate(this%value)!FC = nagfor - end subroutine string_filo_stack_finalize - - recursive subroutine string_filo_stack_contains(this,string,success) - class(string_filo_stack_type),intent(in)::this - character(*),intent(in)::string - logical,intent(out)::success - if(this%value==string)then - success=.true. - else - if(associated(this%next))then - call this%next%contains(string,success) - else - success=.false. - end if - end if - end subroutine string_filo_stack_contains - - subroutine string_filo_stack_write_tail(this,unit,separator) - class(string_filo_stack_type),intent(in)::this - integer,intent(in)::unit - character(*),intent(in),optional::separator - if(associated(this%next))call string_filo_stack_write_contents(this%next,unit,separator) - end subroutine string_filo_stack_write_tail - - recursive subroutine string_filo_stack_write_contents(this,unit,separator) - class(string_filo_stack_type),intent(in)::this - integer,intent(in)::unit - character(*),intent(in),optional::separator - if(allocated(this%value))write(unit,fmt=("(a)"),ADVANCE="NO")this%value!FC = nagfor - if(this%value_length>0)write(unit,fmt=("(a)"),ADVANCE="NO")this%value(1:this%value_length)!FC = gfortran - if(associated(this%next))then - if(present(separator))then - write(unit,fmt=("(a)"),ADVANCE="NO")separator - else - write(unit,fmt=*)"" - end if - call this%next%write_contents(unit,separator) - end if - end subroutine string_filo_stack_write_contents - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures for string_list_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine string_list_set_last(this) - class(string_list_type),intent(inout),target::this - if(.not.associated(this%next))then - this%last=>this - else - if(.not.associated(this%last))this%last=>this - do while(associated(this%last%next)) - this%last=>this%last%next - end do - end if - end subroutine string_list_set_last - - subroutine string_list_push_string(this,string) - class(string_list_type),intent(inout),target::this - character(*),intent(in)::string - call string_filo_stack_push_string(this,string) - call string_list_set_last(this) - end subroutine string_list_push_string - - subroutine string_list_push_filo_stack(this,stack) - class(string_list_type),intent(inout),target::this - class(string_filo_stack_type),intent(inout),target::stack - class(string_filo_stack_type),pointer::thisp - thisp=>this - call string_filo_stack_push_filo_stack(this,stack) - call string_list_set_last(this) - end subroutine string_list_push_filo_stack - - subroutine string_list_initialize(this,string) - class(string_list_type),intent(out),target::this - character(*),intent(in),optional::string - print *,"string_list_initialize" - print *,associated(this%last) - this%last=>this - if(allocated(this%value))deallocate(this%value)!FC = nagfor - if(present(string))call this%assign(string) - print *,associated(this%last) - end subroutine string_list_initialize - - subroutine string_list_finalize(this) - class(string_list_type),intent(out),target::this - call string_filo_stack_finalize(this) - nullify(this%last) - end subroutine string_list_finalize - - subroutine string_list_append_string(this,string) - class(string_list_type),target,intent(inout)::this - character(*),intent(in)::string - print *,string - print *,associated(this%last) - allocate(this%last%next) - this%last=>this%last%next - call this%last%assign(string) - end subroutine string_list_append_string - - subroutine string_list_append_filo_stack(this,stack) - class(string_list_type),intent(inout)::this - class(string_filo_stack_type),intent(in),target::stack - this%last%next=>stack - do while(associated(this%last%next)) - this%last=>this%last%next - end do - end subroutine string_list_append_filo_stack - - subroutine string_list_append_list(this,list) - class(string_list_type),intent(inout)::this,list - if(allocated(list%value))call this%append(list%value)!FC = nagfor - call this%append(list%value)!FC = gfortran - call this%append(list%next) - end subroutine string_list_append_list - - subroutine string_list_get_rightmost(this,string) - class(string_list_type),intent(inout)::this - character(*),intent(out)::string - if(allocated(this%last%value))string=this%last%value!FC = nagfor - string=this%last%value!FC = gfortran - end subroutine string_list_get_rightmost - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures for argument_class !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - elemental function argument_is_given(this) - logical::argument_is_given - class(argument_class),intent(in)::this - argument_is_given=this%is_given_comp - end function argument_is_given - - function argument_get_a_form(this) result(form) - class(argument_class),intent(in)::this - character(max(1,this%long_form_length))::form!FC = nagfor - character(len=20)::form!FC = gfortran - if(allocated(this%long_form))then!FC = nagfor - form=this%long_form!FC = nagfor - else!FC = nagfor - form=this%short_form!FC = nagfor - end if!FC = nagfor - form="gfortran bug #48059"!FC = gfortran - end function argument_get_a_form - - subroutine argument_initialize(this,arg_list,short,long,description,description_list,named_option) - class(argument_class),intent(inout),target::this - character,intent(in),optional::short - character(*),intent(in),optional::long,description,named_option - type(string_list_type),intent(inout),optional,target::description_list -! type(argument_list_type),intent(inout),optional::arg_list - class(argument_list_type),optional,intent(inout)::arg_list - if(present(long).or.present(short))then - if(present(short))then - this%short_form=short - this%has_short_form=.true. - else - this%short_form=" " - this%has_short_form=.false. - end if - if(allocated(this%long_form))deallocate(this%long_form)!FC = nagfor - if(present(long))then - this%long_form_length=len(long) - allocate(this%long_form,source=long)!FC = nagfor - this%long_form=long!FC = gfortran - this%has_long_form=.true. - else - this%long_form_length=0 - this%has_long_form=.false. - end if - allocate(this%description) - call this%description%initialize() - if(present(arg_list))call arg_list%push(this) - if(present(description_list))then - call this%description%push(description_list) - else - if(present(description))then -! print *,description - call this%description%append(description) - end if - end if - if(allocated(this%named_option))deallocate(this%named_option)!FC = nagfor - if(present(named_option))then - allocate(this%named_option,source=named_option)!FC = nagfor - this%named_option=named_option!FC = gfortran - this%named_option_length=len(named_option) - else - this%named_option_length=0 - end if - else - print *,"argument_initialize: Neither short form nor long form given for argument. Stop." - stop - end if - end subroutine argument_initialize - - subroutine argument_finalize(this) - class(argument_class),intent(out)::this - call this%description%finalize() - deallocate(this%description) - end subroutine argument_finalize - - subroutine argument_compare_short(this,short,index,match) - class(argument_class),intent(inout)::this - character,intent(in)::short - integer,intent(inout)::index - logical,intent(out)::match - if(this%short_form==short)then - match=.true. - this%is_given_comp=.true. - call this%read_option(index) - else - match=.false. - end if - end subroutine argument_compare_short - - subroutine argument_compare_long(this,long,index,match) - class(argument_class),intent(inout)::this - character(*),intent(in)::long - integer,intent(inout)::index - logical,intent(out)::match - if(allocated(this%long_form))then!FC = nagfor - if(this%long_form==long)then - match=.true. - this%is_given_comp=.true. - call this%read_option(index) - else - match=.false. - end if - end if!FC = nagfor - end subroutine argument_compare_long - - subroutine argument_write_description(this,unit) - class(argument_class),intent(in)::this - integer,intent(in)::unit - integer::length - length=6 - write(unit,fmt=("(a2)"),ADVANCE="NO")" " - if(this%has_short_form)then - write(unit,fmt=("(a1,a1)"),ADVANCE="NO")"-",this%short_form - if(this%has_long_form)then - write(unit,fmt=("(a)"),ADVANCE="NO")", " - else - write(unit,fmt=("(a3)"),ADVANCE="NO")" " - end if - else - write(unit,fmt=("(a)"),ADVANCE="NO")" " - end if - if(this%has_long_form)then - write(unit,fmt=("(a,a,a)"),ADVANCE="NO")"--",this%long_form," "!FC = nagfor - write(unit,fmt=("(a,a,a)"),ADVANCE="NO")"--",this%long_form(1:this%long_form_length)," "!FC = gfortran - length=length+this%long_form_length+3 - end if - if(allocated(this%named_option))then!FC = nagfor - if(this%named_option_length>0)then!FC = gfortran - write(unit,fmt=("(a,a)"),ADVANCE="NO")this%named_option(1:this%named_option_length)," " - length=length+this%named_option_length+1 - end if -! if(allocated(this%description%value))then - if(length>=indent_len)then - write(unit,fmt=*)"" - write(unit,fmt=("(a)"),ADVANCE="NO")whitespace - else - write(unit,fmt=("(a)"),ADVANCE="NO")whitespace(1:indent_len-length) - end if - call this%description%write_tail(unit,new_line(" ")//whitespace) -! end if - write(unit,fmt=*)"" - end subroutine argument_write_description - - subroutine argument_write_to_unit(this,unit) - class(argument_class),intent(in)::this - integer,intent(in)::unit - write(unit,fmt=*)"short form: ",this%short_form - if(allocated(this%long_form))then - write(unit,fmt=*)"long form: ",this%long_form - else - write(unit,fmt=*)"long form: ","not allocated." - end if - write(unit,fmt=*)"long form length: ",this%long_form_length - write(unit,fmt=*)"named option length:",this%named_option_length - write(unit,fmt=*)"is given: ",this%is_given_comp - write(unit,fmt=*)"is default: ",this%is_default - write(unit,fmt=*)"is valid: ",this%is_valid - write(unit,fmt=*)"with option: ",this%with_option - write(unit,fmt=*)"has short form: ",this%has_short_form - write(unit,fmt=*)"has long form: ",this%has_long_form - end subroutine argument_write_to_unit - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures for real_argument_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - pure function real_argument_get_actual_value(this) - real(kind=double)::real_argument_get_actual_value - class(real_argument_type),intent(in)::this - real_argument_get_actual_value=this%actual_value - end function real_argument_get_actual_value - - subroutine real_argument_read_option(this,index) - class(real_argument_type),intent(inout)::this - integer,intent(inout)::index - integer::n,length,iostat - character(:),allocatable::option!FC = nagfor - character(char_len)::option!FC = gfortran - index=index+1 - call get_command_argument(index,length=length) - allocate(character(length)::option)!FC = nagfor - call get_command_argument(index,option) - read(option,fmt=*,iostat=iostat)this%actual_value - if(.not.iostat==0)then - print *,"real_argument_read_option: could not parse option ",option," of argument ",this%get_a_form() - if(arguments_stop_at_unrecognized_option)stop - if(arguments_revert_invalid_to_default)then - this%actual_value=this%default_value - else - this%is_valid=.false. - end if - end if - if((this%actual_valuethis%max_value))then - print *,"real_argument_read_option: Option ",option," of argument ",this%get_a_form()," is out of range" - print *,"Range is: [",this%min_value,":",this%max_value,"]" - if(arguments_stop_at_invalid_option)stop - if(arguments_revert_invalid_to_default)then - this%actual_value=this%default_value - else - this%is_valid=.false. - end if - end if - if(allocated(this%value_range))then - this%is_valid=.false. - do n=1,size(this%value_range) - if(this%actual_value==this%value_range(n))then - this%is_valid=.true. - exit - end if - end do - if(.not.this%is_valid)then - print *,"Value ",this%actual_value," for argument ",this%get_a_form()," is invalid." - print *,"Valid values are:" - print *,this%value_range - print *,"Default value is:" - print *,this%default_value - if(arguments_revert_invalid_to_default)then - this%actual_value=this%default_value - else - this%is_valid=.false. - end if - end if - end if - if(this%actual_value==this%default_value)then - this%is_default=.true. - else - this%is_default=.false. - end if - this%is_given_comp=.true. - end subroutine real_argument_read_option - - subroutine real_argument_write_description(this,unit) - class(real_argument_type),intent(in)::this - integer,intent(in)::unit - integer::i - call argument_write_description(this,unit) - if(allocated(this%value_range))then - write(unit,("(a,a,a)"),ADVANCE="NO")whitespace,this%named_option(1:this%named_option_length)," is one of: " - write(unit,fmt='("{",E22.16)',ADVANCE="NO")this%value_range(1) - do i=2,size(this%value_range) - write(unit,fmt='(",",E22.16)',ADVANCE="NO")this%value_range(i) - end do - write(unit,fmt='("}")') - else - write(unit,("(a,a,a)"),ADVANCE="NO")whitespace,this%named_option(1:this%named_option_length)," is in: " - write(unit,fmt="(a,E22.16,a,E22.16,a)")"[",this%min_value,",",this%max_value,"]" - end if - end subroutine real_argument_write_description - - subroutine real_argument_initialize(this,value,min,max,arg_list,short,long,description,description_list,named_option,range) - class(real_argument_type),intent(inout),target::this - real(kind=double),intent(in)::value - real(kind=double),optional,intent(in)::min,max - class(argument_list_type),optional,intent(inout)::arg_list - real(kind=double),dimension(:),intent(in),optional::range - character,intent(in),optional::short - character(*),intent(in),optional::long,description,named_option - type(string_list_type),intent(inout),optional::description_list - character(24)::default_char - call argument_initialize(this,arg_list,short,long,description,description_list,named_option) - this%default_value=value - if(present(min))then - this%min_value=min - else - this%min_value=-huge(1) - end if - if(present(max))then - this%max_value=max - else - this%max_value=huge(1) - end if - if(this%min_value>this%max_value)then - print *,"real_argument_initialize: min value is greater then max value. Stop." - stop - end if - if((this%default_valuethis%max_value))then - print *,"real_argument_initialize: default value is not in range. Stop." - stop - end if - if(allocated(this%value_range))deallocate(this%value_range) - if(present(range))allocate(this%value_range(size(range)),source=range) - this%actual_value=this%default_value - this%is_default=.true. - this%is_valid=.true. - write(default_char,'(E22.16)')this%default_value - call this%description%append("Default value is "//trim(default_char)//".") - end subroutine real_argument_initialize - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures for integer_argument_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - pure function integer_argument_get_actual_value(this) - integer::integer_argument_get_actual_value - class(integer_argument_type),intent(in)::this - integer_argument_get_actual_value=this%actual_value - end function integer_argument_get_actual_value - - subroutine integer_argument_read_option(this,index) - class(integer_argument_type),intent(inout)::this - integer,intent(inout)::index - integer::n,length,iostat - character(:),allocatable::option!FC = nagfor - character(char_len)::option!FC = gfortran - index=index+1 - call get_command_argument(index,length=length) - allocate(character(length)::option)!FC = nagfor - call get_command_argument(index,option) - read(option,fmt=*,iostat=iostat)this%actual_value - if(.not.iostat==0)then - print *,"integer_argument_read_option: could not parse option ",option," of argument ",this%get_a_form() - if(arguments_stop_at_unrecognized_option)stop - if(arguments_revert_invalid_to_default)then - this%actual_value=this%default_value - else - this%is_valid=.false. - end if - end if - if((this%actual_valuethis%max_value))then - print *,"integer_argument_read_option: Option ",option," of argument ",this%get_a_form()," is out of range" - print *,"Range is: [",this%min_value,":",this%max_value,"]" - if(arguments_stop_at_invalid_option)stop - if(arguments_revert_invalid_to_default)then - this%actual_value=this%default_value - else - this%is_valid=.false. - end if - end if - if(allocated(this%value_range))then - this%is_valid=.false. - do n=1,size(this%value_range) - if(this%actual_value==this%value_range(n))then - this%is_valid=.true. - exit - end if - end do - if(.not.this%is_valid)then - print *,"Value ",this%actual_value," for argument ",this%get_a_form()," is invalid." - print *,"Valid values are:" - print *,this%value_range - print *,"Default value is:" - print *,this%default_value - if(arguments_revert_invalid_to_default)then - this%actual_value=this%default_value - else - this%is_valid=.false. - end if - end if - end if - if(this%actual_value==this%default_value)then - this%is_default=.true. - else - this%is_default=.false. - end if - this%is_given_comp=.true. - end subroutine integer_argument_read_option - - subroutine integer_argument_write_description(this,unit) - class(integer_argument_type),intent(in)::this - integer,intent(in)::unit - integer::i - call argument_write_description(this,unit) - if(allocated(this%value_range))then - write(unit,("(a,a,a)"),ADVANCE="NO")whitespace,this%named_option(1:this%named_option_length)," is one of: " - write(unit,fmt='("{",I0)',ADVANCE="NO")this%value_range(1) - do i=2,size(this%value_range) - write(unit,fmt='(",",I0)',ADVANCE="NO")this%value_range(i) - end do - write(unit,fmt='("}")') - else - write(unit,("(a,a,a)"),ADVANCE="NO")whitespace,this%named_option(1:this%named_option_length)," is in: " - write(unit,fmt="(a,I0,a,I0,a)")"[",this%min_value,",",this%max_value,"]" - end if - end subroutine integer_argument_write_description - - subroutine integer_argument_initialize(this,value,min,max,arg_list,short,long,description,description_list,named_option,range) - class(integer_argument_type),intent(inout),target::this - integer,intent(in)::value - integer,optional,intent(in)::min,max - class(argument_list_type),optional,intent(inout)::arg_list - integer,dimension(:),intent(in),optional::range - character,intent(in),optional::short - character(*),intent(in),optional::long,description,named_option - type(string_list_type),intent(inout),optional::description_list - character(12)::default_char - call argument_initialize(this,arg_list,short,long,description,description_list,named_option) - this%default_value=value - if(present(min))then - this%min_value=min - else - this%min_value=-huge(1) - end if - if(present(max))then - this%max_value=max - else - this%max_value=huge(1) - end if - if(this%min_value>this%max_value)then - print *,"integer_argument_initialize: min value is greater then max value. Stop." - stop - end if - if((this%default_valuethis%max_value))then - print *,"integer_argument_initialize: default value is not in range. Stop." - stop - end if - if(allocated(this%value_range))deallocate(this%value_range) - if(present(range))allocate(this%value_range(size(range)),source=range) - this%actual_value=this%default_value - this%is_default=.true. - this%is_valid=.true. - write(default_char,fmt='(I0)')this%default_value - call this%description%append("Default value is "//trim(default_char)//".") - end subroutine integer_argument_initialize - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures for string_argument_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - pure function string_argument_get_actual_value(this) result(def) - class(string_argument_type),intent(in)::this - character(this%actual_length)::def - if(allocated(this%actual_value))then!FC = nagfor - def=this%actual_value!FC = nagfor - else!FC = nagfor - def=""!FC = nagfor - end if!FC = nagfor - def=this%actual_value(:this%actual_length)!FC = gfortran - end function string_argument_get_actual_value - - pure function string_argument_get_default_value(this) result(def) - class(string_argument_type),intent(in)::this - character(this%default_length)::def - if(allocated(this%value_range%value))then!FC = nagfor - def=this%value_range%value!FC = nagfor - else!FC = nagfor - def=""!FC = nagfor - end if!FC = nagfor - def=this%value_range%value!FC = gfortran - end function string_argument_get_default_value - - subroutine string_argument_assign(this,string) - class(string_argument_type),intent(inout)::this - character(*),intent(in)::string - if(allocated(this%actual_value))deallocate(this%actual_value)!FC = nagfor - allocate(this%actual_value,source=string)!FC = nagfor - this%actual_value=string!FC = gfortran - this%actual_length=len(string) - end subroutine string_argument_assign - - subroutine string_argument_push(this,string) - class(string_argument_type),intent(inout)::this - character(*),intent(in)::string - call this%value_range%push(string) - end subroutine string_argument_push - - subroutine string_argument_finalize(this) - class(string_argument_type),intent(inout)::this - call this%value_range%finalize() - end subroutine string_argument_finalize - - subroutine string_argument_write_description(this,unit) - class(string_argument_type),intent(in)::this - integer,intent(in)::unit -! print *,"hallo" - call argument_write_description(this,unit) - if(associated(this%value_range%next))then - write(unit,("(a,a,a)"),ADVANCE="NO")whitespace,this%named_option(1:this%named_option_length)," is one of: " - call this%value_range%write_contents(unit,", ") - write(unit,fmt=*)"" - end if - end subroutine string_argument_write_description - - subroutine string_argument_read_option(this,index) - class(string_argument_type),intent(inout)::this - integer,intent(inout)::index - integer::n,length,iostat - character(:),allocatable::option!FC = nagfor - character(char_len)::option!FC = gfortran - index=index+1 - call get_command_argument(index,length=length) - allocate(character(length)::option)!FC = nagfor - call get_command_argument(index,option) - if(associated(this%value_range%next))then - call this%value_range%contains(option,this%is_valid) - else - this%is_valid=.true. - end if - if(this%is_valid)then - call this%assign(option)!FC = nagfor - call this%assign(option(:length))!FC = gfortran - else - print *,"Value ",option," for argument ",this%short_form," is invalid." - print *,"Valid values are:" - call this%value_range%write_contents(output_unit) - if(arguments_stop_at_invalid_option)stop - if(arguments_revert_invalid_to_default)call this%assign(this%get_default_value()) - end if - if(this%actual_value==this%value_range%value)then - this%is_default=.true. - else - this%is_default=.false. - end if - this%is_given_comp=.true. - end subroutine string_argument_read_option - - subroutine string_argument_initialize(this,value,arg_list,short,long,description,description_list,named_option) - class(string_argument_type),intent(inout),target::this - character(*),intent(in)::value - class(argument_list_type),optional,intent(inout)::arg_list - character,intent(in),optional::short - character(*),intent(in),optional::long,description,named_option - type(string_list_type),intent(inout),optional::description_list - if(present(named_option))then - call argument_initialize(this,arg_list,short,long,description,description_list,named_option) - else - call argument_initialize(this,arg_list,short,long,description,description_list,"") - end if - call this%value_range%assign(value) - this%default_length=len(value) - call this%assign(value) - this%is_default=.true. - this%is_valid=.true. - call this%description%append("Default value is '"//value//"'.") - end subroutine string_argument_initialize - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures for switch_argument_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine switch_argument_read_option(this,index) - class(switch_argument_type),intent(inout)::this - integer,intent(inout)::index - end subroutine switch_argument_read_option - - subroutine switch_argument_negates(this,negative) - class(switch_argument_type),intent(inout),target::this,negative - if(this%default_value.eqv.negative%default_value)then - print *,"switch_argument_negates: Cannot assign negation: Both arguments have got the same default value." - else - this%disable_arg=>negative - negative%disable_arg=>this - call this%description%append("Negates "//negative%get_a_form()) - call negative%description%append("Negates "//this%get_a_form()) - end if - end subroutine switch_argument_negates - - subroutine switch_argument_initialize(this,value,arg_list,short,long,description,description_list) - class(switch_argument_type),intent(inout),target::this - logical,intent(in)::value - class(argument_list_type),optional,intent(inout)::arg_list - character,intent(in),optional::short - character(*),intent(in),optional::long,description - type(string_list_type),intent(inout),optional::description_list - call argument_initialize(this,arg_list,short,long,description,description_list) - this%default_value=value - this%actual_value=value - this%is_default=.true. - this%is_valid=.true. - if(this%default_value)then - call this%description%append("Default value is TRUE.") - else - call this%description%append("Default value is FALSE.") - end if - end subroutine switch_argument_initialize - - subroutine switch_argument_compare_short(this,short,index,match) - class(switch_argument_type),intent(inout)::this - character,intent(in)::short - integer,intent(inout)::index - logical,intent(out)::match - call argument_compare_short(this,short,index,match) - if(match)then - this%actual_value=this%default_value - this%is_default=.true. - if(associated(this%disable_arg))then - this%disable_arg%actual_value=.not.this%default_value - this%disable_arg%is_default=.false. - end if - end if - end subroutine switch_argument_compare_short - - subroutine switch_argument_compare_long(this,long,index,match) - class(switch_argument_type),intent(inout)::this - character(*),intent(in)::long - integer,intent(inout)::index - logical,intent(out)::match - call argument_compare_long(this,long,index,match) - if(match)then - this%actual_value=this%default_value - this%is_default=.true. - if(associated(this%disable_arg))then - this%disable_arg%actual_value=.not.this%default_value - this%disable_arg%is_default=.false. - end if - end if - end subroutine switch_argument_compare_long - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures for plain_argument_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine plain_argument_read_option(this,index) - class(plain_argument_type),intent(inout)::this - integer,intent(inout)::index - end subroutine plain_argument_read_option - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Non Type Bound Procedures !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine process_arguments(& -!&switch_args,& -!&int_args,& -!&real_args,& -!&string_args,& -!&rest_begin,& -!&rest& -&) -! type(switch_argument_type),dimension(:),intent(inout),optional::switch_args -! type(integer_argument_type),dimension(:),intent(inout),optional::int_args -! type(real_argument_type),dimension(:),intent(inout),optional::real_args -! type(string_argument_type),dimension(:),intent(inout),optional::string_args -! integer,intent(out),optional::rest_begin -! type(string_list_type),intent(out),optional::rest -!!$ integer::n_outer,n_inner,n_short,length -!!$ logical::match -!!$ character(2)::arg_kind -!!$ character(:),allocatable::long_arg!FC = nagfor -!!$ character(char_len)::long_arg!FC = gfortran -!!$ character::short_arg -!!$ n_outer=0 -!!$ if(present(rest_begin))rest_begin=-1 -!!$ outer:do while(n_outer2)then -!!$ allocate(character(length)::long_arg)!FC = nagfor -!!$ call get_command_argument(n_outer,long_arg,length=length) -!!$ if(present(switch_args))then -!!$ do n_inner=1,size(switch_args) -!!$ call switch_args(n_inner)%compare_long(long_arg(3:length),n_outer,match) -!!$ if(match)cycle outer -!!$ end do -!!$ end if -!!$ if(present(int_args))then -!!$ do n_inner=1,size(int_args) -!!$ call int_args(n_inner)%compare_long(long_arg(3:length),n_outer,match) -!!$ if(match)cycle outer -!!$ end do -!!$ end if -!!$ if(present(real_args))then -!!$ do n_inner=1,size(real_args) -!!$ call real_args(n_inner)%compare_long(long_arg(3:length),n_outer,match) -!!$ if(match)cycle outer -!!$ end do -!!$ end if -!!$ if(present(string_args))then -!!$ do n_inner=1,size(string_args) -!!$ call string_args(n_inner)%compare_long(long_arg(3:length),n_outer,match) -!!$ if(match)cycle outer -!!$ end do -!!$ end if -!!$ print *,long_arg," is no recognized argument." -!!$ if(arguments_stop_at_unrecognized_argument)stop -!!$ else -!!$ print *,arg_kind,"XD is no valid argument." -!!$ if(arguments_stop_at_invalid_argument)stop -!!$ end if -!!$ else -!!$ if(length>1)then -!!$ allocate(character(length)::long_arg)!FC = nagfor -!!$ call get_command_argument(n_outer,long_arg,length=length) -!!$ short:do n_short=2,length -!!$ short_arg=long_arg(n_short:n_short) -!!$ if(present(switch_args))then -!!$ do n_inner=1,size(switch_args) -!!$ call switch_args(n_inner)%compare_short(short_arg,n_outer,match) -!!$ if(match)cycle short -!!$ end do -!!$ end if -!!$ if(present(int_args))then -!!$ do n_inner=1,size(int_args) -!!$ call int_args(n_inner)%compare_short(short_arg,n_outer,match) -!!$ if(match)cycle short -!!$ end do -!!$ end if -!!$ if(present(real_args))then -!!$ do n_inner=1,size(real_args) -!!$ call real_args(n_inner)%compare_short(short_arg,n_outer,match) -!!$ if(match)cycle short -!!$ end do -!!$ end if -!!$ if(present(string_args))then -!!$ do n_inner=1,size(string_args) -!!$ call string_args(n_inner)%compare_short(short_arg,n_outer,match) -!!$ if(match)cycle short -!!$ end do -!!$ end if -!!$ print *,"-",short_arg," is no recognized argument." -!!$ if(arguments_stop_at_unrecognized_argument)stop -!!$ end do short -!!$ else -!!$ print *,arg_kind," is no valid argument." -!!$ if(arguments_stop_at_invalid_argument)stop -!!$ end if -!!$ end if -!!$ else -!!$ if(present(rest_begin))rest_begin=n_outer -!!$ if(present(rest))then -!!$ do n_inner=command_argument_count(),n_outer+1,-1 -!!$ call get_command_argument(n_inner,arg_kind,length=length) -!!$ allocate(character(length)::long_arg)!FC = nagfor -!!$ call get_command_argument(n_inner,long_arg,length=length) -!!$ call rest%push(long_arg) -!!$ end do -!!$ call get_command_argument(n_inner,arg_kind,length=length) -!!$ allocate(character(length)::long_arg)!FC = nagfor -!!$ call get_command_argument(n_inner,long_arg,length=length) -!!$ call rest%assign(long_arg) -!!$ end if -!!$ exit -!!$ end if -!!$ end do outer - end subroutine process_arguments - - subroutine arguments_setup(un_arg,in_arg,un_opt,in_opt,revert) - logical,intent(in),optional::un_arg,in_arg,un_opt,in_opt,revert - if(present(un_arg))arguments_stop_at_unrecognized_argument=un_arg - if(present(in_arg))arguments_stop_at_invalid_argument=in_arg - if(present(un_opt))arguments_stop_at_unrecognized_option=un_opt - if(present(in_opt))arguments_stop_at_invalid_option=in_opt - if(present(revert))arguments_revert_invalid_to_default=revert - end subroutine arguments_setup - -end module arguments_module Index: branches/attic/boschmann_standalone/pri/lib/kinds.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/kinds.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/kinds.f03.pri (revision 8609) @@ -1,48 +0,0 @@ -! WHIZARD -! -! (C) 1999-2004 by Wolfgang Kilian -! -! WHIZARD is free software; you can redistribute it and/or modify it -! under the terms of the GNU General Public License as published by -! the Free Software Foundation; either version 2, or (at your option) -! any later version. -! -! WHIZARD is distributed in the hope that it will be useful, but -! WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -module kinds - implicit none - private - -! Three types of precision. double is the default, usually. - public :: single, double, quadruple - public :: default, quad_or_single - - integer, parameter :: single = & - & selected_real_kind (precision(1.), range(1.)) - integer, parameter :: double = & - & selected_real_kind (precision(1._single) + 1, range(1._single) + 1) - integer, parameter :: quadruple = & - & selected_real_kind (precision (1._double) + 1, range (1._double)) - - integer, parameter :: default = double - integer, parameter :: quad_or_single = single - -! Integer kinds: 8 bit, 16 bit, 32 bit, and 64 bit -! These should all be available - public :: i8, i16, i32, i64 - - integer, parameter :: i8 = selected_int_kind (2) - integer, parameter :: i16 = selected_int_kind (4) - integer, parameter :: i32 = selected_int_kind (9) - integer, parameter :: i64 = selected_int_kind (18) - -end module kinds - Index: branches/attic/boschmann_standalone/pri/lib/coordinates.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/coordinates.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/coordinates.f03.pri (revision 8609) @@ -1,1012 +0,0 @@ -!!! module: coordinates_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-09 13:50:58 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module coordinates_module - use kinds - use momentum_module - use arguments_module - use common_module - use parameters_module - implicit none - abstract interface - function trafo_in(in) - use kinds - real(kind=double),dimension(3)::trafo_in - real(kind=double),dimension(3),intent(in)::in - end function trafo_in - end interface - abstract interface - pure function coord_scalar_in(hyp) - use kinds - real(kind=double)::coord_scalar_in - real(kind=double),dimension(3),intent(in)::hyp - end function coord_scalar_in - end interface - abstract interface - subroutine coord_hcd_in(hyp,cart,denom) - use kinds - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double),dimension(3),intent(out)::cart - real(kind=double),intent(out)::denom - end subroutine coord_hcd_in - end interface - interface - pure function alphaspdf(Q) - use kinds - real(kind=double)::alphaspdf - real(kind=double),intent(in)::Q - end function alphaspdf - end interface - interface - pure subroutine evolvepdf(x,q,f) - use kinds - real(kind=double),intent(in)::x,q - real(kind=double),intent(out),dimension(-6:6)::f - end subroutine evolvepdf - end interface -! procedure(alpha_s_interface)::alphasPDF -! procedure(evolvepdf_interface)::evolvepdf - real(kind=double)::pts2_scale -! real(kind=double),private :: gev2_q_min,gev2_q_max,x_min,x_max - -contains - - subroutine coordinates_module_init() -! call SetLHAPARM(pdfverbose) -! call SetLHAPARM(0) - call InitPDFsetByName(pdf_file%get_actual_value()) - call initpdf(1) -!!$ call GetQ2min(1,gev2_q_min) -!!$ call GetQ2max(1,gev2_q_max) -!!$ call Getxmin(1,x_min) -!!$ call Getxmax(1,x_max) -!!$ if (gev2_q_min>1D0) then -!!$ print ('("coordinates_module_init: Minimal value for Q^2 of ",E14.7,"GeV^2 is to high. We need at last 1 GeV^2.")'),gev2_q_min -!!$ end if -!!$ if (gev2_q_max<1D0) then -!!$ print ('("coordinates_module_init: Maximal value for Q^2 of ",E14.7,"GeV^2 is to low. We need at least ",E14.7,"GeV^2.")'),& -!!$ &gev2_q_max,gev2_pt_max -!!$ end if -!!$ if (x_min>sqrt(1D0/gev_pt_max)) then -!!$ print ('("coordinates_module_init: Minimal value for x of ",E14.7," is to high. We need at last ",E14.7,".")') ,x_min -!!$ end if -!!$ if (x_max<1D0) then -!!$ print ('("coordinates_module_init: Maximal value for x of ",E14.7," is to low. We need 1.")') ,x_max -!!$ end if -! open(51,file='a') -! open(52,file='b') -! open(53,file='c') -! open(54,file='d') - end subroutine coordinates_module_init - - pure function id(a) - real(kind=double),dimension(:),intent(in)::a - real(kind=double),dimension(size(a))::id - id=a - end function id - - pure function h_to_c_ort(hyp) - real(kind=double),dimension(3)::h_to_c_ort - real(kind=double),dimension(3),intent(in)::hyp - h_to_c_ort=& - &[sqrt(sqrt(((hyp(1)*(1D0-hyp(3)))+hyp(3))**2+(hyp(2)-(5D-1))**2)-(hyp(2)-(5D-1)))& - &,sqrt(sqrt(((hyp(1)*(1D0-hyp(3)))+hyp(3))**2+(hyp(2)-(5D-1))**2)+(hyp(2)-(5D-1)))& - &,hyp(3)] - end function h_to_c_ort - - pure function c_to_h_ort(cart) - real(kind=double),dimension(3)::c_to_h_ort - real(kind=double),dimension(3),intent(in)::cart - c_to_h_ort=[(cart(3)-(cart(1)*cart(2)))/(cart(3)-1D0),(1D0 - cart(1)**2 + cart(2)**2)/2D0,cart(3)] - end function c_to_h_ort - - pure function h_to_c_noparam(hyp) - real(kind=double),dimension(2)::h_to_c_noparam - real(kind=double),dimension(2),intent(in)::hyp - h_to_c_noparam=& - &[sqrt(sqrt(hyp(1)**8+(((hyp(2)-(5D-1))**3)*4)**2)-((hyp(2)-(5D-1))**3)*4)& - &,sqrt(sqrt(hyp(1)**8+(((hyp(2)-(5D-1))**3)*4)**2)+((hyp(2)-(5D-1))**3)*4)] - end function h_to_c_noparam - - pure function c_to_h_noparam(cart) - real(kind=double),dimension(2)::c_to_h_noparam - real(kind=double),dimension(2),intent(in)::cart - c_to_h_noparam=& - &[sqrt(sqrt(cart(1)*cart(2)))& - &,(1D0+sign(abs((cart(2)**2) - (cart(1)**2))**(1/3D0),cart(2)-cart(1)))/2D0] - end function c_to_h_noparam - - pure function h_to_c_param(hyp) - real(kind=double),dimension(3)::h_to_c_param - real(kind=double),dimension(3),intent(in)::hyp - h_to_c_param=& - &[sqrt(sqrt((((hyp(1)**4)*(1D0-hyp(3)))+hyp(3))**2+(((hyp(2)-(5D-1))**3)*4)**2)-((hyp(2)-(5D-1))**3)*4)& - &,sqrt(sqrt((((hyp(1)**4)*(1D0-hyp(3)))+hyp(3))**2+(((hyp(2)-(5D-1))**3)*4)**2)+((hyp(2)-(5D-1))**3)*4)& - &,hyp(3)] - end function h_to_c_param - - pure function c_to_h_param(cart) - real(kind=double),dimension(3)::c_to_h_param - real(kind=double),dimension(3),intent(in)::cart - c_to_h_param=& - &[(((cart(1)*cart(2)) - cart(3))/(1D0 - cart(3)))**(1/4D0)& - &,(1D0+sign(abs((cart(2)**2) - (cart(1)**2))**(1/3D0),cart(2)-cart(1)))/2D0& - &,cart(3)] - end function c_to_h_param - - pure function h_to_c_smooth(hyp) - real(kind=double),dimension(3)::h_to_c_smooth - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double)::h2 - h2=(((hyp(2)-5D-1)**3)*4D0+hyp(2)-5D-1)/2D0 - h_to_c_smooth=& - &[sqrt(sqrt((((hyp(1)**4)*(1D0-hyp(3)))+hyp(3))**2+h2**2)-h2)& - &,sqrt(sqrt((((hyp(1)**4)*(1D0-hyp(3)))+hyp(3))**2+h2**2)+h2)& - &,hyp(3)] - end function h_to_c_smooth - - pure function c_to_h_smooth(cart) - real(kind=double),dimension(3)::c_to_h_smooth - real(kind=double),dimension(3),intent(in)::cart - c_to_h_smooth=& - &[((product(cart(1:2))-cart(3))/(1D0-cart(3)))**(1/4D0)& - &,(3D0-3D0**(2D0/3)/(-9D0*cart(1)**2 + 9D0*cart(2)**2 + sqrt(3D0+81D0*(cart(1)**2-cart(2)**2)**2))**(1D0/3) + 3**(1D0/3)*(-9D0*cart(1)**2 + 9D0*cart(2)**2 + sqrt(3D0 + 81D0*(cart(1)**2 - cart(2)**2)**2))**(1D0/3))/6D0,cart(3)] - end function c_to_h_smooth - - pure function h_to_c_ort_def(hyp) - real(kind=double),dimension(3)::h_to_c_ort_def - real(kind=double),dimension(3),intent(in)::hyp - h_to_c_ort_def=h_to_c_ort([hyp(1),hyp(2),pts2_scale]) - end function h_to_c_ort_def - - pure function c_to_h_ort_def(cart) - real(kind=double),dimension(3)::c_to_h_ort_def - real(kind=double),dimension(3),intent(in)::cart - c_to_h_ort_def=c_to_h_ort([cart(1),cart(2),pts2_scale]) - end function c_to_h_ort_def - - pure function h_to_c_param_def(hyp) - real(kind=double),dimension(3)::h_to_c_param_def - real(kind=double),dimension(3),intent(in)::hyp - h_to_c_param_def=h_to_c_param([hyp(1),hyp(2),pts2_scale]) - end function h_to_c_param_def - - pure function c_to_h_param_def(cart) - real(kind=double),dimension(3)::c_to_h_param_def - real(kind=double),dimension(3),intent(in)::cart - if(product(cart(1:2))>=pts2_scale)then - c_to_h_param_def=c_to_h_param([cart(1),cart(2),pts2_scale]) - else - c_to_h_param_def=[-1D0,-1D0,-1D0] - end if - end function c_to_h_param_def - - pure function h_to_c_smooth_def(hyp) - real(kind=double),dimension(3)::h_to_c_smooth_def - real(kind=double),dimension(3),intent(in)::hyp - h_to_c_smooth_def=h_to_c_smooth([hyp(1),hyp(2),pts2_scale]) - end function h_to_c_smooth_def - - pure function c_to_h_smooth_def(cart) - real(kind=double),dimension(3)::c_to_h_smooth_def - real(kind=double),dimension(3),intent(in)::cart - if(product(cart(1:2))>=pts2_scale)then - c_to_h_smooth_def=c_to_h_smooth([cart(1),cart(2),pts2_scale]) - else - c_to_h_smooth_def=[-1D0,-1D0,-1D0] - end if - end function c_to_h_smooth_def - - pure function voxel_h_to_c_ort(hyp) - real(kind=double)::voxel_h_to_c_ort - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double)::T,TH1 - T=1D0-hyp(3) - TH1=T*(1D0-hyp(1)) - voxel_h_to_c_ort=Sqrt(T**2/(5D0-4D0*(1D0-hyp(2))*hyp(2)-4D0*(2D0-TH1)*TH1)) - end function voxel_h_to_c_ort - - pure function voxel_c_to_h_ort(cart) - real(kind=double)::voxel_c_to_h_ort - real(kind=double),dimension(3),intent(in)::cart - real(kind=double)::P - P=product(cart(1:2)) - if(P>cart(3))then - voxel_c_to_h_ort=(cart(1)**2 + cart(2)**2)/(1D0-cart(3)) - else - voxel_c_to_h_ort=0D0 - end if - end function voxel_c_to_h_ort - - pure function voxel_h_to_c_noparam(hyp) - real(kind=double)::voxel_h_to_c_noparam - real(kind=double),dimension(3),intent(in)::hyp - voxel_h_to_c_noparam=12D0*Sqrt((hyp(1)**6*(1D0-2D0*hyp(2))**4)/(4*hyp(1)**8+(1D0-2D0*hyp(2))**6)) - end function voxel_h_to_c_noparam - - pure function voxel_c_to_h_noparam(cart) - real(kind=double)::voxel_c_to_h_noparam - real(kind=double),dimension(3),intent(in)::cart - real(kind=double)::P - voxel_c_to_h_noparam=(cart(1)**2+cart(2)**2)/(12D0*(cart(1)*cart(2))**(3D0/4D0)*(cart(2)**2+cart(1)**2)**(2D0/3D0)) - end function voxel_c_to_h_noparam - - pure function voxel_h_to_c_param(hyp) - real(kind=double)::voxel_h_to_c_param - real(kind=double),dimension(3),intent(in)::hyp - voxel_h_to_c_param=12*Sqrt((hyp(1)**6*(1D0-2D0*hyp(2))**4*(hyp(3)-1D0)**2)/((1D0-2D0*hyp(2))**6+4D0*(hyp(3)-(hyp(1)**4*(hyp(3)-1D0)))**2)) - end function voxel_h_to_c_param - - pure function voxel_c_to_h_param(cart) - real(kind=double)::voxel_c_to_h_param - real(kind=double),dimension(3),intent(in)::cart - real(kind=double)::P,T,CP,CM - P=product(cart(1:2)) - if(P>cart(3))then - P=P-cart(3) - CP=cart(1)**2+cart(2)**2 - CM=abs(cart(2)**2-cart(1)**2) - T=1-cart(3) - voxel_c_to_h_param=(Cp*sqrt(sqrt(P/T)))/(12*Cm**(2D0/3D0)*P) - else - voxel_c_to_h_param=0D0 - end if - end function voxel_c_to_h_param - - pure function voxel_h_to_c_smooth(hyp) - real(kind=double)::voxel_h_to_c_smooth - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double)::T - T=1D0-hyp(3) - voxel_h_to_c_smooth=& - &8D0*(hyp(1)**3*(1D0+3D0*(hyp(2)-1D0)*hyp(2))*T)& - &/sqrt((1D0-2D0*hyp(2)*(2D0+hyp(2)*(2D0*hyp(2)-3D0)))**2+4D0*(1D0+(hyp(1)**4-1D0)*T)**2) - end function voxel_h_to_c_smooth - - pure function voxel_c_to_h_smooth(cart) - real(kind=double)::voxel_c_to_h_smooth - real(kind=double),dimension(3),intent(in)::cart - real(kind=double)::P,S,T,CM,CP - P=product(cart(1:2)) - if(P>cart(3))then - P=P-cart(3) - CP=cart(1)**2+cart(2)**2 - CM=cart(2)**2-cart(1)**2 - T=1-cart(3) - S=sqrt(3D0+81D0*cm**2) - voxel_c_to_h_smooth=(3D0**(1D0/3D0)*Cp*(3D0**(1D0/3D0)+(9D0*Cm+S)**(2D0/3D0))*sqrt(sqrt(P/T)))/(4D0*P*S*(9D0*Cm+S)**(1D0/3D0)) - else - voxel_c_to_h_smooth=0D0 - end if -end function voxel_c_to_h_smooth - -! - - pure function voxel_h_to_c_ort_def(hyp) - real(kind=double)::voxel_h_to_c_ort_def - real(kind=double),dimension(3),intent(in)::hyp - voxel_h_to_c_ort_def=voxel_h_to_c_ort(hyp) - end function voxel_h_to_c_ort_def - - pure function voxel_c_to_h_ort_def(cart) - real(kind=double)::voxel_c_to_h_ort_def - real(kind=double),dimension(3),intent(in)::cart - voxel_c_to_h_ort_def=voxel_c_to_h_ort(cart) - end function voxel_c_to_h_ort_def - - pure function voxel_h_to_c_param_def(hyp) - real(kind=double)::voxel_h_to_c_param_def - real(kind=double),dimension(3),intent(in)::hyp - voxel_h_to_c_param_def=voxel_h_to_c_param(hyp) - end function voxel_h_to_c_param_def - - pure function voxel_c_to_h_param_def(cart) - real(kind=double)::voxel_c_to_h_param_def - real(kind=double),dimension(3),intent(in)::cart - voxel_c_to_h_param_def=voxel_c_to_h_param(cart) - end function voxel_c_to_h_param_def - - pure function voxel_h_to_c_smooth_def(hyp) - real(kind=double)::voxel_h_to_c_smooth_def - real(kind=double),dimension(3),intent(in)::hyp - voxel_h_to_c_smooth_def=voxel_h_to_c_smooth(hyp) - end function voxel_h_to_c_smooth_def - - pure function voxel_c_to_h_smooth_def(cart) - real(kind=double)::voxel_c_to_h_smooth_def - real(kind=double),dimension(3),intent(in)::cart - voxel_c_to_h_smooth_def=voxel_c_to_h_smooth(cart) - end function voxel_c_to_h_smooth_def - - pure function denom_cart(cart) - real(kind=double)::denom_cart - real(kind=double),dimension(3),intent(in)::cart - denom_cart=1D0/(864D0*Sqrt(cart(3)**3*(1D0-cart(3)/product(cart(1:2))))) - end function denom_cart - - pure function denom_ort(hyp) - real(kind=double)::denom_ort - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double)::Y,P - Y=(1D0-2D0*hyp(2))**2 - P=1D0-hyp(3) - if(hyp(1)>0D0.and.hyp(3)>0D0)then - denom_ort=sqrt((P + (-1 + Hyp(1))*P**2)/(746496*hyp(1)*hyp(3)**3*(4*(1 + (-1 + hyp(1))*P)**2 + Y))) - - else - denom_ort=0D0 - end if - end function denom_ort - - pure function denom_param(hyp) - real(kind=double)::denom_param - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double)::X,Y,P - X=hyp(1)**4 - Y=1D0-2D0*hyp(2) - P=1D0-hyp(3) - if(hyp(3)>0D0)then - denom_param=sqrt((P*(1+P*(X-1))*Sqrt(X)*Y**4)/(5184*(4*(1+P*(X-1))**2+Y**6)*hyp(3)**3)) - else - denom_param=0D0 - end if - end function denom_param - - pure function denom_param_reg(hyp) - real(kind=double)::denom_param_reg - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double)::X,Y,P - X=hyp(1)**4 - Y=1D0-2D0*hyp(2) - P=1D0-hyp(3) - if(hyp(3)>0D0)then - denom_param_reg=sqrt((P*(1+P*(X-1))*Sqrt(X)*Y**4)/(5184*(4*(1+P*(X-1))**2+Y**6)*(hyp(3)+norm2_p_t_0)**3)) - else - denom_param_reg=0D0 - end if - end function denom_param_reg - - pure function denom_smooth(hyp) - real(kind=double)::denom_smooth - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double)::X,Y,P - X=hyp(1)**2 - Y=(1D0-2D0*hyp(2))**2 - P=1D0-hyp(3) - if(hyp(3)>0D0)then - denom_smooth=sqrt((P*X*(1 + P*(-1 + X**2))*(1 + 3*Y)**2)/(46656*hyp(3)**3*(16*(1 + P*(-1 + X**2))**2 + Y + 2*Y**2 + Y**3))) - else - denom_smooth=0D0 - end if - end function denom_smooth - - pure function denom_smooth_reg(hyp) - real(kind=double)::denom_smooth_reg - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double)::X,Y,P - X=hyp(1)**2 - Y=(1D0-2D0*hyp(2))**2 - P=1D0-hyp(3) - if(hyp(3)>0D0)then - denom_smooth_reg=sqrt((P*X*(1 + P*(-1 + X**2))*(1 + 3*Y)**2)/(46656*(hyp(3)+norm2_p_t_0)**3*(16*(1 + P*(-1 + X**2))**2 + Y + 2*Y**2 + Y**3))) - else - denom_smooth_reg=0D0 - end if - end function denom_smooth_reg - - pure function denom_cart_save(cart) - real(kind=double)::denom_cart_save - real(kind=double),dimension(3),intent(in)::cart - if(product(cart(1:2))>cart(3))then - denom_cart_save=denom_cart(cart) - else - denom_cart_save=0D0 - end if - end function denom_cart_save - - pure function denom_ort_save(hyp) - real(kind=double)::denom_ort_save - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double)::Y,Z,W - real(kind=double),dimension(3)::cart - cart=h_to_c_ort(hyp) - if(cart(1)>1D0.or.cart(2)>1D0)then - denom_ort_save=0D0 - else - denom_ort_save=denom_ort(hyp) - end if - end function denom_ort_save - - pure function denom_param_save(hyp) - real(kind=double)::denom_param_save - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double)::Y,Z,W - real(kind=double),dimension(3)::cart - cart=h_to_c_param(hyp) - if(cart(1)>1D0.or.cart(2)>1D0)then - denom_param_save=0D0 - else - denom_param_save=denom_param(hyp) - end if - end function denom_param_save - -! pure - function denom_smooth_save(hyp) - real(kind=double)::denom_smooth_save - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double)::Y,Z,W - real(kind=double),dimension(3)::cart - cart=h_to_c_smooth(hyp) - if(cart(1)>1D0.or.cart(2)>1D0)then - denom_smooth_save=0D0 - else - denom_smooth_save=denom_smooth(hyp) - end if - end function denom_smooth_save - - subroutine denom_cart_cuba_int(d_cart,cart,d_denom,denom,pt2s) - real(kind=double),dimension(3),intent(in)::cart - real(kind=double),dimension(1),intent(out)::denom - real(kind=double),intent(in) :: pt2s - integer,intent(in)::d_cart,d_denom - denom(1)=denom_cart_save([cart(1),cart(2),pt2s]) - end subroutine denom_cart_cuba_int - - subroutine denom_ort_cuba_int(d_hyp,hyp,d_denom,denom,pt2s) - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double),dimension(1),intent(out)::denom - real(kind=double),intent(in) :: pt2s - integer,intent(in)::d_hyp,d_denom - denom(1)=denom_ort_save([hyp(1),hyp(2),pt2s]) - end subroutine denom_ort_cuba_int - - subroutine denom_param_cuba_int(d_hyp,hyp,d_denom,denom,pt2s) - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double),dimension(1),intent(out)::denom - real(kind=double),intent(in) :: pt2s - integer,intent(in)::d_hyp,d_denom - denom(1)=denom_param_save([hyp(1),hyp(2),pt2s]) - end subroutine denom_param_cuba_int - - subroutine denom_smooth_cuba_int(d_hyp,hyp,d_denom,denom,pt2s) - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double),dimension(1),intent(out)::denom - real(kind=double),intent(in) :: pt2s - integer,intent(in)::d_hyp,d_denom - denom(1)=denom_smooth_save([hyp(1),hyp(2),pt2s]) - end subroutine denom_smooth_cuba_int - - subroutine coordinates_hcd_cart(hyp,cart,denom) - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double),dimension(3),intent(out)::cart - real(kind=double),intent(out)::denom - cart=hyp - denom=denom_cart_save(cart) - end subroutine coordinates_hcd_cart - - subroutine coordinates_hcd_ort(hyp,cart,denom) - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double),dimension(3),intent(out)::cart - real(kind=double),intent(out)::denom - cart=h_to_c_ort(hyp) - denom=denom_ort(hyp) - end subroutine coordinates_hcd_ort - - subroutine coordinates_hcd_param(hyp,cart,denom) - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double),dimension(3),intent(out)::cart - real(kind=double),intent(out)::denom - cart=h_to_c_param(hyp) - denom=denom_param(hyp) - end subroutine coordinates_hcd_param - - subroutine coordinates_hcd_param_reg(hyp,cart,denom) - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double),dimension(3),intent(out)::cart - real(kind=double),intent(out)::denom - cart=h_to_c_param(hyp) - denom=denom_param_reg(hyp) - end subroutine coordinates_hcd_param_reg - - subroutine coordinates_hcd_smooth(hyp,cart,denom) - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double),dimension(3),intent(out)::cart - real(kind=double),intent(out)::denom - cart=h_to_c_smooth(hyp) - denom=denom_smooth(hyp) - end subroutine coordinates_hcd_smooth - - subroutine coordinates_hcd_smooth_reg(hyp,cart,denom) - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double),dimension(3),intent(out)::cart - real(kind=double),intent(out)::denom - cart=h_to_c_smooth(hyp) - denom=denom_smooth_reg(hyp) - end subroutine coordinates_hcd_smooth_reg - - pure function pdf_in_in_kind(process_id,double_pdf_id,c1,c2,gev_pt) - real(kind=double)::pdf_in_in_kind - real(kind=double),intent(in)::c1,c2,gev_pt - integer,intent(in)::process_id,double_pdf_id - real(kind=double)::pdf1,pdf2 - call single_pdf(valid_processes(1,process_id),double_pdf_kinds(1,double_pdf_id),c1,gev_pt,pdf1) - call single_pdf(valid_processes(2,process_id),double_pdf_kinds(2,double_pdf_id),c2,gev_pt,pdf2) - pdf_in_in_kind=pdf1*pdf2 - contains - pure subroutine single_pdf(flavor,pdf_kind,c,gev_pt,pdf) - integer,intent(in)::flavor,pdf_kind - real(kind=double),intent(in)::c,gev_pt - real(kind=double),intent(out)::pdf - real(kind=double),dimension(-6:6)::lha_pdf - call evolvePDF(c,gev_pt,lha_pdf) - select case(pdf_kind) - case(1) - pdf=lha_pdf(0) - case(2) - if(flavor==1.or.flavor==2)then - pdf=lha_pdf(-flavor) - else - pdf=lha_pdf(flavor) - end if - case(3) - pdf=lha_pdf(1)-lha_pdf(-1) - case(4) - pdf=lha_pdf(2)-lha_pdf(-2) - end select - end subroutine single_pdf - end function pdf_in_in_kind - - elemental function ps_io_pol(process_io_id,pt2shat) - real(kind=double)::ps_io_pol - integer,intent(in)::process_io_id - real(kind=double),intent(in)::pt2shat - ps_io_pol=dot_product(& - &[1D0,pt2shat,pt2shat**2,pt2shat**3]& - &,phase_space_coefficients_inout(1:4,valid_processes(6,process_io_id))) - end function ps_io_pol - - pure subroutine coordinates_dddsigma(process_id,double_pdf_id,hyp,cart,dddsigma) - real(kind=double),intent(out)::dddsigma - integer,intent(in)::process_id,double_pdf_id - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double),dimension(3),intent(out)::cart - real(kind=double)::a,pt2shat,gev_pt - cart=h_to_c_param(hyp) - a=product(cart(1:2)) - if(cart(1)<=1D0.and.cart(2)<=1D0)then - pt2shat=hyp(3)/a - gev_pt=sqrt(hyp(3))*gev_pt_max -! print *,process_id,pt2shat - dddsigma=& - &const_pref& - &*alphasPDF(gev_pt)**2& - &*ps_io_pol(process_id,pt2shat)& - &*pdf_in_in_kind(process_id,double_pdf_id,cart(1),cart(2),gev_pt)& - &*denom_param(hyp)& - &/a - else - dddsigma=0D0 - end if - end subroutine coordinates_dddsigma - - pure subroutine coordinates_dddsigma_reg(process_id,double_pdf_id,hyp,cart,dddsigma) - real(kind=double),intent(out)::dddsigma - integer,intent(in)::process_id,double_pdf_id - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double),dimension(3),intent(out)::cart - real(kind=double)::a,pt2shat,gev_pt,gev2_pt - cart=h_to_c_param(hyp) - a=product(cart(1:2)) - if(cart(1)<=1D0.and.cart(2)<=1D0)then - pt2shat=hyp(3)/a - gev_pt=sqrt(hyp(3))*gev_pt_max - gev2_pt=hyp(3)*gev2_pt_max -! print *,process_id,pt2shat - dddsigma=& - &const_pref& - &*alphasPDF(sqrt(gev2_pt+gev2_p_t_0))**2& - &*ps_io_pol(process_id,pt2shat)& - &*pdf_in_in_kind(process_id,double_pdf_id,cart(1),cart(2),gev_pt)& - &*denom_param_reg(hyp)& - &/a - else - dddsigma=0D0 - end if - end subroutine coordinates_dddsigma_reg - - subroutine coordinates_dddsigma_print(process_id,double_pdf_id,hyp,cart,dddsigma) - real(kind=double),intent(out)::dddsigma - integer,intent(in)::process_id,double_pdf_id - real(kind=double),dimension(3),intent(in)::hyp - real(kind=double),dimension(3),intent(out)::cart - real(kind=double)::a,pt2shat,gev_pt - cart=h_to_c_param(hyp) - a=product(cart(1:2)) - if(cart(1)<=1D0.and.cart(2)<=1D0)then - pt2shat=hyp(3)/a - gev_pt=sqrt(hyp(3))*gev_pt_max -! print *,process_id,pt2shat - dddsigma=& - &const_pref& -! &*alphasPDF(gev_pt)**2& - &*ps_io_pol(process_id,pt2shat)& - &*pdf_in_in_kind(process_id,double_pdf_id,cart(1),cart(2),gev_pt)& - &*denom_param(hyp)& - &/a - else - dddsigma=0D0 - end if - write(11,fmt=*)dddsigma,pt2shat,pdf_in_in_kind(process_id,double_pdf_id,cart(1),cart(2),gev_pt),ps_io_pol(process_id,pt2shat),const_pref,denom_param(hyp),a - flush(11) - end subroutine coordinates_dddsigma_print - - pure subroutine coordinates_dddsigma_cart(process_id,double_pdf_id,cart,dddsigma) - real(kind=double),intent(out)::dddsigma - integer,intent(in)::process_id,double_pdf_id - real(kind=double),dimension(3),intent(in)::cart - real(kind=double)::a,pt2shat,gev_pt - a=product(cart(1:2)) - if(cart(1)<=1D0.and.cart(2)<=1D0)then - pt2shat=cart(3)/a - gev_pt=sqrt(cart(3))*gev_pt_max -! print *,process_id,pt2shat - dddsigma=& - &const_pref& - &*alphasPDF(gev_pt)**2& - &*ps_io_pol(process_id,pt2shat)& - &*pdf_in_in_kind(process_id,double_pdf_id,cart(1),cart(2),gev_pt)& - &*denom_cart(cart)& - &/a - else - dddsigma=0D0 - end if - end subroutine coordinates_dddsigma_cart - - subroutine cuba_gg_me_smooth(d_hyp,hyp,d_me,me,pt2s) - integer,intent(in)::d_hyp,d_me - real(kind=double),dimension(d_hyp),intent(in)::hyp - real(kind=double),dimension(1),intent(out)::me - real(kind=double),dimension(3)::cart - real(kind=double),intent(in)::pt2s - real(kind=double)::p,p2 - if(d_hyp==3)then - p=hyp(3) - p2=hyp(3)**2 - else - if(d_hyp==2)then - p=sqrt(pt2s) - p2=pt2s - end if - end if - cart=h_to_c_smooth([hyp(1),hyp(2),p2]) - if(p>pts_min.and.product(cart(1:2))>p2)then - me(1)=& - &const_pref& - &*alphasPDF(p*gev_pt_max)**2& - &*ps_io_pol(109,p2)& - &*pdf_in_in_kind(109,11,cart(1),cart(2),p2)& - &*denom_smooth([hyp(1),hyp(2),p2])& - &/product(cart(1:2)) - else - me(1)=0D0 - end if - end subroutine cuba_gg_me_smooth - - subroutine cuba_gg_me_param(d_hyp,hyp,d_me,me,pt2s) - integer,intent(in)::d_hyp,d_me - real(kind=double),dimension(d_hyp),intent(in)::hyp - real(kind=double),dimension(1),intent(out)::me - real(kind=double),dimension(3)::cart - real(kind=double),intent(in)::pt2s - real(kind=double)::p,p2 - if(d_hyp==3)then - p=hyp(3) - p2=hyp(3)**2 - else - if(d_hyp==2)then - p=sqrt(pt2s) - p2=pt2s - end if - end if - cart=h_to_c_param([hyp(1),hyp(2),p2]) - if(p>pts_min.and.product(cart(1:2))>p2)then - me(1)=& - &const_pref& - &*alphasPDF(p*gev_pt_max)**2& - &*ps_io_pol(109,p2)& - &*pdf_in_in_kind(109,11,cart(1),cart(2),p2)& - &*denom_param([hyp(1),hyp(2),p2])& - &/product(cart(1:2)) - else - me(1)=0D0 - end if - end subroutine cuba_gg_me_param - - subroutine cuba_gg_me_ort(d_hyp,hyp,d_me,me,pt2s) - integer,intent(in)::d_hyp,d_me - real(kind=double),dimension(d_hyp),intent(in)::hyp - real(kind=double),dimension(1),intent(out)::me - real(kind=double),dimension(3)::cart - real(kind=double),intent(in)::pt2s - real(kind=double)::p,p2 - if(d_hyp==3)then - p=hyp(3) - p2=hyp(3)**2 - else - if(d_hyp==2)then - p=sqrt(pt2s) - p2=pt2s - end if - end if - cart=h_to_c_ort([hyp(1),cart(2),p2]) - if(p>pts_min.and.product(cart(1:2))>p2)then - me(1)=& - &const_pref& - &*alphasPDF(p*gev_pt_max)**2& - &*ps_io_pol(109,p2)& - &*pdf_in_in_kind(109,11,cart(1),cart(2),p2)& - &*denom_ort([hyp(1),hyp(2),p2])& - &/product(cart(1:2)) - else - me(1)=0D0 - end if - end subroutine cuba_gg_me_ort - - subroutine cuba_gg_me_cart(d_cart,cart,d_me,me,pt2s) - integer,intent(in)::d_cart,d_me - real(kind=double),dimension(d_cart),intent(in)::cart - real(kind=double),dimension(1),intent(out)::me - real(kind=double),intent(in)::pt2s - real(kind=double)::a,p,p2 - if(d_cart==3)then - p=cart(3) - p2=cart(3)**2 - else - if(d_cart==2)then - p=sqrt(pt2s) - p2=pt2s - end if - end if - a=product(cart(1:2)) - if(p>pts_min.and.a>p2)then - me(1)=& - &const_pref& - &*alphasPDF(p*gev_pt_max)**2& - &*ps_io_pol(109,p2)& - &*pdf_in_in_kind(109,11,cart(1),cart(2),p2)& - &*denom_cart([cart(1),cart(2),p2])& - &/a - else - me(1)=0D0 - end if - end subroutine cuba_gg_me_cart - - subroutine coordinates_proton_proton_integrand_generic_17_reg(hyp_2,trafo,f,pt) - real(kind=double),dimension(2),intent(in)::hyp_2 - procedure(coord_hcd_in)::trafo - real(kind=double),dimension(17),intent(out)::f - type(transversal_momentum_type), intent(in) :: pt - real(kind=double),dimension(3)::cart,hyp_3 - real(kind=double),dimension(5)::psin - real(kind=double),dimension(-6:6)::c,d - real(kind=double)::gev_pt,gev2_pt,pts,pt2s,pt2shat,a,& - pdf_seaquark_seaquark,pdf_seaquark_gluon,pdf_gluon_gluon,& - pdf_up_seaquark,pdf_up_gluon,pdf_down_seaquark,pdf_down_gluon,& - v1u,v1d,v2u,v2d,denom - - pts=pt%get_unit_scale() - pt2s=pt%get_unit2_scale() - gev_pt=pt%get_gev_scale() - gev2_pt=pt%get_gev2_scale() - - hyp_3(1:2)=hyp_2 - hyp_3(3)=pt2s - call trafo(hyp_3,cart,denom) - a=product(cart(1:2)) - if(cart(1)<=1D0.and.cart(2)<=1D0.and.a>pt2s)then - pt2shat=pt2s/a - - ! phase space polynom - psin=matmul([1D0,pt2shat,pt2shat**2,pt2shat**3],phase_space_coefficients_in) - ! pdf - call evolvepdf(cart(1),gev_pt,c) - call evolvepdf(cart(2),gev_pt,d) - !c=[1,1,1,1,1,1,1,1,1,1,1,1,1]*1D0 - !d=c - v1d=c(1)-c(-1) - v1u=c(2)-c(-2) - v2d=d(1)-d(-1) - v2u=d(2)-d(-2) - c(1)=c(-1) - c(2)=c(-2) - d(1)=d(-1) - d(2)=d(-2) - f(1)=0D0 - !gluon_gluon - f( 2)=(& - !type5 - &c(0)*d(0)& - &)*psin(5) - !gluon_seaquark - f( 3)=(& - !type4 - &c(0)*d(-4)+c(0)*d(-3)+c(0)*d(-2)+c(0)*d(-1)+c(0)*d(1)+c(0)*d(2)+c(0)*d(3)+c(0)*d(4)& - &)*psin(4) - !gluon_down - f( 4)=(& - !type4 - &c( 0)*v2d& - &)*psin(4) - !gluon_up - f( 5)=(& - !type4 - &c(0)*v2u& - &)*psin(4) - !seaquark_gluon - f( 6)=(& - !type4 - &c(-4)*d(0)+c(-3)*d(0)+c(-2)*d(0)+c(-1)*d(0)+c(1)*d(0)+c(2)*d(0)+c(3)*d(0)+c(4)*d(0)& - &)*psin(4) - !seaquark_seaquark - f( 7)=& - !type1 - (c(-4)*d(-3)+c(-4)*d(-2)+c(-4)*d(-1)+c(-4)*d( 1)+c(-4)*d( 2)+c(-4)*d( 3)+& - c(-3)*d(-4)+c(-3)*d(-2)+c(-3)*d(-1)+c(-3)*d( 1)+c(-3)*d( 2)+c(-3)*d( 4)+& - c(-2)*d(-4)+c(-2)*d(-3)+c(-2)*d(-1)+c(-2)*d( 1)+c(-2)*d( 3)+c(-2)*d( 4)+& - c(-1)*d(-4)+c(-1)*d(-3)+c(-1)*d(-2)+c(-1)*d( 2)+c(-1)*d( 3)+c(-1)*d( 4)+& - c( 1)*d(-4)+c( 1)*d(-3)+c( 1)*d(-2)+c( 1)*d( 2)+c( 1)*d( 3)+c( 1)*d( 4)+& - c( 2)*d(-4)+c( 2)*d(-3)+c( 2)*d(-1)+c( 2)*d( 1)+c( 2)*d( 3)+c( 2)*d( 4)+& - c( 3)*d(-4)+c( 3)*d(-2)+c( 3)*d(-1)+c( 3)*d( 1)+c( 3)*d( 2)+c( 3)*d( 4)+& - c( 4)*d(-3)+c( 4)*d(-2)+c( 4)*d(-1)+c( 4)*d( 1)+c( 4)*d( 2)+c( 4)*d( 3))& - *psin(1)& - !type2 - +(c(-4)*d(-4)+c(-3)*d(-3)+c(-2)*d(-2)+c(-1)*d(-1)+c( 4)*d( 4)+c( 3)*d( 3)+c(2)*d( 2)+c(1)*d( 1))& - *psin(2)& - !type3 - +(c(-4)*d( 4)+c(-3)*d( 3)+c(-2)*d( 2)+c(-1)*d( 1)+c( 4)*d(-4)+c( 3)*d(-3)+c(2)*d(-2)+c(1)*d(-1))& - *psin(3) - !seaquark_down - f( 8)=& - !type1 - (c(-4)*v2d+c(-3)*v2d+c(-2)*v2d+c( 2)*v2d+c( 3)*v2d+c( 4)*v2d)& - *psin(1)& - !type2 - +c( 1)*v2d& - *psin(2)& - !type3 - +c(-1)*v2d& - *psin(3) - !seaquark_up - f( 9)=& - !type1 - (c(-4)*v2u+c(-3)*v2u+c(-1)*v2u+c( 1)*v2u+c( 3)*v2u+c( 4)*v2u)& - *psin(1)& - !type2 - +c(2)*v2u& - *psin(2)& - !type3 - +c(-2)*v2u& - *psin(3) - !down_gluon - f(10)=(& - !type4 - v1d*d( 0)& - )*psin(4) - !down_seaquark - f(11)=& - !type1 - (v1d*d(-4)+v1d*d(-3)+v1d*d(-2)+v1d*d( 2)+v1d*d( 3)+v1d*d( 4))& - *psin(1)& - !type2 - +v1d*d( 1)& - *psin(2)& - !type3 - +v1d*d(-1)& - *psin(3) - !down_down - f(12)=v1d*v2d*psin(2) - !down_up - f(13)=v1d*v2u*psin(1) - !up_gluon - f(14)=(& - !type4 - &v1u*d(0)& - &)*psin(4) - !up_seaquark - f(15)=& - !type1 - (v1u*d(-4)+v1u*d(-3)+v1u*d(-1)+v1u*d( 1)+v1u*d( 3)+v1u*d( 4))& - *psin(1)& - !type2 - +v1u*d(2)& - *psin(2)& - !type3 - +v1u*d(-2)& - *psin(3) - !up_down - f(16)=v1u*v2d*psin(1) - !up_up - f(17)=v1u*v2u*psin(2) - f=f& - *const_pref& - *alphasPDF(sqrt(gev2_pt+gev2_p_t_0))**2& - *denom& - /a - ! print *,const_pref,alphasPDF(gev_pt)**2,denom_smooth(hyp),a - else - f=[0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0] - end if -! print *,pt2shat,c(0)*d(0),psin(5),const_pref,alphasPDF(gev_pt)**2,denom,a - end subroutine coordinates_proton_proton_integrand_generic_17_reg - -!!$ subroutine coordinates_proton_proton_integrand_cart_11(d_hyp,hyp_2,d_f,f) -!!$ integer,intent(in)::d_hyp,d_f -!!$ real(kind=double),dimension(2),intent(in)::hyp_2 -!!$ real(kind=double),dimension(11),intent(out)::f -!!$ call coordinates_proton_proton_integrand_generic_11(hyp_2,coordinates_hcd_cart,f) -!!$! write (51,*)hyp_2,momentum_get_pts_scale(),f -!!$ end subroutine coordinates_proton_proton_integrand_cart_11 -!!$ -!!$ subroutine coordinates_proton_proton_integrand_ort_11(d_hyp,hyp_2,d_f,f) -!!$ integer,intent(in)::d_hyp,d_f -!!$ real(kind=double),dimension(2),intent(in)::hyp_2 -!!$ real(kind=double),dimension(11),intent(out)::f -!!$ call coordinates_proton_proton_integrand_generic_11(hyp_2,coordinates_hcd_ort,f) -!!$! write (52,*)hyp_2,momentum_get_pts_scale(),f -!!$ end subroutine coordinates_proton_proton_integrand_ort_11 -!!$ -!!$ subroutine coordinates_proton_proton_integrand_param_11(d_hyp,hyp_2,d_f,f) -!!$ integer,intent(in)::d_hyp,d_f -!!$ real(kind=double),dimension(2),intent(in)::hyp_2 -!!$ real(kind=double),dimension(11),intent(out)::f -!!$ call coordinates_proton_proton_integrand_generic_11(hyp_2,coordinates_hcd_param,f) -!!$! write (53,*)hyp_2,momentum_get_pts_scale(),f -!!$ end subroutine coordinates_proton_proton_integrand_param_11 -!!$ -!!$ subroutine coordinates_proton_proton_integrand_smooth_11(d_hyp,hyp_2,d_f,f) -!!$ integer,intent(in)::d_hyp,d_f -!!$ real(kind=double),dimension(2),intent(in)::hyp_2 -!!$ real(kind=double),dimension(11),intent(out)::f -!!$ call coordinates_proton_proton_integrand_generic_11(hyp_2,coordinates_hcd_smooth,f) -!!$! write (54,*)hyp_2,momentum_get_pts_scale(),f -!!$ end subroutine coordinates_proton_proton_integrand_smooth_11 - - subroutine coordinates_proton_proton_integrand_param_17_reg(d_hyp,hyp_2,d_f,f,pt) - integer,intent(in)::d_hyp,d_f - real(kind=double),dimension(2),intent(in)::hyp_2 - real(kind=double),dimension(17),intent(out)::f - type(transversal_momentum_type), intent(in) :: pt - call coordinates_proton_proton_integrand_generic_17_reg(hyp_2,coordinates_hcd_param_reg,f,pt) - ! write (53,*)hyp_2,momentum_get_pts_scale(),f - end subroutine coordinates_proton_proton_integrand_param_17_reg - - subroutine coordinates_proton_proton_integrand_smooth_17_reg(d_hyp,hyp_2,d_f,f,pt) - integer,intent(in)::d_hyp,d_f - real(kind=double),dimension(2),intent(in)::hyp_2 - real(kind=double),dimension(17),intent(out)::f - type(transversal_momentum_type), intent(in) :: pt - call coordinates_proton_proton_integrand_generic_17_reg(hyp_2,coordinates_hcd_smooth_reg,f,pt) - ! write (53,*)hyp_2,momentum_get_pts_scale(),f - end subroutine coordinates_proton_proton_integrand_smooth_17_reg - - -end module coordinates_module Index: branches/attic/boschmann_standalone/pri/lib/decision_tree.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/decision_tree.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/decision_tree.f03.pri (revision 8609) @@ -1,499 +0,0 @@ -!!! module: decision_tree_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2010 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2010-12-02 16:10:03 CET(+0100) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module decision_tree_module - use kinds - use basic_types_module - use misc_module,only:max_array - implicit none - integer,parameter::decision_tree_dimension=3 - real(kind=double),parameter::decision_tree_epsilon=1D-2 - real(kind=double)::t=0D0 - real(kind=double)::t1=0D0 - real(kind=double)::t2=0D0 - real(kind=double)::t3=0D0 - real(kind=double)::t4=0D0 - real(kind=double)::t5=0D0 - real(kind=double)::t6=0D0 - real(kind=double)::t7=0D0 - real(kind=double)::t8=0D0 - - type,extends(serializable_class)::decision_atom_type - integer::degeneracy=0 - real(kind=double),dimension(decision_tree_dimension)::coordinates - contains - !overridden serializable_class procedures - procedure::write_formatted=>decision_atom_write_formatted - procedure::read_formatted=>decision_atom_read_formatted - procedure::print_to_unit=>decision_atom_print_to_unit - procedure,nopass::get_type=>decision_atom_get_type - !new procedures - procedure::initialize=>decision_atom_initialize - procedure::merge=>decision_atom_merge - end type decision_atom_type - - type,extends(serializable_class)::decision_node_type - integer::normal=0 - integer::cardinality=0 - integer::used=0 - real(kind=double)::position=0D0 - real(kind=double),dimension(decision_tree_dimension)::epsilon=[1d-3,1d-3,1d-3] -! real(kind=double),dimension(decision_tree_dimension)::mean=[0D0,0D0,0D0] -! real(kind=double),dimension(decision_tree_dimension)::variance=[0D0,0D0,0D0] - real(kind=double),dimension(decision_tree_dimension,2)::corners=reshape([0D0,0D0,0D0,1D0,1D0,1D0],[3,2]) - type(decision_atom_type),dimension(16**decision_tree_dimension)::set - class(decision_node_type),pointer::left=>null() - class(decision_node_type),pointer::right=>null() - contains - !overridden serializable_class procedures - procedure::write_formatted=>decision_node_write_formatted - procedure::read_formatted=>decision_node_read_formatted - procedure::print_to_unit=>decision_node_print_to_unit - procedure,nopass::get_type=>decision_node_get_type - !new procedures - procedure::analyse=>decision_node_analyse - procedure :: push => decision_node_push - procedure :: push_here => decision_node_push_here - procedure :: push_atom => decision_node_push_atom - procedure :: decide => decision_node_decide - procedure :: find => decision_node_find - procedure :: reduce => decision_node_reduce - procedure :: density_plot_pstvue3d => decision_node_density_plot_pstvue3d - procedure :: lop => decision_node_lop - end type decision_node_type - -contains - - SUBROUTINE decision_atom_write_formatted(dtv,unit,iotype,v_list,iostat,iomsg) - ! the derived-type value/variable - CLASS(decision_atom_type),INTENT(IN) :: dtv - INTEGER, INTENT(IN) :: unit - ! the edit descriptor string - CHARACTER (LEN=*), INTENT(IN) :: iotype - INTEGER, INTENT(IN) :: v_list(:) - INTEGER, INTENT(OUT) :: iostat - CHARACTER (LEN=*), INTENT(INOUT) :: iomsg - ! local variables - write(unit,fmt=*)dtv%degeneracy,dtv%coordinates - END SUBROUTINE decision_atom_write_formatted - - SUBROUTINE decision_atom_read_formatted(dtv,unit,iotype,v_list,iostat,iomsg) - ! the derived-type value/variable - CLASS(decision_atom_type),INTENT(INOUT) :: dtv - INTEGER, INTENT(IN) :: unit - ! the edit descriptor string - CHARACTER (LEN=*), INTENT(IN) :: iotype - INTEGER, INTENT(IN) :: v_list(:) - INTEGER, INTENT(OUT) :: iostat - CHARACTER (LEN=*), INTENT(INOUT) :: iomsg - ! local variables - read(unit,fmt=*)dtv%degeneracy,dtv%coordinates - END SUBROUTINE decision_atom_read_formatted - - subroutine decision_atom_print_to_unit(this,unit,parents,components,peers) - class(decision_atom_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - class(serializable_class),pointer::ser - write(unit,'("Components of decision_atom_type:")') - write(unit,fmt=*)"Degeneracy: ",this%degeneracy - write(unit,fmt=*)"Cordinates: ",this%coordinates - end subroutine decision_atom_print_to_unit - - pure function decision_atom_get_type() result(t) - character(:),allocatable::t !FC = nagfor - character(32)::t !FC = gfortran - allocate(t,source="decision_atom_type")!FC = nagfor - t="decision_atom_type"!FC = gfortran - end function decision_atom_get_type - - subroutine decision_atom_initialize(this,coords) - class(decision_atom_type),intent(out)::this - real(kind=double),intent(in),dimension(decision_tree_dimension)::coords - this%coordinates=coords - this%degeneracy=1 - end subroutine decision_atom_initialize - - subroutine decision_atom_merge(this,coords,epsilon,merged) - class(decision_atom_type),intent(inout)::this - real(kind=double),intent(in),dimension(decision_tree_dimension)::coords,epsilon - logical,intent(out)::merged - real(kind=double),dimension(decision_tree_dimension)::tmp - integer::n - merged=.true. - tmp=(abs(this%coordinates-coords)-epsilon) - do n=1,size(tmp) - if(tmp(n)>0D0)then - merged=.false. - exit - end if - end do - if(merged)then - this%coordinates=(this%degeneracy*this%coordinates+coords)/(1+this%degeneracy) - this%degeneracy=this%degeneracy+1 - end if - end subroutine decision_atom_merge - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures for decision_node_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - SUBROUTINE decision_node_write_formatted(dtv,unit,iotype,v_list,iostat,iomsg) - ! the derived-type value/variable - CLASS(decision_node_type),INTENT(IN) :: dtv - INTEGER, INTENT(IN) :: unit - ! the edit descriptor string - CHARACTER (LEN=*), INTENT(IN) :: iotype - INTEGER, INTENT(IN) :: v_list(:) - INTEGER, INTENT(OUT) :: iostat - CHARACTER (LEN=*), INTENT(INOUT) :: iomsg - ! local variables - class(serializable_class),pointer::ser - integer::n - write(unit,fmt=*)dtv%normal,dtv%cardinality,dtv%used,dtv%position - write(unit,fmt=*)dtv%epsilon - write(unit,fmt=*)dtv%corners - if(dtv%normal==0)then - do n=1,dtv%used - call decision_atom_write_formatted(dtv%set(n),unit,iotype,v_list,iostat,iomsg) - end do - else - ser=>dtv%left - call serialize_write_pointer(ser,unit,iotype,V_LIST,iostat,iomsg) - ser=>dtv%right - call serialize_write_pointer(ser,unit,iotype,V_LIST,iostat,iomsg) - end if - END SUBROUTINE decision_node_write_formatted - - SUBROUTINE decision_node_read_formatted(dtv,unit,iotype,v_list,iostat,iomsg) - ! the derived-type value/variable - CLASS(decision_node_type),INTENT(INOUT) :: dtv - INTEGER, INTENT(IN) :: unit - ! the edit descriptor string - CHARACTER (LEN=*), INTENT(IN) :: iotype - INTEGER, INTENT(IN) :: v_list(:) - INTEGER, INTENT(OUT) :: iostat - CHARACTER (LEN=*), INTENT(INOUT) :: iomsg - ! local variables - integer::n - class(serializable_class),pointer::ser - read(unit,fmt=*)dtv%normal,dtv%cardinality,dtv%used,dtv%position - read(unit,fmt=*)dtv%epsilon - read(unit,fmt=*)dtv%corners - if(dtv%normal==0)then - do n=1,dtv%used - call decision_atom_read_formatted(dtv%set(n),unit,iotype,v_list,iostat,iomsg) - end do - else - allocate(dtv%left) - ser=>dtv%left - call ser%deserialize(unit) - allocate(dtv%right) - ser=>dtv%right - call ser%deserialize(unit) - end if - END SUBROUTINE decision_node_read_formatted - - subroutine decision_node_print_to_unit(this,unit,parents,components,peers) - class(decision_node_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - class(serializable_class),pointer::ser - integer::n - write(unit,'("Components of decision_node_type:")') - write(unit,fmt=*)"Cardinality: ",this%cardinality - write(unit,fmt=*)"Used: ",this%used - write(unit,fmt=*)"Normal: ",this%normal - write(unit,fmt=*)"Position: ",this%position - write(unit,fmt=*)"Epsilon: ",this%epsilon - write(unit,fmt=*)"Corner 1: ",this%corners(:,1) - write(unit,fmt=*)"Corner 2: ",this%corners(:,2) - if(components>0)then - write (unit,fmt=*)"Set:" - do n=1,this%used - call this%set(n)%print_to_unit(unit,parents,components-1,peers) - end do - end if - ser=>this%left - call serialize_print_peer_pointer(ser,unit,parents,components,peers,"LEFT") - ser=>this%right - call serialize_print_peer_pointer(ser,unit,parents,components,peers,"RIGHT") - end subroutine decision_node_print_to_unit - - pure function decision_node_get_type() result(t) - character(:),allocatable::t !FC = nagfor - character(32)::t !FC = gfortran - allocate(t,source="decision_node_type")!FC = nagfor - t="decision_node_type"!FC = gfortran - end function decision_node_get_type - - subroutine decision_node_analyse(this,unit) - class(decision_node_type),intent(in)::this - integer,intent(in)::unit - integer::n,m,true_cardinality - real(kind=double),dimension(decision_tree_dimension)::diff,true_mean,true_variance,abs_variance - real(kind=double),dimension(decision_tree_dimension,5)::crit - real(kind=double)::area,density - real(kind=double),dimension(5)::tmp_crit - integer,dimension(5)::res - diff=this%corners(:,2)-this%corners(:,1) - area=product(diff) - density=this%cardinality/area - true_mean=[0D0,0D0,0D0] - true_variance=true_mean - abs_variance=true_variance - true_cardinality=0 - tmp_crit=[1D0,1D0,1D0,1D0,1D0] - - do n=1,this%used - true_mean=true_mean+this%set(n)%coordinates*this%set(n)%degeneracy - true_cardinality=true_cardinality+this%set(n)%degeneracy - end do - true_mean=true_mean/true_cardinality - do n=1,this%used - true_variance=true_variance+((true_mean-this%set(n)%coordinates)**2)*this%set(n)%degeneracy - abs_variance=abs_variance+abs(true_mean-this%set(n)%coordinates)*this%set(n)%degeneracy - end do - true_variance=true_variance/true_cardinality - abs_variance=abs_variance/true_cardinality - do n=1,decision_tree_dimension - crit(n,1)=((this%corners(n,2)-true_mean(n))*(true_mean(n)-this%corners(n,1)))/(diff(n)) - crit(n,2)=min(this%corners(n,2)-true_mean(n),true_mean(n)-this%corners(n,1))/(diff(n)) - crit(n,3)=sqrt(true_variance(n))/diff(n) - crit(n,4)=abs_variance(n)/diff(n) - crit(n,5)=crit(n,2)*crit(n,4) - do m=1,5 - if(crit(n,m)min_balance)then - min_balance=balance - this%normal=dim - end if - end do - call cpu_time(t) - t7=t7+t - t8=t8-t - this%position=mean(this%normal) - allocate(this%left) - this%left%epsilon=this%epsilon - this%left%corners=this%corners - this%left%corners(this%normal,2)=this%position - allocate(this%right) - this%right%epsilon=this%epsilon - this%right%corners=this%corners - this%right%corners(this%normal,1)=this%position - do dim=1,this%used - if(this%set(dim)%coordinates(this%normal)this%left - else - successor=>this%right - end if - end subroutine decision_node_decide - - subroutine decision_node_find(this,criterion,successor) - class(decision_node_type),target,intent(in)::this - real(kind=double),intent(in),dimension(:)::criterion - class(decision_node_type),pointer,intent(out)::successor - class(decision_node_type),pointer::tmp_successor - successor=>this - tmp_successor=>this - do while(associated(tmp_successor)) - successor=>tmp_successor - call successor%decide(criterion,tmp_successor) - end do - end subroutine decision_node_find - - recursive subroutine decision_node_reduce(this,unit,normal,mask,position) - class(decision_node_type),target,intent(in)::this - integer,intent(in)::unit,normal - integer,intent(in),dimension(2)::mask - real(kind=double)::position - if(this%normal==0)then - call this%density_plot_pstvue3d(unit,mask) - else - if(this%normal==normal)then - if(this%position -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-16 10:57:15 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -MODULE error_stack_module - use basic_types_module - implicit none - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! derived type definitions !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type,extends(identified_type)::error_type - integer::ordinal=-1 - class(error_type),pointer::next=>null() - contains - ! overridden serializable_class procedures - procedure::write_to_ring=>error_write_to_ring - procedure::read_from_ring=>error_read_from_ring - procedure::print_to_unit=>error_print_to_unit - procedure,nopass::get_type=>error_get_type - ! new error_type procedures - procedure::finalize=>error_finalize - end type error_type - - type,extends(error_type)::ref_error_type - class(serializable_class),pointer::sender - contains - ! overridden serializable_class procedures - procedure::write_to_ring=>ref_error_write_to_ring - procedure::read_from_ring=>ref_error_read_from_ring - procedure::print_to_unit=>ref_error_print_to_unit - procedure,nopass::get_type=>ref_error_get_type - ! new error_type procedures - procedure::ref_error_initialize - generic::initialize=>ref_error_initialize - end type ref_error_type - - type,extends(serializable_class)::error_stack_type - private - logical::halt_on_error_flag=.true. - logical::halt_flag=.false. - logical::error_flag=.false. - integer::last_ordinal=0 - class(error_type),pointer::error=>null() - contains - ! overridden serializable_class procedures - procedure::write_to_ring=>error_stack_write_to_ring - procedure::read_from_ring=>error_stack_read_from_ring - procedure::print_to_unit=>error_stack_print_to_unit - procedure,nopass::get_type=>error_stack_get_type - ! new error_stack procedures - procedure::error_stack_push_error - procedure::error_stack_push_ref_error - procedure::error_stack_push_by_reference - procedure::pop=>error_stack_pop - procedure::clear=>error_stack_clear - procedure::continue=>error_stack_continue - procedure::halt=>error_stack_halt - procedure::continue_on_error=>error_stack_continue_on_error - procedure::halt_on_error=>error_stack_halt_on_error - procedure::get_error_flag=>error_stack_get_error_flag - procedure::get_halt_flag=>error_stack_get_halt_flag - procedure::get_halt_on_error_flag=>error_stack_get_halt_on_error_flag - procedure::finalize=>error_stack_finalize - generic::push=>error_stack_push_error,error_stack_push_ref_error,error_stack_push_by_reference - end type error_stack_type - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Derived Type Module Components Definitions !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type(error_stack_type),save::default_error_stack - class(serializable_class),pointer::hallo - -contains - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures For error_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine error_write_to_ring(this,ring,status) - class(error_type),intent(in)::this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - class(serializable_class),pointer::ser - ser=>this%next - call xml_write_begin_tag(ring,"ERROR_TYPE") - call identified_write_to_ring(this,ring,status) - call xml_write(ring,"ORDINAL",this%ordinal) - call serialize_pointer(ser,ring,"NEXT") - call xml_write_end_tag(ring,"ERROR_TYPE") - end subroutine error_write_to_ring - - subroutine error_read_from_ring(this,ring,status) - class(error_type),intent(out)::this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - class(serializable_class),pointer::ser - call xml_verify_begin_tag(ring,"ERROR_TYPE") - call identified_read_from_ring(this,ring,status) - call xml_read(ring,this%ordinal) - call deserialize_pointer(ser,ring) - if(associated(ser))then - select type (ser) - class is(error_type) - this%next=>ser - end select - end if - call xml_verify_end_tag(ring,"ERROR_TYPE") - end subroutine error_read_from_ring - - recursive subroutine error_print_to_unit(this,unit,parents,components,peers) - class(error_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - class(serializable_class),pointer::ser - call identified_print_to_unit(this,unit,parents-1,components,peers) - write(unit,'("components of error_type:")') - write(unit,'("error id : ",I10)')this%ordinal - ser=>this%next - call serialize_print_peer_pointer(ser,unit,parents,components,peers,"NEXT ERROR") - end subroutine error_print_to_unit - - pure function error_get_type() result(type) - character(:),allocatable::type!FC = nagfor - allocate(type,source="ERROR_TYPE")!FC = nagfor - character(32)::type!FC = gfortran - type="ERROR_TYPE"!FC = gfortran - end function error_get_type - - recursive subroutine error_finalize(this) - class(error_type),intent(out)::this - if(associated(this%next))then - call this%next%finalize() - deallocate(this%next) - end if - call identified_finalize(this) - end subroutine error_finalize - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures For ref_error_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine ref_error_write_to_ring(this,ring,status) - class(ref_error_type),intent(in)::this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - class(serializable_class),pointer::ser - call xml_write_begin_tag(ring,"REF_ERROR_TYPE") - call error_write_to_ring(this,ring,status) - ser=>this%sender - call serialize_pointer(ser,ring,"SENDER") - call xml_write_end_tag(ring,"REF_ERROR_TYPE") - end subroutine ref_error_write_to_ring - - subroutine ref_error_read_from_ring(this,ring,status) - class(ref_error_type),intent(out)::this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - class(serializable_class),pointer::ser - call xml_verify_begin_tag(ring,"REF_ERROR_TYPE") - call error_read_from_ring(this,ring,status) - call deserialize_pointer(ser,ring) - if(associated(ser))then - this%sender=>ser - end if - call xml_verify_end_tag(ring,"REF_ERROR_TYPE") - end subroutine ref_error_read_from_ring - - recursive subroutine ref_error_print_to_unit(this,unit,parents,components,peers) - class(ref_error_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - class(serializable_class),pointer::ser - call error_print_to_unit(this,unit,parents-1,components,peers) - write(unit,'("components of ref_error_type:")') - ser=>this%sender - call serialize_print_comp_pointer(ser,unit,parents,components,peers,"SENDER") - end subroutine ref_error_print_to_unit - - pure function ref_error_get_type() result(type) - character(:),allocatable::type!FC = nagfor - allocate(type,source="REF_ERROR_TYPE")!FC = nagfor - character(32)::type!FC = gfortran - type="REF_ERROR_TYPE"!FC = gfortran - end function ref_error_get_type - - subroutine ref_error_initialize(this,id,message,sender) - class(ref_error_type),intent(out)::this - integer,intent(in)::id - character(*),intent(in)::message - class(serializable_class),target::sender - call this%initialize(id,message) - this%sender=>sender - end subroutine ref_error_initialize - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! type bound procedures for error_stack_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine error_stack_write_to_ring(this,ring,status) - class(error_stack_type),intent(in)::this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - class(serializable_class),pointer::ser - ser=>this%error - call xml_write_begin_tag(ring,"ERROR_STACK_TYPE") - call xml_write(ring,"error_flag",this%error_flag) - call xml_write(ring,"halt_flag",this%halt_flag) - call xml_write(ring,"halt_on_error_flag",this%halt_on_error_flag) - call xml_write(ring,"last_ordinal",this%last_ordinal) - call serialize_pointer(ser,ring,"ERROR") - call xml_write_end_tag(ring,"ERROR_STACK_TYPE") - end subroutine error_stack_write_to_ring - - subroutine error_stack_read_from_ring(this,ring,status) - class(error_stack_type),intent(out)::this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - class(serializable_class),pointer::ser - type(error_type),target::error - type(ref_error_type),target::ref_error - call xml_verify_begin_tag(ring,"ERROR_STACK_TYPE") - call xml_read(ring,this%error_flag) - call xml_read(ring,this%halt_flag) - call xml_read(ring,this%halt_on_error_flag) - call xml_read(ring,this%last_ordinal) - call serialize_push_reference(error) - call serialize_push_reference(ref_error) - call deserialize_pointer(ser,ring) - call serialize_remove_reference(ref_error) - call serialize_remove_reference(error) - if(associated(ser))then - select type(ser) - class is (error_type) - this%error=>ser - class default - nullify(this%error) - end select - else - nullify(this%error) - end if - call xml_verify_end_tag(ring,"ERROR_STACK_TYPE") - end subroutine error_stack_read_from_ring - - subroutine error_stack_print_to_unit(this,unit,parents,components,peers) - class(error_stack_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - class(serializable_class),pointer::ser - write(unit,'("type : ",a)')this%get_type() - write(unit,'("error: ",L5)')this%error_flag - write(unit,'("halt : ",L5)')this%halt_flag - write(unit,'("halt on error: ",L5)')this%halt_on_error_flag - ser=>this%error - call serialize_print_comp_pointer(ser,unit,parents,components,peers,"ERRORS") - end subroutine error_stack_print_to_unit - - function error_stack_get_type() result(type) - character(:),allocatable::type!FC = nagfor - allocate(type,source="error_stack_type")!FC = nagfor - character(32)::type!FC = gfortran - type="error_stack_type"!FC = gfortran - end function error_stack_get_type - - subroutine error_stack_push_by_reference(this,error) - class(error_stack_type),intent(inout)::this - class(error_type),target,intent(inout)::error - this%error_flag=.true. - if(this%halt_on_error_flag)this%halt_flag=.true. - this%last_ordinal=this%last_ordinal+1 - error%ordinal=this%last_ordinal - error%next=>this%error - this%error=>error - end subroutine error_stack_push_by_reference - - subroutine error_stack_push_error(this,code,message) - class(error_stack_type),intent(inout)::this - integer,intent(in)::code - character(len=*),intent(in)::message - class(error_type),pointer::error - allocate(error) - call error%initialize(code,message) - call error_stack_push_by_reference(this,error) - end subroutine error_stack_push_error - - subroutine error_stack_push_ref_error(this,code,message,sender) - class(error_stack_type),intent(inout)::this - integer,intent(in)::code - character(len=*),intent(in)::message - class(serializable_class),target,intent(in)::sender - class(ref_error_type),pointer::error - allocate(ref_error_type::error) - call error%initialize(code,message,sender) - call error_stack_push_by_reference(this,error) - end subroutine error_stack_push_ref_error - - subroutine error_stack_pop(this,error) - class(error_stack_type),intent(inout)::this - class(error_type),pointer,intent(out)::error - error=>this%error - if(associated(error%next))then - this%error=>error%next - else - this%error=>null() - this%error_flag=.false. - end if - end subroutine error_stack_pop - - subroutine error_stack_clear(this) - class(error_stack_type),intent(inout)::this - this%error_flag=.false. - this%halt_flag=.false. - end subroutine error_stack_clear - - subroutine error_stack_continue(this) - class(error_stack_type),intent(inout)::this - this%halt_flag=.false. - end subroutine error_stack_continue - - subroutine error_stack_halt(this) - class(error_stack_type),intent(inout)::this - this%halt_flag=.true. - end subroutine error_stack_halt - - subroutine error_stack_continue_on_error(this) - class(error_stack_type),intent(inout)::this - this%halt_on_error_flag=.false. - end subroutine error_stack_continue_on_error - - subroutine error_stack_halt_on_error(this) - class(error_stack_type),intent(inout)::this - this%halt_on_error_flag=.true. - end subroutine error_stack_halt_on_error - - elemental function error_stack_get_error_flag(this) result(flag) - class(error_stack_type),intent(in)::this - logical::flag - flag=this%error_flag - end function error_stack_get_error_flag - - elemental function error_stack_get_halt_flag(this) result(flag) - class(error_stack_type),intent(in)::this - logical::flag - flag=this%halt_flag - end function error_stack_get_halt_flag - - elemental function error_stack_get_halt_on_error_flag(this) result(flag) - class(error_stack_type),intent(in)::this - logical::flag - flag=this%halt_on_error_flag - end function error_stack_get_halt_on_error_flag - - subroutine error_stack_finalize(this) - class(error_stack_type),intent(inout)::this - if(associated(this%error)) call this%error%finalize() - end subroutine error_stack_finalize - -end MODULE error_stack_module - Index: branches/attic/boschmann_standalone/pri/lib/print_ieee_support.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/print_ieee_support.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/print_ieee_support.f03.pri (revision 8609) @@ -1,135 +0,0 @@ -!!! module: print_ieee_support_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2010 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2010-05-27 16:56:43 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -MODULE print_ieee_support_module - use,intrinsic::ieee_features - use,intrinsic::ieee_exceptions - use,intrinsic::ieee_arithmetic - implicit none - integer,parameter::realp6=max(selected_real_kind(0),selected_real_kind(6)) - integer,parameter::realp15=max(selected_real_kind(7),selected_real_kind(15)) - integer,parameter::realp33=max(selected_real_kind(16),selected_real_kind(33)) - real(max(1,realp6)),private::p6 - real(max(1,realp15)),private::p15 - real(max(1,realp33)),private::p33 - logical,parameter::realp6_is_IEEE754_real32=& - &(precision(p6)==6).and.& - &(maxexponent(p6)==127).and.& - &(minexponent(p6)==-126) - logical,parameter::realp15_is_IEEE754_real64=& - &(precision(p15)==15).and.& - &(maxexponent(p6)==1023).and.& - &(minexponent(p6)==-1022) - logical,parameter::realp33_is_IEEE754_real128=& - &(precision(p33)==33).and.& - &(maxexponent(p6)==16383).and.& - &(minexponent(p6)==-16382) - -contains - - subroutine print_ieee_support() - print *,"ieee_support_flag(ieee_invalid): ",ieee_support_flag(ieee_invalid) - print *,"ieee_support_flag(ieee_overflow): ",ieee_support_flag(ieee_overflow) - print *,"ieee_support_flag(ieee_divide_by_zero): ",ieee_support_flag(ieee_divide_by_zero) - print *,"ieee_support_flag(ieee_underflow): ",ieee_support_flag(ieee_underflow) - print *,"ieee_support_flag(ieee_inexact): ",ieee_support_flag(ieee_inexact) - print *,"ieee_support_halting(ieee_invalid): ",ieee_support_halting(ieee_invalid) - print *,"ieee_support_halting(ieee_overflow): ",ieee_support_halting(ieee_overflow) - print *,"ieee_support_halting(ieee_divide_by_zero): ",ieee_support_halting(ieee_divide_by_zero) - print *,"ieee_support_halting(ieee_underflow): ",ieee_support_halting(ieee_underflow) - print *,"ieee_support_halting(ieee_inexact): ",ieee_support_halting(ieee_inexact) - print *,"" - print *,"Printing properties of supported real kinds:" - print *, "name= p6 p15 p33" - print '(a,4(I5))'," kind= ",realp6,realp15,realp33 - print '(a,4(I5))'," radix= ",radix(p6),radix(p15),radix(p33) - print '(a,4(I5))'," precision= ",precision(p6),precision(p15),precision(p33) - print '(a,4(I5))'," digits= ",digits(p6),digits(p15),digits(p33) - print *,"epsilon= ",epsilon(p6),epsilon(p15),epsilon(p33) - print *,"tiny= ",tiny(p6),tiny(p15),tiny(p33) - print *,"huge= ",huge(p6),huge(p15),huge(p33) - print '(a,4(I5))'," maxexponent= ",maxexponent(p6),maxexponent(p15),maxexponent(p33) - print '(a,4(I5))'," minexponent= ",minexponent(p6),minexponent(p15),minexponent(p33) - print '(a,4(I5))'," range= ",range(p6),range(p15),range(p33) - print '(a,4(L5))'," is ieee 754 compatible= ",realp6_is_IEEE754_real32,realp15_is_IEEE754_real64,realp33_is_IEEE754_real128 - print *,"" - print *,"Testing ieee support for real kinds:" - print *,"name= all p6 p15 p33" - print '(a,4(L4))',"ieee_support_datatype(): ",& - &ieee_support_datatype(),& - &ieee_support_datatype(p6),& - &ieee_support_datatype(p15),& - &ieee_support_datatype(p33) - print '(a,4(L4))',"ieee_support_inf(): ",& - &ieee_support_inf(),& - &ieee_support_inf(p6),& - &ieee_support_inf(p15),& - &ieee_support_inf(p33) - print '(a,4(L4))',"ieee_support_io(): ",& - &ieee_support_io(),& - &ieee_support_io(p6),& - &ieee_support_io(p15),& - &ieee_support_io(p33) - print '(a,4(L4))',"ieee_support_nan(): ",& - &ieee_support_nan(),& - &ieee_support_nan(p6),& - &ieee_support_nan(p15),& - &ieee_support_nan(p33) - print '(a,4(L4))',"ieee_support_rounding(ieee_nearest): ",& - &ieee_support_rounding(ieee_nearest),& - &ieee_support_rounding(ieee_nearest,p6),& - &ieee_support_rounding(ieee_nearest,p15),& - &ieee_support_rounding(ieee_nearest,p33) - print '(a,4(L4))',"ieee_support_rounding(ieee_up): ",& - &ieee_support_rounding(ieee_up),& - &ieee_support_rounding(ieee_up,p6),& - &ieee_support_rounding(ieee_up,p15),& - &ieee_support_rounding(ieee_up,p33) - print '(a,4(L4))',"ieee_support_rounding(ieee_down): ",& - &ieee_support_rounding(ieee_down),& - &ieee_support_rounding(ieee_down,p6),& - &ieee_support_rounding(ieee_down,p15),& - &ieee_support_rounding(ieee_down,p33) - print '(a,4(L4))',"ieee_support_rounding(ieee_to_zero): ",& - &ieee_support_rounding(ieee_to_zero),& - &ieee_support_rounding(ieee_to_zero,p6),& - &ieee_support_rounding(ieee_to_zero,p15),& - &ieee_support_rounding(ieee_to_zero,p33) - print '(a,4(L4))',"ieee_support_sqrt(): ",& - &ieee_support_sqrt(),& - &ieee_support_sqrt(p6),& - &ieee_support_sqrt(p15),& - &ieee_support_sqrt(p33) - print '(a,4(L4))',"ieee_support_standard(): ",& - &ieee_support_standard(),& - &ieee_support_standard(p6),& - &ieee_support_standard(p15),& - &ieee_support_standard(p33) - print '(a,4(L4))',"ieee_support_underflow_control(): ",& - &ieee_support_underflow_control(),& - &ieee_support_underflow_control(p6),& - &ieee_support_underflow_control(p15),& - &ieee_support_underflow_control(p33) - end subroutine print_ieee_support - -end MODULE print_ieee_support_module - Index: branches/attic/boschmann_standalone/pri/lib/print_twins.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/print_twins.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/print_twins.f03.pri (revision 8609) @@ -1,57 +0,0 @@ -!!! program: test -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2010 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2010-01-22 11:11:09 CET(+0100) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -PROGRAM print_twins - use parameters_module - implicit none - call print_twin(int2) - call print_twin(int3) - call print_twin(int4) - call print_twin(int5) - call print_twin(int6) - call print_twin(int7) - call print_twin(int8) - call print_twin(int9) - call print_twin(int10) - call print_twin(int11) -contains - subroutine print_twin(list) - integer,dimension(:)::list - integer::id,twin_id,p,n,n_max - integer,dimension(4)::partons - n_max=size(list) - print('("[&")') - do n=1,n_max - id=list(n) - partons=phase_space_kinds_inout(1:4,id) - p=partons(1) - partons(1)=partons(2) - partons(2)=p - do twin_id=1,n_kinds - if(sum(abs(partons-phase_space_kinds_inout(1:4,twin_id)))==0)then - print('("&",I4,",",I4,",&")'),id,twin_id - end if - end do - end do - print('("&]")') - end subroutine print_twin -end PROGRAM print_twins - Index: branches/attic/boschmann_standalone/pri/lib/aq_sigma.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/aq_sigma.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/aq_sigma.f03.pri (revision 8609) @@ -1,143 +0,0 @@ -!!! module: aq_sigma_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-17 09:00:34 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module aq_sigma_module - use,intrinsic::iso_fortran_env - use kinds -! use momentum_module - use arguments_module - use common_module - use parameters_module - use coordinates_module - use basic_types_module - use cuba_types_module - use aqa_module - implicit none - integer,parameter,private::dim_f=11 - - type, extends(aqa_class) :: aq_sigma_type - type(cuba_cuhre_type) :: cuhre_int - ! type(cuba_divonne_type) :: cuhre_int - contains - ! overridden serializable_class procedures - procedure::write_to_ring=>aq_sigma_write_to_ring - procedure::read_from_ring=>aq_sigma_read_from_ring - procedure::print_to_unit=>aq_sigma_print_to_unit - procedure,nopass::get_type=>aq_sigma_get_type - ! new procedures - procedure :: evaluate => aq_sigma_evaluate - procedure :: init => aq_sigma_init - procedure :: init_extended => aq_sigma_init_extended - procedure :: reset => aq_sigma_reset - end type aq_sigma_type - -contains - - Subroutine Aq_sigma_write_to_ring(this,ring,status) - CLASS(aq_sigma_type), INTENT(IN) :: this - class(page_ring_type),intent(inout)::ring - INTEGER, INTENT(OUT) :: status - ! local variables - class(serializable_class),pointer::ser - call xml_write_begin_tag(ring,"AQ_SIGMA_TYPE") - call aqa_write_to_ring(this,ring,status) - call this%cuhre_int%write_to_ring(ring,status) - call xml_write_end_tag(ring,"AQ_SIGMA_TYPE") - end SUBROUTINE aq_sigma_write_to_ring - - SUBROUTINE aq_sigma_read_from_ring(this,ring,status) - CLASS(aq_sigma_type), INTENT(out) :: this - class(page_ring_type),intent(inout)::ring - INTEGER, INTENT(OUT) :: status - ! local variables - call xml_verify_begin_tag(ring,"AQ_SIGMA_TYPE",status) - call aqa_read_from_ring(this,ring,status) - call this%cuhre_int%read_from_ring(ring,status) - call xml_verify_end_tag(ring,"AQ_SIGMA_TYPE",status) - end SUBROUTINE aq_sigma_read_from_ring - - subroutine aq_sigma_print_to_unit(this,unit,parents,components,peers) - class(aq_sigma_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - integer::ite - if(parents>0)call aqa_print_to_unit(this,unit,parents-1,components,peers) - write(unit,'("Components of aq_sigma_type")') - if(components>0)then - write(unit,fmt=*)"Printing components of cuhre_int:" - call this%cuhre_int%print_to_unit(unit,parents,components-1,peers) - else - write(unit,fmt=*)"Skipping components of cuhre_int:" - end if - end subroutine aq_sigma_print_to_unit - - pure function aq_sigma_get_type() result(type) - character(:),allocatable::type!FC = nagfor - allocate(type,source="AQ_SIGMA_TYPE")!FC = nagfor - character(32)::type!FC = gfortran - type="AQ_SIGMA_TYPE"!FC = gfortran - end function aq_sigma_get_type - - subroutine aq_sigma_evaluate(this,x,y) - class(aq_sigma_type),intent(in) :: this - real(kind=double), intent(in) :: x - real(kind=double), intent(out),dimension(:):: y -! call momentum_set_GeV_scale(x) -! call alpha_s_calc_regular() -! call this%cuhre_int%integrate(remnant_proton_proton_integrand_11) - call this%cuhre_int%get_integral_array(y) - end subroutine aq_sigma_evaluate - - subroutine aq_sigma_init(this) - class(aq_sigma_type),intent(inout) :: this - call identified_initialize(this,0,"totaler wirkungsquerschnitt in GeV") - this%rel_error_goal = 1D-2!-4 - this%abs_error_goal = 1D-2 - call this%init_extended -! call this%set_name("totaler wirkungsquerschnitt in 2*pt/s ") -! call this%init_error_tree((/8D-1/gev2_pt_max,1D-6,1D-5,1D-4,1D-3,1D-2,1D-1,1D0/)) -! call this%init_error_tree((/8D-1,1D0,1D1,1D2,1D3,7D3,gev2_pt_max/)) - call this%init_error_tree(dim_f,(/GeV_PT_MIN,1D0,1D1,1D2,1D3,GeV_PT_MAX/)) - end subroutine aq_sigma_init - - subroutine aq_sigma_init_extended(this) - class(aq_sigma_type),intent(inout) :: this - call coordinates_module_init() - call this%cuhre_int%set_common(& - &dim_f=dim_f,& - &dim_x=2,& - &eps_rel=1D-2,& !-4 - &eps_abs=1D-17,& !-17 - &flags = 0) -! this%cuhre_int%key=13 ! key=13 => cuhre dim=2 rule -! call this%cuhre_int%set_deferred(n_start,n_increase) - this%is_deferred_initialised = .true. - end subroutine aq_sigma_init_extended - - subroutine aq_sigma_reset(this) - class(aq_sigma_type),intent(inout) :: this - call aqa_reset(this) - call this%init() - end subroutine aq_sigma_reset - -end module aq_sigma_module - - Index: branches/attic/boschmann_standalone/pri/lib/remnant_interface.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/remnant_interface.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/remnant_interface.f03.pri (revision 8609) @@ -1,309 +0,0 @@ -!!! module: remnant_interface_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2010 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2010-08-13 08:37:59 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! this module is not complete. some missing features dont't provide a warning! - -module remnant_interface_module - use kinds - use basic_types_module - implicit none - - type,extends(serializable_class),abstract::qcd_2_2_class - contains - procedure(qcd_get_beam),deferred::get_beam - procedure(qcd_get_int),deferred::get_process_id - procedure(qcd_get_int),deferred::get_integrand_id - procedure(qcd_get_int),deferred::get_diagram_kind - procedure(qcd_get_int_4),deferred::get_lha_flavors - procedure(qcd_get_int_4),deferred::get_pdg_flavors - procedure(qcd_get_int_2),deferred::get_parton_kinds - procedure(qcd_get_int_2),deferred::get_pdf_int_kinds - procedure(qcd_get_double),deferred::get_PTS2 - procedure(qcd_get_double),deferred::get_GeV_PT - procedure(qcd_get_double),deferred::get_momentum_boost - procedure(qcd_get_double_3),deferred::get_parton_in_momenta - procedure(qcd_get_double_2),deferred::get_remnant_momentum_fractions - procedure(qcd_get_double_2),deferred::get_total_momentum_fractions - end type qcd_2_2_class - - type,extends(serializable_class),abstract::proton_remnant_class - integer,dimension(2)::valence_content=[1,2] - real(kind=double),dimension(3)::kind_weight=[1D0,1D0,1D0]![valence,sea,companion] - real(kind=double),dimension(4)::pdf_int_weight=[1D0,1D0,1D0,1D0]![valence down,valence up,sea quark,gluon] - real(kind=double)::momentum_fraction=1D0 - contains - ! manipulating parton content - procedure(proton_smf),deferred::remove_valence_quark - procedure(proton_sm),deferred::remove_valence_down_quark - procedure(proton_sm),deferred::remove_valence_up_quark - procedure(proton_smf),deferred::remove_sea_quark - procedure(proton_sm),deferred::remove_gluon - ! getting pdf - procedure(proton_smfvs),deferred::momentum_kind_pdf - procedure(proton_smfp),deferred::momentum_flavor_pdf - procedure(proton_smp_13_2),deferred::momentum_kind_pdf_array - procedure(proton_smp_13),deferred::momentum_flavor_pdf_array - procedure(proton_smfvs),deferred::parton_kind_pdf - procedure(proton_smfp),deferred::parton_flavor_pdf - procedure(proton_smp_13_2),deferred::parton_kind_pdf_array - procedure(proton_smp_13),deferred::parton_flavor_pdf_array - ! getting components - procedure(proton_get_double_3),deferred::get_kind_weight - procedure(proton_get_double_4),deferred::get_pdf_int_weight - procedure(proton_get_double),deferred::get_valence_weight - procedure(proton_get_double),deferred::get_sea_weight - procedure(proton_get_int_2),deferred::get_valence_content - procedure(proton_get_double),deferred::get_momentum_fraction - ! misc - procedure(proton_none),deferred::reset - end type proton_remnant_class - -!!$ type,abstract,extends(proton_remnant_class)::proton_remnant_companion_abstract_type -!!$ contains -!!$ procedure(),deferred::remove_companion -!!$ procedure(),deferred::get_companion_weight -!!$ procedure(),deferred::get_companion_parton_pdf -!!$ procedure(),deferred::get_companion_momentum_pdf -!!$ procedure(),deferred::get_companion_parton_pdf_array -!!$ procedure(),deferred::get_companion_momentum_pdf_array -!!$ procedure(),deferred::get_number_of_active_companions -!!$ procedure(),deferred,private::add_companion -!!$ procedure(),deferred,private::calculate_companion_norm -!!$ end type proton_remnant_companion_abstract_type - - type,extends(serializable_class),abstract::beam_remnant_class - contains - procedure(beam_q_in),deferred::apply_interaction - procedure(beam_get_double_int),deferred::get_pdf_int_weights - procedure(beam_none),deferred::reset - procedure(beam_get_double),deferred::get_gev_initial_cme - procedure(beam_get_double),deferred::get_gev_actual_cme - procedure(beam_get_double),deferred::get_cme_fraction - procedure(beam_get_double_2),deferred::get_proton_remnant_momentum_fractions - procedure(beam_get_protons),deferred::get_proton_remnants - procedure(beam_get_double_13_2),deferred::get_remnant_parton_flavor_pdf_arrays - end type beam_remnant_class - - abstract interface - subroutine qcd_none(this) - import qcd_2_2_class - class(qcd_2_2_class),target,intent(in)::this - end subroutine qcd_none - subroutine qcd_get_beam(this,beam) - import qcd_2_2_class - import beam_remnant_class - class(qcd_2_2_class),target,intent(in)::this - class(beam_remnant_class),pointer,intent(out)::beam - end subroutine qcd_get_beam - elemental function qcd_get_double(this) - use kinds - import qcd_2_2_class - class(qcd_2_2_class),intent(in)::this - real(kind=double)::qcd_get_double - end function qcd_get_double - pure function qcd_get_double_2(this) - use kinds - import qcd_2_2_class - class(qcd_2_2_class),intent(in)::this - real(kind=double),dimension(2)::qcd_get_double_2 - end function qcd_get_double_2 - pure function qcd_get_double_3(this) - use kinds - import qcd_2_2_class - class(qcd_2_2_class),intent(in)::this - real(kind=double),dimension(3)::qcd_get_double_3 - end function qcd_get_double_3 - elemental function qcd_get_int(this) - use kinds - import qcd_2_2_class - class(qcd_2_2_class),intent(in)::this - integer::qcd_get_int - end function qcd_get_int - pure function qcd_get_int_2(this) - use kinds - import qcd_2_2_class - class(qcd_2_2_class),intent(in)::this - integer,dimension(2)::qcd_get_int_2 - end function qcd_get_int_2 - pure function qcd_get_int_4(this) - use kinds - import qcd_2_2_class - class(qcd_2_2_class),intent(in)::this - integer,dimension(4)::qcd_get_int_4 - end function qcd_get_int_4 - end interface - - abstract interface - subroutine proton_none(this) - use kinds - import proton_remnant_class - class(proton_remnant_class),intent(inout)::this - end subroutine proton_none - elemental function proton_get_double(this) - use kinds - import proton_remnant_class - class(proton_remnant_class),intent(in)::this - real(kind=double)::proton_get_double - end function proton_get_double - pure function proton_get_double_2(this) - use kinds - import proton_remnant_class - class(proton_remnant_class),intent(in)::this - real(kind=double),dimension(2)::proton_get_double_2 - end function proton_get_double_2 - pure function proton_get_double_3(this) - use kinds - import proton_remnant_class - class(proton_remnant_class),intent(in)::this - real(kind=double),dimension(3)::proton_get_double_3 - end function proton_get_double_3 - pure function proton_get_double_4(this) - use kinds - import proton_remnant_class - class(proton_remnant_class),intent(in)::this - real(kind=double),dimension(4)::proton_get_double_4 - end function proton_get_double_4 - elemental function proton_get_int(this) - use kinds - import proton_remnant_class - class(proton_remnant_class),intent(in)::this - integer::proton_get_int - end function proton_get_int - pure function proton_get_int_2(this) - use kinds - import proton_remnant_class - class(proton_remnant_class),intent(in)::this - integer,dimension(2)::proton_get_int_2 - end function proton_get_int_2 - pure function proton_get_int_4(this) - use kinds - import proton_remnant_class - class(proton_remnant_class),intent(in)::this - integer,dimension(4)::proton_get_int_4 - end function proton_get_int_4 - subroutine proton_sf(this,GeV_scale,lha_flavor) - use kinds - import proton_remnant_class - class(proton_remnant_class),intent(inout)::this - real(kind=double),intent(in)::GeV_scale - integer,intent(in)::lha_flavor - end subroutine proton_sf - subroutine proton_smf(this,GeV_scale,momentum_fraction,lha_flavor) - use kinds - import proton_remnant_class - class(proton_remnant_class),intent(inout)::this - real(kind=double),intent(in)::GeV_scale - integer,intent(in)::lha_flavor - real(kind=double),intent(in)::momentum_fraction - end subroutine proton_smf - subroutine proton_sm(this,GeV_scale,momentum_fraction) - use kinds - import proton_remnant_class - class(proton_remnant_class),intent(inout)::this - real(kind=double),intent(in)::GeV_scale - real(kind=double),intent(in)::momentum_fraction - end subroutine proton_sm - subroutine proton_smfvs(this,GeV_scale,momentum,lha_flavor,valence_pdf,sea_pdf) - use kinds - import proton_remnant_class - class(proton_remnant_class),intent(in)::this - real(kind=double),intent(in)::GeV_scale,momentum - integer,intent(in)::lha_flavor - real(kind=double),intent(out)::valence_pdf,sea_pdf - end subroutine proton_smfvs - subroutine proton_smfp(this,GeV_scale,momentum,lha_flavor,pdf) - use kinds - import proton_remnant_class - class(proton_remnant_class),intent(in)::this - real(kind=double),intent(in)::GeV_scale,momentum - integer,intent(in)::lha_flavor - real(kind=double),intent(out)::pdf - end subroutine proton_smfp - subroutine proton_smp_13(this,GeV_scale,momentum,pdf) - use kinds - import proton_remnant_class - class(proton_remnant_class),intent(in)::this - real(kind=double),intent(in)::GeV_scale,momentum - real(kind=double),dimension(-6:6),intent(out)::pdf - end subroutine proton_smp_13 - subroutine proton_smp_13_2(this,GeV_scale,momentum,valence_pdf,sea_pdf) - use kinds - import proton_remnant_class - class(proton_remnant_class),intent(in)::this - real(kind=double),intent(in)::GeV_scale,momentum - real(kind=double),dimension(-6:6),intent(out)::sea_pdf - real(kind=double),dimension(1:2),intent(out)::valence_pdf - end subroutine proton_smp_13_2 - end interface - - abstract interface - subroutine beam_none(this) - import beam_remnant_class - class(beam_remnant_class),intent(inout)::this - end subroutine beam_none - subroutine beam_q_in(this,qcd_2_2) - import beam_remnant_class - import qcd_2_2_class - class(beam_remnant_class),intent(inout)::this - class(qcd_2_2_class),intent(in)::qcd_2_2 - end subroutine beam_q_in - subroutine beam_q_out(this,qcd_2_2) - import beam_remnant_class - import qcd_2_2_class - class(beam_remnant_class),intent(inout)::this - class(qcd_2_2_class),intent(out),pointer::qcd_2_2 - end subroutine beam_q_out - pure function beam_get_double_int(this,pdf_int_kinds) - use kinds - import beam_remnant_class - class(beam_remnant_class),intent(in)::this - integer,dimension(2),intent(in)::pdf_int_kinds - real(kind=double)::beam_get_double_int - end function beam_get_double_int - elemental function beam_get_double(this) - use kinds - import beam_remnant_class - class(beam_remnant_class),intent(in)::this - real(kind=double)::beam_get_double - end function beam_get_double - pure function beam_get_double_2(this) - use kinds - import beam_remnant_class - class(beam_remnant_class),intent(in)::this - real(kind=double),dimension(2)::beam_get_double_2 - end function beam_get_double_2 - subroutine beam_get_protons(this,proton1,proton2) - import beam_remnant_class - import proton_remnant_class - class(beam_remnant_class),intent(in)::this - class(proton_remnant_class),intent(out),pointer::proton1,proton2 - end subroutine beam_get_protons - subroutine beam_get_double_13_2(this,GeV_scale,momentum1,momentum2,pdf1,pdf2) - use kinds - import beam_remnant_class - class(beam_remnant_class),intent(in)::this - real(kind=double),intent(in)::GeV_scale,momentum1,momentum2 - real(kind=double),dimension(-6:6),intent(out)::pdf1,pdf2 - end subroutine beam_get_double_13_2 - end interface - -end module remnant_interface_module Index: branches/attic/boschmann_standalone/pri/lib/aqd_sigma.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/aqd_sigma.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/aqd_sigma.f03.pri (revision 8609) @@ -1,146 +0,0 @@ -!!! module: aqd_sigma_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-28 11:53:48 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module aqd_sigma_module - use,intrinsic::iso_fortran_env - use kinds - use momentum_module - use arguments_module - use common_module - use parameters_module - use coordinates_module - use basic_types_module - use cuba_types_module - use aqa_module - implicit none - integer,parameter,private::dim_f=17 - - type, extends(aqa_class) :: aqd_sigma_type - type(cuba_divonne_type) :: cuba_int -! type(cuba_suave_type) :: cuba_int - contains - ! overridden serializable_class procedures - procedure::write_to_ring=>aqd_sigma_write_to_ring - procedure::read_from_ring=>aqd_sigma_read_from_ring - procedure::print_to_unit=>aqd_sigma_print_to_unit - procedure,nopass::get_type=>aqd_sigma_get_type - ! new procedures - procedure :: evaluate => aqd_sigma_evaluate - procedure :: aqd_sigma_initialize - generic :: initialize => aqd_sigma_initialize -! procedure :: reset => aqd_sigma_reset - end type aqd_sigma_type - -contains - - SUBROUTINE aqd_sigma_write_to_ring(this,ring,status) - CLASS(aqd_sigma_type), INTENT(IN) :: this - class(page_ring_type),intent(inout)::ring - INTEGER, INTENT(OUT) :: status - ! local variables - class(serializable_class),pointer::ser - call xml_write_begin_tag(ring,"AQD_SIGMA_TYPE") - call aqa_write_to_ring(this,ring,status) - call this%cuba_int%serialize(ring,"CUBA_INT") - call xml_write_end_tag(ring,"AQD_SIGMA_TYPE") - end SUBROUTINE aqd_sigma_write_to_ring - - SUBROUTINE aqd_sigma_read_from_ring(this,ring,status) - CLASS(aqd_sigma_type), INTENT(out) :: this - class(page_ring_type),intent(inout)::ring - INTEGER, INTENT(OUT) :: status - ! local variables - call xml_verify_begin_tag(ring,"AQD_SIGMA_TYPE",status) - call aqa_read_from_ring(this,ring,status) - call this%cuba_int%deserialize(ring) - call xml_verify_end_tag(ring,"AQD_SIGMA_TYPE",status) - end SUBROUTINE aqd_sigma_read_from_ring - - subroutine aqd_sigma_print_to_unit(this,unit,parents,components,peers) - class(aqd_sigma_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - integer::ite - if(parents>0)call aqa_print_to_unit(this,unit,parents-1,components,peers) - write(unit,'("Components of aqd_sigma_type")') - if(components>0)then - write(unit,fmt=*)"Printing components of cuba_int:" - call this%cuba_int%print_to_unit(unit,parents,components-1,peers) - else - write(unit,fmt=*)"Skipping components of cuba_int:" - end if - end subroutine aqd_sigma_print_to_unit - - pure function aqd_sigma_get_type() result(type) - character(:),allocatable::type!FC = nagfor - allocate(type,source="AQD_SIGMA_TYPE")!FC = nagfor - character(32)::type!FC = gfortran - type="AQD_SIGMA_TYPE"!FC = gfortran - end function aqd_sigma_get_type - - subroutine aqd_sigma_evaluate(this,x,y) - class(aqd_sigma_type),intent(in) :: this - real(kind=double), intent(in) :: x - real(kind=double), intent(out),dimension(:):: y - type(transversal_momentum_type) :: pt - call pt%set_unit_scale(x) - ! print *,"evaluate" - ! call random_number(y(2:17)) -! call this%cuba_int%integrate(coordinates_proton_proton_integrand_smooth_17_reg) - call this%cuba_int%integrate_ud(& - coordinates_proton_proton_integrand_param_17_reg,pt) - ! if(this%cuba_int%fail==0)then - call this%cuba_int%get_integral_array(y) - ! else - ! print *,"aqd_sigma_evaluate: failed." - ! stop - ! end if - end subroutine aqd_sigma_evaluate - - subroutine aqd_sigma_initialize(this,id,name,goal,max_nodes,dim,cuba_goal) - class(aqd_sigma_type),intent(inout) :: this - integer,intent(in)::id,dim,max_nodes - character(*),intent(in)::name - real(kind=double),intent(in)::goal,cuba_goal - call identified_initialize(this,id,name) - this%rel_error_goal = goal!1d-4 - this%max_nodes=max_nodes - call coordinates_module_init() - call this%cuba_int%set_common(& - &dim_f=dim,& - &dim_x=2,& - &eps_rel=cuba_goal,&!1d-6 - &flags = 0) - call this%cuba_int%set_deferred(xgiven_flat=[1D-2,5D-1+epsilon(1D0),1D-2,5D-1-epsilon(1D0)]) -! call aqa_initialize(this,id,name,d_goal,max_nodes,dim_f,(/8D-1/7D3,2D-3,1D-2,1D-1,1D0/)) - call this%init_error_tree(dim,(/8D-1/7D3,2D-3,1D-2,1D-1,1D0/)) - this%is_deferred_initialised = .true. - end subroutine aqd_sigma_initialize - -!!$ subroutine aqd_sigma_reset(this) -!!$ class(aqd_sigma_type),intent(inout) :: this -!!$ call aqa_reset(this) -!!$ call this%initialize(id,name,d_goal,max_nodes,dim_f,init,cuba_goal) -!!$ end subroutine aqd_sigma_reset - -end module aqd_sigma_module - - Index: branches/attic/boschmann_standalone/pri/lib/remnant_plots.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/remnant_plots.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/remnant_plots.f03.pri (revision 8609) @@ -1,524 +0,0 @@ -!!! module: remnant_plots_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-09 13:54:50 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -MODULE remnant_plots_module - use,intrinsic::ieee_arithmetic!FC = nagfor - use,intrinsic::iso_fortran_env - use arguments_module - use kinds - use misc_module - use parameters_module - use basic_types_module - use error_stack_module - use cuba_types_module - use tao_random_numbers - use common_module - use lin_approx_tree_module - use remnant_interface_module - - use beam_remnant_module - use,intrinsic::ieee_arithmetic!FC = nagfor - implicit none - interface - subroutine splot_interface(x1,x2,res) - use kinds - real(kind=double),intent(in)::x1,x2 - real(kind=double),intent(out)::res - end subroutine splot_interface -! subroutine plot_interface(this,x,dim,res) -! use remnant_module -! type(proton_remnant_companion_type),intent(in)::this -! real(kind=double),intent(in)::x -! integer,intent(out)::dim -! real(kind=double),allocatable,dimension(:),intent(out)::res -! end subroutine plot_interface - end interface - - integer,private::plot_moment=0 - integer,private::plot_lha_flavor=2 - integer,private::plot_parton_kind=3 - real(kind=double),private::plot_xs - real(kind=double),private::plot_gev_scale - type(proton_remnant_companion_type),private,save,allocatable::plot_remnant - -contains - - ! plot meta functions - - subroutine splot_single_pdf(eval,name,xmin,xmax,qmin,qmax,nx,nq) - procedure(splot_interface)::eval - character(len=*),intent(in)::name - real(kind=double),intent(in),optional::xmin,xmax,qmin,qmax - integer,intent(in),optional::nx,nq - real(kind=double)::l_xmin,l_xmax,l_qmin,l_qmax,l_dx,l_dq,result,ax,aq,norm - integer::l_nx,l_nq,a_nx,a_nq,unit - call open_and_echo(name,unit) - call plot_set_optional_range(xmin,0D0,l_xmin,xmax,1D0,l_xmax,nx,100,l_nx,l_dx) - call plot_set_optional_range(qmin,1D0,l_qmin,qmax,7D4,l_qmax,nq,100,l_nq,l_dq) - ax=l_xmin - x_loop:do a_nx=1,l_nx - aq=l_qmax - call eval(ax,aq,norm) - if(norm==0D0)then - norm=1D0 - end if - q_loop:do a_nq=1,l_nq - call eval(ax,aq,result) - write(unit,'(3(E20.7))')ax,aq,result/norm - aq=aq-l_dq - end do q_loop - write(unit,'("")') - ax=ax+l_dx - end do x_loop - close(unit) - end subroutine splot_single_pdf - -!!$ subroutine remnant_plots_pdf_array(this,eval,name,xmin,xmax,nx,log_plot,gev_scale) -!!$ type(proton_remnant_companion_type),intent(in)::this -!!$ procedure(plot_interface)::eval -!!$ character(len=*),intent(in)::name -!!$ real(kind=double),intent(in),optional::xmin,xmax -!!$ integer,intent(in),optional::nx -!!$ logical,optional::log_plot -!!$ real(kind=double),intent(in),optional::gev_scale -!!$ real(kind=double)::l_xmin,l_xmax,l_dx,ax -!!$ integer::l_nx,a_nx,unit,dim -!!$ real(kind=double),allocatable,dimension(:)::res -!!$ character(len=11)::fmt -!!$ call plot_set_optional_range(xmin,0D0,l_xmin,xmax,1D0,l_xmax,nx,100,l_nx,l_dx) -!!$ call open_and_echo(name,unit) -!!$ ax=l_xmin -!!$ if(present(gev_scale))then -!!$ plot_gev_scale=gev_scale -!!$ end if -!!$ if(present(log_plot))then -!!$ l_dx=(l_xmax/l_xmin)**(1D0/l_nx) -!!$ log_loop:do a_nx=0,l_nx -!!$! print('("Processing x=",I5," out of ",I5)'),a_nx,l_nx -!!$ call eval(this,ax,dim,res) -!!$ write(fmt,'("(",I2,"(E20.7))")')dim -!!$ write(unit,fmt=fmt)res(1:dim) -!!$ flush(unit) -!!$ ax=ax*l_dx -!!$ end do log_loop -!!$ else -!!$ lin_loop:do a_nx=0,l_nx -!!$! print('("Processing x=",I5," out of ",I5)'),a_nx,l_nx -!!$ call eval(this,ax,dim,res) -!!$ write(fmt,'("(",I2,"(E20.7))")')dim -!!$ write(unit,fmt=fmt)res(1:dim) -!!$ flush(unit) -!!$ ax=ax+l_dx -!!$ end do lin_loop -!!$ end if -!!$ close(unit) -!!$ end subroutine remnant_plots_pdf_array - - ! actual plot functions - - ! splot - - subroutine plots_testplot(x1,x2,res) - real(kind=double),intent(in)::x1,x2 - real(kind=double),intent(out)::res - res=exp(-(((x1-0.5D0)/1D-1)**2+((x2-5D3)/1D3)**2)) - end subroutine plots_testplot - - subroutine plots_pp_integrand(k1,k2,sigma) - real(kind=double),intent(in)::k1,k2 - real(kind=double),intent(out)::sigma - real(kind=double),dimension(11)::f -! call remnant_proton_proton_integrand_11(2,[k1,k2],11,f) - sigma=f(6) - end subroutine plots_pp_integrand - - ! array plot by x - - subroutine remnant_plots_kind_momentum_by_x(this,momentum,dim,pdf_out) - type(proton_remnant_companion_type),intent(in)::this - real(kind=double),intent(in)::momentum - integer,intent(out)::dim - real(kind=double),dimension(:),allocatable,intent(out)::pdf_out - real(kind=double),dimension(2)::valence_pdf - real(kind=double),dimension(-6:6)::sea_pdf - real(kind=double),dimension(:),allocatable::companion_pdf - associate(n_c=>this%get_number_of_active_companions()) - dim=17+n_c - allocate(pdf_out(dim)) - call this%momentum_kind_pdf_array(plot_gev_scale,momentum,valence_pdf,sea_pdf) - call this%momentum_companion_pdf_array(momentum,companion_pdf) - pdf_out(1)=momentum - pdf_out(2)=0D0 - pdf_out(3:4)=valence_pdf - pdf_out(5:17)=sea_pdf - if(n_c>0)pdf_out(18:17+n_c)=companion_pdf(1:n_c) - end associate -! deallocate(companion_pdf) - end subroutine remnant_plots_kind_momentum_by_x - - subroutine remnant_plots_kind_parton_by_x(this,momentum,dim,pdf_out) - type(proton_remnant_companion_type),intent(in)::this - real(kind=double),intent(in)::momentum - integer,intent(out)::dim - real(kind=double),dimension(:),allocatable,intent(out)::pdf_out - real(kind=double),dimension(2)::valence_pdf - real(kind=double),dimension(-6:6)::sea_pdf - real(kind=double),dimension(:),allocatable::companion_pdf - associate(n_c=>this%get_number_of_active_companions()) - dim=17+n_c - allocate(pdf_out(dim)) - call this%parton_kind_pdf_array(plot_gev_scale,momentum,valence_pdf,sea_pdf) - call this%parton_companion_pdf_array(momentum,companion_pdf) - pdf_out(1)=momentum - pdf_out(2)=0D0 - pdf_out(3:4)=valence_pdf - pdf_out(5:17)=sea_pdf - if(n_c>0)pdf_out(18:17+n_c)=companion_pdf(1:n_c) - end associate -! deallocate(companion_pdf) - end subroutine remnant_plots_kind_parton_by_x - - subroutine remnant_plots_some_parton_by_x(this,momentum,dim,pdf_out) - type(proton_remnant_companion_type),intent(in)::this - real(kind=double),intent(in)::momentum - integer,intent(out)::dim - real(kind=double),dimension(:),allocatable,intent(out)::pdf_out - real(kind=double),dimension(2)::valence_pdf - real(kind=double),dimension(-6:6)::sea_pdf - real(kind=double),dimension(:),allocatable::companion_pdf - associate(n_c=>this%get_number_of_active_companions()) - dim=5+n_c - allocate(pdf_out(dim)) - call this%momentum_kind_pdf_array(plot_gev_scale,momentum,valence_pdf,sea_pdf) - call this%momentum_companion_pdf_array(momentum,companion_pdf) - valence_pdf=valence_pdf+sea_pdf(1:2) - pdf_out(1)=momentum - pdf_out(2)=sea_pdf(0) - pdf_out(3:4)=valence_pdf -! pdf_out(3:4)=sea_pdf(1:2) - pdf_out(5)=sea_pdf(3) - if(n_c>0)pdf_out(6:5+n_c)=companion_pdf(1:n_c) - where(ieee_is_nan(pdf_out))pdf_out=0D0!FC = nagfor - end associate - end subroutine remnant_plots_some_parton_by_x - - ! array plots by q - - SUBROUTINE remnant_plots_momentum_pdf_by_q(this,GeV_Q,dim,pdf) - type(proton_remnant_companion_type),intent(in)::this - real(kind=double),intent(in)::GeV_Q - integer,intent(out)::dim - real(kind=double),allocatable,dimension(:),intent(out)::pdf - integer,parameter::n_grid=10000 - real(kind=double),parameter::d_grid=real(n_grid,kind=double) - real(kind=double),parameter::dx=1D0/d_grid - real(kind=double),dimension(:),allocatable::companion - real(kind=double),dimension(:),allocatable::companion_sum - real(kind=double),dimension(-6:6)::sea - real(kind=double),dimension(-6:6)::sea_norm=0D0 - real(kind=double),dimension(1:2)::valence=0D0 - real(kind=double),dimension(1:2)::valence_norm=0D0 - real(kind=double)::all=0D0 - real(kind=double)::all_norm=0D0 - real(kind=double)::x - integer::ite,n_c - n_c=this%get_number_of_active_companions() - all_norm=0D0 - sea_norm=0D0 - valence_norm=0D0 - dim=17+n_c - allocate(pdf(1:dim)) - allocate(companion_sum(n_c)) - companion_sum=0D0 - x=dx/2D0 - do ite=1,n_grid - call this%momentum_kind_pdf_array(GeV_Q,x,valence,sea) - call this%momentum_companion_pdf_array(x,companion) - all=sum(sea)+sum(valence)+sum(companion) - all_norm=all_norm+all - sea_norm=sea_norm+sea - valence_norm=valence_norm+valence - companion_sum=companion_sum+companion(1:n_c) -! deallocate(companion) - x=x+dx - end do - pdf(1)=GeV_Q - pdf(2)=all_norm*dx - pdf(3:4)=valence_norm*dx - pdf(5:17)=sea_norm*dx - if(n_c>0)pdf(18:17+n_c)=companion_sum(1:n_c)*dx - end SUBROUTINE remnant_plots_momentum_pdf_by_q - - SUBROUTINE remnant_plots_parton_pdf_by_q(this,GeV_Q,dim,pdf) - type(proton_remnant_companion_type),intent(in)::this - real(kind=double),intent(in)::GeV_Q - integer,intent(out)::dim - real(kind=double),allocatable,dimension(:),intent(out)::pdf - integer,parameter::n_grid=10000 - real(kind=double),parameter::d_grid=real(n_grid,kind=double) - real(kind=double),parameter::dx=1D0/d_grid -! real(kind=double),dimension(:),allocatable::companion - real(kind=double),dimension(-6:6)::sea - real(kind=double),dimension(-6:6)::sea_norm=0D0 - real(kind=double),dimension(1:2)::valence=0D0 - real(kind=double),dimension(1:2)::valence_norm=0D0 - real(kind=double)::all=0D0 - real(kind=double)::all_norm=0D0 - real(kind=double)::x - integer::ite - all_norm=0D0 - sea_norm=0D0 - valence_norm=0D0 - dim=17!+this%number_of_active_companions - allocate(pdf(1:dim)) - x=dx/2D0 - do ite=1,n_grid - call this%parton_kind_pdf_array(GeV_Q,x,valence,sea)!,companion) - all=sum(sea)+sum(valence) - all_norm=all_norm+all - sea_norm=sea_norm+sea - valence_norm=valence_norm+valence - x=x+dx - end do - pdf(1)=GeV_Q - pdf(2)=all_norm*dx - pdf(3:4)=valence_norm*dx - pdf(5:17)=sea_norm*dx - end SUBROUTINE remnant_plots_parton_pdf_by_q - - subroutine remnant_plots_integrate_4_5(remnant,GeV_Q,dim,pdf) - type(proton_remnant_companion_type),intent(in)::remnant - real(kind=double),intent(in)::GeV_Q - integer,intent(out)::dim - real(kind=double),allocatable,dimension(:),intent(out)::pdf - type(cuba_vegas_type)::cuba - real(kind=double)::res0,res1 - dim=1 - plot_remnant=remnant - allocate(pdf(dim)) - plot_gev_scale=GeV_Q - call cuba%set_common(& - &dim_f=1,& - &dim_x=1,& - &eps_rel=1D-3,& !-4 - &eps_abs=1D-11,& !-17 - &flags = 0) - plot_moment=0 - call cuba%integrate(remnant_integrand_f_k_m_x) - call cuba%get_integral_1(res0) - plot_moment=1 - call cuba%integrate(remnant_integrand_f_k_m_x) - call cuba%get_integral_1(res1) - pdf(1)=res1/res0 - end subroutine remnant_plots_integrate_4_5 - - - ! cuba integrand procedures - - subroutine remnant_integrand_f_k_m_x(dim_x,x,dim_f,f,pt) - integer,intent(in)::dim_x,dim_f - real(kind=double),dimension(1),intent(in)::x - real(kind=double),dimension(1),intent(out)::f - type(transversal_momentum_type),intent(in)::pt - real(kind=double),dimension(2)::pdf - call plot_remnant%momentum_kind_pdf(plot_gev_scale,x(1),plot_lha_flavor,pdf(1),pdf(2)) - f(1)=pdf(plot_parton_kind)*(x(1)**plot_moment) - end subroutine remnant_integrand_f_k_m_x - - subroutine remnant_integrand_all_x(dim_x,x,dim_f,f,pt2s) - integer,intent(in)::dim_x,dim_f - real(kind=double),dimension(1),intent(in)::x - real(kind=double),dimension(1),intent(out)::f - real(kind=double),intent(in)::pt2s - real(kind=double),dimension(-6:6)::pdf_array - call evolvePDF(x(1),plot_gev_scale,pdf_array) - f(1)=sum(pdf_array) - end subroutine remnant_integrand_all_x - -!!$ SUBROUTINE remnant_integrate_x(GeV_Q,dim,pdf) -!!$ real(kind=double),intent(in)::GeV_Q -!!$ integer,intent(out)::dim -!!$ real(kind=double),allocatable,dimension(:),intent(out)::pdf -!!$ type(cuba_vegas_type)::cuba -!!$ integer::parton -!!$ real(kind=double)::res -!!$ dim=16 -!!$ allocate(pdf(dim)) -!!$ plot_gev_scale=GeV_Q -!!$ call cuba%set_common(& -!!$ &dim_f=1,& -!!$ &dim_x=1,& -!!$ &eps_rel=1D-2,& !-4 -!!$ &eps_abs=1D-11,& !-17 -!!$ &flags = 0) -!!$! call cuba%set_deferred(7) -!!$ print ('("integrating all at ",E20.7," GeV")'),GeV_Q -!!$ call cuba%integrate(remnant_integrand_all_x) -!!$ call cuba%get_integral_1(res) -!!$ pdf(1)=res -!!$ do parton=-6,6 -!!$ plot_lha_flavor=parton -!!$ print ('("integrating parton ",I2," at ",E20.7," GeV")'),parton,GeV_Q -!!$ call cuba%integrate(remnant_integrand_f_k_m_x) -!!$ call cuba%get_integral_1(res) -!!$ print ('("result is: ",E20.7)'),res -!!$ pdf(parton+10)=res -!!$ end do -!!$ pdf(2)=sum(pdf(4:16)) -!!$ pdf(3)=pdf(1)-pdf(2) -!!$ end SUBROUTINE remnant_integrate_x - -!!$ SUBROUTINE remnant_plot_q_dependence(GeV_Q,dim,pdf) -!!$ use cuba_types_module -!!$ real(kind=double),intent(in)::GeV_Q -!!$ integer,intent(out)::dim -!!$ real(kind=double),allocatable,dimension(:),intent(out)::pdf -!!$ type(cuba_vegas_type)::cuba -!!$ integer::parton -!!$ real(kind=double)::res -!!$ dim=16 -!!$ allocate(pdf(dim)) -!!$ call momentum_set_gev_scale(GeV_Q) -!!$ call cuba%set_common(& -!!$ &dim_f=1,& -!!$ &dim_x=1,& -!!$ &eps_rel=1D-2,& !-4 -!!$ &eps_abs=1D-11,& !-17 -!!$ &flags = 0) -!!$ plot_parton_kind=2 -!!$ do parton=1,2 -!!$ plot_lha_flavor=parton -!!$ print ('("integrating parton ",I2," at ",E20.7," GeV")'),parton,GeV_Q -!!$ call cuba%integrate(remnant_integrand_f_k_m_x) -!!$ call cuba%get_integral_1(res) -!!$ print ('("result is: ",E20.7)'),res -!!$ pdf(parton+1)=res -!!$ end do -!!$ plot_parton_kind=1 -!!$ do parton=-6,6 -!!$ plot_lha_flavor=parton -!!$ print ('("integrating parton ",I2," at ",E20.7," GeV")'),parton,GeV_Q -!!$ call cuba%integrate(remnant_integrand_f_k_m_x) -!!$ call cuba%get_integral_1(res) -!!$ res=res*pdf_rescale -!!$ print ('("result is: ",E20.7)'),res -!!$ pdf(parton+10)=res -!!$ end do -!!$ pdf(1)=sum(pdf(2:16)) -!!$ end SUBROUTINE remnant_plot_q_dependence - - subroutine remnant_plots_mean(remnant,GeV_Q,dim,pdf) - type(proton_remnant_companion_type),intent(in)::remnant - real(kind=double),intent(in)::GeV_Q - integer,intent(out)::dim - real(kind=double),allocatable,dimension(:),intent(out)::pdf - integer::parton - real(kind=double)::mean,norm - dim=42 - allocate(pdf(dim)) - plot_gev_scale=GeV_Q - do parton=-6,6 -! call remnant_mean_x(parton,3,(GeV_Q/gev_pt_max)**2,mean,norm) - pdf(parton+8)=mean - pdf(parton+22)=norm - if(norm>0D0)then - pdf(parton+36)=mean/norm - else - pdf(parton+36)=0D0 - end if - end do - pdf(1)=sum(pdf(2:14)) - pdf(15)=sum(pdf(16:28)) - pdf(29)=sum(pdf(30:42)) - end subroutine remnant_plots_mean - - subroutine remnant_companion_plot(x,dim,f) - real(kind=double),intent(in)::x - integer,intent(out)::dim - real(kind=double),allocatable,dimension(:),intent(out)::f - dim=1 - allocate(f(dim)) - f(1)=x*remnant_companion_pdf_p(x,plot_xs,gluon_exp) - end subroutine remnant_companion_plot - - ! auxiliary procedures - - subroutine plot_set_optional_range(min,min_d,min_o,max,max_d,max_o,n,n_d,n_o,d_o) - real(kind=double),intent(in)::min_d,max_d - real(kind=double),intent(out)::min_o,max_o,d_o - real(kind=double),intent(in),optional::min,max - integer,intent(in)::n_d - integer,intent(out)::n_o - integer,intent(in),optional::n - if(present(min))then - min_o=min - else - min_o=min_d - end if - if(present(max))then - max_o=max - else - max_o=max_d - end if - if(present(n))then - n_o=n - else - n_o=n_d - end if - d_o=(max_o-min_o)/n_o - end subroutine plot_set_optional_range - -!!$ subroutine remnant_mean_x(flavour,kind,pt2s,mean,norm) -!!$ integer,intent(in)::flavour,kind -!!$ real(kind=double),intent(in)::pt2s -!!$ real(kind=double),intent(out)::mean,norm -!!$ type(cuba_vegas_type)::cuba -!!$ call cuba%set_common(& -!!$ dim_f=1,& -!!$ dim_x=1,& -!!$ eps_rel=1D-2,& !-4 -!!$ eps_abs=1D-11,& !-17 -!!$ flags = 0,& -!!$ userdata=pt2s) -!!$ plot_lha_flavor=flavour -!!$ plot_parton_kind=kind -!!$ plot_moment=1 -!!$ call cuba%integrate(remnant_integrand_f_k_m_x) -!!$ call cuba%get_integral_1(mean) -!!$ plot_moment=0 -!!$ call cuba%integrate(remnant_integrand_f_k_m_x) -!!$ call cuba%get_integral_1(norm) -!!$ end subroutine remnant_mean_x - - subroutine divide_array_regular(dim,enum_array,denom_array,quotient_array) - integer,intent(in)::dim - real(kind=double),intent(in),dimension(1:dim)::enum_array,denom_array - real(kind=double),intent(out),dimension(1:dim)::quotient_array - where(denom_array==0D0) - quotient_array=0D0 - elsewhere - quotient_array=enum_array/denom_array - end where - end subroutine divide_array_regular - -end MODULE remnant_plots_module - Index: branches/attic/boschmann_standalone/pri/lib/dynamic_binning.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/dynamic_binning.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/dynamic_binning.f03.pri (revision 8609) @@ -1,820 +0,0 @@ -!!! module: dynamic_binning_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-16 15:38:38 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module dynamic_binning_module - use fibonacci_tree_module - implicit none - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Derived Type Definition !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type,extends(measurable_class)::dynamic_bin_type - integer::count=0 - real(kind=double),dimension(2)::range=[0D0,1D0] - contains - ! overridden serializable_class procedures - procedure::write_to_ring=>dynamic_bin_write_to_ring - procedure::read_from_ring=>dynamic_bin_read_from_ring - procedure::print_to_unit=>dynamic_bin_print_to_unit - procedure,nopass::get_type=>dynamic_bin_get_type - ! overridden measurable_class procedures - procedure::measure=>dynamic_bin_measure - ! new procedures - end type dynamic_bin_type - - type,extends(dynamic_bin_type)::dynamic_bin_tree_type - class(dynamic_bin_tree_type),pointer::left=>null() - class(dynamic_bin_tree_type),pointer::right=>null() - contains - ! overridden serializable_class procedures - procedure::write_to_ring=>dynamic_bin_tree_write_to_ring - procedure::read_from_ring=>dynamic_bin_tree_read_from_ring - procedure::print_to_unit=>dynamic_bin_tree_print_to_unit - procedure,nopass::get_type=>dynamic_bin_tree_get_type - ! overridden measurable_class procedures - procedure::measure=>dynamic_bin_tree_measure - ! new procedures - procedure::update=>dynamic_bin_tree_update - procedure::at_count=>dynamic_bin_tree_at_count - procedure::at_depth=>dynamic_bin_tree_at_depth - end type dynamic_bin_tree_type - - type,extends(fibonacci_leave_type)::dynamic_bin_candidate_type - class(dynamic_bin_candidate_type),pointer::pred=>null() - class(dynamic_bin_candidate_type),pointer::succ=>null() - contains - ! overridden serializable_class procedures - procedure::write_to_ring=>dynamic_bin_candidate_write_to_ring - procedure::read_from_ring=>dynamic_bin_candidate_read_from_ring - procedure::print_to_unit=>dynamic_bin_candidate_print_to_unit - procedure,nopass::get_type=>dynamic_bin_candidate_get_type - ! overridden fibonacci_leave_type procedures - procedure::write_pstricks=>dynamic_bin_candidate_write_pstricks - procedure::get_bin_tree=>dynamic_bin_candidate_get_bin_tree - end type dynamic_bin_candidate_type - - type,extends(identified_type)::dynamic_binning_type - logical::autorange=.true. - integer::count=0 - integer::max_bins=100 - real(kind=double),dimension(2)::range=[0D0,1D0] - real(kind=double),dimension(2)::plot_range=[0D0,1D0] - type(fibonacci_root_type)::raw_bin_tree - class(dynamic_bin_tree_type),pointer::done_bin_tree - real(kind=double)::init_value=0D0 - contains - ! overridden serializable_class procedures - procedure::write_to_ring=>dynamic_binning_write_to_ring - procedure::read_from_ring=>dynamic_binning_read_from_ring - procedure::print_to_unit=>dynamic_binning_print_to_unit - procedure,nopass::get_type=>dynamic_binning_get_type - ! overridden identified_type procedures - procedure::dynamic_binning_initialize - generic::initialize=>dynamic_binning_initialize - ! new procedures - procedure::initialize_bins=>dynamic_binning_initialize_bins - procedure :: push_scalar => dynamic_binning_push_scalar - procedure :: push_array => dynamic_binning_push_array - procedure :: set_range => dynamic_binning_set_range - ! plots - procedure :: boxplot => dynamic_binning_boxplot - procedure :: boxplot_n_bins => dynamic_binning_boxplot_n_bins - ! binning - procedure :: make_bin_tree => dynamic_binning_make_bin_tree -! procedure :: at_height => dynamic_binning_at_height - ! generic - generic :: push => push_scalar,push_array - end type dynamic_binning_type - - interface - subroutine plotfunc_interface(this,unit) - import dynamic_bin_tree_type - class(dynamic_bin_tree_type),intent(in)::this - integer,intent(in)::unit - end subroutine plotfunc_interface - end interface - -contains - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! type bound procedures for dynamic_bin_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine dynamic_bin_write_to_ring(this,ring,status) - CLASS(dynamic_bin_type),INTENT(IN) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - end subroutine dynamic_bin_write_to_ring - - subroutine dynamic_bin_read_from_ring(this,ring,status) - CLASS(dynamic_bin_type),INTENT(INOUT) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - end subroutine dynamic_bin_read_from_ring - - subroutine dynamic_bin_print_to_unit(this,unit,parents,components,peers) - class(dynamic_bin_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - write(unit,fmt=*)"Components of DYNAMIC_BIN_TYPE:" - write(unit,fmt=*)"Count= ",this%count - write(unit,fmt=*)"Range= [",this%range,"]" - end subroutine dynamic_bin_print_to_unit - - pure function dynamic_bin_get_type() result(type) - character(:),allocatable::type !FC = nagfor - character(32)::type !FC = gfortran - allocate(type,source="DYNAMIC_BIN_TYPE")!FC = nagfor - type="DYNAMIC_BIN_TYPE"!FC = gfortran - end function dynamic_bin_get_type - - elemental function dynamic_bin_measure(this) - class(dynamic_bin_type),intent(in)::this - real(kind=double)::dynamic_bin_measure - dynamic_bin_measure=this%range(2) - end function dynamic_bin_measure - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! type bound procedures for dynamic_bin_tree_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine dynamic_bin_tree_write_to_ring(this,ring,status) - CLASS(dynamic_bin_tree_type),INTENT(IN) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - end subroutine dynamic_bin_tree_write_to_ring - - subroutine dynamic_bin_tree_read_from_ring(this,ring,status) - CLASS(dynamic_bin_tree_type),INTENT(INOUT) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - end subroutine dynamic_bin_tree_read_from_ring - - subroutine dynamic_bin_tree_print_to_unit(this,unit,parents,components,peers) - class(dynamic_bin_tree_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - class(serializable_class),pointer::ser - if(parents>0)call dynamic_bin_print_to_unit(this,unit,parents-1,components,peers) - write(unit,fmt=*)"Components of DYNAMIC_BIN_TREE_TYPE:" - ser=>this%left - call serialize_print_peer_pointer(ser,unit,parents,components,peers,"LEFT: ") - ser=>this%right - call serialize_print_peer_pointer(ser,unit,parents,components,peers,"RIGHT: ") - end subroutine dynamic_bin_tree_print_to_unit - - pure function dynamic_bin_tree_get_type() result(type) - character(:),allocatable::type !FC = nagfor - character(32)::type !FC = gfortran - allocate(type,source="DYNAMIC_BIN_TREE_TYPE")!FC = nagfor - type="DYNAMIC_BIN_TREE_TYPE"!FC = gfortran - end function dynamic_bin_tree_get_type - - elemental function dynamic_bin_tree_measure(this) - class(dynamic_bin_tree_type),intent(in)::this - real(kind=double)::dynamic_bin_tree_measure - dynamic_bin_tree_measure=real(this%count,kind=double) - end function dynamic_bin_tree_measure - - subroutine dynamic_bin_tree_update(this) - class(dynamic_bin_tree_type),intent(inout)::this - this%count=this%left%count+this%right%count - this%range=[this%left%range(1),this%right%range(2)] - end subroutine dynamic_bin_tree_update - - recursive subroutine dynamic_bin_tree_at_count(this,unit,count,plot_range,plotfunc,next,bins) - class(dynamic_bin_tree_type),intent(in)::this - procedure(plotfunc_interface)::plotfunc - integer,intent(in)::unit,count - real(kind=double),dimension(2),intent(in)::plot_range - integer,intent(out)::next,bins - integer::n1,n2,b1,b2 - next=-1 - bins=1 - if(this%range(1)plot_range(1))then - if(this%count>count)then - if(associated(this%left).and.associated(this%right))then - call this%left%at_count(unit,count,plot_range,plotfunc,n1,b1) - call this%right%at_count(unit,count,plot_range,plotfunc,n2,b2) - next = max(n1,n2) - bins=b1+b2 - else - call plotfunc(this,unit) - end if - else - call plotfunc(this,unit) - if(associated(this%left).and.associated(this%right))then - next=this%count-1 - end if - end if - end if - end subroutine dynamic_bin_tree_at_count - - subroutine dynamic_bin_tree_boxplot(this,unit) - class(dynamic_bin_tree_type),intent(in)::this - integer,intent(in)::unit - write(unit,fmt=*)this%range(1),0D0,0D0 - write(unit,fmt=*)this%range(1),this%count/(this%range(2)-this%range(1)),this%count - write(unit,fmt=*)this%range(2),this%count/(this%range(2)-this%range(1)),this%count - write(unit,fmt=*)this%range(2),0D0,0D0 - end subroutine dynamic_bin_tree_boxplot - - subroutine dynamic_bin_tree_stepplot(this,unit) - class(dynamic_bin_tree_type),intent(in)::this - integer,intent(in)::unit - write(unit,fmt=*)this%range(1),this%count/(this%range(2)-this%range(1)),this%count - end subroutine dynamic_bin_tree_stepplot - - recursive subroutine dynamic_bin_tree_at_depth(this,depth) - class(dynamic_bin_tree_type),intent(in)::this - integer,intent(in)::depth - if(depth>0)then - if(associated(this%left).and.associated(this%right))then - call this%left%at_depth(depth-1) - call this%right%at_depth(depth-1) - else - print *,this%count - end if - else - print *,this%count - end if - end subroutine dynamic_bin_tree_at_depth - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! type bound procedures for dynamic_bin_candidate_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine dynamic_bin_candidate_write_to_ring(this,ring,status) - CLASS(dynamic_bin_candidate_type),INTENT(IN) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - end subroutine dynamic_bin_candidate_write_to_ring - - subroutine dynamic_bin_candidate_read_from_ring(this,ring,status) - CLASS(dynamic_bin_candidate_type),INTENT(INOUT) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - end subroutine dynamic_bin_candidate_read_from_ring - - subroutine dynamic_bin_candidate_print_to_unit(this,unit,parents,components,peers) - class(dynamic_bin_candidate_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - class(serializable_class),pointer::ser - if(parents>0)call fibonacci_leave_print_to_unit(this,unit,parents-1,components,peers) - write(unit,fmt=*)"Components of DYNAMIC_BIN_CANDIDATE_TYPE:" - ser=>this%pred - call serialize_print_peer_pointer(ser,unit,parents,components,min(peers,1),"PRED") - ser=>this%succ - call serialize_print_peer_pointer(ser,unit,parents,components,min(peers,1),"SUCC") - end subroutine dynamic_bin_candidate_print_to_unit - - pure function dynamic_bin_candidate_get_type() result(type) - character(:),allocatable::type !FC = nagfor - character(32)::type !FC = gfortran - allocate(type,source="DYNAMIC_BIN_CANDIDATE_TYPE")!FC = nagfor - type="DYNAMIC_BIN_CANDIDATE_TYPE"!FC = gfortran - end function dynamic_bin_candidate_get_type - - subroutine dynamic_bin_candidate_write_pstricks(this,unitnr) - class(dynamic_bin_candidate_type),target :: this - integer,intent(in) :: unitnr - integer::p,s - p=0 - s=0 - if(associated(this%succ))s=int(this%succ%measure()) - if(associated(this%pred))p=int(this%pred%measure()) - write(unitnr,'("\begin{psTree}{\Toval[linecolor=green]{$\begin{matrix}",i3,"\\",I3,"-",I3,"-",I3,"\end{matrix}$}}")') this%depth,p,int(this%measure()),s - if (associated(this%left)) then - write(unitnr,'("\Tr[",a,"]{}")') "edge=\childofleave" - end if - if (associated(this%right)) then - write(unitnr,'("\Tr[",a,"]{}")') "edge=\childofleave" - end if - write(unitnr,'("\end{psTree}")') - end subroutine dynamic_bin_candidate_write_pstricks - - subroutine dynamic_bin_candidate_get_bin_tree(this,bin_tree) - class(dynamic_bin_candidate_type),intent(in) :: this - class(dynamic_bin_tree_type),pointer,intent(out)::bin_tree - class(measurable_class),pointer::bin - call this%get_content(bin) - select type(bin) - class is (dynamic_bin_tree_type) - bin_tree=>bin - end select - end subroutine dynamic_bin_candidate_get_bin_tree - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! type bound procedures for dynamic_binning_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine dynamic_binning_write_to_ring(this,ring,status) - CLASS(dynamic_binning_type),INTENT(IN) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - end subroutine dynamic_binning_write_to_ring - - subroutine dynamic_binning_read_from_ring(this,ring,status) - CLASS(dynamic_binning_type),INTENT(INOUT) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - end subroutine dynamic_binning_read_from_ring - - subroutine dynamic_binning_print_to_unit(this,unit,parents,components,peers) - class(dynamic_binning_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - if(parents>0)call identified_print_to_unit(this,unit,parents-1,components,peers) - write(unit,fmt=*)"Components of DYNAMIC_BINNING_TYPE:" - write(unit,fmt=*)"Autorange=",this%autorange - write(unit,fmt=*)"Count= ",this%count - write(unit,fmt=*)"Max Bins= ",this%max_bins - write(unit,fmt=*)"Range= ",this%range - if(this%raw_bin_tree%is_valid())then - if(components>0)then - write(unit,fmt=*)"Bin Tree:" - call this%raw_bin_tree%write_contents(unit) - else - write(unit,fmt=*)"Skipping Bin Tree." - end if - else - write(unit,fmt=*)"Bin Tree is not initialized." - end if - end subroutine dynamic_binning_print_to_unit - - pure function dynamic_binning_get_type() result(type) - character(:),allocatable::type !FC = nagfor - character(32)::type !FC = gfortran - allocate(type,source="DYNAMIC_BINNING_TYPE")!FC = nagfor - type="DYNAMIC_BINNING_TYPE"!FC = gfortran - end function dynamic_binning_get_type - - subroutine dynamic_binning_initialize_bins(this,value1,value2) - class(dynamic_binning_type),intent(inout)::this - real(kind=double),intent(in)::value1,value2 - real(kind=double)::svalue1,svalue2 - class(dynamic_bin_type),pointer::b1,b2 - if(value1this%range(2))then - print *,"dynamic_binning_initialize_bins(",value1,",",value2,"): Initial values are out of range [",this%range,"]" - STOP - end if - end if - allocate(b1) - allocate(b2) - b1%count=1 - b2%count=1 - b1%range=[svalue1,svalue1] - b2%range=[svalue2,svalue2] - call this%raw_bin_tree%init_by_content(b1,b2) - this%count=2 - end subroutine dynamic_binning_initialize_bins - - subroutine dynamic_binning_initialize(this,id,name,max_bins,range,plot_range) - class(dynamic_binning_type),intent(out)::this - integer,intent(in)::id - character,intent(in)::name - integer,intent(in)::max_bins - real(kind=double),dimension(2),intent(in),optional::range,plot_range - call identified_initialize(this,id,name) - this%max_bins=max_bins - if(present(range))call this%set_range(range) - if(present(plot_range))call this%set_range(plot_range) - !call this%bin_tree%write_pstricks(11)!PSTRICKS - end subroutine dynamic_binning_initialize - - subroutine dynamic_binning_push_scalar(this,value) - class(dynamic_binning_type),intent(inout)::this - class(fibonacci_leave_type),pointer::leave,new_leave - class(dynamic_bin_type),pointer::bin - class(measurable_class),pointer::ser - real(kind=double),intent(in)::value - if(this%autorange)then - if(valuecan2 - can2%pred=>can1 - call merge_bin_trees(bin1,bin2,binu) - call can1%set_content(binu) - nullify(binu) - call merge_bin_trees(bin2,bin3,binu) - call can2%set_content(binu) - nullify(binu) - call can_tree%init_by_leave(can1,can2) - ! Now we process all remaining leaves. - do while(associated(leave)) - bin2=>bin3 - bin3=>bin4 - nullify(binu) - can1=>can2 - nullify(can2) - call fib_to_bin(leave,bin4) - call common_boundary(bin3,bin4) - call merge_bin_trees(bin2,bin3,binu) - allocate(can2) - call can2%set_content(binu) - can1%succ=>can2 - can2%pred=>can1 - push_leave=>can2 - call can_tree%push_by_leave(push_leave) - call leave%get_right(leave) - end do - ! The last leave was used for the last boundary, not for the last candidate. Now we use the content of the last leave for the last candidate. - nullify(binu) - can1=>can2 - nullify(can2) - call merge_bin_trees(bin3,bin4,binu) - allocate(can2) - call can2%set_content(binu) - can1%succ=>can2 - can2%pred=>can1 - push_leave=>can2 - call can_tree%push_by_leave(push_leave) - - ! initial tree is ready. start processing. - call can_tree%pop_left(leave) -! print *,"Depth=",can_tree%get_depth() - do while (can_tree%get_depth()>1) - select type(leave) - class is (dynamic_bin_candidate_type) - if(associated(leave%pred))then - can1=>leave%pred - !write(11,fmt=*)"fibonacci leave pick pred(",int(can1%measure()),")\\"!PSTRICKS - !flush(11)!PSTRICKS - call can1%pick() - !call can_tree%write_pstricks(11)!PSTRICKS - !flush(11)!PSTRICKS - call can_tilt_right(can1,leave) - !write(11,fmt=*)"fibonacci tree push(",int(can1%measure()),")\\"!PSTRICKS - !flush(11)!PSTRICKS - push_leave=>can1 - call can_tree%push_by_leave(push_leave) - end if - if(associated(leave%succ))then - can2=>leave%succ - !write(11,fmt=*)"fibonacci leave pick succ(",int(can2%measure()),")\\"!PSTRICKS - !flush(11)!PSTRICKS - call can2%pick() - !call can_tree%write_pstricks(11)!PSTRICKS - !flush(11)!PSTRICKS - call can_tilt_left(leave,can2) - !write(11,fmt=*)"fibonacci tree push(",int(can2%measure()),")\\"!PSTRICKS - !flush(11)!PSTRICKS - push_leave=>can2 - call can_tree%push_by_leave(push_leave) - end if - end select - deallocate(leave) - call can_tree%pop_left(leave) - end do - ! We have got two leaves in tree and one leave in hand. The tree cannot be used for sorting any more. -! call leave%print(10,1,1) - select type(leave) - class is (dynamic_bin_candidate_type) - if(associated(leave%pred))then - can1=>leave%pred - call can_tilt_right(can1,leave) - end if - if(associated(leave%succ))then - can2=>leave%succ - call can_tilt_left(leave,can2) - end if - end select - deallocate(leave) - !call can_tree%write_pstricks(11)!PSTRICKS - ! Now we only got two leaves in tree left. - leave=>can_tree%leftmost - select type(leave) - class is (dynamic_bin_candidate_type) - can1=>leave - end select - leave=>can_tree%rightmost - select type(leave) - class is (dynamic_bin_candidate_type) - can2=>leave - end select -! call can1%print_parents -! call can2%print_parents - if(associated(can2%pred,can1))then -! print *,"ordered" - call can_tilt_left(can1,can2) - call can2%get_bin_tree(bin_tree) - else -! print *,"not ordered" - call can_tilt_right(can2,can1) - print *,associated(bin_tree) - call can2%get_bin_tree(bin_tree) - print *,associated(bin_tree) - end if - deallocate(can1) - deallocate(can2) - end subroutine fibonacci_root_to_bin_tree - - subroutine common_boundary(bin1,bin2) - class(dynamic_bin_tree_type),intent(inout)::bin1,bin2 - real(kind=double)::center - !print *,dynamic_bin_measure(bin1)>dynamic_bin_measure(bin2) -! print *,"common_boundary" -! print *,bin1%range,bin2%range - center=(bin1%range(2)+bin2%range(1))/2D0 - bin1%range(2)=center - bin2%range(1)=center -! print *,bin1%range,bin2%range -! print *,"" - end subroutine common_boundary - - subroutine fib_to_bin(fib_leave,bin_tree) - class(fibonacci_leave_type),intent(in)::fib_leave - class(dynamic_bin_tree_type),pointer,intent(out)::bin_tree - class(measurable_class),pointer::bin - call fib_leave%get_content(bin) - select type(bin) - class is (dynamic_bin_type) - allocate(bin_tree) - bin_tree%count=bin%count - bin_tree%range=bin%range - end select - end subroutine fib_to_bin - - subroutine merge_bin_trees(tree1,tree2,merged) - class(dynamic_bin_tree_type),target,intent(in)::tree1,tree2 - class(dynamic_bin_tree_type),pointer,intent(out)::merged -! print *,"merge_bin_trees" - allocate(merged) - merged%left=>tree1 - merged%right=>tree2 - merged%count=tree1%count+tree2%count - merged%range=[tree1%range(1),tree2%range(2)] - ! print *,tree1%range - ! PRINT *,tree2%range - ! print *,merged%range - ! print *,"" - end subroutine merge_bin_trees - - subroutine can_tilt_left(pred,succ) - class(dynamic_bin_candidate_type),target,intent(inout)::succ,pred - class(measurable_class),pointer::succ_c,pred_c - succ%pred=>pred%pred - call succ%get_content(succ_c) - call pred%get_content(pred_c) - select type(succ_c) - class is(dynamic_bin_tree_type) - select type(pred_c) - class is(dynamic_bin_tree_type) -! print *,pred_c%range,succ_c%range - succ_c%left=>pred_c - call succ_c%update -! print *,pred_c%range,succ_c%range - end select - end select - end subroutine can_tilt_left - - subroutine can_tilt_right(pred,succ) - class(dynamic_bin_candidate_type),target,intent(inout)::succ,pred - class(measurable_class),pointer::succ_c,pred_c - pred%succ=>succ%succ - call succ%get_content(succ_c) - call pred%get_content(pred_c) - select type(succ_c) - class is(dynamic_bin_tree_type) - select type(pred_c) - class is(dynamic_bin_tree_type) - pred_c%right=>succ_c - call pred_c%update - end select - end select - end subroutine can_tilt_right - -!!$ -!!$ can=>leave%succ -!!$ can%pred=>leave%pred -!!$ call can%get_content(bin3) -!!$ select type(bin3) -!!$ class is(dynamic_bin_tree_type) -!!$ bin3%left=>bin2 -!!$ call bin3%update -!!$ end select - -!!$ subroutine make_candidate_tree(raw_tree,range,can_tree) -!!$ class(fibonacci_root_type),intent(in)::raw_tree -!!$ real(kind=double),dimension(2),intent(in)::range -!!$ class(fibonacci_root_type),intent(out)::can_tree -!!$ type(dynamic_bin_type)::bin -!!$ class(serializable_class),pointer::new_bin -!!$ class(fibonacci_node_type),pointer::node -!!$ class(fibonacci_leave_type),pointer::leave -!!$ real(kind=double)::value -!!$! value=raw_tree%rightmost%value -!!$ bin%range=range -!!$ bin%count=0 -!!$ call make_candidate_tree_rec(raw_tree,value,bin,can_tree) -!!$ new_bin=>can_tree%rightmost%content -!!$ select type (new_bin) -!!$ class is (dynamic_bin_type) -!!$ new_bin%range(1)= -!!$ end select -!!$ allocate(leave) -!!$ call leave%copy_content(bin) -!!$ leave%right=>can_tree%rightmost -!!$ can_tree%rightmost=>leave -!!$ node=>can_tree%rightmost -!!$ do while (associated(node)) -!!$ select type(node) -!!$ class is (fibonacci_leave_type) -!!$ call node%XXXX%print_all() -!!$ end select -!!$ node=>node%right -!!$ end do -!!$ end subroutine make_candidate_tree -!!$ -!!$ recursive subroutine make_candidate_tree_rec(raw_tree,value,bin,can_tree) -!!$ class(fibonacci_node_type),intent(in)::raw_tree -!!$ real(kind=double),intent(inout)::value -!!$ class(dynamic_bin_type),intent(inout)::bin -!!$ class(fibonacci_root_type),intent(inout)::can_tree -!!$ class(dynamic_bin_type),pointer::new_bin -!!$ class(fibonacci_leave_type),pointer::new_leave -!!$ select type(raw_tree) -!!$ class is (fibonacci_leave_type) -!!$ if(raw_tree==value)then -!!$ bin%count=bin%count+1 -!!$ else -!!$ allocate(new_leave) -!!$ new_leave%right=>can_tree%rightmost -!!$ can_tree%rightmost=>new_leave -!!$ allocate(new_bin,source=bin) -!!$! new_bin%range(1)=(raw_tree%value+value)/2D0 -!!$ call new_leave%set_content(new_bin) -!!$ bin%count=1 -!!$ bin%range(2)=new_bin%range(1) -!!$! value=raw_tree%value -!!$ end if -!!$ class default -!!$ call make_candidate_tree_rec(raw_tree%right,value,bin,can_tree) -!!$ call make_candidate_tree_rec(raw_tree%left,value,bin,can_tree) -!!$ end select -!!$ end subroutine make_candidate_tree_rec - -end module dynamic_binning_module Index: branches/attic/boschmann_standalone/pri/lib/common.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/common.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/common.f03.pri (revision 8609) @@ -1,106 +0,0 @@ -!!! module: common_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-01-05 12:03:26 CET(+0100) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module common_module -! use,intrinsic::iso_fortran_env -! use,intrinsic::ieee_arithmetic!FC = nagfor - use kinds - use arguments_module - use misc_module - use tao_random_numbers - implicit none -! integer,parameter::n_threads=4 - integer,save::seed_unit - - type(string_argument_type),target,save::home_dir,plot_dir,data_dir,output_dir,pdf_file,random_seed_file - type(switch_argument_type),target,save::verbose,quiet - type(integer_argument_type),target,save::random_seed - type(plain_argument_type),target,save::help_arg - type(argument_list_type),target,save::args -! type(tao_random_state),dimension(n_threads),save::parallel_tao_states - type(tao_random_state),save::sequentiel_tao_state - -contains - - subroutine common_run() - call help_arg%write_to_unit(output_unit) - call verbose%initialize(.false.,args,"v","verbose",description="Genrate more output.") - call quiet%initialize(.true.,args,"q","quiet",description="Genrate less output.") - call random_seed%initialize(1,1,2**30,args,long="random_seed",named_option="", description="When given, tao random numbers are initialized with .") - call random_seed_file%initialize("seed",args,long="random_seed_file",named_option="",description=" contains an integer number 0 -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-16 15:07:16 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -MODULE beam_remnant_module - use,intrinsic::iso_fortran_env - use kinds - use basic_types_module - use parameters_module - use common_module - use remnant_interface_module - use remnant_module - implicit none - type,extends(beam_remnant_class)::beam_remnant_type - real(kind=double),private::gev_initial_cme = gev_cme_tot - real(kind=double),private::X=1D0 - type(proton_remnant_type),private::proton1,proton2 - contains - procedure::apply_interaction=>beam_remnant_apply_interaction - procedure::get_pdf_int_weights=>beam_remnant_get_pdf_int_weights -! procedure::set_pdf_weight=>beam_remnant_set_pdf_weight - procedure::reset=>beam_remnant_reset - procedure::get_gev_initial_cme=>beam_remnant_get_gev_initial_cme - procedure::get_gev_actual_cme=>beam_remnant_get_gev_actual_cme - procedure::get_cme_fraction=>beam_remnant_get_cme_fraction - procedure::get_proton_remnant_momentum_fractions=>beam_remnant_get_proton_remnant_momentum_fractions - procedure::get_proton_remnants=>beam_remnant_get_proton_remnants - procedure::get_remnant_parton_flavor_pdf_arrays=>beam_remnant_get_remnant_parton_flavor_pdf_arrays - ! overridden serializable_class procedures - procedure::write_to_ring=>beam_remnant_write_to_ring - procedure::read_from_ring=>beam_remnant_read_from_ring - procedure::print_to_unit=>beam_remnant_print_to_unit - procedure,nopass::get_type=>beam_remnant_get_type - end type beam_remnant_type - - contains - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! type bound procedures for beam_remnant_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine beam_remnant_apply_interaction(this,qcd_2_2) - class(beam_remnant_type),intent(inout)::this - class(qcd_2_2_class),intent(in)::qcd_2_2 - integer,dimension(4)::lha_f - integer,dimension(2)::int_k - real(kind=double)::gev_pt - real(kind=double),dimension(2)::mom_f - mom_f=qcd_2_2%get_remnant_momentum_fractions() - lha_f=qcd_2_2%get_lha_flavors() - int_k=qcd_2_2%get_pdf_int_kinds() - gev_pt=qcd_2_2%get_gev_pt() - select case (int_k(1)) - case(pdf_int_kind_val_down) - call this%proton1%remove_valence_down_quark(gev_pt,mom_f(1)) - case(pdf_int_kind_val_up) - call this%proton1%remove_valence_up_quark(gev_pt,mom_f(1)) - case(pdf_int_kind_sea) - call this%proton1%remove_sea_quark(gev_pt,mom_f(1),lha_f(1)) - case(pdf_int_kind_gluon) - call this%proton1%remove_gluon(gev_pt,mom_f(1)) - end select - select case (int_k(2)) - case(pdf_int_kind_val_down) - call this%proton2%remove_valence_down_quark(gev_pt,mom_f(2)) - case(pdf_int_kind_val_up) - call this%proton2%remove_valence_up_quark(gev_pt,mom_f(2)) - case(pdf_int_kind_sea) - call this%proton2%remove_sea_quark(gev_pt,mom_f(2),lha_f(2)) - case(pdf_int_kind_gluon) - call this%proton2%remove_gluon(gev_pt,mom_f(2)) - end select - this%X=this%proton1%momentum_fraction*this%proton2%momentum_fraction - end subroutine beam_remnant_apply_interaction - - subroutine beam_remnant_reset(this) - class(beam_remnant_type),intent(inout)::this - call this%proton1%reset() - call this%proton2%reset() - this%proton1%momentum_fraction=1D0 - this%proton2%momentum_fraction=1D0 - this%X=1D0 - end subroutine beam_remnant_reset - - pure function beam_remnant_get_pdf_int_weights(this,pdf_int_kinds) result(weight) - class(beam_remnant_type),intent(in)::this - real(kind=double)::weight - integer,dimension(2),intent(in)::pdf_int_kinds ! pdf_int_kind - weight=this%proton1%pdf_int_weight(pdf_int_kinds(1))*this%proton2%pdf_int_weight(pdf_int_kinds(2))!*((this%x)**2) - end function beam_remnant_get_pdf_int_weights - - elemental function beam_remnant_get_pdf_int_weight(this,kind1,kind2) result(weight) - class(beam_remnant_type),intent(in)::this - real(kind=double)::weight - integer,intent(in)::kind1,kind2 ! pdf_int_kind - weight=this%proton1%pdf_int_weight(kind1)*this%proton2%pdf_int_weight(kind2)!*((this%x)**2) - end function beam_remnant_get_pdf_int_weight - - subroutine beam_remnant_set_pdf_weight(this,weights) - class(beam_remnant_type),intent(inout)::this - real(kind=double),dimension(8),intent(in)::weights - this%proton1%pdf_int_weight=weights(1:4) - this%proton2%pdf_int_weight=weights(5:8) - end subroutine beam_remnant_set_pdf_weight - - elemental function beam_remnant_get_gev_initial_cme(this) result(cme) - class(beam_remnant_type),intent(in)::this - real(kind=double)::cme - cme=this%gev_initial_cme - end function beam_remnant_get_gev_initial_cme - - elemental function beam_remnant_get_gev_actual_cme(this) result(cme) - class(beam_remnant_type),intent(in)::this - real(kind=double)::cme - cme=this%gev_initial_cme*this%X - end function beam_remnant_get_gev_actual_cme - - elemental function beam_remnant_get_cme_fraction(this) result(cme) - class(beam_remnant_type),intent(in)::this - real(kind=double)::cme - cme=this%X - end function beam_remnant_get_cme_fraction - - pure function beam_remnant_get_proton_remnant_momentum_fractions(this) result(fractions) - class(beam_remnant_type),intent(in)::this - real(kind=double),dimension(2)::fractions - fractions=[this%proton1%get_momentum_fraction(),this%proton2%get_momentum_fraction()] - end function beam_remnant_get_proton_remnant_momentum_fractions - - subroutine beam_remnant_get_proton_remnants(this,proton1,proton2) - class(beam_remnant_type),target,intent(in)::this - class(proton_remnant_class),intent(out),pointer::proton1,proton2 - proton1=>this%proton1 - proton2=>this%proton2 - end subroutine beam_remnant_get_proton_remnants - - subroutine beam_remnant_get_remnant_parton_flavor_pdf_arrays(this,GeV_scale,momentum1,momentum2,pdf1,pdf2) - class(beam_remnant_type),intent(in)::this - real(kind=double),intent(in)::GeV_scale,momentum1,momentum2 - real(kind=double),dimension(-6:6),intent(out)::pdf1,pdf2 - call this%proton1%parton_flavor_pdf_array(GeV_scale,momentum1,pdf1) - call this%proton2%parton_flavor_pdf_array(GeV_scale,momentum2,pdf2) - end subroutine beam_remnant_get_remnant_parton_flavor_pdf_arrays - - !overridden procedures - - SUBROUTINE beam_remnant_write_to_ring(this,ring,status) - CLASS(beam_remnant_type),INTENT(IN) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - call xml_write_begin_tag(ring,"BEAM_REMNANT_TYPE") - call xml_write(ring,"gev_initial_cme",this%gev_initial_cme) - call xml_write(ring,"X",this%X) - call this%proton1%write_to_ring(ring,status) - call this%proton2%write_to_ring(ring,status) - call xml_write_end_tag(ring,"BEAM_REMNANT_TYPE") - END SUBROUTINE beam_remnant_write_to_ring - - SUBROUTINE beam_remnant_read_from_ring(this,ring,status) - CLASS(beam_remnant_type),INTENT(INOUT) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - call xml_verify_begin_tag(ring,"BEAM_REMNANT_TYPE",status) - call xml_read(ring,"gev_initial_cme",this%gev_initial_cme,status) - call xml_read(ring,"X",this%X,status) - call this%proton1%read_from_ring(ring,status) - call this%proton2%read_from_ring(ring,status) - call xml_verify_end_tag(ring,"BEAM_REMNANT_TYPE",status) - END SUBROUTINE beam_remnant_read_from_ring - - subroutine beam_remnant_print_to_unit(this,unit,parents,components,peers) - class(beam_remnant_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - write(unit,'("Instance of type: ",a)')this%get_type() - write(unit,'("Initial center of mass energy: ",F7.2)')this%gev_initial_cme - write(unit,'("Actual center of mass energy: ",F7.2)')this%get_gev_actual_cme() - write(unit,'("Total Momentum Fraction is: ",F7.2)')this%X - if(components>0)then - call this%proton1%print_to_unit(unit,parents,components-1,peers) - call this%proton2%print_to_unit(unit,parents,components-1,peers) - end if - end subroutine beam_remnant_print_to_unit - - pure function beam_remnant_get_type() result(type) - character(:),allocatable::type!FC = nagfor - allocate(type,source="BEAM_REMNANT_TYPE")!FC = nagfor - character(32)::type!FC = gfortran - type="BEAM_REMNANT_TYPE"!FC = gfortran - end function beam_remnant_get_type - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Cuba Integrand Functions !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine remnant_proton_proton_integrand_6(dim_x,x,dim_f,f,pt2s) -! use momentum_module - integer,intent(in)::dim_x,dim_f -! real(kind=double),intent(in),dimension(dim_x)::x -! real(kind=double),intent(out),dimension(dim_f)::f - real(kind=double),intent(in),dimension(2)::x - real(kind=double),intent(out),dimension(6)::f - real(kind=double),intent(in) :: pt2s - real(kind=double),dimension(2)::valence_pdf - real(kind=double),dimension(-6:6)::c,d - real(kind=double),dimension(5)::psin - real(kind=double)::k1,k2,x1,x2,a,b,Q,pt2shat,abs_b,b_a,& - ®,pscom,pscom_reg,alphas_reg,pdf_down,pdf_up,pdf_all,v1u,v1d,v2u,v2d - k1=x(1) - k2=x(2) - q=sqrt(pt2s)*gev_pt_max - alphas_reg=alphaspdf(q+gev_p_t_0) - ! Coordinate transformation to cartesian coordiantes - a=(k1**4)*(1D0-pt2s)+pt2s - b=4D0*((k2-5D-1)**3) - abs_b=abs(b) - b_a=abs_b/a - pt2shat=pt2s/a - if (b_a0) then - x1=sqrt(a)*(1-b_a/2+(b_a**2)/8) - x2=sqrt(a)*(1+b_a/2+(b_a**2)/8) - else - x1=sqrt(a)*(1-b_a/2+(b_a**2)/8) - x2=sqrt(a)*(1+b_a/2+(b_a**2)/8) - end if - else - if ((1D0/b_a)0D0) then - x1=a/sqrt(2*abs_b) - x2=sqrt(abs_b/2)*(2+1/(4*b_a**2)) - else - x1=sqrt(abs_b/2)*(2+1/(4*b_a**2)) - x2=a/sqrt(2*abs_b) - end if - else - x1=sqrt(sqrt(a**2+abs_b**2)-b) - x2=sqrt(sqrt(a**2+abs_b**2)+b) - end if - end if - if(x1<=1D0.and.x2<=1D0)then - ! phase space polynom - psin=matmul([1D0,pt2shat,pt2shat**2,pt2shat**3],phase_space_coefficients_in) - ! commen ps factor - pscom=& - &(pi/(36D0*b_sigma_tot_nd))*& - &((1D0-2D0*k2)**2)*k1*sqrt(a/(a**2+b**2))*& - &sqrt(1D0-pt2s) - reg=(alphas_reg**2)*(((pt2s+norm2_p_t_0)*gev2_cme_tot)**(-3/2)) - pscom_reg=pscom*reg - ! pscom=& - ! &(pi/(144D0*gev2_cme_tot*b_sigma_tot_nd))*& - ! &((1D0-2D0*k2)**2)*k1*sqrt(a/(a**2+b**2))*& - ! &(alphas**2)*& - ! &sqrt(1D0-pt2s)/((pt2s)**2) - ! pdf - call evolvepdf(x1,q,c) - call evolvepdf(x2,q,d) - v1d=c(1)-c(-1) - v1u=c(2)-c(-2) - v2d=d(1)-d(-1) - v2u=d(2)-d(-2) - c(1)=c(-1) - c(2)=c(-2) - d(1)=d(-1) - d(2)=d(-2) - pdf_all=dot_product([& - !type1 - &c(-4)*d(-3)+c(-4)*d(-2)+c(-4)*d(-1)+c(-4)*d( 1)+c(-4)*d( 2)+c(-4)*d( 3)+& - &c(-3)*d(-4)+c(-3)*d(-2)+c(-3)*d(-1)+c(-3)*d( 1)+c(-3)*d( 2)+c(-3)*d( 4)+& - &c(-2)*d(-4)+c(-2)*d(-3)+c(-2)*d(-1)+c(-2)*d( 1)+c(-2)*d( 3)+c(-2)*d( 4)+& - &c(-1)*d(-4)+c(-1)*d(-3)+c(-1)*d(-2)+c(-1)*d( 2)+c(-1)*d( 3)+c(-1)*d( 4)+& - &c( 1)*d(-4)+c( 1)*d(-3)+c( 1)*d(-2)+c( 1)*d( 2)+c( 1)*d( 3)+c( 1)*d( 4)+& - &c( 2)*d(-4)+c( 2)*d(-3)+c( 2)*d(-1)+c( 2)*d( 1)+c( 2)*d( 3)+c( 2)*d( 4)+& - &c( 3)*d(-4)+c( 3)*d(-2)+c( 3)*d(-1)+c( 3)*d( 1)+c( 3)*d( 2)+c( 3)*d( 4)+& - &c( 4)*d(-3)+c( 4)*d(-2)+c( 4)*d(-1)+c( 4)*d( 1)+c( 4)*d( 2)+c( 4)*d( 3),& - !type2 - &c(-4)*d(-4)+c(-3)*d(-3)+c(-2)*d(-2)+c(-1)*d(-1)+c( 4)*d( 4)+c( 3)*d( 3)+c(2)*d( 2)+c(1)*d( 1),& - !type3 - &c(-4)*d( 4)+c(-3)*d( 3)+c(-2)*d( 2)+c(-1)*d( 1)+c( 4)*d(-4)+c( 3)*d(-3)+c(2)*d(-2)+c(1)*d(-1),& - !type4 - &c(0)*d(-4)+c(0)*d(-3)+c(0)*d(-2)+c(0)*d(-1)+c(0)*d(1)+c(0)*d(2)+c(0)*d(3)+c(0)*d(4)+& - &c(-4)*d(0)+c(-3)*d(0)+c(-2)*d(0)+c(-1)*d(0)+c(1)*d(0)+c(2)*d(0)+c(3)*d(0)+c(4)*d(0),& - !type5 - &c(0)*d(0)],psin) - pdf_up=dot_product([& - !type1 - v1u*d(-4)+v1u*d(-3)+v1u*d(-1)+v1u*d( 1)+v1u*d( 3)+v1u*d( 4)+& - c(-4)*v2u+c(-3)*v2u+c(-1)*v2u+c( 1)*v2u+c( 3)*v2u+c( 4)*v2u,& - !type2 - &v1u*d(2)+c(2)*v2u,& - !type3 - &v1u*d(-2)+& - &c(-2)*v2u,& - !type4 - &v1u*d(0)+& - &c(0)*v2u,& - !type5 - &0D0],psin) - pdf_down=dot_product([& - !type1 - v1d*d(-4)+v1d*d(-3)+v1d*d(-2)+v1d*d( 2)+v1d*d( 3)+v1d*d( 4)+& - c(-4)*v2d+c(-3)*v2d+c(-2)*v2d+c( 2)*v2d+c( 3)*v2d+c( 4)*v2d,& - !type2 - &v1d*d( 1)+c( 1)*v2d,& - !type3 - &v1d*d(-1)+c(-1)*v2d,& - !type4 - &v1d*d( 0)+& - &c( 0)*v2d,& - !type5 - &0D0],psin) - f(1)=v1d*v2d*psin(2) - f(2)=v1u*v2u*psin(2) - f(3)=(v1u*v2d+v1d*v2u)*psin(1) - f(4)=pdf_down - f(5)=pdf_up - f(6)=pdf_all - f=(f*pscom_reg)/(A*b_sigma_tot_nd) - else - f=0D0 - end if - end subroutine remnant_proton_proton_integrand_6 - - subroutine remnant_proton_proton_integrand_11(dim_x,x,dim_f,f,pt2s) -! use momentum_module - integer,intent(in)::dim_x,dim_f - real(kind=double),intent(in),dimension(2)::x - real(kind=double),intent(out),dimension(11)::f - real(kind=double),intent(in) :: pt2s - real(kind=double),dimension(2)::valence_pdf - real(kind=double),dimension(-6:6)::c,d - real(kind=double),dimension(5)::psin - real(kind=double)::k1,k2,x1,x2,a,b,Q,pt2shat,abs_b,b_a,& - ®,pscom,pscom_reg,alphas_reg,& - &pdf_seaquark_seaquark,pdf_seaquark_gluon,pdf_gluon_gluon,& - &pdf_up_seaquark,pdf_up_gluon,pdf_down_seaquark,pdf_down_gluon,& - &v1u,v1d,v2u,v2d - k1=x(1) - k2=x(2) - q=sqrt(pt2s)*gev_pt_max - alphas_reg=alphaspdf(q+gev_p_t_0) - ! Coordinate transformation to cartesian coordiantes - a=(k1**4)*(1D0-pt2s)+pt2s - b=4D0*((k2-5D-1)**3) - abs_b=abs(b) - b_a=abs_b/a - pt2shat=pt2s/a - if (b_a0) then - x1=sqrt(a)*(1-b_a/2+(b_a**2)/8) - x2=sqrt(a)*(1+b_a/2+(b_a**2)/8) - else - x1=sqrt(a)*(1-b_a/2+(b_a**2)/8) - x2=sqrt(a)*(1+b_a/2+(b_a**2)/8) - end if - else - if ((1D0/b_a)0D0) then - x1=a/sqrt(2*abs_b) - x2=sqrt(abs_b/2)*(2+1/(4*b_a**2)) - else - x1=sqrt(abs_b/2)*(2+1/(4*b_a**2)) - x2=a/sqrt(2*abs_b) - end if - else - x1=sqrt(sqrt(a**2+abs_b**2)-b) - x2=sqrt(sqrt(a**2+abs_b**2)+b) - end if - end if - if(x1<=1D0.and.x2<=1D0)then - ! phase space polynom - psin=matmul([1D0,pt2shat,pt2shat**2,pt2shat**3],phase_space_coefficients_in) - ! commen ps factor - pscom=& - &(pi/(36D0*b_sigma_tot_nd))*& - &((1D0-2D0*k2)**2)*k1*sqrt(a/(a**2+b**2))*& - &sqrt(1D0-pt2s) - reg=(alphas_reg**2)*(((pt2s+norm2_p_t_0)*gev2_cme_tot)**(-3/2)) - pscom_reg=pscom*reg - ! pscom=& - ! &(pi/(144D0*gev2_cme_tot*b_sigma_tot_nd))*& - ! &((1D0-2D0*k2)**2)*k1*sqrt(a/(a**2+b**2))*& - ! &(alphas**2)*& - ! &sqrt(1D0-pt2s)/((pt2s)**2) - ! pdf - call evolvepdf(x1,q,c) - call evolvepdf(x2,q,d) - v1d=c(1)-c(-1) - v1u=c(2)-c(-2) - v2d=d(1)-d(-1) - v2u=d(2)-d(-2) - c(1)=c(-1) - c(2)=c(-2) - d(1)=d(-1) - d(2)=d(-2) - pdf_seaquark_seaquark=dot_product([& - !type1 - &c(-4)*d(-3)+c(-4)*d(-2)+c(-4)*d(-1)+c(-4)*d( 1)+c(-4)*d( 2)+c(-4)*d( 3)+& - &c(-3)*d(-4)+c(-3)*d(-2)+c(-3)*d(-1)+c(-3)*d( 1)+c(-3)*d( 2)+c(-3)*d( 4)+& - &c(-2)*d(-4)+c(-2)*d(-3)+c(-2)*d(-1)+c(-2)*d( 1)+c(-2)*d( 3)+c(-2)*d( 4)+& - &c(-1)*d(-4)+c(-1)*d(-3)+c(-1)*d(-2)+c(-1)*d( 2)+c(-1)*d( 3)+c(-1)*d( 4)+& - &c( 1)*d(-4)+c( 1)*d(-3)+c( 1)*d(-2)+c( 1)*d( 2)+c( 1)*d( 3)+c( 1)*d( 4)+& - &c( 2)*d(-4)+c( 2)*d(-3)+c( 2)*d(-1)+c( 2)*d( 1)+c( 2)*d( 3)+c( 2)*d( 4)+& - &c( 3)*d(-4)+c( 3)*d(-2)+c( 3)*d(-1)+c( 3)*d( 1)+c( 3)*d( 2)+c( 3)*d( 4)+& - &c( 4)*d(-3)+c( 4)*d(-2)+c( 4)*d(-1)+c( 4)*d( 1)+c( 4)*d( 2)+c( 4)*d( 3),& - !type2 - &c(-4)*d(-4)+c(-3)*d(-3)+c(-2)*d(-2)+c(-1)*d(-1)+c( 4)*d( 4)+c( 3)*d( 3)+c(2)*d( 2)+c(1)*d( 1),& - !type3 - &c(-4)*d( 4)+c(-3)*d( 3)+c(-2)*d( 2)+c(-1)*d( 1)+c( 4)*d(-4)+c( 3)*d(-3)+c(2)*d(-2)+c(1)*d(-1)& - &,0D0,0D0],psin) - pdf_seaquark_gluon=(& - !type4 - &c(0)*d(-4)+c(0)*d(-3)+c(0)*d(-2)+c(0)*d(-1)+c(0)*d(1)+c(0)*d(2)+c(0)*d(3)+c(0)*d(4)+& - &c(-4)*d(0)+c(-3)*d(0)+c(-2)*d(0)+c(-1)*d(0)+c(1)*d(0)+c(2)*d(0)+c(3)*d(0)+c(4)*d(0)& - &)*psin(4) - pdf_gluon_gluon=(& - !type5 - &c(0)*d(0)& - &)*psin(5) - pdf_up_seaquark=dot_product([& - !type1 - v1u*d(-4)+v1u*d(-3)+v1u*d(-1)+v1u*d( 1)+v1u*d( 3)+v1u*d( 4)+& - c(-4)*v2u+c(-3)*v2u+c(-1)*v2u+c( 1)*v2u+c( 3)*v2u+c( 4)*v2u,& - !type2 - &v1u*d(2)+c(2)*v2u,& - !type3 - &v1u*d(-2)+& - &c(-2)*v2u& - &,0D0,0D0],psin) - pdf_up_gluon=(& - !type4 - &v1u*d(0)+& - &c(0)*v2u& - &)*psin(4) - pdf_down_seaquark=dot_product([& - !type1 - v1d*d(-4)+v1d*d(-3)+v1d*d(-2)+v1d*d( 2)+v1d*d( 3)+v1d*d( 4)+& - c(-4)*v2d+c(-3)*v2d+c(-2)*v2d+c( 2)*v2d+c( 3)*v2d+c( 4)*v2d,& - !type2 - &v1d*d( 1)+c( 1)*v2d,& - !type3 - &v1d*d(-1)+c(-1)*v2d& - &,0D0,0D0],psin) - pdf_down_gluon=(& - !type4 - &v1d*d( 0)+& - &c( 0)*v2d& - &)*psin(4) - f(1)=0D0 - f(2)=v1d*v2d*psin(2) - f(3)=v1u*v2u*psin(2) - f(4)=(v1u*v2d+v1d*v2u)*psin(1) - f(5)=pdf_down_seaquark - f(6)=pdf_down_gluon - f(7)=pdf_up_seaquark - f(8)=pdf_up_gluon - f(9)=pdf_seaquark_seaquark - f(10)=pdf_seaquark_gluon - f(11)=pdf_gluon_gluon - f=(f*pscom_reg)/(A*b_sigma_tot_nd) - else - f=0D0 - end if - end subroutine remnant_proton_proton_integrand_11 - -end MODULE beam_remnant_module - Index: branches/attic/boschmann_standalone/pri/lib/sample_fractions.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/sample_fractions.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/sample_fractions.f03.pri (revision 8609) @@ -1,1220 +0,0 @@ -!!! module: sample_fractions_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-20 11:05:59 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -module sample_fractions_module - use kinds - use common_module - use basic_types_module - use tao_random_numbers - use coordinates_module - use dynamic_binning_3_module,only:log_color_code - implicit none - - integer,private,parameter::max_n=2**30 - real(kind=double),private,parameter::max_d=1D0*max_n - real(kind=double),private,parameter,dimension(2,2)::unit_square=reshape([0D0,0D0,1D0,1D0],[2,2]) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Derived Type Definitions !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type,extends(serializable_class)::sample_region_type - integer::n_hits=0 - integer::n_alloc=0 - real(kind=double),dimension(2,2)::corners=unit_square - real(kind=double),dimension(:,:),allocatable::hyp_hits - contains - ! overridden serializable_class procedures - procedure :: write_to_ring=>sample_region_write_to_ring - procedure :: read_from_ring=>sample_region_read_from_ring - procedure :: print_to_unit=>sample_region_print_to_unit - procedure,nopass :: get_type=>sample_region_get_type - ! new procedures - procedure :: initialize=>sample_region_initialize - procedure :: generate_hit=>sample_region_generate_hit - procedure :: confirm_hit=>sample_region_confirm_hit - procedure :: split=>sample_region_split - procedure :: write_hits=>sample_region_write_hits - procedure :: is_full=>sample_region_is_full - procedure :: move_components=>sample_region_move_components - procedure :: mean=>sample_region_mean - procedure :: area=>sample_region_area - procedure :: density=>sample_region_density - procedure :: contains=>sample_region_contains - procedure :: to_generator=>sample_region_to_generator - end type sample_region_type - - type,extends(serializable_class)::sample_2d_type - integer::n_regions=0 - integer::n_alloc=0 - integer::n_hits=0 - real(kind=double),dimension(2)::range=[0,1] - type(sample_region_type),dimension(:),allocatable::regions - contains - ! overridden serializable_class procedures - procedure :: write_to_ring=>sample_2d_write_to_ring - procedure :: read_from_ring=>sample_2d_read_from_ring - procedure :: print_to_unit=>sample_2d_print_to_unit - procedure,nopass :: get_type=>sample_2d_get_type - ! new procedures - procedure :: initialize=>sample_2d_initialize - procedure :: contains=>sample_2d_contains - procedure :: generate_hit=>sample_2d_generate_hit - procedure :: confirm_hit=>sample_2d_confirm_hit - procedure :: split=>sample_2d_split - procedure :: push=>sample_2d_push - procedure :: write_hits=>sample_2d_write_hits - procedure :: is_full=>sample_2d_is_full - procedure :: move_components=>sample_2d_move_components - procedure :: thickness=>sample_2d_thickness - procedure :: analyse=>sample_2d_analyse - procedure :: to_generator=>sample_2d_to_generator - procedure :: mean=>sample_2d_mean - end type sample_2d_type - - type,extends(serializable_class)::sample_3d_type - integer::n_slices=0 - integer::n_alloc=0 - type(sample_2d_type),dimension(:),allocatable::slices - contains - ! overridden serializable_class procedures - procedure :: write_to_ring=>sample_3d_write_to_ring - procedure :: read_from_ring=>sample_3d_read_from_ring - procedure :: print_to_unit=>sample_3d_print_to_unit - procedure,nopass :: get_type=>sample_3d_get_type - ! overridden measurable_class procedures - procedure :: measure=>sample_3d_measure - ! new procedures - procedure :: to_generator=>sample_3d_to_generator - procedure :: sample_3d_initialize - procedure :: sample_3d_generate_hit - procedure :: sample_3d_confirm_hit - procedure :: enlarge=>sample_3d_enlarge - generic::initialize=>sample_3d_initialize - generic::generate_hit=>sample_3d_generate_hit - generic::confirm_hit=>sample_3d_confirm_hit - end type sample_3d_type - - type,extends(sample_3d_type)::sample_int_kind_type - integer::n_proc=0 - integer(kind=i64)::n_tries=0 - integer::n_hits=0 - integer::n_over=0 - integer,dimension(:),allocatable::hits,weights,processes - real(kind=double)::overall_boost=1D-1 - contains - ! overridden serializable_class procedures - procedure :: write_to_ring=>sample_int_kind_write_to_ring - procedure :: read_from_ring=>sample_int_kind_read_from_ring - procedure :: print_to_unit=>sample_int_kind_print_to_unit - procedure,nopass :: get_type=>sample_int_kind_get_type - ! overridden sample_3d_type procedures - procedure :: to_generator=>sample_int_kind_to_generator - ! new procedures - procedure :: process_id=>sample_int_kind_process_id - procedure :: sample_int_kind_initialize - procedure :: sample_int_kind_generate_hit - procedure :: mcgenerate_hit=>sample_int_kind_mcgenerate_hit - procedure :: sample_int_kind_confirm_hit - procedure :: analyse=>sample_int_kind_analyse - generic::initialize=>sample_int_kind_initialize - generic::generate_hit=>sample_int_kind_generate_hit - generic::confirm_hit=>sample_int_kind_confirm_hit - end type sample_int_kind_type - - type,extends(serializable_class)::sample_inclusive_type - integer::n_alloc=0 - type(sample_int_kind_type),dimension(:),allocatable::int_kinds - contains - ! overridden serializable_class procedures - procedure :: write_to_ring=>sample_inclusive_write_to_ring - procedure :: read_from_ring=>sample_inclusive_read_from_ring - procedure :: print_to_unit=>sample_inclusive_print_to_unit - procedure,nopass :: get_type=>sample_inclusive_get_type - ! new procedures - procedure :: process_id=>sample_inclusive_process_id - procedure :: initialize=>sample_inclusive_initialize - procedure :: generate_hit=>sample_inclusive_generate_hit - procedure :: mcgenerate_hit=>sample_inclusive_mcgenerate_hit - procedure :: confirm_hit=>sample_inclusive_confirm_hit - procedure :: analyse=>sample_inclusive_analyse - procedure :: to_generator=>sample_inclusive_to_generator - end type sample_inclusive_type - -contains - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! type bound procedures for sample_region_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - SUBROUTINE sample_region_write_to_ring(this,ring,status) - CLASS(sample_region_type),INTENT(IN) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - integer::n - call xml_write_begin_tag(ring,"SAMPLE_REGION_TYPE") - call xml_write(ring,"N_HITS",this%n_hits) - call xml_write(ring,"N_ALLOC",this%n_alloc) - call xml_write(ring,"LOWER_CORNER",this%corners(1:2,1)) - call xml_write(ring,"UPPER_CORNER",this%corners(1:2,2)) - if(allocated(this%hyp_hits))then - call xml_write(ring,"hyp_hits",this%hyp_hits) - else - call xml_write_null_instance(ring,"hyp_hits") - end if - call xml_write_end_tag(ring,"SAMPLE_REGION_TYPE") - END SUBROUTINE sample_region_write_to_ring - - SUBROUTINE sample_region_read_from_ring(this,ring,status) - CLASS(sample_region_type),INTENT(OUT) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - integer::n - call xml_verify_begin_tag(ring,"SAMPLE_REGION_TYPE") - call xml_read(ring,"N_HITS",this%n_hits,status) - call xml_read(ring,"N_ALLOC",this%n_alloc,status) - call xml_read(ring,"LOWER_CORNER",this%corners(1:2,1),status) - call xml_read(ring,"UPPER_CORNER",this%corners(1:2,2),status) - if(allocated(this%hyp_hits))deallocate(this%hyp_hits) - call xml_verify_null_instance(ring,"hyp_hits",status) - if(.not.status==serialize_null)then - call xml_read(ring,"hyp_hits",this%hyp_hits,status) - end if - call xml_verify_end_tag(ring,"SAMPLE_REGION_TYPE") - END SUBROUTINE sample_region_read_from_ring - - subroutine sample_region_print_to_unit(this,unit,parents,components,peers) - class(sample_region_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - write(unit,fmt=*)"Components of sample_region_type" - write(unit,'("N_HITS: ",I10)')this%n_hits - write(unit,'("N_ALLOC: ",I10)')this%n_alloc - write(unit,'("Corners: ",4(E20.10))')this%corners - if(allocated(this%hyp_hits))then - if(components>0)then - write(unit,'("HITS:")') - print *,shape(this%hyp_hits) - write(unit,fmt='(3(E20.10))')this%hyp_hits(1:3,this%n_hits) - else - write(unit,fmt=*)"Skipping HITS." - end if - else - write(unit,fmt=*)"HITS are not allocated." - end if - end subroutine sample_region_print_to_unit - - pure function sample_region_get_type() result(t) - character(:),allocatable::t !FC = nagfor - character(32)::t !FC = gfortran - allocate(t,source="SAMPLE_REGION_TYPE")!FC = nagfor - t="SAMPLE_REGION_TYPE"!FC = gfortran - end function sample_region_get_type - - subroutine sample_region_initialize(this,n_alloc) - class(sample_region_type),intent(out)::this - integer,intent(in)::n_alloc - if(allocated(this%hyp_hits))deallocate(this%hyp_hits) - allocate(this%hyp_hits(3,n_alloc)) - this%n_alloc=n_alloc - end subroutine sample_region_initialize - - pure subroutine sample_region_generate_hit(this,rnd,area,hit) - class(sample_region_type),intent(in)::this - integer,intent(in),dimension(2)::rnd - real(kind=double),dimension(2),intent(out)::hit - real(kind=double),intent(out)::area - call sample_fractions_generate_hit(rnd,this%corners,hit) - area=this%area() - end subroutine sample_region_generate_hit - - subroutine sample_region_confirm_hit(this,hit) - class(sample_region_type),intent(inout)::this - real(kind=double),dimension(3),intent(in)::hit -! print *,"sample_region_confirm_hit: ",this%n_hits,this%n_alloc,hit - this%n_hits=this%n_hits+1 - if(this%n_hits<=this%n_alloc)then - this%hyp_hits(1:3,this%n_hits)=hit - else - print *,"sample_region_confirm_hit: Region is already full." - end if - end subroutine sample_region_confirm_hit - - subroutine sample_region_split(this,pos,dimX,n_alloc,lower,upper) - class(sample_region_type),intent(in)::this - type(sample_region_type),intent(out)::lower,upper - real(kind=double),dimension(3)::hit - real(kind=double),intent(in)::pos - integer,intent(in)::dimX,n_alloc - integer::n_hit - call lower%initialize(n_alloc) - call upper%initialize(n_alloc) - do n_hit=1,this%n_hits - hit=this%hyp_hits(1:3,n_hit) - if(hit(dimX)0)then - call xml_write_begin_tag(ring,"REGIONS") - do n=1,this%n_regions - call sample_region_write_to_ring(this%regions(n),ring,status) - end do - call xml_write_end_tag(ring,"REGIONS") - end if - call xml_write_end_tag(ring,"SAMPLE_2D_TYPE") - END SUBROUTINE sample_2d_write_to_ring - - SUBROUTINE sample_2d_read_from_ring(this,ring,status) - CLASS(sample_2d_type),INTENT(OUT) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - integer::n - call xml_verify_begin_tag(ring,"SAMPLE_2D_TYPE") - call xml_read(ring,"N_REGIONS",this%n_regions,status) - call xml_read(ring,"N_ALLOC",this%n_alloc,status) - call xml_read(ring,"N_HITS",this%n_hits,status) - call xml_read(ring,"RANGE",this%range,status) - if(this%n_regions>0)then - allocate(this%regions(this%n_regions)) - call xml_verify_begin_tag(ring,"REGIONS",status) - do n=1,this%n_regions - call sample_region_read_from_ring(this%regions(n),ring,status) - end do - call xml_verify_end_tag(ring,"REGIONS",status) - end if - call xml_verify_end_tag(ring,"SAMPLE_2D_TYPE") - END SUBROUTINE sample_2d_read_from_ring - - subroutine sample_2d_print_to_unit(this,unit,parents,components,peers) - class(sample_2d_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - integer::n - write(unit,fmt=*)"Components of sample_2d_type" - write(unit,'("N_REGIONS: ",I10)')this%n_regions - write(unit,'("N_ALLOC: ",I10)')this%n_alloc - write(unit,'("RANGE: ",2(E20.10))')this%range - if(allocated(this%regions))then - if(components>0)then - write(unit,'("REGIONS:")') - do n=1,this%n_regions - call this%regions(n)%print_to_unit(unit,parents,components-1,peers) - end do - else - write(unit,fmt=*)"Skipping REGIONS." - end if - else - write(unit,fmt=*)"REGIONS are not allocated." - end if - end subroutine sample_2d_print_to_unit - - pure function sample_2d_get_type() result(t) - character(:),allocatable::t !FC = nagfor - character(32)::t !FC = gfortran - allocate(t,source="SAMPLE_2D_TYPE")!FC = nagfor - t="SAMPLE_2D_TYPE"!FC = gfortran - end function sample_2d_get_type - - subroutine sample_2d_initialize(this,n_alloc) - class(sample_2d_type),intent(out)::this - integer,intent(in)::n_alloc - integer::n - if(allocated(this%regions))deallocate(this%regions) - allocate(this%regions(n_alloc)) - this%n_alloc=n_alloc - this%n_regions=1 - call this%regions(1)%initialize(n_alloc) -! do n=1,n_alloc -! call this%regions(n)%initialize(n_alloc) -! end do - end subroutine sample_2d_initialize - - pure logical function sample_2d_contains(this,pts2) - class(sample_2d_type),intent(in)::this - real(kind=double),intent(in)::pts2 - sample_2d_contains=this%range(1)<=pts2.and.pts2<=this%range(2) - end function sample_2d_contains - - pure subroutine sample_2d_generate_hit(this,rnd,boost,hit,region) - class(sample_2d_type),intent(in)::this - integer,dimension(3),intent(in)::rnd - integer,intent(out)::region - real(kind=double),dimension(2),intent(out)::hit - real(kind=double),intent(out)::boost - region=modulo(rnd(1),this%n_regions)+1!this should be improved - call this%regions(region)%generate_hit(rnd(2:3),boost,hit) - boost=boost*this%n_regions - end subroutine sample_2d_generate_hit - - subroutine sample_2d_confirm_hit(this,hit,region,full) - class(sample_2d_type),intent(inout)::this - integer,intent(in)::region - real(kind=double),dimension(3),intent(in)::hit - type(sample_region_type),allocatable::old_region - real(kind=double),dimension(2)::mean,var,diff,cm,cv,c - integer::n,n_alloc,dim - logical,intent(out)::full - this%n_hits=this%n_hits+1 - if(region<=this%n_alloc)then - full=.false. - call this%regions(region)%confirm_hit(hit) - n_alloc=this%regions(region)%n_alloc - if(this%regions(region)%is_full())then - if(this%is_full())then - full=.true. - else - this%n_regions=this%n_regions+1 - allocate(old_region) - call this%regions(region)%move_components(old_region) - mean=sum(old_region%hyp_hits(1:2,:),dim=2)/n_alloc - var=0D0 - do n=1,n_alloc - var=var+abs(mean-old_region%hyp_hits(1:2,n)) - end do - var=var/n_alloc - diff=old_region%corners(1:2,2)-old_region%corners(1:2,1) - cm=abs([0.5D0,0.5D0]-(old_region%corners(1:2,2)-mean)/diff) - cv=abs(2*([0.25D0,0.25D0]-var/diff)) - c=max(cm,cv) - if(c(1)pos)then - call upper%push(hit) - else - call lower%push(hit) - end if - end do - end do - lower%range=[this%range(1),pos] - upper%range=[pos,this%range(2)] - end subroutine sample_2d_split - - subroutine sample_2d_push(this,hit) - class(sample_2d_type),intent(inout)::this - real(kind=double),dimension(3),intent(in)::hit - integer::region - logical::full - do region=1,this%n_regions - if(this%regions(region)%contains(hit))then - call this%confirm_hit(hit,region,full) -! call this%regions(region)%confirm_hit(hit) - if(full)print *,"sample_2d_push: region is full now" - exit - end if - end do - if(region>this%n_regions)print *,"sample_2d_push: no region contains ",hit - end subroutine sample_2d_push - -!!$ subroutine sample_2d_split(this,n_alloc,pos,lower,upper) -!!$ class(sample_2d_type),intent(in)::this -!!$ integer,intent(in)::n_alloc -!!$ real(kind=double),intent(in)::pos -!!$ type(sample_2d_type),intent(out)::lower,upper -!!$ integer::n,n_hit -!!$ real(kind=double),dimension(3)::hit -!!$ allocate(lower%regions(n_alloc)) -!!$ allocate(upper%regions(n_alloc)) -!!$ !$OMP PARALLEL DO FIRSTPRIVATE(this,pos,n_alloc) SHARED(lower,upper) -!!$ do n=1,this%n_regions -!!$ call sample_region_split(this%regions(n),pos,3,n_alloc,lower%regions(n),upper%regions(n)) -!!$ end do -!!$ !$OMP END PARALLEL DO -!!$ lower%n_regions=this%n_regions -!!$ upper%n_regions=this%n_regions -!!$ lower%n_alloc=n_alloc -!!$ upper%n_alloc=n_alloc -!!$ lower%range=[this%range(1),pos] -!!$ upper%range=[pos,this%range(2)] -!!$ end subroutine sample_2d_split - - subroutine sample_2d_write_hits(this,unit) - class(sample_2d_type),intent(in)::this - integer,intent(in)::unit - integer::n - do n=1,this%n_regions - call this%regions(n)%write_hits(unit) - end do - end subroutine sample_2d_write_hits - - subroutine sample_2d_move_components(this,that) - class(sample_2d_type),intent(inout)::this - class(sample_2d_type),intent(out)::that - that%n_alloc=this%n_alloc - that%n_regions=this%n_regions - that%n_hits=this%n_hits - that%range=this%range - call move_alloc(this%regions,that%regions) - this%n_alloc=0 - this%n_regions=0 - this%n_hits=0 - this%range=[0D0,0D0] - end subroutine sample_2d_move_components - - elemental function sample_2d_thickness(this) - class(sample_2d_type),intent(in)::this - real(kind=double)::sample_2d_thickness - sample_2d_thickness=this%range(2)-this%range(1) - end function sample_2d_thickness - - subroutine sample_2d_analyse(this,dir,file) - class(sample_2d_type),intent(in)::this - character(*),intent(in)::dir,file - integer::u - real(kind=double),dimension(1:2,0:100,0:100)::grid - integer,dimension(0:100,0:100)::i_grid - integer::r,x,y - integer,dimension(2,2)::i - call open_and_echo(dir//"/"//file,u) - do x=0,100 - do y=0,100 - grid(1:2,x,y)=[-1D0,-1D0] - end do - end do - do r=1,this%n_regions - i=int(this%regions(r)%corners*1D2) - do x=i(1,1),i(1,2) - do y=i(2,1),i(2,2) - i_grid(x,y)=this%regions(r)%n_hits - grid(1,x,y)=1D0/this%regions(r)%area() - grid(2,x,y)=this%regions(r)%density() - end do - end do - end do - do x=0,100 - do y=0,100 - write(u,fmt=*)x,y,i_grid(x,y),grid(1:2,x,y) - end do - write(u,fmt=*)"" - end do - close(u) - end subroutine sample_2d_analyse - - subroutine sample_2d_to_generator(this) - class(sample_2d_type),intent(inout)::this - integer::region - do region=1,this%n_regions - call this%regions(region)%to_generator() - end do - end subroutine sample_2d_to_generator - - elemental function sample_2d_mean(this,dim) result(mean) - class(sample_2d_type),intent(in)::this - integer,intent(in)::dim - real(kind=double)::mean - integer::region,hit - mean=0D0 - do region=1,this%n_regions - do hit=1,this%regions(region)%n_hits - mean=mean+this%regions(region)%hyp_hits(dim,hit) - end do - end do - mean=mean/this%n_hits - end function sample_2d_mean - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! type bound procedures for sample_3d_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - SUBROUTINE sample_3d_write_to_ring(this,ring,status) - CLASS(sample_3d_type),INTENT(IN) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - integer::n - call xml_write_begin_tag(ring,"SAMPLE_3D_TYPE") - call xml_write(ring,"N_SLICES",this%n_slices) - call xml_write(ring,"N_ALLOC",this%n_alloc) - if(this%n_slices>0)then - call xml_write_begin_tag(ring,"SLICES") - do n=1,this%n_slices - call sample_2d_write_to_ring(this%slices(n),ring,status) - end do - call xml_write_end_tag(ring,"SLICES") - end if - call xml_write_end_tag(ring,"SAMPLE_3D_TYPE") - END SUBROUTINE sample_3d_write_to_ring - - SUBROUTINE sample_3d_read_from_ring(this,ring,status) - CLASS(sample_3d_type),INTENT(OUT) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - integer::n - call xml_verify_begin_tag(ring,"SAMPLE_3D_TYPE") - call xml_read(ring,"N_SLICES",this%n_slices,status) - call xml_read(ring,"N_ALLOC",this%n_alloc,status) - if(this%n_slices>0)then - call xml_verify_begin_tag(ring,"SLICES",status) - allocate(this%slices(this%n_slices)) - do n=1,this%n_slices - call sample_2d_read_from_ring(this%slices(n),ring,status) - end do - call xml_verify_end_tag(ring,"SLICES",status) - end if - call xml_verify_end_tag(ring,"SAMPLE_3D_TYPE") - END SUBROUTINE sample_3d_read_from_ring - - subroutine sample_3d_print_to_unit(this,unit,parents,components,peers) - class(sample_3d_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - integer::n - write(unit,fmt=*)"Components of sample_3d_type" - write(unit,'("N_SLICES: ",I10)')this%n_slices - write(unit,'("N_ALLOC: ",I10)')this%n_alloc - if(allocated(this%slices))then - if(components>0)then - do n=1,this%n_slices - call this%slices(n)%print_to_unit(unit,parents,components-1,peers) - end do - else - write(unit,fmt=*)"Skipping SLICES." - end if - else - write(unit,fmt=*)"SLICES are not allocated." - end if - end subroutine sample_3d_print_to_unit - - pure function sample_3d_get_type() result(t) - character(:),allocatable::t !FC = nagfor - character(32)::t !FC = gfortran - allocate(t,source="SAMPLE_3D_TYPE")!FC = nagfor - t="SAMPLE_3D_TYPE"!FC = gfortran - end function sample_3d_get_type - - elemental function sample_3d_measure(this) - real(kind=double)::sample_3d_measure - class(sample_3d_type),intent(in)::this - sample_3d_measure=1D0 - end function sample_3d_measure - - subroutine sample_3d_to_generator(this) - class(sample_3d_type),intent(inout)::this - integer::slice - do slice=1,this%n_slices - call this%slices(slice)%to_generator() - end do - end subroutine sample_3d_to_generator - - subroutine sample_3d_initialize(this,n_alloc) - class(sample_3d_type),intent(out)::this - integer,intent(in)::n_alloc - if(allocated(this%slices))deallocate(this%slices) - if(n_alloc>0)then - allocate(this%slices(n_alloc)) - this%n_alloc=n_alloc - this%n_slices=1 - call this%slices(1)%initialize(n_alloc) - else - this%n_alloc=0 - end if - end subroutine sample_3d_initialize - - pure subroutine sample_3d_generate_hit(this,rnd,pts2,boost,hit,region,slice) - class(sample_3d_type),intent(in)::this - integer,intent(in),dimension(3)::rnd - real(kind=double),intent(in)::pts2 - integer,intent(out)::slice,region - real(kind=double),dimension(3),intent(out)::hit - real(kind=double),intent(out)::boost - if(this%n_slices==0)then - call sample_fractions_generate_hit(rnd,unit_square,hit(1:2)) - boost=1D0 - slice=1 - region=1 - else - do slice=1,this%n_slices - if(this%slices(slice)%contains(pts2))exit - end do - call this%slices(slice)%generate_hit(rnd,boost,hit(1:2),region) - end if - hit(3)=pts2 - end subroutine sample_3d_generate_hit - - subroutine sample_3d_confirm_hit(this,hit,region,slice) - class(sample_3d_type),intent(inout)::this - integer,intent(in)::slice,region - real(kind=double),intent(in),dimension(3)::hit - type(sample_2d_type),allocatable::old_slice - integer::n - logical::full - if(this%n_alloc0)then - call xml_write(ring,"HITS",this%hits) - end if - if(this%n_proc>0)then - call xml_write(ring,"PROCESSES",this%processes) - call xml_write(ring,"WEIGHTS",this%weights) - end if - call xml_write_end_tag(ring,"SAMPLE_INT_KIND_TYPE") - END SUBROUTINE sample_int_kind_write_to_ring - - SUBROUTINE sample_int_kind_read_from_ring(this,ring,status) - CLASS(sample_int_kind_type),INTENT(OUT) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - call xml_verify_begin_tag(ring,"SAMPLE_INT_KIND_TYPE") - call sample_3d_read_from_ring(this,ring,status) - call xml_read(ring,"N_HITS",this%n_hits,status) - call xml_read(ring,"N_PROC",this%n_proc,status) - call xml_read(ring,"BOOST",this%overall_boost,status) - if(this%n_hits>0)then - allocate(this%hits(this%n_hits)) - call xml_read(ring,"HITS",this%hits,status) - end if - if(this%n_proc>0)then - allocate(this%processes(this%n_proc)) - call xml_read(ring,"PROCESSES",this%processes,status) - allocate(this%weights(this%n_proc)) - call xml_read(ring,"WEIGHTS",this%weights,status) - end if - call xml_verify_end_tag(ring,"SAMPLE_INT_KIND_TYPE") - END SUBROUTINE sample_int_kind_read_from_ring - - subroutine sample_int_kind_print_to_unit(this,unit,parents,components,peers) - class(sample_int_kind_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - integer::n - if(parents>0)call sample_3d_print_to_unit(this,unit,parents,components,peers) - write(unit,fmt=*)"Components of sample_int_kind_type" - write(unit,'("N_HITS: ",I10)')this%n_hits - write(unit,'("N_PROC: ",I10)')this%n_proc - write(unit,'("OVERALL_BOOST: ",E14.7)')this%overall_boost - write(unit,'("HITS:")') - write(unit,'(10(I0," "))')this%hits(1:this%n_hits) - write(unit,'("WEIGHTS:")') - write(unit,'(10(I0," "))')this%weights - write(unit,'("PROCESSES:")') - write(unit,'(2(I0," "))')this%processes - end subroutine sample_int_kind_print_to_unit - - pure function sample_int_kind_get_type() result(t) - character(:),allocatable::t !FC = nagfor - character(32)::t !FC = gfortran - allocate(t,source="SAMPLE_INT_KIND_TYPE")!FC = nagfor - t="SAMPLE_INT_KIND_TYPE"!FC = gfortran - end function sample_int_kind_get_type - - subroutine sample_int_kind_to_generator(this) - class(sample_int_kind_type),intent(inout)::this - integer::int_kind - if(allocated(this%hits))deallocate(this%hits) - call sample_3d_to_generator(this) - end subroutine sample_int_kind_to_generator - - elemental integer function sample_int_kind_process_id(this,subprocess) - class(sample_int_kind_type),intent(in)::this - integer,intent(in)::subprocess - sample_int_kind_process_id=this%processes(subprocess) - end function sample_int_kind_process_id - - subroutine sample_int_kind_initialize(this,n_alloc,processes,overall_boost) - class(sample_int_kind_type),intent(out)::this - integer,intent(in)::n_alloc - integer,intent(in),dimension(:)::processes - real(kind=double),optional,intent(in)::overall_boost - integer::s,n - s=size(processes) - call sample_3d_initialize(this,n_alloc) - if(allocated(this%hits))deallocate(this%hits) - allocate(this%hits(n_alloc)) - if(allocated(this%weights))deallocate(this%weights) - allocate(this%weights(s)) - if(allocated(this%processes))deallocate(this%processes) - allocate(this%processes(s),source=processes) - do n=1,s - this%weights(n)=0 - end do - this%n_alloc=n_alloc - this%n_hits=0 - this%n_proc=s - if(present(overall_boost))this%overall_boost=overall_boost - this%overall_boost=this%overall_boost*this%n_proc -! print *,this%weights - end subroutine sample_int_kind_initialize - -! pure -subroutine sample_int_kind_generate_hit(this,rnd,pts2,boost,hit,region,slice,subprocess) - class(sample_int_kind_type),intent(in)::this - integer,dimension(4),intent(in)::rnd - real(kind=double),intent(in)::pts2 - real(kind=double),dimension(3),intent(out)::hit - integer,intent(out)::region,slice,subprocess - real(kind=double),intent(out)::boost - integer::n_n -! print *,rnd,pts2,boost,hit,region,slice,subprocess - call sample_3d_generate_hit(this,rnd(2:4),pts2,boost,hit,region,slice) - n_n=modulo(rnd(1),this%n_hits+size(this%weights))+1 - if(n_n>this%n_hits)then - subprocess=n_n-this%n_hits - else - subprocess=this%hits(n_n) - end if - boost=boost*this%overall_boost*(this%n_proc+this%n_hits)/(this%n_proc*(this%weights(subprocess)+1)) - end subroutine sample_int_kind_generate_hit - - subroutine sample_int_kind_mcgenerate_hit(this,pts2,mean,integrand_kind,tao_rnd,process_id,cart_hit) - class(sample_int_kind_type),intent(inout)::this - integer,intent(in)::integrand_kind - real(kind=double),intent(in)::pts2,mean - type(tao_random_state),intent(inout)::tao_rnd - real(kind=double),dimension(3),intent(out)::cart_hit - integer,intent(out)::process_id - real(kind=double)::boost - integer::region,slice,subprocess - integer,dimension(4)::i_rnd - real(kind=double)::dddsigma,d_rnd - real(kind=double),dimension(3)::hyp_hit - MC:do - this%n_tries=this%n_tries+1 - call tao_random_number(tao_rnd,i_rnd) - call tao_random_number(tao_rnd,d_rnd) - !print *,pts2,mean,integrand_kind,process_id,cart_hit - call this%generate_hit(i_rnd,pts2,boost,hyp_hit,region,slice,subprocess) - process_id=this%process_id(subprocess) - call coordinates_dddsigma_reg(process_id,integrand_kind,hyp_hit,cart_hit,dddsigma) - dddsigma=dddsigma*boost - if(d_rnd*meansize(this%hits))then - call move_alloc(this%hits,tmp_hits) - allocate(this%hits(2*size(tmp_hits))) - this%hits(1:size(tmp_hits))=tmp_hits - end if - this%hits(this%n_hits)=subprocess - end if - this%weights(subprocess)=this%weights(subprocess)+1 - call sample_3d_confirm_hit(this,hit,region,slice) - end subroutine sample_int_kind_confirm_hit - - subroutine sample_int_kind_analyse(this,dir,prefix) - class(sample_int_kind_type),intent(in)::this - character(*),intent(in)::dir,prefix - integer::slices_unit,subprocs_unit - integer::n,slice - character(3)::slice_name - integer,dimension(:),allocatable::int_a - real(kind=double),dimension(:),allocatable::real_a - call open_and_echo(dir//"/"//prefix//"slice_distribution.plot",slices_unit) - call open_and_echo(dir//"/"//prefix//"subproc_distribution.plot",subprocs_unit) - allocate(real_a(this%n_slices)) - allocate(int_a(this%n_slices)) - do n=1,this%n_slices - real_a(n)=this%slices(n)%range(1) - end do - call misc_sort(real_a,int_a) - do n=1,size(this%weights) - if(this%n_hits>0)then - write(subprocs_unit,fmt=*)real(this%weights(n)),real(this%weights(n)+1)/this%n_hits - else - write(subprocs_unit,fmt=*)0,0 - end if - end do - do n=1,this%n_slices - slice=int_a(n) - call integer_with_leading_zeros(n,3,slice_name) - call sample_2d_analyse(this%slices(slice),dir,prefix//slice_name//".plot") - write(slices_unit,fmt=*)& - &this%slices(slice)%range(1),& - &this%slices(slice)%range(2),& - &this%slices(slice)%n_hits,& - &real(this%slices(slice)%n_hits)/(this%n_hits*(this%slices(slice)%range(2)-this%slices(slice)%range(1))) - end do - write(slices_unit,fmt=*)1D0,0D0,0D0,0D0 - close(slices_unit) - close(subprocs_unit) - end subroutine sample_int_kind_analyse - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! type bound procedures for sample_inclusive_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - SUBROUTINE sample_inclusive_write_to_ring(this,ring,status) - CLASS(sample_inclusive_type),INTENT(IN) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - integer::n - call xml_write_begin_tag(ring,"SAMPLE_INCLUSIVE_TYPE") - call xml_write(ring,"N_ALLOC",this%n_alloc) - if(allocated(this%int_kinds))then - call xml_write_instance_begin(ring,"sample_int_kind_type","int_kinds") - do n=1,size(this%int_kinds) - call this%int_kinds(n)%write_to_ring(ring,status) - end do - call xml_write_instance_end(ring) - else - call xml_write_null_instance(ring,"int_kinds") - end if - call xml_write_end_tag(ring,"SAMPLE_INCLUSIVE_TYPE") - END SUBROUTINE sample_inclusive_write_to_ring - - SUBROUTINE sample_inclusive_read_from_ring(this,ring,status) - CLASS(sample_inclusive_type),INTENT(OUT) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - integer::n_int_kinds,n - call xml_verify_begin_tag(ring,"SAMPLE_INCLUSIVE_TYPE") - call xml_read(ring,"N_ALLOC",this%n_alloc,status) - call xml_verify_null_component(ring,"int_kinds",status) - if(.not.status==serialize_null)then - call xml_verify_begin_tag(ring,"int_kinds",status) - do n=1,size(this%int_kinds) - call this%int_kinds(n)%read_from_ring(ring,status) - end do - call xml_verify_end_tag(ring,"int_kinds",status) - end if - call xml_verify_end_tag(ring,"SAMPLE_INCLUSIVE_TYPE") - END SUBROUTINE sample_inclusive_read_from_ring - - subroutine sample_inclusive_print_to_unit(this,unit,parents,components,peers) - class(sample_inclusive_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - integer::n - write(unit,fmt=*)"Components of sample_inclusive_type" - write(unit,'("N_ALLOC: ",I10)')this%n_alloc - if(allocated(this%int_kinds))then - if(components>0)then - write(unit,'("INT_KINDS:")') - do n=1,this%n_alloc - call this%int_kinds(n)%print_to_unit(unit,parents,components-1,peers) - end do - else - write(unit,fmt=*)"Skipping INT_KINDS." - end if - else - write(unit,fmt=*)"INT_KINDS are not allocated." - end if - end subroutine sample_inclusive_print_to_unit - - pure function sample_inclusive_get_type() result(t) - character(:),allocatable::t !FC = nagfor - character(32)::t !FC = gfortran - allocate(t,source="SAMPLE_INCLUSIVE_TYPE")!FC = nagfor - t="SAMPLE_INCLUSIVE_TYPE"!FC = gfortran - end function sample_inclusive_get_type - - elemental integer function sample_inclusive_process_id(this,subprocess,int_kind) - class(sample_inclusive_type),intent(in)::this - integer,intent(in)::subprocess,int_kind - sample_inclusive_process_id=this%int_kinds(int_kind)%processes(subprocess) - end function sample_inclusive_process_id - - subroutine sample_inclusive_initialize(this,n_alloc,sizes,processes,overall_boost) - class(sample_inclusive_type),intent(out)::this - integer,intent(in)::n_alloc - integer,dimension(:),intent(in)::sizes,processes - real(kind=double),optional,intent(in)::overall_boost - integer::n,sum - this%n_alloc=size(sizes) - if(allocated(this%int_kinds))deallocate(this%int_kinds) - allocate(this%int_kinds(this%n_alloc)) - sum=0 - do n=1,this%n_alloc - call this%int_kinds(n)%initialize(n_alloc,processes(sum+1:sum+sizes(n)),overall_boost) - sum=sum+sizes(n) - end do - end subroutine sample_inclusive_initialize - -! pure -subroutine sample_inclusive_generate_hit(this,rnd,pts2,int_kind,hit,region,boost,slice,process) - class(sample_inclusive_type),intent(in)::this - integer,dimension(4),intent(in)::rnd - real(kind=double),intent(in)::pts2 - integer,intent(in)::int_kind - real(kind=double),dimension(3),intent(out)::hit - integer,intent(out)::region,slice,process - real(kind=double),intent(out)::boost - call this%int_kinds(int_kind)%generate_hit(rnd,pts2,boost,hit,region,slice,process) - end subroutine sample_inclusive_generate_hit - - subroutine sample_inclusive_mcgenerate_hit(this,pts2,mean,integrand_kind,tao_rnd,process_id,cart_hit) - class(sample_inclusive_type),intent(inout)::this - real(kind=double),intent(in)::pts2,mean - integer,intent(in)::integrand_kind - type(tao_random_state),intent(inout)::tao_rnd - real(kind=double),dimension(3),intent(out)::cart_hit - integer,intent(out)::process_id - print *,"sample_inclusive_mcgenerate_hit(this,",pts2,mean,integrand_kind,process_id,cart_hit,")" - call sample_int_kind_mcgenerate_hit(this%int_kinds(integrand_kind),pts2,mean,integrand_kind,tao_rnd,process_id,cart_hit) - end subroutine sample_inclusive_mcgenerate_hit - - subroutine sample_inclusive_confirm_hit(this,hit,int_kind,region,slice,process,over) - class(sample_inclusive_type),intent(inout)::this - real(kind=double),dimension(3),intent(in)::hit - integer,intent(in)::int_kind,region,slice,process - logical,optional,intent(in)::over - call this%int_kinds(int_kind)%confirm_hit(hit,region,slice,process,over) - end subroutine sample_inclusive_confirm_hit - - subroutine sample_inclusive_analyse(this,dir,subdirs) - class(sample_inclusive_type),intent(in)::this - character(*),intent(in)::dir - logical,intent(in)::subdirs - integer::inclusive_unit - - integer::n,n_hits - character(2)::sample_name - call open_and_echo(plot_dir%get_actual_value()//"/"//dir//"/int_kinds.plot",inclusive_unit) - n_hits=0 - do n=1,size(this%int_kinds) - n_hits=n_hits+this%int_kinds(n)%n_hits - end do - do n=1,size(this%int_kinds) - write(inclusive_unit,fmt=*)n,real(this%int_kinds(n)%n_hits)/n_hits - call integer_with_leading_zeros(n,2,sample_name) - if(subdirs)then - call sample_int_kind_analyse(& - this%int_kinds(n),& - plot_dir%get_actual_value()//"/"//dir//"/"//sample_name,& - "") - else - call sample_int_kind_analyse(& - this%int_kinds(n),& - plot_dir%get_actual_value()//"/"//dir,& - sample_name//"_") - end if - end do - close(inclusive_unit) - end subroutine sample_inclusive_analyse - - subroutine sample_inclusive_to_generator(this) - class(sample_inclusive_type),intent(inout)::this - integer::int_kind - do int_kind=1,size(this%int_kinds) - call this%int_kinds(int_kind)%to_generator() - end do - end subroutine sample_inclusive_to_generator - - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! non type bound procedures !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - pure subroutine sample_fractions_generate_hit(rnd,corners,hit) - real(kind=double),dimension(2),intent(out)::hit - integer,intent(in),dimension(2)::rnd - real(kind=double),dimension(2,2),intent(in)::corners - !print *,hit - !print *,corners - !print *,(corners(1:2,2)-corners(1:2,1)) - hit=(rnd/max_d)*(corners(1:2,2)-corners(1:2,1))+corners(1:2,1) - end subroutine sample_fractions_generate_hit - - subroutine plot_pstvue3d(unit,corners,density) - integer,intent(in)::unit - real(kind=double),dimension(2,2),intent(in)::corners - real(kind=double),intent(in)::density - real(kind=double),dimension(2)::width,mean - real(kind=double),dimension(3,3)::plot - width=(corners(:,2)-corners(:,1))/2D0 - mean=(corners(:,1)+corners(:,2))/2D0 - plot(1,1)=width(1) - plot(2,1)=width(2) - plot(3,1)=density/2D0 - plot(1,2)=mean(1) - plot(2,2)=mean(2) - plot(3,2)=density/2D0 - call log_color_code(density,plot(1:3,3)) - if(density>1D0)then - write(unit,fmt='("\mybigcube{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}")')plot - return - end if - write(unit,fmt='("\mycube{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}")')plot - end subroutine plot_pstvue3d - -end module sample_fractions_module Index: branches/attic/boschmann_standalone/pri/lib/lin_approx_tree.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/lin_approx_tree.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/lin_approx_tree.f03.pri (revision 8609) @@ -1,1576 +0,0 @@ -!!! module: lin_approx_tree_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-28 15:45:26 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module lin_approx_tree_module - use basic_types_module - use misc_module - use parameters_module - use,intrinsic::iso_fortran_env - implicit none - - !!!!!!!!!!!!!!!!!!!!!!!!! - !!! Module components !!! - !!!!!!!!!!!!!!!!!!!!!!!!! - - integer,private,parameter::value_dimension=7 - integer,private,parameter::r_value_index=1 - integer,private,parameter::d_value_index=2 - integer,parameter::r_integral_index=3 - integer,private,parameter::d_integral_index=4 - integer,private,parameter::r_propability_index=5 - integer,private,parameter::d_propability_index=6 - integer,private,parameter::error_index=7 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Derived Type Definitions !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type,extends(measurable_class) :: lin_approx_cont_type - private - integer::dim=0 - real(kind=double)::r_position=0D0 - real(kind=double)::d_position=0D0 - real(kind=double)::measure_comp=0D0 - real(kind=double),dimension(:,:),allocatable::values - !first index runs from 1 to dim - !second index is in {r_value,d_value,r_integral,d_integral,r_propability,d_propability} - contains - ! overridden serializable_class procedures - procedure :: write_to_ring => lin_approx_cont_write_to_ring - procedure :: read_from_ring => lin_approx_cont_read_from_ring - procedure :: print_to_unit => lin_approx_cont_print_to_unit - procedure,nopass :: get_type => lin_approx_cont_get_type - ! overridden measurable_class procedures - procedure::measure=>lin_approx_cont_measure - ! init/deinit - procedure::initialize=>lin_approx_cont_initialize - ! components - procedure,public::get_dimension => lin_approx_cont_get_dimension - procedure,public::get_l_position => lin_approx_cont_get_l_position - procedure,public::get_r_position => lin_approx_cont_get_r_position - procedure,public::get_d_position => lin_approx_cont_get_d_position - procedure,public::get_l_value_array => lin_approx_cont_get_l_value_array - procedure,public::get_l_value_element=> lin_approx_cont_get_l_value_element - procedure,public::get_r_value_array => lin_approx_cont_get_r_value_array - procedure,public::get_r_value_element=> lin_approx_cont_get_r_value_element - procedure,public::get_d_value_array => lin_approx_cont_get_d_value_array - procedure,public::get_d_value_element=> lin_approx_cont_get_d_value_element - procedure,public::get_l_integral_array => lin_approx_cont_get_l_integral_array - procedure,public::get_l_integral_element=> lin_approx_cont_get_l_integral_element - procedure,public::get_r_integral_array => lin_approx_cont_get_r_integral_array - procedure,public::get_r_integral_element=> lin_approx_cont_get_r_integral_element - procedure,public::get_d_integral_array => lin_approx_cont_get_d_integral_array - procedure,public::get_d_integral_element=> lin_approx_cont_get_d_integral_element - procedure,public::get_l_propability_element => lin_approx_cont_get_l_propability_element - procedure,public::get_l_propability_array => lin_approx_cont_get_l_propability_array - procedure,public::get_r_propability_element => lin_approx_cont_get_r_propability_element - procedure,public::get_r_propability_array => lin_approx_cont_get_r_propability_array - procedure,public::get_d_propability_element => lin_approx_cont_get_d_propability_element - procedure,public::get_d_propability_array => lin_approx_cont_get_d_propability_array - procedure,public::get_error => lin_approx_cont_get_error - procedure,public::get_error_sum => lin_approx_cont_get_error_sum - procedure,public::get_integral_sum => lin_approx_cont_get_integral_sum - generic,public::get_l_value => get_l_value_array,get_l_value_element - generic,public::get_r_value => get_r_value_array,get_r_value_element - generic,public::get_d_value => get_d_value_array,get_d_value_element - generic,public::get_l_integral => get_l_integral_array,get_l_integral_element - generic,public::get_r_integral => get_r_integral_array,get_r_integral_element - generic,public::get_d_integral => get_d_integral_array,get_d_integral_element - generic,public::get_l_propability => get_l_propability_array,get_l_propability_element - generic,public::get_r_propability => get_r_propability_array,get_r_propability_element - generic,public::get_d_propability => get_d_propability_array,get_d_propability_element - ! interpolations - procedure,public::get_value_at_position => lin_approx_cont_get_value_at_position - procedure::set_r_value => lin_approx_cont_set_r_value - procedure::set_d_value => lin_approx_cont_set_d_value - procedure::set_r_integral => lin_approx_cont_set_r_integral - procedure::set_d_integral => lin_approx_cont_set_d_integral - procedure::set_r_propability => lin_approx_cont_set_r_propability - procedure::set_d_propability => lin_approx_cont_set_d_propability - procedure::set_error => lin_approx_cont_set_error - ! tests - procedure,public:: is_left_of => lin_approx_cont_is_left_of - procedure,public:: includes => lin_approx_cont_includes - ! convert - procedure :: to_node => lin_approx_cont_to_node - ! approximation - procedure :: approx_value => lin_approx_cont_approx_value - procedure :: approx_value_n => lin_approx_cont_approx_value_n - procedure :: approx_integral => lin_approx_cont_approx_integral - procedure :: approx_integral_n => lin_approx_cont_approx_integral_n - procedure :: approx_propability => lin_approx_cont_approx_propability - procedure :: approx_propability_n => lin_approx_cont_approx_propability_n - procedure :: approx_position_by_integral => lin_approx_cont_approx_position_by_integral - ! procedure :: choose_partons => lin_approx_cont_choose_partons - procedure :: split => lin_approx_cont_split - procedure :: update => lin_approx_cont_update - end type lin_approx_cont_type - - type,extends(lin_approx_cont_type),abstract :: lin_approx_node_class - private - class(lin_approx_node_class), pointer :: left => null() - class(lin_approx_node_class), pointer :: right => null() -! real(kind=double) :: criterion - contains - private - ! overridden serializable_class procedures - procedure,public :: deserialize=>lin_approx_node_deserialize - ! new procedures - procedure(lin_approx_append_interface),deferred,public::append - procedure(lin_approx_final_interface),deferred,public :: finalize - procedure,public :: get_left => lin_approx_node_get_left - procedure,public :: get_right => lin_approx_node_get_right - procedure,public :: get_leftmost => lin_approx_node_get_leftmost - procedure,public :: get_rightmost => lin_approx_node_get_rightmost - procedure,public :: decide_by_value => lin_approx_node_decide_by_value - procedure,public :: decide_by_position => lin_approx_node_decide_by_position - procedure,public :: decide_decreasing => lin_approx_node_decide_decreasing - procedure,public :: to_tree => lin_approx_node_to_tree -! procedure,public :: copy => lin_approx_node_copy -! generic,public :: assignment(=) => copy -! procedure,deferred,public :: approx => lin_approx_node_approx - generic,public::decide=>decide_by_value,decide_by_position - end type lin_approx_node_class - - type,extends(lin_approx_node_class) :: lin_approx_tree_type - class(lin_approx_node_class), pointer :: down => null() - contains - ! overridden serializable_class procedures - procedure :: write_to_ring => lin_approx_tree_write_to_ring - procedure :: read_from_ring => lin_approx_tree_read_from_ring - procedure :: print_to_unit => lin_approx_tree_print_to_unit - procedure,nopass :: get_type => lin_approx_tree_get_type - ! overridden linn_approx_node_class procedures - procedure,public :: finalize => lin_approx_tree_finalize - procedure,public :: decide_by_value => lin_approx_tree_decide_by_value - procedure,public :: decide_by_position => lin_approx_tree_decide_by_position - procedure,public :: decide_decreasing => lin_approx_tree_decide_decreasing - ! new procedures - procedure,public :: get_left_list => lin_approx_tree_get_left_list - procedure,public :: get_right_list => lin_approx_tree_get_right_list - procedure,public :: find_by_value => lin_approx_tree_find_by_value - procedure,public :: find_by_position => lin_approx_tree_find_by_position - procedure,public :: find_decreasing => lin_approx_tree_find_decreasing - procedure,public :: approx_by_integral => lin_approx_tree_approx_by_integral - procedure,public :: approx_by_propability => lin_approx_tree_approx_by_propability - procedure,public :: to_tree => lin_approx_tree_to_tree - generic,public::find=>find_by_value,find_by_position - procedure::append=>lin_approx_tree_append - end type lin_approx_tree_type - - type,extends(lin_approx_node_class) :: lin_approx_list_type - contains - ! overridden serializable_class procedures - procedure :: write_to_ring => lin_approx_list_write_to_ring - procedure :: read_from_ring => lin_approx_list_read_from_ring - procedure :: print_to_unit => lin_approx_list_print_to_unit - procedure,nopass :: get_type => lin_approx_list_get_type - ! new procedures - procedure,public :: finalize => lin_approx_list_finalize - procedure,public :: insert_right_a => lin_approx_list_insert_right_a -! procedure,public :: insert_right_b => lin_approx_list_insert_right_b - generic,public :: insert_right => insert_right_a!,insert_right_b - procedure,public :: insert_left_a => lin_approx_list_insert_left_a -! procedure,public :: insert_left_b => lin_approx_list_insert_left_b - generic,public :: insert_left => insert_left_a!,insert_left_b - procedure::append=>lin_approx_list_append - procedure,public :: to_tree => lin_approx_list_to_tree - procedure,public :: gnuplot => lin_approx_list_gnuplot - procedure,public :: integrate => lin_approx_list_integrate - procedure,public :: check => lin_approx_list_check - end type lin_approx_list_type - - abstract interface - subroutine lin_approx_append_interface(this,right) - import lin_approx_node_class - class(lin_approx_node_class),intent(inout),target :: this,right - end subroutine lin_approx_append_interface - subroutine lin_approx_final_interface(this) - import lin_approx_node_class - class(lin_approx_node_class),intent(out),target :: this - end subroutine lin_approx_final_interface - end interface - -contains - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures for lin_approx_cont_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! overridden serializable_class procedures - - SUBROUTINE lin_approx_cont_write_to_ring (this,ring,status) - CLASS(lin_approx_cont_type), INTENT(IN) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - ! local variables - integer::dim - call xml_write_begin_tag(ring,"LIN_APPROX_CONT_TYPE") - call xml_write(ring,"dim",this%dim) - call xml_write(ring,"r_position",this%r_position) - call xml_write(ring,"d_position",this%d_position) - if(allocated(this%values))then - call xml_write(ring,"values",this%values) - else - call xml_write_null_component(ring,"values") - end if - call xml_write_end_tag(ring,"LIN_APPROX_CONT_TYPE") - end SUBROUTINE lin_approx_cont_write_to_ring - - SUBROUTINE lin_approx_cont_read_from_ring (this,ring,status) - CLASS(lin_approx_cont_type), INTENT(OUT) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - ! local variables - integer::dim - call xml_verify_begin_tag(ring,"LIN_APPROX_CONT_TYPE",status) - call xml_read(ring,"dim",this%dim,status) - call xml_read(ring,"r_position",this%r_position,status) - call xml_read(ring,"d_position",this%d_position,status) - if(allocated(this%values))deallocate(this%values) - call xml_verify_null_component(ring,"values",status) - if(status==serialize_ok)then - allocate(this%values(this%dim,7)) - call xml_read(ring,this%values) - call xml_verify_end_tag(ring,"values") - end if - call xml_verify_end_tag(ring,"LIN_APPROX_CONT_TYPE",status) - end SUBROUTINE lin_approx_cont_read_from_ring - - subroutine lin_approx_cont_print_to_unit(this,unit,parents,components,peers) - class(lin_approx_cont_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - write(unit,'("Components of lin_approx_cont_type:")') - write(unit,fmt=*)"Dimension: ",this%dim - write(unit,fmt=*)"Right position: ",this%r_position - write(unit,fmt=*)"Position step: ",this%d_position - if(allocated(this%values))then - if(components>0)then - write(unit,fmt=*)"Right values: ",lin_approx_cont_get_r_value_array(this) - write(unit,fmt=*)"Value step: ",this%get_d_value() - write(unit,fmt=*)"Right integrals: ",this%get_r_integral() - write(unit,fmt=*)"Integral step: ",this%get_d_integral() - write(unit,fmt=*)"Right propabilities:",this%get_r_propability() - write(unit,fmt=*)"Propability step: ",this%get_d_propability() - write(unit,fmt=*)"Errors: ",this%get_error() - else - write(unit,fmt=*)"Values are allocated." - end if - else - write(unit,fmt=*)"Values are not allocated." - end if - end subroutine lin_approx_cont_print_to_unit - - function lin_approx_cont_get_type() result(type) - character(:),allocatable::type!FC = nagfor - allocate(type,source="LIN_APPROX_CONT_TYPE")!FC = nagfor - character(32)::type!FC = gfortran - type="LIN_APPROX_CONT_TYPE"!FC = gfortran - end function lin_approx_cont_get_type - - elemental function lin_approx_cont_measure(this) - class(lin_approx_cont_type),intent(in)::this - real(kind=double)::lin_approx_cont_measure - lin_approx_cont_measure=this%measure_comp - end function lin_approx_cont_measure - - subroutine lin_approx_cont_initialize(this,dim,r_position,d_position) - class(lin_approx_cont_type),intent(inout)::this - integer,intent(in)::dim - real(kind=double),intent(in)::r_position,d_position - integer::dim1,dim2 - this%dim=dim - this%r_position=r_position - this%d_position=d_position - if(allocated(this%values))deallocate(this%values) - allocate(this%values(dim,value_dimension)) - do dim2=1,value_dimension-1 - do dim1=1,dim - this%values(dim1,dim2)=0D0 - end do - end do - do dim1=1,dim - this%values(dim1,value_dimension)=huge(1D0) - end do - this%measure_comp=huge(1D0) - end subroutine lin_approx_cont_initialize - - !!! components !!! - - elemental function lin_approx_cont_get_dimension(this) result(dim) - class(lin_approx_cont_type),intent(in)::this - integer::dim - dim=this%dim - end function lin_approx_cont_get_dimension - - pure function lin_approx_cont_get_l_position(this) result(pos) - class(lin_approx_cont_type),intent(in)::this - real(kind=double)::pos - pos=this%r_position-this%d_position - end function lin_approx_cont_get_l_position - - pure function lin_approx_cont_get_r_position(this) result(pos) - class(lin_approx_cont_type),intent(in)::this - real(kind=double)::pos - pos=this%r_position - end function lin_approx_cont_get_r_position - - pure function lin_approx_cont_get_d_position(this) result(pos) - class(lin_approx_cont_type),intent(in)::this - real(kind=double)::pos - pos=this%d_position - end function lin_approx_cont_get_d_position - - pure function lin_approx_cont_get_error_sum(this) result(error) - class(lin_approx_cont_type),intent(in)::this - real(kind=double)::error - error=sum(this%values(1:this%dim,error_index)) - end function lin_approx_cont_get_error_sum - - pure function lin_approx_cont_get_integral_sum(this) result(error) - class(lin_approx_cont_type),intent(in)::this - real(kind=double)::error - error=sum(this%values(1:this%dim,d_integral_index)) - end function lin_approx_cont_get_integral_sum - - pure function lin_approx_cont_get_l_value_element(this,set) result(element) - class(lin_approx_cont_type),intent(in)::this - integer,intent(in)::set - real(kind=double)::element - element=this%values(set,r_value_index)-this%values(set,d_value_index) - end function lin_approx_cont_get_l_value_element - - pure function lin_approx_cont_get_l_value_array(this) result(subarray) - class(lin_approx_cont_type),intent(in)::this - real(kind=double),dimension(this%dim)::subarray - subarray=this%values(1:this%dim,r_value_index)-this%values(1:this%dim,d_value_index) - end function lin_approx_cont_get_l_value_array - - pure function lin_approx_cont_get_r_value_element(this,set) result(element) - class(lin_approx_cont_type),intent(in)::this - integer,intent(in)::set - real(kind=double)::element - element=this%values(set,r_value_index) - end function lin_approx_cont_get_r_value_element - - pure function lin_approx_cont_get_r_value_array(this) result(subarray) - class(lin_approx_cont_type),intent(in)::this - real(kind=double),dimension(this%dim)::subarray - subarray=this%values(1:this%dim,r_value_index) - end function lin_approx_cont_get_r_value_array - - pure function lin_approx_cont_get_d_value_element(this,set) result(element) - class(lin_approx_cont_type),intent(in)::this - integer,intent(in)::set - real(kind=double)::element - element=this%values(set,d_value_index) - end function lin_approx_cont_get_d_value_element - - pure function lin_approx_cont_get_d_value_array(this) result(subarray) - class(lin_approx_cont_type),intent(in)::this - real(kind=double),dimension(this%dim)::subarray - subarray=this%values(1:this%dim,d_value_index) - end function lin_approx_cont_get_d_value_array - - pure function lin_approx_cont_get_l_integral_element(this,set) result(element) - class(lin_approx_cont_type),intent(in)::this - integer,intent(in)::set - real(kind=double)::element - element=this%values(set,r_integral_index)-this%values(set,d_integral_index) - end function lin_approx_cont_get_l_integral_element - - pure function lin_approx_cont_get_l_integral_array(this) result(subarray) - class(lin_approx_cont_type),intent(in)::this - real(kind=double),dimension(this%dim)::subarray - subarray=this%values(1:this%dim,r_integral_index)-this%values(1:this%dim,d_integral_index) - end function lin_approx_cont_get_l_integral_array - - pure function lin_approx_cont_get_r_integral_element(this,set) result(element) - class(lin_approx_cont_type),intent(in)::this - integer,intent(in)::set - real(kind=double)::element - element=this%values(set,r_integral_index) - end function lin_approx_cont_get_r_integral_element - - pure function lin_approx_cont_get_r_integral_array(this) result(subarray) - class(lin_approx_cont_type),intent(in)::this - real(kind=double),dimension(this%dim)::subarray - subarray=this%values(1:this%dim,r_integral_index) - end function lin_approx_cont_get_r_integral_array - - pure function lin_approx_cont_get_d_integral_element(this,set) result(element) - class(lin_approx_cont_type),intent(in)::this - integer,intent(in)::set - real(kind=double)::element - element=this%values(set,d_integral_index) - end function lin_approx_cont_get_d_integral_element - - pure function lin_approx_cont_get_d_integral_array(this) result(subarray) - class(lin_approx_cont_type),intent(in)::this - real(kind=double),dimension(this%dim)::subarray - subarray=this%values(1:this%dim,d_integral_index) - end function lin_approx_cont_get_d_integral_array - - pure function lin_approx_cont_get_l_propability_element(this,set) result(element) - class(lin_approx_cont_type),intent(in)::this - integer,intent(in)::set - real(kind=double)::element - element=this%values(set,r_propability_index)-this%values(set,d_propability_index) - end function lin_approx_cont_get_l_propability_element - - pure function lin_approx_cont_get_l_propability_array(this) result(subarray) - class(lin_approx_cont_type),intent(in)::this - real(kind=double),dimension(this%dim)::subarray - subarray=this%values(1:this%dim,r_propability_index)-this%values(1:this%dim,d_propability_index) - end function lin_approx_cont_get_l_propability_array - - pure function lin_approx_cont_get_r_propability_element(this,set) result(element) - class(lin_approx_cont_type),intent(in)::this - integer,intent(in)::set - real(kind=double)::element - element=this%values(set,r_propability_index) - end function lin_approx_cont_get_r_propability_element - - pure function lin_approx_cont_get_r_propability_array(this) result(subarray) - class(lin_approx_cont_type),intent(in)::this - real(kind=double),dimension(this%dim)::subarray - subarray=this%values(1:this%dim,r_propability_index) - end function lin_approx_cont_get_r_propability_array - - pure function lin_approx_cont_get_d_propability_array(this) result(subarray) - class(lin_approx_cont_type),intent(in)::this - real(kind=double),dimension(this%dim)::subarray - subarray=this%values(1:this%dim,d_propability_index) - end function lin_approx_cont_get_d_propability_array - - pure function lin_approx_cont_get_d_propability_element(this,set) result(element) - class(lin_approx_cont_type),intent(in)::this - integer,intent(in)::set - real(kind=double)::element - element=this%values(set,d_propability_index) - end function lin_approx_cont_get_d_propability_element - - pure function lin_approx_cont_get_error(this) result(error) - class(lin_approx_cont_type),intent(in)::this - real(kind=double),dimension(this%dim)::error - error=this%values(1:this%dim,error_index) - end function lin_approx_cont_get_error - - ! interpolation - - subroutine lin_approx_cont_get_value_at_position(this,pos,subarray) - class(lin_approx_cont_type),intent(in)::this - real(kind=double),intent(in)::pos - real(kind=double),dimension(this%dim),intent(out)::subarray - subarray=this%get_r_value_array()-this%get_d_value()*this%d_position/(this%r_position-pos) - end subroutine lin_approx_cont_get_value_at_position - - ! write access - - subroutine lin_approx_cont_set_r_value(this,subarray) - class(lin_approx_cont_type),intent(inout)::this - real(kind=double),intent(in),dimension(1:this%dim)::subarray - this%values(1:this%dim,r_value_index)=subarray - end subroutine lin_approx_cont_set_r_value - - subroutine lin_approx_cont_set_d_value(this,subarray) - class(lin_approx_cont_type),intent(inout)::this - real(kind=double),intent(in),dimension(1:this%dim)::subarray - this%values(1:this%dim,d_value_index)=subarray - end subroutine lin_approx_cont_set_d_value - - subroutine lin_approx_cont_set_r_integral(this,subarray) - class(lin_approx_cont_type),intent(inout)::this - real(kind=double),intent(in),dimension(1:this%dim)::subarray - this%values(1:this%dim,r_integral_index)=subarray - end subroutine lin_approx_cont_set_r_integral - - subroutine lin_approx_cont_set_d_integral(this,subarray) - class(lin_approx_cont_type),intent(inout)::this - real(kind=double),intent(in),dimension(1:this%dim)::subarray - this%values(1:this%dim,d_integral_index)=subarray - end subroutine lin_approx_cont_set_d_integral - - subroutine lin_approx_cont_set_r_propability(this,subarray) - class(lin_approx_cont_type),intent(inout)::this - real(kind=double),intent(in),dimension(1:this%dim)::subarray - this%values(1:this%dim,r_propability_index)=subarray - end subroutine lin_approx_cont_set_r_propability - - subroutine lin_approx_cont_set_d_propability(this,subarray) - class(lin_approx_cont_type),intent(inout)::this - real(kind=double),intent(in),dimension(1:this%dim)::subarray - this%values(1:this%dim,d_propability_index)=subarray - end subroutine lin_approx_cont_set_d_propability - - subroutine lin_approx_cont_set_error(this,subarray) - class(lin_approx_cont_type),intent(inout)::this - real(kind=double),intent(in),dimension(1:this%dim)::subarray - this%values(1:this%dim,error_index)=subarray - this%measure_comp=sum(subarray) - end subroutine lin_approx_cont_set_error - - ! tests - - pure function lin_approx_cont_is_left_of(this,that) result(is_left) - logical::is_left - class(lin_approx_cont_type),intent(in)::this,that - is_left=this%r_position<=that%r_position!-that%d_position -! if (is_left.and.that%r_positionposition.or.position>=this%get_r_position())includes=.false. - end if - if(present(value))then - if(this%get_l_value(dim)>value.or.value>=this%get_r_value(dim))includes=.false. - end if - if(present(integral))then - if(this%get_l_integral(dim)>integral.or.integral>=this%get_r_integral(dim))includes=.false. - end if - if(present(propability))then - if(this%get_l_propability(dim)>propability.or.propability>=this%get_r_propability(dim))includes=.false. - end if - end function lin_approx_cont_includes - - subroutine lin_approx_cont_update(this) - class(lin_approx_cont_type),intent(inout) :: this - real(kind=double),dimension(:),allocatable :: int - allocate(int(this%dim),source=this%get_d_integral()) - call this%set_d_integral(-this%d_position*(this%get_r_value_array()-this%get_d_value()/2D0)) - call this%set_error(abs(this%get_d_integral()-int)) -! print('(11(D20.10))'),this%get_d_integral() - end subroutine lin_approx_cont_update - - subroutine lin_approx_cont_split(this,c_value,c_position,new_node) - class(lin_approx_cont_type),intent(inout) :: this - real(kind=double),intent(in) :: c_position - real(kind=double),intent(in),dimension(this%dim) :: c_value - class(lin_approx_cont_type),intent(out),pointer :: new_node - real(kind=double) :: ndpr,ndpl - real(kind=double),dimension(:),allocatable::ov,edv - ndpr=this%r_position-c_position - ndpl=this%d_position-ndpr - allocate(ov(this%dim),source=this%get_r_value_array()-ndpr*this%get_d_value()/this%d_position) - allocate(edv(this%dim),source=c_value-ov) - allocate(new_node) - call new_node%initialize(dim=this%dim,& - &r_position=c_position,& - &d_position=ndpl) - call new_node%set_r_value(c_value) - call new_node%set_d_value(this%get_d_value()+c_value-this%get_r_value_array()) - call new_node%set_d_integral(ndpl*(this%get_d_value()-this%get_r_value_array()-c_value)/2D0) - call new_node%set_error(abs((edv*ndpl)/2D0)) - !new_node%measure_comp=sum(abs((edv*ndpl)/2D0)) - this%d_position=ndpr - call this%set_d_value(this%get_r_value_array()-c_value) - call this%set_d_integral(-(ndpr*(this%get_r_value_array()+c_value)/2D0)) - call this%set_error(abs(edv*ndpr/2D0)) - !this%measure_comp=sum(abs(edv*ndpr/2D0)) -! print ('("lin_approx_cont_split: new errors:")') -! print ('(E14.7)'),this%get_error() -! print ('(E14.7)'),new_node%get_error() -! print('(11(D20.10))'),new_node%get_d_integral() -! print('(11(D20.10))'),this%get_d_integral() - end subroutine lin_approx_cont_split - - pure function lin_approx_cont_approx_value(this,x) result(val) - ! returns the values at x - class(lin_approx_cont_type),intent(in) :: this - real(kind=double),dimension(this%dim) :: val - real(kind=double), intent(in) :: x - val = this%get_r_value_array()+(x-this%r_position)*this%get_d_value()/this%d_position - end function lin_approx_cont_approx_value - - elemental function lin_approx_cont_approx_value_n(this,x,n) result(val) - ! returns the value at x - class(lin_approx_cont_type),intent(in) :: this - real(kind=double)::val - real(kind=double), intent(in) :: x - integer,intent(in)::n - val = this%get_r_value_element(n)+(x-this%r_position)*this%get_d_value_element(n)/this%d_position - end function lin_approx_cont_approx_value_n - - pure function lin_approx_cont_approx_integral(this,x) - ! returns the integral from x to r_position - class(lin_approx_cont_type),intent(in) :: this - real(kind=double),dimension(this%dim) :: lin_approx_cont_approx_integral - real(kind=double), intent(in) :: x - lin_approx_cont_approx_integral = & -! &this%get_r_integral()+& -! &(this%r_position-x)*this%get_r_value()+& -! &(x**2-this%r_position**2)*this%get_d_integral()/(this%d_position*2D0) - &this%get_r_integral()+& - &((this%r_position-x)*& - &(-this%get_d_value()*(this%r_position-x)+2*this%d_position*this%get_r_value_array()))/& - &(2*this%d_position) - end function lin_approx_cont_approx_integral - - elemental function lin_approx_cont_approx_integral_n(this,x,n) result(val) - ! returns the integral from x to r_position - class(lin_approx_cont_type),intent(in) :: this - real(kind=double)::val - real(kind=double), intent(in) :: x - integer,intent(in)::n - val = & - &this%get_r_integral_element(n)+& - &((this%r_position-x)*& - &(-this%get_d_value_element(n)*(this%r_position-x)+2*this%d_position*this%get_r_value_element(n)))/& - &(2*this%d_position) - end function lin_approx_cont_approx_integral_n - - pure function lin_approx_cont_approx_propability(this,x) result(prop) - ! returns the vlaues at x - class(lin_approx_cont_type),intent(in) :: this - real(kind=double),dimension(this%dim) :: prop - real(kind=double), intent(in) :: x - prop=exp(-this%approx_integral(x)) - end function lin_approx_cont_approx_propability - - elemental function lin_approx_cont_approx_propability_n(this,x,n) result(val) - ! returns the integral from x to r_position - class(lin_approx_cont_type),intent(in) :: this - real(kind=double)::val - real(kind=double), intent(in) :: x - integer,intent(in)::n - val = exp(-this%approx_integral_n(x,n)) - end function lin_approx_cont_approx_propability_n - - elemental function lin_approx_cont_approx_position_by_integral(this,dim,int) result(val) - class(lin_approx_cont_type),intent(in) :: this - real(kind=double)::val - integer,intent(in)::dim - real(kind=double),intent(in)::int - real(kind=double)::dpdv - dpdv=(this%d_position/this%values(dim,d_value_index)) - val=this%r_position-dpdv*& - &(this%values(dim,r_value_index)-& - &sqrt(((this%values(dim,r_integral_index)-int)*2D0/dpdv)+this%values(dim,r_value_index)**2)) - end function lin_approx_cont_approx_position_by_integral - - subroutine lin_approx_cont_to_node(this,value,list,tree) - class(lin_approx_cont_type),intent(in) :: this - real(kind=double),intent(in) :: value -! class(lin_approx_node_class),optional,pointer,intent(out) :: node - class(lin_approx_list_type),optional,pointer,intent(out) :: list - class(lin_approx_tree_type),optional,pointer,intent(out) :: tree -!!$ if(present(node))then -!!$ allocate(node) -!!$ node%dim=this%dim -!!$ node%r_position=this%r_position -!!$ node%d_position=this%d_position -!!$ allocate(node%values(this%dim,value_dimension),source=this%values) -!!$ end if - if(present(list))then - allocate(list) - list%dim=this%dim - list%r_position=this%r_position - list%d_position=this%d_position - allocate(list%values(this%dim,value_dimension),source=this%values) - end if - if(present(tree))then - allocate(tree) - tree%dim=this%dim - tree%r_position=this%r_position - tree%d_position=this%d_position - allocate(tree%values(this%dim,value_dimension),source=this%values) - end if - end subroutine lin_approx_cont_to_node - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures for lin_approx_node_class !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine lin_approx_node_deserialize(this,ring) - CLASS(lin_approx_node_class), INTENT(OUT) :: this - class(page_ring_type),intent(inout)::ring - INTEGER::V_LIST(1),status - CHARACTER::iotype,iomsg - class(serializable_class),pointer::ser - allocate(lin_approx_tree_type::ser) - call serialize_push_reference(ser) - allocate(lin_approx_list_type::ser) - call serialize_push_reference(ser) - call serializable_deserialize(this,ring) - call serialize_pop_reference(ser) - deallocate(ser) - call serialize_pop_reference(ser) - deallocate(ser) - end subroutine lin_approx_node_deserialize - - subroutine lin_approx_node_to_tree(this,out_tree) - class(lin_approx_node_class),intent(in) :: this - class(lin_approx_tree_type),intent(out) :: out_tree - out_tree%left=>this%left - out_tree%right=>this%right - end subroutine lin_approx_node_to_tree - - subroutine lin_approx_node_get_left(this,left) - class(lin_approx_node_class),intent(in) :: this - class(lin_approx_node_class),pointer,intent(out) :: left - left=>this%left - end subroutine lin_approx_node_get_left - - subroutine lin_approx_node_get_right(this,right) - class(lin_approx_node_class),intent(in) :: this - class(lin_approx_node_class),pointer,intent(out) :: right - right=>this%right - end subroutine lin_approx_node_get_right - - subroutine lin_approx_node_get_leftmost(this,node) - class(lin_approx_node_class),intent(in) :: this - class(lin_approx_node_class),pointer,intent(out) :: node - if (associated(this%left)) then - node=>this%left - do while (associated(node%left)) - node=>node%left - end do - else - nullify(node) - end if - end subroutine lin_approx_node_get_leftmost - - subroutine lin_approx_node_get_rightmost(this,right) - class(lin_approx_node_class),intent(in) :: this - class(lin_approx_node_class),pointer,intent(out) :: right - if (associated(this%right)) then - right=>this%right - do while (associated(right%right)) - right=>right%right - end do - else - nullify(right) - end if - end subroutine lin_approx_node_get_rightmost - - subroutine lin_approx_node_decide_by_value(this,value,dim,record,node) - class(lin_approx_node_class),intent(in) :: this - real(kind=double),intent(in)::value - integer,intent(in)::record,dim - class(lin_approx_node_class),pointer,intent(out) :: node - if(this%values(dim,record)>value)then - node=>this%left - else - node=>this%right - end if - end subroutine lin_approx_node_decide_by_value - - subroutine lin_approx_node_decide_by_position(this,position,node) - class(lin_approx_node_class),intent(in) :: this - real(kind=double),intent(in)::position - class(lin_approx_node_class),pointer,intent(out) :: node - if(this%r_position>position)then - node=>this%left - else - node=>this%right - end if - end subroutine lin_approx_node_decide_by_position - - subroutine lin_approx_node_decide_decreasing(this,value,dim,record,node) - class(lin_approx_node_class),intent(in) :: this - real(kind=double),intent(in)::value - integer,intent(in)::record,dim - class(lin_approx_node_class),pointer,intent(out) :: node - if(this%values(dim,record)<=value)then - node=>this%left - else - node=>this%right - end if - end subroutine lin_approx_node_decide_decreasing - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures for lin_approx_list_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - SUBROUTINE lin_approx_list_write_to_ring (this,ring,status) - CLASS(lin_approx_list_type), INTENT(IN) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - ! local variables - class(serializable_class),pointer::ser - call xml_write_begin_tag(ring,"LIN_APPROX_LIST_TYPE") - call lin_approx_cont_write_to_ring(this,ring,status) - ser=>this%right - call serialize_pointer(ser,ring,"RIGHT") - call xml_write_end_tag(ring,"LIN_APPROX_LIST_TYPE") - end SUBROUTINE lin_approx_list_write_to_ring - - SUBROUTINE lin_approx_list_read_from_ring (this,ring,status) - CLASS(lin_approx_list_type),target, INTENT(OUT) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - ! local variables - class(serializable_class),pointer::ser - call xml_verify_begin_tag(ring,"LIN_APPROX_LIST_TYPE",status) - call lin_approx_cont_read_from_ring(this,ring,status) - call deserialize_pointer(ser,ring) - if(associated(ser))then - select type(ser) - class is (lin_approx_list_type) - this%right=>ser - ser%left=>this - class default - nullify(this%right) - end select - else - nullify(this%right) - end if - call xml_verify_end_tag(ring,"LIN_APPROX_LIST_TYPE",status) - end SUBROUTINE lin_approx_list_read_from_ring - - recursive subroutine lin_approx_list_print_to_unit(this,unit,parents,components,peers) - class(lin_approx_list_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - class(serializable_class),pointer::ser - if(parents>0)call lin_approx_cont_print_to_unit(this,unit,parents-1,components,peers) - ser=>this%left - call serialize_print_peer_pointer(ser,unit,-1,-1,-1,"LEFT") - ser=>this%right - call serialize_print_peer_pointer(ser,unit,parents,components,peers,"RIGHT") - end subroutine lin_approx_list_print_to_unit - - function lin_approx_list_get_type() result(type) - character(:),allocatable::type!FC = nagfor - allocate(type,source="LIN_APPROX_LIST_TYPE")!FC = nagfor - character(32)::type!FC = gfortran - type="LIN_APPROX_LIST_TYPE"!FC = gfortran - end function lin_approx_list_get_type - - recursive subroutine lin_approx_list_finalize(this) - class(lin_approx_list_type) :: this - if (associated(this%right)) then - call this%right%finalize() - deallocate(this%right) - end if - if (allocated(this%values)) then - deallocate(this%values) - end if - this%dim=0 - end subroutine lin_approx_list_finalize - - subroutine lin_approx_list_insert_left_a(this,value,content,new_node) - class(lin_approx_list_type),intent(inout),target :: this - real(kind=double),intent(in) :: value - class(lin_approx_cont_type),intent(in) :: content - class(lin_approx_list_type),pointer,intent(out) :: new_node - call content%to_node(value,list=new_node) - new_node%right=>this - if(associated(this%left))then - new_node%left=>this%left - this%left%right=>new_node - else - nullify(new_node%left) - end if - this%left=>new_node - end subroutine lin_approx_list_insert_left_a - - subroutine lin_approx_list_insert_right_old(this,value,content,new_node) - class(lin_approx_list_type),intent(inout),target :: this - real(kind=double),intent(in) :: value - class(lin_approx_cont_type),intent(in) :: content - class(lin_approx_list_type),pointer,intent(out) :: new_node - call content%to_node(value,list=new_node) - new_node%left=>this - if(associated(this%right))then - new_node%right=>this%right - this%right%left=>new_node - else - nullify(new_node%right) - end if - this%right=>new_node - end subroutine lin_approx_list_insert_right_old - - subroutine lin_approx_list_insert_right_a(this,value,content,new_node) - class(lin_approx_list_type),intent(inout),target :: this - real(kind=double),intent(in) :: value - class(lin_approx_cont_type),intent(in) :: content - class(lin_approx_list_type),pointer,intent(out) :: new_node - class(lin_approx_list_type),pointer :: tmp_list - call content%to_node(value,list=tmp_list) - if(associated(this%right))then - this%right%left=>tmp_list - tmp_list%right=>this%right - else - nullify(tmp_list%right) - end if - this%right=>tmp_list - tmp_list%left=>this - new_node=>tmp_list - end subroutine lin_approx_list_insert_right_a - - subroutine lin_approx_list_append(this,right) - class(lin_approx_list_type),intent(inout),target :: this - class(lin_approx_node_class),intent(inout),target :: right - this%right=>right - right%left=>this - end subroutine lin_approx_list_append - - subroutine lin_approx_list_to_tree(this,out_tree) - class(lin_approx_list_type),target,intent(in) :: this - class(lin_approx_tree_type),intent(out) :: out_tree - type(lin_approx_tree_type),target :: do_list - class(lin_approx_node_class),pointer :: this_entry,do_list_entry,node - class(lin_approx_tree_type),pointer :: tree1,tree2 - integer :: ite,log,n_deep,n_leaves - n_leaves=0 - this_entry => this - count: do while(associated(this_entry)) - n_leaves=n_leaves+1 - this_entry=>this_entry%right - end do count - call ilog2(n_leaves,log,n_deep) - this_entry => this - do_list_entry => do_list - deep: do ite=0,n_deep-1 - allocate(tree1) - tree1%down=>this_entry%right - allocate(tree2) - tree2%down=>this_entry - tree2%left=>this_entry - tree2%right=>this_entry%right - tree1%left=>tree2 - this_entry => this_entry%right%right - do_list_entry%right=>tree1 - do_list_entry=>tree1 - end do deep - rest: do while(associated(this_entry)) - allocate(tree1) - tree1%down=>this_entry - tree1%left=>this_entry - do_list_entry%right => tree1 - do_list_entry => tree1 - this_entry => this_entry%right - ite=ite+1 - end do rest - tree: do while(ite>2) - do_list_entry => do_list%right - node=>do_list - level: do while(associated(do_list_entry)) - node%right=>do_list_entry%right - node=>do_list_entry%right - do_list_entry%right=>node%left - node%left=>do_list_entry - do_list_entry=>node%right - ite=ite-1 - end do level - end do tree - call do_list%right%to_tree(out_tree) - out_tree%right=>out_tree%right%left - if(allocated(out_tree%values))then - deallocate(out_tree%values) - end if - deallocate(do_list%right%right) - deallocate(do_list%right) - end subroutine lin_approx_list_to_tree - - subroutine lin_approx_list_gnuplot(this,dir) - class(lin_approx_list_type),intent(in),target :: this - character(len=*),intent(in)::dir - character(len=*),parameter::val_file="value.plot" - character(len=*),parameter::int_file="integral.plot" - character(len=*),parameter::err_file="integral_error.plot" - character(len=*),parameter::pro_file="propability.plot" - character(len=*),parameter::fmt='(E20.10)' - class(lin_approx_node_class),pointer::list - integer::val_unit,err_unit,int_unit,pro_unit - list=>this - call open_there_or_here(dir,val_file,val_unit) - call open_there_or_here(dir,int_file,int_unit) - call open_there_or_here(dir,err_file,err_unit) - call open_there_or_here(dir,pro_file,pro_unit) - do while (associated(list)) -! print *,list%r_position,list%get_r_value() - write(val_unit,fmt,advance='NO')list%r_position - call write_array(val_unit,list%get_r_value_array(),fmt) - write(int_unit,fmt,advance='NO')list%r_position - call write_array(int_unit,list%get_r_integral(),fmt) - write(err_unit,fmt,advance='NO')list%r_position - call write_array(err_unit,list%get_error(),fmt) - write(pro_unit,fmt,advance='NO')list%r_position - call write_array(pro_unit,list%get_r_propability(),fmt) - list=>list%right - end do - close(val_unit) - close(int_unit) - close(err_unit) - close(pro_unit) - contains - subroutine write_array(unit,array,form) - integer,intent(in)::unit - real(kind=double),dimension(:),intent(in)::array - character(len=*),intent(in)::form - integer::n - do n=1,size(array) - write(unit,form,ADVANCE='NO')array(n) - flush(unit) - end do - write(unit,'("")') - end subroutine write_array - end subroutine lin_approx_list_gnuplot - - subroutine lin_approx_node_error_no_content(this) - class(lin_approx_node_class),intent(in) :: this -! print("lin_approx_node: Trying to access unallocated content.") -! call this%print() - end subroutine lin_approx_node_error_no_content - - subroutine lin_approx_list_integrate(this,integral_sum,error_sum) - class(lin_approx_list_type),intent(in),target :: this - real(kind=double),intent(out)::error_sum,integral_sum - real(kind=double),dimension(:),allocatable::integral - class(lin_approx_node_class),pointer :: node - allocate(integral(this%dim)) - call this%get_rightmost(node) - integral=0D0 - integral_sum=0D0 - error_sum=0D0 - integrate: do while(associated(node)) - node%values(1,r_value_index)=sum(node%values(2:this%dim,r_value_index)) - node%values(1,d_value_index)=sum(node%values(2:this%dim,d_value_index)) -! node%values(1,r_integral_index)=sum(node%values(2:this%dim,r_integral_index)) -! node%values(1,d_integral_index)=sum(node%values(2:this%dim,d_integral_index)) - node%values(1,error_index)=sum(node%values(2:this%dim,error_index)) - error_sum=error_sum+node%values(1,error_index) - call node%set_d_integral(node%get_d_position()*(node%get_d_value()/2D0-node%get_r_value_array())) - call node%set_r_propability(exp(-integral)) - call node%set_r_integral(integral) - integral=integral-node%get_d_integral() - call node%set_d_propability(node%get_r_propability()-exp(-integral)) -! call lin_approx_cont_write(node,output_unit) - call node%get_left(node) - end do integrate - integral_sum=integral(1) - end subroutine lin_approx_list_integrate - - recursive subroutine lin_approx_list_check(this) - class(lin_approx_list_type),intent(in),target :: this - class(lin_approx_node_class),pointer::tn,next - real(kind=double),parameter::eps=1d-10 - logical::test - if(associated(this%right))then - next=>this%right - test=(this%r_position.le.this%right%get_l_position()+eps) - print *,"position check: ",test - if(.not.test)then - call this%print_parents() - call next%print_parents() - end if - select type (next) - class is (lin_approx_list_type) - tn=>this - print *,"structure check: ",associated(tn,next%left) - print *,"class check: T" - call next%check() - class default - print *,"class check: F" - end select - else - print *,"end of list at ",this%r_position - end if - end subroutine lin_approx_list_check - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures for lin_approx_tree_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - SUBROUTINE lin_approx_tree_write_to_ring (this,ring,status) - CLASS(lin_approx_tree_type), INTENT(IN),target :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - ! local variables - class(lin_approx_list_type),pointer::list - class(serializable_class),pointer::ser - call xml_write_begin_tag(ring,"LIN_APPROX_TREE_TYPE") - call this%get_left_list(list) - ser=>list - call serialize_pointer(ser,ring,"LIST") - call xml_write_end_tag(ring,"LIN_APPROX_TREE_TYPE") - end SUBROUTINE lin_approx_tree_write_to_ring - - SUBROUTINE lin_approx_tree_read_from_ring (this,ring,status) - CLASS(lin_approx_tree_type), INTENT(OUT) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - ! local variables - class(serializable_class),pointer::ser - call xml_verify_begin_tag(ring,"LIN_APPROX_TREE_TYPE",status) - call deserialize_pointer(ser,ring) - if(associated(ser))then - select type(ser) - class is (lin_approx_list_type) - call ser%to_tree(this) - class default - nullify(this%left) - nullify(this%right) - nullify(this%down) - end select - else - nullify(this%left) - nullify(this%right) - nullify(this%down) - end if - call xml_verify_end_tag(ring,"LIN_APPROX_TREE_TYPE",status) - end SUBROUTINE lin_approx_tree_read_from_ring - - recursive subroutine lin_approx_tree_print_to_unit(this,unit,parents,components,peers) - class(lin_approx_tree_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - class(serializable_class),pointer::ser - if(parents>0)call lin_approx_cont_print_to_unit(this,unit,parents-1,components,peers) - ser=>this%down - call serialize_print_peer_pointer(ser,unit,1,0,1,"DOWN") - if(associated(this%left))then - select type(sertmp=>this%left) - class is(lin_approx_list_type) - ser=>sertmp - call serialize_print_peer_pointer(ser,unit,parents,components,0,"LEFT") - class default - call serialize_print_peer_pointer(ser,unit,parents,components,peers,"LEFT") - end select - else - write(unit,fmt=*)"Left is not associated." - end if - if(associated(this%right))then - select type(sertmp=>this%right) - class is(lin_approx_list_type) - ser=>sertmp - call serialize_print_peer_pointer(ser,unit,parents,components,0,"RIGHT") - class default - call serialize_print_peer_pointer(ser,unit,parents,components,peers,"RIGHT") - end select - else - write(unit,fmt=*)"Right is not associated." - end if - end subroutine lin_approx_tree_print_to_unit - - function lin_approx_tree_get_type() result(type) - character(:),allocatable::type!FC = nagfor - allocate(type,source="LIN_APPROX_TREE_TYPE")!FC = nagfor - character(32)::type!FC = gfortran - type="LIN_APPROX_TREE_TYPE"!FC = gfortran - end function lin_approx_tree_get_type - - ! overridden linn_approx_node_class procedures - - subroutine lin_approx_tree_get_left_list(this,list) - class(lin_approx_tree_type),intent(in) :: this - class(lin_approx_list_type),pointer,intent(out) :: list - class(lin_approx_node_class),pointer::node - call this%get_leftmost(node) - if(associated(node))then - select type(node) - class is (lin_approx_list_type) - list=>node - class default - nullify(list) - end select - end if - end subroutine lin_approx_tree_get_left_list - - subroutine lin_approx_tree_get_right_list(this,list) - class(lin_approx_tree_type),intent(in) :: this - class(lin_approx_list_type),pointer,intent(out) :: list - class(lin_approx_node_class),pointer::node - call this%get_rightmost(node) - if(associated(node))then - select type(node) - class is (lin_approx_list_type) - list=>node - class default - nullify(list) - end select - end if - end subroutine lin_approx_tree_get_right_list - - recursive subroutine lin_approx_tree_finalize(this) - class(lin_approx_tree_type) :: this - if (associated(this%right)) then - call this%right%finalize() - deallocate(this%right) - end if - if (associated(this%left)) then - call this%left%finalize() - deallocate(this%left) - end if - if (allocated(this%values)) then - deallocate(this%values) - end if - this%dim=0 - end subroutine lin_approx_tree_finalize - - subroutine lin_approx_tree_decide_by_value(this,value,dim,record,node) - class(lin_approx_tree_type),intent(in) :: this - real(kind=double),intent(in)::value - integer,intent(in)::record,dim - class(lin_approx_node_class),pointer,intent(out) :: node - if(this%down%values(dim,record)>value)then - node=>this%left - else - node=>this%right - end if - end subroutine lin_approx_tree_decide_by_value - - subroutine lin_approx_tree_decide_by_position(this,position,node) - class(lin_approx_tree_type),intent(in) :: this - real(kind=double),intent(in)::position - class(lin_approx_node_class),pointer,intent(out) :: node - if(this%down%r_position>position)then - node=>this%left - else - node=>this%right - end if - end subroutine lin_approx_tree_decide_by_position - - subroutine lin_approx_tree_decide_decreasing(this,value,dim,record,node) - class(lin_approx_tree_type),intent(in) :: this - real(kind=double),intent(in)::value - integer,intent(in)::record,dim -! integer,save::count=0 - class(lin_approx_node_class),pointer,intent(out) :: node -! count=count+1 - if(this%down%values(dim,record)<=value)then -! print('("Decide: value(",I2,",",I1,")=",E20.7," > ",E20.7,": go left.")'),dim,record,this%down%values(dim,record),value - node=>this%left - else -! print('("Decide: value(",I2,",",I1,")=",E20.7," <= ",E20.7,": go right.")'),dim,record,this%down%values(dim,record),value - node=>this%right - end if - end subroutine lin_approx_tree_decide_decreasing - - subroutine lin_approx_tree_find_by_value(this,value,dim,record,node) - class(lin_approx_tree_type),intent(in),target :: this - real(kind=double),intent(in)::value - integer,intent(in)::record,dim - class(lin_approx_node_class),pointer,intent(out) :: node - node=>this - do while(.not.allocated(node%values)) - call node%decide(value,dim,record,node) - end do - end subroutine lin_approx_tree_find_by_value - - subroutine lin_approx_tree_find_by_position(this,position,node) - class(lin_approx_tree_type),intent(in),target :: this - real(kind=double),intent(in)::position - class(lin_approx_node_class),pointer,intent(out) :: node - node=>this - do while(.not.allocated(node%values)) - call node%decide(position,node) - end do - end subroutine lin_approx_tree_find_by_position - - subroutine lin_approx_tree_find_decreasing(this,value,dim,record,node) - class(lin_approx_tree_type),intent(in),target :: this - real(kind=double),intent(in)::value - integer,intent(in)::record,dim - class(lin_approx_node_class),pointer,intent(out) :: node - node=>this - do while(.not.allocated(node%values)) - call node%decide_decreasing(value,dim,record,node) - end do - end subroutine lin_approx_tree_find_decreasing - - subroutine lin_approx_tree_approx_by_integral(this,int,dim,in_range,position,value,integral,content) - class(lin_approx_tree_type),intent(in),target :: this - real(kind=double),intent(in) :: int - integer,intent(in)::dim - logical,intent(out) :: in_range - class(lin_approx_node_class),pointer,intent(out),optional :: content - real(kind=double),intent(out),optional :: position,value,integral - integer::i - real(kind=double) :: DINT!,l_prop,r_prop,d_prop - real(kind=double)::RP,DP,RV,DV,RI!FC = gfortran - class(lin_approx_node_class),pointer :: node - node=>this - do while(.not.allocated(node%values)) - call node%decide_decreasing(INT,dim,r_integral_index,node) - end do - if( int<=node%values(dim,r_integral_index)-node%values(dim,d_integral_index)& - &.and.& - &int>=node%values(dim,r_integral_index))then - in_range=.true. - associate(&!FC = nagfor - &RP=>node%r_position,&!FC = nagfor - &DP=>node%d_position,&!FC = nagfor - &RV=>node%values(dim,r_value_index),&!FC = nagfor - &DV=>node%values(dim,d_value_index),&!FC = nagfor - &RI=>node%values(dim,r_integral_index))!FC = nagfor - RP=node%r_position!FC = gfortran - DP=node%d_position!FC = gfortran - RV=node%values(dim,r_value_index)!FC = gfortran - DV=node%values(dim,d_value_index)!FC = gfortran - RI=node%values(dim,r_integral_index)!FC = gfortran - if (present(position)) then - DINT=(ri-int)*2D0*dv/dp - position=rp-(dp/dv)*(rv-sqrt(dint+rv**2)) - end if - if (present(value)) then - value=Sqrt(dp*(-2*dv*int + 2*dv*ri + dp*rv**2))/dp - end if - if (present(integral)) then - integral=int - end if - if (present(content)) then - content=>node - end if - end associate!FC = nagfor - else - in_range=.false. - end if - end subroutine lin_approx_tree_approx_by_integral - - subroutine lin_approx_tree_approx_by_propability(this,prop,dim,in_range,position,value,integral,content) - class(lin_approx_tree_type),intent(in),target :: this - real(kind=double),intent(in) :: prop - integer,intent(in)::dim - logical,intent(out) :: in_range - class(lin_approx_node_class),pointer,intent(out),optional :: content - real(kind=double),intent(out),optional :: position,value,integral - integer::i - real(kind=double) :: INT,DINT,l_prop,r_prop,d_prop - class(lin_approx_node_class),pointer :: node - if(0D0this - INT=-log(prop) - call lin_approx_tree_approx_by_integral(this,int,dim,in_range,position,value,integral,content) - else - in_range=.false. - end if - end subroutine lin_approx_tree_approx_by_propability - - subroutine lin_approx_tree_to_tree(this,out_tree) - class(lin_approx_tree_type),intent(in) :: this - class(lin_approx_tree_type),intent(out) :: out_tree - out_tree%left=>this%left - out_tree%right=>this%right - out_tree%down=>this%down - end subroutine lin_approx_tree_to_tree - - subroutine lin_approx_tree_append(this,right) - class(lin_approx_tree_type),intent(inout),target :: this - class(lin_approx_node_class),intent(inout),target :: right - print ('("lin_approx_tree_append: Not yet implemented.")') - end subroutine lin_approx_tree_append - - - !!!!!!!!!!!!!!!! - !!! Outdated !!! - !!!!!!!!!!!!!!!! - -!!$ subroutine lin_approx_node_new_by_reals(value,& -!!$ &l_pos,r_position,l_val,r_value,d_integral,r_integral,r_propability,d_propability,error,node,list,tree) -!!$ real(kind=double),intent(in) :: value -!!$ real(kind=double),intent(in),optional :: & -!!$ &l_pos,r_position,l_val,r_value,d_integral,r_integral,r_propability,d_propability,error -!!$ class(lin_approx_node_class),optional,pointer,intent(out) :: node -!!$ class(lin_approx_list_type),optional,pointer,intent(out) :: list -!!$ class(lin_approx_tree_type),optional,pointer,intent(out) :: tree -!!$ if(present(node))then -!!$ allocate(node) -!!$ call lin_approx_node_set(& -!!$ &node,value,l_pos,r_position,l_val,r_value,d_integral,r_integral,r_propability,d_propability,error) -!!$ end if -!!$ if(present(list))then -!!$ allocate(list) -!!$ call lin_approx_node_set(& -!!$ &list,value,l_pos,r_position,l_val,r_value,d_integral,r_integral,r_propability,d_propability,error) -!!$ end if -!!$ if(present(tree))then -!!$ allocate(tree) -!!$ call lin_approx_node_set(& -!!$ &tree,value,l_pos,r_position,l_val,r_value,d_integral,r_integral,r_propability,d_propability,error) -!!$ end if -!!$ end subroutine lin_approx_node_new_by_reals - -!!$ subroutine lin_approx_list_insert_left_b(this,value,l_pos,r_position,l_val,r_value,d_integral,r_integral,error,new_list) -!!$ class(lin_approx_list_type),intent(inout),target :: this -!!$ real(kind=double),intent(in) :: value -!!$ real(kind=double),intent(in),optional :: l_pos,r_position,l_val,r_value,d_integral,r_integral,error -!!$ class(lin_approx_list_type),pointer,intent(out):: new_list -!!$ allocate(new_list) -!!$ call lin_approx_node_set(new_list,value,l_pos,r_position,l_val,r_value,d_integral,r_integral,error) -!!$ this%left=>new_list -!!$ new_list%right=>this -!!$ end subroutine lin_approx_list_insert_left_b - -!!$ subroutine lin_approx_list_insert_right_b(this,value,l_pos,r_position,l_val,r_value,d_integral,r_integral,error,new_list) -!!$ class(lin_approx_list_type),intent(inout),target :: this -!!$ real(kind=double),intent(in) :: value -!!$ real(kind=double),intent(in),optional :: l_pos,r_position,l_val,r_value,d_integral,r_integral,error -!!$ class(lin_approx_list_type),pointer,intent(out):: new_list -!!$ class(lin_approx_list_type),pointer :: tmp_list -!!$ allocate(tmp_list) -!!$ if(associated(this%right))then -!!$ this%right%left=>tmp_list -!!$ tmp_list%right=>this%right -!!$ else -!!$ nullify(tmp_list%right) -!!$ end if -!!$ this%right=>tmp_list -!!$ tmp_list%left=>this -!!$ new_list=>tmp_list -!!$ call lin_approx_node_set(new_list,value,l_pos,r_position,l_val,r_value,d_integral,r_integral,error) -!!$ end subroutine lin_approx_list_insert_right_b - -!!$ recursive subroutine fib2lin(fib_tree,lin_tree) -!!$ use fibonacci_tree_module -!!$ class(fibonacci_node_type),target,intent(in) :: fib_tree -!!$ type(lin_approx_tree_type),intent(out) :: lin_tree -!!$! class(lin_approx_list_type),pointer :: list -!!$ class(serializable_old_type),pointer :: content -!!$ -!!$ -!!$ lin_tree%value = fib_tree%value -!!$ select type (fib_tree) -!!$ class is (fibonacci_leave_type) -!!$! leave => fib_tree -!!$ if (associated(fib_tree%content)) then -!!$ content => fib_tree%content -!!$ select type (content) -!!$ class is (lin_approx_cont_type) -!!$ allocate(lin_tree%content,source=content) -!!$ end select -!!$ end if -!!$ class default -!!$ allocate(lin_tree%left) -!!$ allocate(lin_tree%right) -!!$ call fib2lin(fib_tree%left,lin_tree%left) -!!$ call fib2lin(fib_tree%right,lin_tree%right) -!!$ end select -!!$ end subroutine fib2lin - - ! subroutine lin_list_copy_and_revert(in_list,out_list) - ! class(lin_approx_tree_type),target,intent(in) :: in_list - ! class(lin_approx_tree_type),pointer,intent(out):: out_list - ! class(lin_approx_tree_type),pointer :: tmp_list - ! tmp_list=>in_list - ! do while(associated(tmp_list)) - ! call lin_approx_tree_new(out_list,value=tmp_list%value,right=out_list) - ! end do - ! end subroutine lin_list_copy_and_revert - -!!$ subroutine lin_approx_cont_choose_partons(this,partons) -!!$ class(lin_approx_cont_type),intent(in) :: this -!!$ integer,dimension(1:2),intent(out) :: partons -!!$ real(kind=double) :: rnd,ratio -!!$ integer :: p1,p2 -!!$ p1=-4 -!!$ p2=4 -!!$ ratio=this%ratios(p2,p1) -!!$ call random_number(rnd) -!!$ do while(ratio=0D0) -!!$ kind=kind+1 -!!$ rnd=rnd-values(kind) -!!$ end do -!!$ else -!!$ pt=-1D0 -!!$ kind=-1 -!!$ end if -!!$ end subroutine lin_approx_tree_generate_pt_by_sum - -!!$ subroutine lin_approx_tree_generate_pt_by_competition(this,start_node,start_pt,remnand,in_range,node,pt,kind) -!!$ !dummy arguments -!!$ class(lin_approx_tree_type),intent(in),target :: this -!!$ class(lin_approx_node_class),pointer,intent(in)::start_node -!!$ real(kind=double),intent(in) :: start_pt -!!$ type(beam_remnand_type),intent(in)::remnand -!!$ logical,intent(out) :: in_range -!!$ real(kind=double),intent(out) :: pt -!!$ integer,intent(out)::kind -!!$ class(lin_approx_node_class),pointer,intent(out)::node -!!$ !local variables -!!$ integer::n -!!$ real(kind=double)::rnd,tmp_pt,norm -!!$ real(kind=double),dimension(:),allocatable::tmp_prop -!!$ class(lin_approx_node_class),pointer::tmp_node -!!$ logical :: tmp_in_range -!!$ allocate(tmp_prop(start_node%dim)) -!!$ tmp_prop=start_node%approx_propability(start_pt) -!!$ in_range=.false. -!!$ pt=-1D0 -!!$ n=-1 -!!$ nullify(node) -!!$ do n=2,start_node%dim -!!$ norm=remnand%get_pdf_weight(pdf_int_11(1:2,n)) -!!$ if(norm>0D0)then -!!$ call random_number(rnd) -!!$ rnd=((tmp_prop(n))**(1D0/norm))*rnd -!!$ call this%approx_by_propability(rnd,n,tmp_in_range,tmp_pt,content=tmp_node) -!!$ if(tmp_in_range)then -!!$ if(tmp_pt>pt)then -!!$ node=>tmp_node -!!$ pt=tmp_pt -!!$ in_range=.true. -!!$ kind=n -!!$ end if -!!$ end if -!!$ end if -!!$ end do -!!$ end subroutine lin_approx_tree_generate_pt_by_competition - -end module lin_approx_tree_module - Index: branches/attic/boschmann_standalone/pri/lib/misc.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/misc.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/misc.f03.pri (revision 8609) @@ -1,239 +0,0 @@ -!!! module: misc_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-03-03 17:45:51 CET(+0100) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module misc_module - use kinds - contains - - function max_array(array) - real(kind=double),dimension(:),intent(in)::array - real(kind=double)::max_array - integer::n - max_array=array(1) - do n=2,size(array) - max_array=max(max_array,array(n)) - end do - end function max_array - - subroutine integer_with_leading_zeros(number,length,string) - integer,intent(in) :: number,length - character(len=*),intent(out) :: string - integer :: zeros - character::sign - if(number==0)then - string = repeat("0",length) - else - if(number>0)then - zeros=length-floor(log10(real(number)))-1 - if(zeros<0)then - string=repeat("*",length) - else - write(string,fmt='(a,I0)') repeat("0",zeros),number - end if - else - zeros=length-floor(log10(real(-number)))-2 - if(zeros<0)then - string=repeat("*",length) - else - write(string,fmt='(a,a,I0)') "-",repeat("0",zeros),abs(number) - end if - end if - end if - end subroutine integer_with_leading_zeros - - subroutine integer_to_character_array(number,length,array) - integer,intent(in) :: number,length - character,dimension(length),intent(out)::array - character,dimension(0:9),parameter::char_table=["a","b","c","d","e","f","g","h","i","j"] - integer::pos,digit,rest - rest=number - do pos=length,1,-1 - digit=modulo(rest,10) - rest=rest/10 - array(pos)=char_table(digit) - end do - end subroutine integer_to_character_array - - subroutine ilog2(int,exp,rem) - integer,intent(in) :: int - integer,intent(out) :: exp,rem - integer :: count - count = 2 - exp = 1 - do while (countint) then - rem=(int-ishft(count,-1)) - else - rem=0 - end if - end subroutine ilog2 - - subroutine generate_unit(unit,min,max) - integer,intent(out) :: unit - integer,intent(in),optional :: min,max - integer :: min_u,max_u - logical :: is_open - unit = -1 - if(present(min))then - min_u=min - else - min_u=10 - end if - if(present(max))then - max_u=max - else - max_u=huge(max_u) - end if - do unit=min_u,max_u - inquire(unit,opened=is_open) - if (.not. is_open) then - exit - end if - end do - end subroutine generate_unit - - subroutine open_and_echo(filename,unit,status) - character(len=*),intent(in)::filename - integer,intent(out)::unit - character(len=*),intent(in),optional::status - logical::exist - integer::iostat - character(len=255)::iomsg - call generate_unit(unit,100) - write (*,fmt='("Trying to open ",a,"...")',advance='NO')filename - if(present(status))then - open(unit,file=filename,recl=10000,iostat=iostat,iomsg=iomsg,status=status) - else - open(unit,file=filename,recl=10000,iostat=iostat,iomsg=iomsg) - end if - if(iostat==0)then - write(*,*)"ok ",unit - else - write(*,'("failed")') - write(*,'(a)')iomsg - unit=-1 - end if - end subroutine open_and_echo - - subroutine open_and_echo_int(filename,number,length,unit,status) - character(len=*),intent(in)::filename - integer,intent(in)::number,length - integer,intent(out)::unit - character(len=*),intent(in),optional::status - character(len=length)::string - call integer_with_leading_zeros(number,length,string) - call open_and_echo(filename//string,unit,status) - end subroutine open_and_echo_int - - subroutine check_dir_and_open(filename,dir,unit,default_dir) - character(len=*),intent(in)::filename,dir - character(len=*),intent(in),optional::default_dir - integer,intent(out)::unit - logical::exist - print *,"check_dir_and_open ",filename," ",dir,default_dir - unit=-1 - inquire(file=dir,exist=exist) - if(exist)then - call open_and_echo(dir//"/"//filename,unit) - else - if(present(default_dir))then - print *,"Directory ",dir," not found. Trying alternative..." - inquire(file=default_dir,exist=exist) - if(exist)then - call open_and_echo(default_dir//"/"//filename,unit) - else - print *,"Neither directory ",dir," nor alternative directory ",default_dir," exist. Stop." - end if - else - print *,"Directory ",dir," not found and no alternative given. Stop." - end if - end if - end subroutine check_dir_and_open - - subroutine open_there_or_here(dir,filename,unit) - character(len=*),intent(in)::filename,dir - integer,intent(out)::unit - call check_dir_and_open(filename,dir,unit,".") - end subroutine open_there_or_here - - subroutine write_integer_matrix(unit,fmt,matrix) - integer,intent(in)::unit,fmt - integer,dimension(:,:),intent(in)::matrix - integer,dimension(2)::dim - integer::dim_x - character(len=9)::fmt_char - dim=shape(matrix) - write(fmt_char,'("(",I2,"(I",I2,"))")')dim(1),fmt - write(unit,fmt_char)matrix - end subroutine write_integer_matrix - - recursive subroutine misc_sort(in,out) - real(kind=double),dimension(:),intent(in)::in - integer,dimension(:),intent(out)::out - integer,dimension(:),allocatable::tmp - integer::n,k,l,cut - if(size(in)==1)then - out=[1] - else - if(size(in)==2)then - if(in(1)<=in(2))then - out=[1,2] - else - out=[2,1] - end if - else - cut=size(in)/2 - k=1 - l=cut+1 - allocate(tmp(size(in))) - call misc_sort(in(1:cut),tmp(1:cut)) - call misc_sort(in(cut+1:),tmp(cut+1:)) - do n=cut+1,size(in) - tmp(n)=tmp(n)+cut - end do - do n=1,size(in) - if(k>cut)then - out(n)=tmp(l) - l=l+1 - else - if(l>size(tmp))then - out(n)=tmp(k) - k=k+1 - else - if(in(tmp(k)) -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-29 09:07:26 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module fibonacci_tree_module - use,intrinsic::iso_fortran_env - use basic_types_module - use kinds - use misc_module - implicit none - - !!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Parameter Definition !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!! - - character(*),parameter,private :: no_par = "edge=\noparent" - character(*),parameter,private :: no_ret = "edge=\noreturn" - character(*),parameter,private :: no_kid = "edge=\nochild" - character(*),parameter,private :: le_kid = "edge=\childofleave" - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Derived Type Module Component Declaration !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! class(serializable_ref_type),pointer,private::ref_list - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Derived Type Definitions !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type,extends(measurable_class) :: fibonacci_node_type -! private - class(fibonacci_node_type), pointer :: up => null() - class(measurable_class), pointer :: XXXX => null() - class(fibonacci_node_type), pointer :: left => null() - class(fibonacci_node_type), pointer :: right => null() - integer :: depth = 0 -! real(kind=double) :: value - contains - ! overridden serializable_class procedures - procedure::write_to_ring=>fibonacci_node_write_to_ring - procedure::read_from_ring=>fibonacci_node_read_from_ring - procedure::print_to_unit=>fibonacci_node_print_to_unit - procedure,nopass::get_type=>fibonacci_node_get_type - procedure::deserialize=>fibonacci_node_deserialize - ! overridden measurable_class procedures - procedure::measure=>fibonacci_node_measure - ! init/final - procedure,public :: deallocate_tree => fibonacci_node_deallocate_tree - procedure,public :: deallocate_all => fibonacci_node_deallocate_all -! interface - procedure,public :: get_depth => fibonacci_node_get_depth - procedure,public :: count_leaves => fibonacci_node_count_leaves -! public tests - procedure,public,nopass :: is_leave => fibonacci_node_is_leave - procedure,public,nopass :: is_root => fibonacci_node_is_root - procedure,public,nopass :: is_inner => fibonacci_node_is_inner -! print methods - procedure,public :: write_association => fibonacci_node_write_association - procedure,public :: write_contents => fibonacci_node_write_contents - procedure,public :: write_values => fibonacci_node_write_values - procedure,public :: write_leaves => fibonacci_node_write_leaves - !procedure,public :: write => fibonacci_node_write_contents -! write methods - procedure,public :: write_pstricks => fibonacci_node_write_pstricks -! elaborated functions - procedure,public :: copy_node => fibonacci_node_copy_node - procedure,public :: find_root => fibonacci_node_find_root - procedure,public :: find_leftmost => fibonacci_node_find_leftmost - procedure,public :: find_rightmost => fibonacci_node_find_rightmost - procedure,public :: find => fibonacci_node_find - procedure,public :: find_left_leave => fibonacci_node_find_left_leave - procedure,public :: find_right_leave => fibonacci_node_find_right_leave - procedure,public :: apply_to_leaves => fibonacci_node_apply_to_leaves - procedure,public :: apply_to_leaves_rl => fibonacci_node_apply_to_leaves_rl -! private procedures: these are unsafe! - procedure :: set_depth => fibonacci_node_set_depth - procedure :: append_left => fibonacci_node_append_left - procedure :: append_right => fibonacci_node_append_right - procedure :: replace => fibonacci_node_replace - procedure :: swap => fibonacci_node_swap_nodes - procedure :: flip => fibonacci_node_flip_children - procedure :: rip => fibonacci_node_rip - procedure :: remove_and_keep_parent => fibonacci_node_remove_and_keep_parent - procedure :: remove_and_keep_twin => fibonacci_node_remove_and_keep_twin - procedure :: rotate_left => fibonacci_node_rotate_left - procedure :: rotate_right => fibonacci_node_rotate_right - procedure :: rotate => fibonacci_node_rotate - procedure :: balance_node => fibonacci_node_balance_node - procedure :: update_depth_save => fibonacci_node_update_depth_save - procedure :: update_depth_unsave => fibonacci_node_update_depth_unsave - procedure :: repair => fibonacci_node_repair -! tests: these are save when type is fibonacci_node_type and else unsafe. - procedure :: is_left_short => fibonacci_node_is_left_short - procedure :: is_right_short => fibonacci_node_is_right_short - procedure :: is_unbalanced => fibonacci_node_is_unbalanced - procedure :: is_left_too_short => fibonacci_node_is_left_too_short - procedure :: is_right_too_short => fibonacci_node_is_right_too_short - procedure :: is_too_unbalanced => fibonacci_node_is_too_unbalanced - procedure :: is_left_child => fibonacci_node_is_left_child - procedure :: is_right_child => fibonacci_node_is_right_child - ! user - ! node - ! tree -! procedure :: balance -! procedure :: sort -! procedure :: merge -! procedure :: split - end type fibonacci_node_type - - type,extends(fibonacci_node_type) :: fibonacci_leave_type -! class(measurable_class),pointer :: content - contains - ! overridden serializable_class procedures - procedure::write_to_ring=>fibonacci_leave_write_to_ring - procedure::read_from_ring=>fibonacci_leave_read_from_ring - procedure::print_to_unit=>fibonacci_leave_print_to_unit - procedure,nopass::get_type=>fibonacci_leave_get_type - ! new procedures - procedure,public :: pick => fibonacci_leave_pick - procedure,public :: get_left => fibonacci_leave_get_left - procedure,public :: get_right => fibonacci_leave_get_right - procedure,public :: write_pstricks => fibonacci_leave_write_pstricks - procedure,public :: copy_content => fibonacci_leave_copy_content - procedure,public :: set_content => fibonacci_leave_set_content - procedure,public :: get_content => fibonacci_leave_get_content - procedure,public,nopass :: is_inner => fibonacci_leave_is_inner - procedure,public,nopass :: is_leave => fibonacci_leave_is_leave - procedure :: insert_leave_by_node => fibonacci_leave_insert_leave_by_node - procedure :: is_left_short => fibonacci_leave_is_left_short - procedure :: is_right_short => fibonacci_leave_is_right_short - procedure :: is_unbalanced => fibonacci_leave_is_unbalanced - procedure :: is_left_too_short => fibonacci_leave_is_left_too_short - procedure :: is_right_too_short => fibonacci_leave_is_right_too_short - procedure :: is_too_unbalanced => fibonacci_leave_is_too_unbalanced - end type fibonacci_leave_type - - type,extends(fibonacci_node_type) :: fibonacci_root_type - logical::is_valid_c=.false. - class(fibonacci_leave_type),pointer :: leftmost => null() - class(fibonacci_leave_type),pointer :: rightmost => null() - contains - ! overridden serializable_class procedures - procedure::write_to_ring=>fibonacci_root_write_to_ring - procedure::read_from_ring=>fibonacci_root_read_from_ring - procedure::print_to_unit=>fibonacci_root_print_to_unit - procedure,nopass::get_type=>fibonacci_root_get_type - ! new procedures - procedure::get_leftmost=>fibonacci_root_get_leftmost - procedure::get_rightmost=>fibonacci_root_get_rightmost -! public tests - procedure,public,nopass :: is_root => fibonacci_root_is_root - procedure,public,nopass :: is_inner => fibonacci_root_is_inner - procedure,public :: is_valid => fibonacci_root_is_valid - procedure,public :: count_leaves => fibonacci_root_count_leaves - procedure,public :: write_pstricks => fibonacci_root_write_pstricks - procedure,public :: copy_root => fibonacci_root_copy_root - procedure,public :: push_by_content => fibonacci_root_push_by_content - procedure,public :: push_by_leave => fibonacci_root_push_by_leave - procedure,public :: pop_left => fibonacci_root_pop_left - procedure,public :: pop_right => fibonacci_root_pop_right - procedure,public :: merge => fibonacci_root_merge - procedure,public :: set_leftmost => fibonacci_root_set_leftmost - procedure,public :: set_rightmost => fibonacci_root_set_rightmost - procedure,public :: init_by_leave => fibonacci_root_init_by_leave - procedure,public :: init_by_content => fibonacci_root_init_by_content - procedure,public :: reset => fibonacci_root_reset - ! init/final - procedure,public :: deallocate_tree => fibonacci_root_deallocate_tree - procedure,public :: deallocate_all => fibonacci_root_deallocate_all - procedure :: is_left_child => fibonacci_root_is_left_child - procedure :: is_right_child => fibonacci_root_is_right_child - end type fibonacci_root_type - - type,extends(fibonacci_root_type) :: fibonacci_stub_type - contains - ! overridden serializable_class procedures -!!$ procedure::write_to_ring=>fibonacci_stub_write_to_ring -!!$ procedure::read_from_ring=>fibonacci_stub_read_from_ring -!!$ procedure::print_to_unit=>fibonacci_stub_print_to_unit - procedure,nopass::get_type=>fibonacci_stub_get_type - ! overridden fibonacci_root_type procedures - procedure,public :: push_by_content => fibonacci_stub_push_by_content - procedure,public :: push_by_leave => fibonacci_stub_push_by_leave - procedure,public :: pop_left => fibonacci_stub_pop_left - procedure,public :: pop_right => fibonacci_stub_pop_right - end type fibonacci_stub_type - - type fibonacci_leave_list_type - class(fibonacci_leave_type),pointer :: leave => null() - class(fibonacci_leave_list_type),pointer :: next => null() - end type fibonacci_leave_list_type - -contains - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures for fibonacci_node_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! overridden serializable_class procedures - - SUBROUTINE fibonacci_node_write_to_ring(this,ring,status) - CLASS(fibonacci_node_type), INTENT(IN) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status -! local variables - class(serializable_class),pointer::ser - call xml_write_begin_tag(ring,"FIBONACCI_NODE_TYPE") - ser=>this%left - call serialize_pointer(ser,ring,"LEFT") - ser=>this%right - call serialize_pointer(ser,ring,"RIGHT") - call xml_write_end_tag(ring,"FIBONACCI_NODE_TYPE") - end SUBROUTINE fibonacci_node_write_to_ring - - SUBROUTINE fibonacci_node_read_from_ring(this,ring,status) - CLASS(fibonacci_node_type),target,INTENT(out) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status -! local variables - class(serializable_class),pointer::ser - call xml_verify_begin_tag(ring,"FIBONACCI_NODE_TYPE",status) - call deserialize_pointer(ser,ring) - if(status==0)then - select type(ser) - class is (fibonacci_node_type) - this%left=>ser - this%left%up=>this - end select - end if - call deserialize_pointer(ser,ring) - if(status==0)then - select type(ser) - class is (fibonacci_node_type) - this%right=>ser - this%right%up=>this - end select - end if - call xml_verify_end_tag(ring,"FIBONACCI_NODE_TYPE",status) - end SUBROUTINE fibonacci_node_read_from_ring - - pure function fibonacci_node_get_type() - character(:),allocatable::fibonacci_node_get_type!FC = nagfor - allocate(fibonacci_node_get_type,source="FIBONACCI_NODE_TYPE")!FC = nagfor - character(32)::fibonacci_node_get_type!FC = gfortran - fibonacci_node_get_type="FIBONACCI_NODE_TYPE"!FC = gfortran - end function fibonacci_node_get_type - - subroutine fibonacci_node_deserialize(this,ring) - class(fibonacci_node_type),intent(out)::this - class(page_ring_type),intent(inout)::ring - class(serializable_class),pointer::ser - allocate(fibonacci_leave_type::ser) - call serialize_push_reference(ser) - allocate(fibonacci_node_type::ser) - call serialize_push_reference(ser) - call serializable_deserialize(this,ring) - call serialize_pop_reference(ser) - deallocate(ser) - call serialize_pop_reference(ser) - deallocate(ser) - end subroutine fibonacci_node_deserialize - - subroutine fibonacci_node_print_to_unit(this,unit,parents,components,peers) - class(fibonacci_node_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - class(serializable_class),pointer::ser - write(unit,'("Components of fibonacci_node_type:")') - write(unit,'("Depth: ",I22)')this%depth - write(unit,'("Value: ",E23.16)')this%measure() - ser=>this%up - call serialize_print_comp_pointer(ser,unit,parents,-1,-1,"Up: ") - ser=>this%left - call serialize_print_peer_pointer(ser,unit,parents,components,peers,"Left: ") - ser=>this%right - call serialize_print_peer_pointer(ser,unit,parents,components,peers,"Right: ") - end subroutine fibonacci_node_print_to_unit - - elemental function fibonacci_node_measure(this) - class(fibonacci_node_type),intent(in)::this - real(kind=double)::fibonacci_node_measure - fibonacci_node_measure=this%XXXX%measure() - end function fibonacci_node_measure - - ! init/final - - recursive subroutine fibonacci_node_deallocate_tree(this) - class(fibonacci_node_type) :: this - if (associated(this%left)) then - call this%left%deallocate_tree() - deallocate(this%left) - end if - if (associated(this%right)) then - call this%right%deallocate_tree() - deallocate(this%right) - end if - call this%set_depth(0) - end subroutine fibonacci_node_deallocate_tree - - recursive subroutine fibonacci_node_deallocate_all(this) - class(fibonacci_node_type) :: this - if (associated(this%left)) then - call this%left%deallocate_all() - deallocate(this%left) - end if - if (associated(this%right)) then - call this%right%deallocate_all() - deallocate(this%right) - end if - call this%set_depth(0) - end subroutine fibonacci_node_deallocate_all - - subroutine fibonacci_node_set_depth(this,depth) - class(fibonacci_node_type) :: this - integer,intent(in) :: depth - this%depth=depth - end subroutine fibonacci_node_set_depth - - elemental function fibonacci_node_get_depth(this) - class(fibonacci_node_type),intent(in) :: this - integer :: fibonacci_node_get_depth - fibonacci_node_get_depth = this%depth - end function fibonacci_node_get_depth - - elemental function fibonacci_node_is_leave() - logical :: fibonacci_node_is_leave - fibonacci_node_is_leave = .false. - end function fibonacci_node_is_leave - - elemental function fibonacci_node_is_root() - logical :: fibonacci_node_is_root - fibonacci_node_is_root = .false. - end function fibonacci_node_is_root - - elemental function fibonacci_node_is_inner() - logical :: fibonacci_node_is_inner - fibonacci_node_is_inner = .true. - end function fibonacci_node_is_inner - - subroutine fibonacci_node_write_leaves(this,unit) - class(fibonacci_node_type),target :: this - integer,intent(in),optional :: unit - call this%apply_to_leaves(fibonacci_leave_write,unit) - end subroutine fibonacci_node_write_leaves - - subroutine fibonacci_node_write_contents(this,unit) - class(fibonacci_node_type),target :: this - integer,intent(in),optional :: unit - call this%apply_to_leaves(fibonacci_leave_write_content,unit) - end subroutine fibonacci_node_write_contents - - subroutine fibonacci_node_write_values(this,unit) - class(fibonacci_node_type),target :: this - integer,intent(in),optional :: unit - call this%apply_to_leaves(fibonacci_leave_write_value,unit) - end subroutine fibonacci_node_write_values - - subroutine fibonacci_node_write_association(this,that) - class(fibonacci_node_type),target :: this - class(fibonacci_node_type),intent(in),target :: that - if (associated(that%left,this)) then - write(*,'("this is left child of that")') - end if - if (associated(that%right,this)) then - write(*,'("this is right child of that")') - end if - if (associated(that%up,this)) then - write(*,'("this is parent of that")') - end if - if (associated(this%left,that)) then - write(*,'("that is left child of this")') - end if - if (associated(this%right,that)) then - write(*,'("that is right child of this")') - end if - if (associated(this%up,that)) then - write(*,'("that is parent of this")') - end if - end subroutine fibonacci_node_write_association - - recursive subroutine fibonacci_node_write_pstricks(this,unitnr) - class(fibonacci_node_type),target :: this - integer,intent(in) :: unitnr - if (associated(this%up)) then - if (associated(this%up%left,this).neqv.(associated(this%up%right,this))) then -! write(unitnr,'("\begin{psTree}{\Toval{$",i3,"$}}")') int(this%depth) - write(unitnr,'("\begin{psTree}{\Toval{\node{",i3,"}{",f9.3,"}}}")') int(this%depth),this%measure() - else - write(unitnr,'("\begin{psTree}{\Toval[",a,"]{\node{",i3,"}{",f9.3,"}}}")') no_ret,int(this%depth),this%measure() - end if - else - write(unitnr,'("\begin{psTree}{\Toval[",a,"]{\node{",i3,"}{",f9.3,"}}}")') no_par,int(this%depth),this%measure() - end if - if (associated(this%left)) then - call this%left%write_pstricks(unitnr) - else - write(unitnr,'("\Tr[edge=brokenline]{}")') - end if - if (associated(this%right)) then - call this%right%write_pstricks(unitnr) - else - write(unitnr,'("\Tr[edge=brokenline]{}")') - end if - write(unitnr,'("\end{psTree}")') - end subroutine fibonacci_node_write_pstricks - - subroutine fibonacci_node_copy_node(this,primitive) - class(fibonacci_node_type),intent(out) :: this - class(fibonacci_node_type),intent(in) :: primitive - this%up => primitive%up - this%left => primitive%left - this%right => primitive%right - this%depth = primitive%depth - this%XXXX=> primitive%XXXX - end subroutine fibonacci_node_copy_node - - subroutine fibonacci_node_find_root(this,root) - class(fibonacci_node_type),target :: this - class(fibonacci_root_type),pointer,intent(out) :: root - class(fibonacci_node_type),pointer :: node - node=>this - do while(associated(node%up)) - node=>node%up - end do - select type (node) - class is (fibonacci_root_type) - root=>node - class default - nullify(root) - print *,"fibonacci_node_find_root: root is not type compatible to fibonacci_root_type. Retured NULL()." - end select - end subroutine fibonacci_node_find_root - - subroutine fibonacci_node_find_leftmost(this,leave) - class(fibonacci_node_type), target :: this - class(fibonacci_leave_type),pointer,intent(out) :: leave - class(fibonacci_node_type), pointer :: node - node=>this - do while(associated(node%left)) - node=>node%left - end do - select type (node) - class is (fibonacci_leave_type) - leave => node - class default - leave => null() - end select - end subroutine fibonacci_node_find_leftmost - - subroutine fibonacci_node_find_rightmost(this,leave) - class(fibonacci_node_type), target :: this - class(fibonacci_leave_type),pointer,intent(out) :: leave - class(fibonacci_node_type), pointer :: node - node=>this - do while(associated(node%right)) - node=>node%right - end do - select type (node) - class is (fibonacci_leave_type) - leave => node - class default - leave => null() - end select - end subroutine fibonacci_node_find_rightmost - - subroutine fibonacci_node_find(this,value,leave) - class(fibonacci_node_type),target :: this - real(kind=double),intent(in) :: value - class(fibonacci_leave_type),pointer,intent(out) :: leave - class(fibonacci_node_type), pointer :: node - node=>this - do - if (node>=value) then - if (associated(node%left)) then - node=>node%left - else - print *,"fibonacci_node_find: broken tree!" - leave => null() - return - end if - else - if (associated(node%right)) then - node=>node%right - else - print *,"fibonacci_node_find: broken tree!" - leave => null() - return - end if - end if - select type (node) - class is (fibonacci_leave_type) - leave => node - exit - end select - end do - end subroutine fibonacci_node_find - - subroutine fibonacci_node_find_left_leave(this,leave) - class(fibonacci_node_type),target :: this - class(fibonacci_node_type),pointer :: node - class(fibonacci_leave_type),pointer,intent(out) :: leave - nullify(leave) - node=>this - do while (associated(node%up)) - if (associated(node%up%right,node)) then - node=>node%up%left - do while (associated(node%right)) - node=>node%right - end do - select type (node) - class is (fibonacci_leave_type) - leave=>node - end select - exit - end if - node=>node%up - end do - end subroutine fibonacci_node_find_left_leave - - subroutine fibonacci_node_find_right_leave(this,leave) - class(fibonacci_node_type),target :: this - class(fibonacci_node_type),pointer :: node - class(fibonacci_leave_type),pointer,intent(out) :: leave - nullify(leave) - node=>this - do while (associated(node%up)) - if (associated(node%up%left,node)) then - node=>node%up%right - do while (associated(node%left)) - node=>node%left - end do - select type (node) - class is (fibonacci_leave_type) - leave=>node - end select - exit - end if - node=>node%up - end do - end subroutine fibonacci_node_find_right_leave - - subroutine fibonacci_node_replace(this,old_node) - class(fibonacci_node_type),target :: this - class(fibonacci_node_type),target :: old_node - if (associated(old_node%up)) then - if (old_node%is_left_child()) then - old_node%up%left => this - else - if (old_node%is_right_child()) then - old_node%up%right => this - end if - end if - this%up => old_node%up - else - nullify(this%up) - end if - end subroutine fibonacci_node_replace - - subroutine fibonacci_node_swap_nodes(left,right) - class(fibonacci_node_type),target,intent(inout) :: left,right - class(fibonacci_node_type),pointer :: left_left,right_right - class(measurable_class),pointer::XXXX - ! swap branches - left_left =>left%left - right_right=>right%right - left%left =>right%right - right%right=>left_left - ! repair up components - right_right%up=>left - left_left%up =>right - ! repair down components - XXXX => left%XXXX - left%XXXX => right%XXXX - right%XXXX => XXXX - end subroutine fibonacci_node_swap_nodes - -! subroutine fibonacci_node_swap_nodes(this,that) -! class(fibonacci_node_type),target :: this -! class(fibonacci_node_type),pointer,intent(in) :: that -! class(fibonacci_node_type),pointer :: par_i,par_a -! par_i => this%up -! par_a => that%up -! if (associated(par_i%left,this)) then -! par_i%left => that -! else -! par_i%right => that -! end if -! if (associated(par_a%left,that)) then -! par_a%left => this -! else -! par_a%right => this -! end if -! this%up => par_a -! that%up => par_i -! end subroutine fibonacci_node_swap_nodes - - subroutine fibonacci_node_flip_children(this) - class(fibonacci_node_type) :: this - class(fibonacci_node_type),pointer :: child - child => this%left - this%left=>this%right - this%right => child - end subroutine fibonacci_node_flip_children - - subroutine fibonacci_node_rip(this) - class(fibonacci_node_type),target :: this - if (this%is_left_child()) then - nullify(this%up%left) - end if - if (this%is_right_child()) then - nullify(this%up%right) - end if - nullify(this%up) - end subroutine fibonacci_node_rip - - subroutine fibonacci_node_remove_and_keep_twin(this,twin) - class(fibonacci_node_type),target :: this - class(fibonacci_node_type),intent(out),pointer :: twin - class(fibonacci_node_type),pointer :: pa - if (.not. (this%is_root())) then - pa=>this%up - if (.not. pa%is_root()) then - if (this%is_left_child()) then - twin => pa%right - else - twin => pa%left - end if - if (pa%is_left_child()) then - pa%up%left => twin - else - pa%up%right => twin - end if - end if - twin%up => pa%up - if(associated(this%right))then - this%right%left=>this%left - end if - if(associated(this%left))then - this%left%right=>this%right - end if - nullify(this%left) - nullify(this%right) - nullify(this%up) - deallocate(pa) - end if - end subroutine fibonacci_node_remove_and_keep_twin - - subroutine fibonacci_node_remove_and_keep_parent(this,pa) - class(fibonacci_node_type),target :: this - class(fibonacci_node_type),intent(out),pointer :: pa - class(fibonacci_node_type),pointer :: twin - if (.not. (this%is_root())) then - pa=>this%up - if (this%is_left_child()) then - twin => pa%right - else - twin => pa%left - end if - twin%up=>pa%up - if (associated(twin%left)) then - twin%left%up => pa - end if - if (associated(twin%right)) then - twin%right%up => pa - end if - call pa%copy_node(twin) - select type(pa) - class is (fibonacci_root_type) - call pa%set_leftmost() - call pa%set_rightmost() - end select - if(associated(this%right))then - this%right%left=>this%left - end if - if(associated(this%left))then - this%left%right=>this%right - end if - nullify(this%left) - nullify(this%right) - nullify(this%up) - deallocate(twin) - else - pa=>this - end if - end subroutine fibonacci_node_remove_and_keep_parent - - subroutine fibonacci_leave_pick(this) - class(fibonacci_leave_type),target,intent(inout) :: this - class(fibonacci_node_type),pointer :: other - class(fibonacci_root_type),pointer :: root -! call this%up%print_parents() - call this%find_root(root) - if(associated(this%up,root))then - if(this%up%depth<2)then - print *,"fibonacci_leave_pick: Cannot pick leave. Tree must have at least three leaves." - return - else - call this%remove_and_keep_parent(other) - call other%repair() - end if - else - call this%remove_and_keep_twin(other) - call other%up%repair() - end if - if(associated(root%leftmost,this))call root%set_leftmost() - if(associated(root%rightmost,this))call root%set_rightmost() - end subroutine fibonacci_leave_pick - - subroutine fibonacci_node_append_left(this,new_branch) - class(fibonacci_node_type),target :: this - class(fibonacci_node_type),target :: new_branch - this%left => new_branch - new_branch%up => this - end subroutine fibonacci_node_append_left - - subroutine fibonacci_node_append_right(this,new_branch) - class(fibonacci_node_type),target :: this - class(fibonacci_node_type),target :: new_branch - this%right => new_branch - new_branch%up => this - end subroutine fibonacci_node_append_right - - subroutine fibonacci_node_rotate_left(this) - class(fibonacci_node_type),target :: this - call this%swap(this%right) - call this%right%flip() - call this%right%update_depth_unsave() - call this%flip() -! value = this%value -! this%value = this%left%value -! this%left%value = value - end subroutine fibonacci_node_rotate_left - - subroutine fibonacci_node_rotate_right(this) - class(fibonacci_node_type),target :: this - call this%left%swap(this) - call this%left%flip() - call this%left%update_depth_unsave() - call this%flip() -! value = this%value -! this%value = this%right%value -! this%right%value = value - end subroutine fibonacci_node_rotate_right - - subroutine fibonacci_node_rotate(this) - class(fibonacci_node_type),target :: this - if (this%is_left_short()) then - call this%rotate_left() - else - if (this%is_right_short()) then - call this%rotate_right() - end if - end if - end subroutine fibonacci_node_rotate - - subroutine fibonacci_node_balance_node(this,changed) - class(fibonacci_node_type),target :: this - logical,intent(out) :: changed - changed=.false. - if (this%is_left_too_short()) then - if (this%right%is_right_short()) then - call this%right%rotate_right - end if - call this%rotate_left() - changed=.true. - else - if (this%is_right_too_short()) then - if (this%left%is_left_short()) then - call this%left%rotate_left - end if - call this%rotate_right() - changed=.true. - end if - end if - end subroutine fibonacci_node_balance_node - - subroutine fibonacci_node_update_depth_unsave(this) - class(fibonacci_node_type) :: this - this%depth=max(this%left%depth+1,this%right%depth+1) - end subroutine fibonacci_node_update_depth_unsave - - subroutine fibonacci_node_update_depth_save(this,updated) - class(fibonacci_node_type) :: this - logical,intent(out) :: updated - integer :: left,right,new_depth - if (associated(this%left)) then - left=this%left%depth+1 - else - left=-1 - end if - if (associated(this%right)) then - right=this%right%depth+1 - else - right=-1 - end if - new_depth=max(left,right) - if (this%depth == new_depth) then - updated = .false. - else - this%depth=new_depth - updated = .true. - end if - end subroutine fibonacci_node_update_depth_save - - subroutine fibonacci_node_repair(this) - class(fibonacci_node_type),target :: this - class(fibonacci_node_type),pointer:: node - logical :: new_depth,new_balance - new_depth = .true. - node=>this - do while((new_depth .or. new_balance) .and. (associated(node))) - call node%balance_node(new_balance) - call node%update_depth_save(new_depth) - node=>node%up - end do - end subroutine fibonacci_node_repair - -!!$ subroutine fibonacci_node_update_value(this,right_value) -!!$ class(fibonacci_node_type),target :: this -!!$ class(fibonacci_node_type),pointer:: node -!!$ real(kind=double),intent(in) :: right_value -!!$ if (associated(this%left) .and. associated(this%right)) then -!!$ node=>this -!!$! node%value = node%left%value -!!$! right_value = node%right%value -!!$ inner: do while(associated(node%up)) -!!$ if (node%is_right_child()) then -!!$ node=>node%up -!!$ else -!!$ node%up%value=right_value -!!$ exit -!!$ end if -!!$ end do inner -!!$ end if -!!$ end subroutine fibonacci_node_update_value - - elemental logical function fibonacci_node_is_left_short(this) - class(fibonacci_node_type),intent(in) :: this - fibonacci_node_is_left_short = (this%left%depth0)call fibonacci_node_print_to_unit(this,unit,parents-1,components,peers) - write(unit,'("Components of fibonacci_root_type:")') - ser=>this%leftmost - call serialize_print_peer_pointer(ser,unit,parents,components,min(peers,1),"Leftmost: ") - ser=>this%rightmost - call serialize_print_peer_pointer(ser,unit,parents,components,min(peers,1),"Rightmost:") - end subroutine fibonacci_root_print_to_unit - - pure function fibonacci_root_get_type() result(type) - character(:),allocatable::type!FC = nagfor - allocate(type,source="FIBONACCI_ROOT_TYPE")!FC = nagfor - character(32)::type!FC = gfortran - type="FIBONACCI_ROOT_TYPE"!FC = gfortran - end function fibonacci_root_get_type - - subroutine fibonacci_root_get_leftmost(this,leftmost) - class(fibonacci_root_type),intent(in)::this - class(fibonacci_leave_type),pointer::leftmost - leftmost=>this%leftmost - end subroutine fibonacci_root_get_leftmost - - subroutine fibonacci_root_get_rightmost(this,rightmost) - class(fibonacci_root_type),intent(in)::this - class(fibonacci_leave_type),pointer::rightmost - rightmost=>this%rightmost - end subroutine fibonacci_root_get_rightmost - - elemental function fibonacci_root_is_inner() - logical::fibonacci_root_is_inner - fibonacci_root_is_inner=.false. - end function fibonacci_root_is_inner - - elemental function fibonacci_root_is_root() - logical::fibonacci_root_is_root - fibonacci_root_is_root=.true. - end function fibonacci_root_is_root - - elemental function fibonacci_root_is_valid(this) - class(fibonacci_root_type),intent(in) :: this - logical :: fibonacci_root_is_valid - fibonacci_root_is_valid=this%is_valid_c - end function fibonacci_root_is_valid - - subroutine fibonacci_root_count_leaves(this,n) - class(fibonacci_root_type),intent(in) :: this - integer,intent(out) :: n - n=0 - call fibonacci_node_count_leaves(this,n) - end subroutine fibonacci_root_count_leaves - - subroutine fibonacci_root_copy_node(this,primitive) - class(fibonacci_root_type) :: this - type(fibonacci_node_type),intent(in) :: primitive - call fibonacci_node_copy_node(this,primitive) - call primitive%find_leftmost(this%leftmost) - call primitive%find_rightmost(this%rightmost) - end subroutine fibonacci_root_copy_node - - subroutine fibonacci_root_write_pstricks(this,unitnr) - class(fibonacci_root_type),target :: this - integer,intent(in) :: unitnr - logical :: is_opened - character :: is_sequential,is_formatted,is_writeable - print *,"pstricks" - inquire(unitnr,opened=is_opened,& - &sequential=is_sequential,formatted=is_formatted,write=is_writeable) - if (is_opened) then - if (is_sequential=="Y" .and. is_formatted=="Y" .and. is_writeable=="Y") then -! write(unitnr,'("\begin{psTree}{\Toval[linecolor=blue]{$",i3,"$}}")') int(this%depth) - write(unitnr,'("\begin{psTree}{\Toval[linecolor=blue]{\node{",i3,"}{",f9.3,"}}}")') this%depth,this%measure() - if (associated(this%leftmost)) then - call this%leftmost%write_pstricks(unitnr) - else - write(unitnr,'("\Tr[",a,"]{}")') no_kid - end if - if (associated(this%left)) then - call this%left%write_pstricks(unitnr) - else - write(unitnr,'("\Tr[",a,"]{}")') no_kid - end if - if (associated(this%right)) then - call this%right%write_pstricks(unitnr) - else - write(unitnr,'("\Tr[",a,"]{}")') no_kid - end if - if (associated(this%rightmost)) then - call this%rightmost%write_pstricks(unitnr) - else - write(unitnr,'("\Tr[",a,"]{}")') no_kid - end if - write(unitnr,'("\end{psTree}")') - write(unitnr,'("\\")') - else - print '("fibonacci_node_write_pstricks: Unit ",I2," is not opened properly.")',unitnr - print '("No output is written to unit.")' - end if - else - print '("fibonacci_node_write_pstricks: Unit ",I2," is not opened.")',unitnr - print '("No output is written to unit.")' - end if - end subroutine fibonacci_root_write_pstricks - - subroutine fibonacci_root_copy_root(this,primitive) - class(fibonacci_root_type),intent(out) :: this - class(fibonacci_root_type),intent(in) :: primitive - call fibonacci_node_copy_node(this,primitive) - this%leftmost => primitive%leftmost - this%rightmost => primitive%rightmost - end subroutine fibonacci_root_copy_root - -!!$ subroutine fibonacci_root_push_by_node(this,new_leave) -!!$ class(fibonacci_root_type),target,intent(inout) :: this -!!$ class(fibonacci_leave_type),pointer,intent(inout) :: new_leave -!!$ class(fibonacci_leave_type),pointer :: old_leave -!!$ if (new_leave<=this%leftmost) then -!!$ old_leave=>this%leftmost -!!$ this%leftmost=>new_leave -!!$ else -!!$ if (new_leave>this%rightmost) then -!!$ old_leave=>this%rightmost -!!$ this%rightmost=>new_leave -!!$ else -!!$ call this%find(new_leave%measure(),old_leave) -!!$ end if -!!$ end if -!!$! call old_leave%insert_leave_by_node(new_leave) -!!$ call fibonacci_leave_insert_leave_by_node(old_leave,new_leave) -!!$ call new_leave%up%repair() -!!$! call new_leave%up%update_value() -!!$ end subroutine fibonacci_root_push_by_node - - subroutine fibonacci_root_push_by_content(this,content) - class(fibonacci_root_type),target,intent(inout) :: this - class(measurable_class),target,intent(in)::content - class(fibonacci_leave_type),pointer :: node -! print *,"fibonacci_root_push_by_content: ",content%measure() - allocate(node) - node%XXXX=>content - call this%push_by_leave(node)!FC = nagfor - call fibonacci_root_push_by_leave(this,node)!FC = gfortran - end subroutine fibonacci_root_push_by_content - - ! this is a workaround for BUG 44696. This subroutine is a merge of - ! fibonacci_tree_push_by_node - ! fibonacci_node_find - ! fibonacci_leave_insert_leave_by_node - subroutine fibonacci_root_push_by_leave(this,new_leave) - class(fibonacci_root_type),target,intent(inout) :: this - class(fibonacci_leave_type),pointer,intent(inout) :: new_leave - class(fibonacci_leave_type),pointer :: old_leave - class(fibonacci_node_type), pointer :: node,new_node,leave_c - !write(11,fmt=*)"push by leave(",new_leave%measure(),")\\"!PSTRICKS - !flush(11)!PSTRICKS - if (new_leave<=this%leftmost) then - old_leave=>this%leftmost - this%leftmost=>new_leave - node=>old_leave%up - call fibonacci_node_spawn(new_node,new_leave,old_leave,old_leave%left,old_leave%right) - call node%append_left(new_node) - else - if (new_leave>this%rightmost) then - old_leave=>this%rightmost - this%rightmost=>new_leave - node=>old_leave%up - call fibonacci_node_spawn(new_node,old_leave,new_leave,old_leave%left,old_leave%right) - call node%append_right(new_node) - else - node=>this - do - if (new_leave<=node) then - leave_c=>node%left - select type (leave_c) - class is (fibonacci_leave_type) - if(new_leave<=leave_c)then -! print *,"left left" - call fibonacci_node_spawn(new_node,new_leave,leave_c,leave_c%left,leave_c%right) - else -! print *,"left right" - call fibonacci_node_spawn(new_node,leave_c,new_leave,leave_c%left,leave_c%right) - end if - call node%append_left(new_node) - exit - class default -! print *,"left" - node=>node%left - end select - else - leave_c=>node%right - select type (leave_c) - class is (fibonacci_leave_type) - if(new_leave<=leave_c)then -! print *,"right left" - call fibonacci_node_spawn(new_node,new_leave,leave_c,leave_c%left,leave_c%right) - else -! print *,"right right" - call fibonacci_node_spawn(new_node,leave_c,new_leave,leave_c%left,leave_c%right) - end if - call node%append_right(new_node) - exit - class default -! print *,"right" - node=>node%right - end select - end if - end do - end if - end if - !call this%write_pstricks(11)!PSTRICKS - !flush(11)!PSTRICKS - !write(11,fmt=*)"repair\\"!PSTRICKS - call node%repair() - !call this%write_pstricks(11)!PSTRICKS - !flush(11)!PSTRICKS -! call node%update_value(right_value) -! call this%write_pstricks(11) -! print *,new_node%value,new_node%left%value,new_node%right%value - end subroutine fibonacci_root_push_by_leave - - subroutine fibonacci_root_pop_left(this,leave) - class(fibonacci_root_type),target :: this - class(fibonacci_leave_type),pointer,intent(out) :: leave - class(fibonacci_node_type),pointer :: parent,grand - !write(11,fmt=*)"fibonacci root pop left\\"!PSTRICKS - !flush(11)!PSTRICKS - leave => this%leftmost - if (this%left%depth>=1) then - parent => leave%up - grand=>parent%up - grand%left => parent%right - parent%right%up=>grand - deallocate(parent) - parent=>grand%left - if (.not.parent%is_leave())then - parent=>parent%left - end if - select type (parent) - class is (fibonacci_leave_type) - this%leftmost => parent - class default - print *,"fibonacci_root_pop_left: ERROR: leftmost is no leave." - call parent%print_all() - STOP - end select - !call this%write_pstricks(11)!PSTRICKS - !flush(11)!PSTRICKS - !write(11,fmt=*)"fibonacci node repair\\"!PSTRICKS - !flush(11)!PSTRICKS - call grand%repair() - else - if (this%left%depth==0.and.this%right%depth==1) then - parent => this%right - parent%right%up=>this - parent%left%up=>this - this%left=>parent%left - this%right=>parent%right - this%depth=1 - deallocate(parent) - parent=>this%left - select type (parent) - class is (fibonacci_leave_type) - this%leftmost => parent - end select - this%XXXX=>this%leftmost%XXXX - end if - end if - nullify(leave%right%left) - nullify(leave%up) - nullify(leave%right) - nullify(this%leftmost%left) - !call this%write_pstricks(11)!PSTRICKS - !flush(11)!PSTRICKS - end subroutine fibonacci_root_pop_left - - subroutine fibonacci_root_pop_right(this,leave) - class(fibonacci_root_type),target :: this - class(fibonacci_leave_type),pointer,intent(out) :: leave - class(fibonacci_node_type),pointer :: parent,grand - leave => this%rightmost - if (this%right%depth>=1) then - parent => leave%up - grand=>parent%up - grand%right => parent%left - parent%left%up=>grand - deallocate(parent) - parent=>grand%right - if (.not.parent%is_leave())then - parent=>parent%right - end if - select type (parent) - class is (fibonacci_leave_type) - this%rightmost => parent - class default - print *,"fibonacci_root_pop_left: ERROR: leftmost is no leave." - call parent%print_all() - STOP - end select - call grand%repair() - else - if (this%right%depth==0.and.this%left%depth==1) then - parent => this%left - parent%left%up=>this - parent%right%up=>this - this%right=>parent%right - this%left=>parent%left - this%depth=1 - deallocate(parent) - parent=>this%right - select type (parent) - class is (fibonacci_leave_type) - this%rightmost => parent - end select - this%XXXX=>this%rightmost%XXXX - end if - end if - end subroutine fibonacci_root_pop_right - - subroutine fibonacci_root_merge(this_tree,that_tree,merge_tree) - ! I neither used nor revised this procedure for a long time, so it might be broken. - class(fibonacci_root_type),intent(in) :: this_tree - class(fibonacci_root_type),intent(in) :: that_tree - class(fibonacci_root_type),pointer,intent(out) :: merge_tree - class(fibonacci_leave_type),pointer :: this_leave,that_leave,old_leave - type(fibonacci_leave_list_type),target :: leave_list - class(fibonacci_leave_list_type),pointer :: last_leave - integer :: n_leaves - if (associated(this_tree%leftmost).and.associated(that_tree%leftmost)) then - n_leaves=1 - this_leave=>this_tree%leftmost - that_leave=>that_tree%leftmost - if (this_leave < that_leave) then - allocate(leave_list%leave,source=this_leave) - call this_leave%find_right_leave(this_leave) - else - allocate(leave_list%leave,source=that_leave) - call that_leave%find_right_leave(that_leave) - end if - last_leave=>leave_list - do while (associated(this_leave).and.associated(that_leave)) - if (this_leave < that_leave) then - old_leave=>this_leave - call this_leave%find_right_leave(this_leave) - else - old_leave=>that_leave - call that_leave%find_right_leave(that_leave) - end if - allocate(last_leave%next) - last_leave=>last_leave%next - allocate(last_leave%leave,source=old_leave) - n_leaves=n_leaves+1 - end do - if (associated(this_leave)) then - old_leave=>this_leave - else - old_leave=>that_leave - end if - do while (associated(old_leave)) - allocate(last_leave%next) - last_leave=>last_leave%next - allocate(last_leave%leave,source=old_leave) - n_leaves=n_leaves+1 - call old_leave%find_right_leave(old_leave) - end do - allocate(merge_tree) - call fibonacci_root_list_to_tree(merge_tree,n_leaves,leave_list) - else - n_leaves=0 - end if - if(associated(leave_list%next)) then - last_leave=>leave_list%next - do while (associated(last_leave%next)) - leave_list%next=>last_leave%next - deallocate(last_leave) - last_leave=>leave_list%next - end do - deallocate(last_leave) - end if - end subroutine fibonacci_root_merge - - subroutine fibonacci_root_list_to_tree(this,n_leaves,leave_list_target) - class(fibonacci_root_type),target :: this - integer,intent(in) :: n_leaves - type(fibonacci_leave_list_type),target,intent(in) :: leave_list_target -! class(fibonacci_root_type),pointer,intent(out) :: tree - integer:: depth,n_deep,n_merge - class(fibonacci_node_type),pointer :: node - class(fibonacci_leave_list_type),pointer :: leave_list - class(fibonacci_leave_type),pointer::content - real(kind=double) :: up_value - leave_list=>leave_list_target - call ilog2(n_leaves,depth,n_deep) - n_deep=n_deep*2 - n_merge=0 - this%depth=depth - node=>this - outer: do - do while(depth>1) - depth=depth-1 - allocate(node%left) - node%left%up=>node - node=>node%left - node%depth=depth - end do - node%left=>leave_list%leave - node%XXXX=>leave_list%leave%XXXX - leave_list=>leave_list%next - node%right=>leave_list%leave - content => leave_list%leave - leave_list=>leave_list%next - n_merge=n_merge+2 - inner: do - if (associated(node%up)) then - if (node%is_left_child()) then - if (n_merge==n_deep.and.depth==1) then - node=>node%up - node%right=>leave_list%leave - node%right%up=>node - node%XXXX=>content%XXXX - content=>leave_list%leave - leave_list=>leave_list%next - n_merge=n_merge+1 - cycle - end if - exit inner - else - node=>node%up - depth=depth+1 - end if - else - exit outer - end if - end do inner - node=>node%up - node%XXXX=>content%XXXX - allocate(node%right) - node%right%up => node - node=>node%right - if (n_deep==n_merge) then - depth=depth-1 - end if - node%depth=depth - end do outer - call this%set_leftmost - call this%set_rightmost - end subroutine fibonacci_root_list_to_tree - - subroutine fibonacci_root_set_leftmost(this) - class(fibonacci_root_type) :: this - call this%find_leftmost(this%leftmost) - end subroutine fibonacci_root_set_leftmost - - subroutine fibonacci_root_set_rightmost(this) - class(fibonacci_root_type) :: this - call this%find_rightmost(this%rightmost) - end subroutine fibonacci_root_set_rightmost - - subroutine fibonacci_root_init_by_leave(this,left_leave,right_leave) - class(fibonacci_root_type),target,intent(out) :: this - class(fibonacci_leave_type),target,intent(in) :: left_leave,right_leave - if (left_leave <= right_leave) then - this%left => left_leave - this%right => right_leave - this%leftmost => left_leave - this%rightmost => right_leave - else - this%left => right_leave - this%right => left_leave - this%leftmost => right_leave - this%rightmost => left_leave - end if - this%left%up => this - this%right%up => this - this%XXXX=>this%leftmost%XXXX - this%depth = 1 - this%leftmost%right=>this%rightmost - this%rightmost%left=>this%leftmost - this%is_valid_c=.true. - end subroutine fibonacci_root_init_by_leave - - subroutine fibonacci_root_init_by_content(this,left_content,right_content) - class(fibonacci_root_type),target,intent(out) :: this - class(measurable_class),intent(in),target :: left_content,right_content - call fibonacci_root_reset(this) - print *,"fibonacci_root_init_by_content: ",left_content%measure(),right_content%measure() - if (left_contentthis%leftmost%XXXX - this%is_valid_c=.true. - end subroutine fibonacci_root_init_by_content - - subroutine fibonacci_root_reset(this) - class(fibonacci_root_type),target,intent(out) :: this - call fibonacci_root_deallocate_tree(this) - allocate (this%leftmost) - allocate (this%rightmost) - this%depth=1 - this%leftmost%depth=0 - this%rightmost%depth=0 - this%left=>this%leftmost - this%right=>this%rightmost - this%left%up=>this - this%right%up=>this - this%leftmost%right=>this%rightmost - this%rightmost%left=>this%leftmost - end subroutine fibonacci_root_reset - - recursive subroutine fibonacci_root_deallocate_tree(this) - class(fibonacci_root_type) :: this - call fibonacci_node_deallocate_tree(this) - nullify(this%leftmost) - nullify(this%rightmost) - end subroutine fibonacci_root_deallocate_tree - - recursive subroutine fibonacci_root_deallocate_all(this) - class(fibonacci_root_type) :: this - call fibonacci_node_deallocate_all(this) - nullify(this%leftmost) - nullify(this%rightmost) - end subroutine fibonacci_root_deallocate_all - - elemental logical function fibonacci_root_is_left_child(this) - class(fibonacci_root_type),intent(in) :: this - fibonacci_root_is_left_child = .false. - end function fibonacci_root_is_left_child - elemental logical function fibonacci_root_is_right_child(this) - class(fibonacci_root_type),intent(in) :: this - fibonacci_root_is_right_child = .false. - end function fibonacci_root_is_right_child - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures for fibonacci_stub_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - SUBROUTINE fibonacci_stub_write_to_ring(this,ring,status) - CLASS(fibonacci_stub_type), INTENT(IN) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(inout)::status - end SUBROUTINE fibonacci_stub_write_to_ring - - SUBROUTINE fibonacci_stub_read_from_ring(this,ring,status) - CLASS(fibonacci_stub_type),target,INTENT(out) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(inout)::status - end SUBROUTINE fibonacci_stub_read_from_ring - - pure function fibonacci_stub_get_type() result(type) - character(:),allocatable::type!FC = nagfor - allocate(type,source="FIBONACCI_STUB_TYPE")!FC = nagfor - character(32)::type!FC = gfortran - type="FIBONACCI_STUB_TYPE"!FC = gfortran - end function fibonacci_stub_get_type - - subroutine fibonacci_stub_push_by_content(this,content) - class(fibonacci_stub_type),target,intent(inout) :: this - class(measurable_class),target,intent(in)::content - class(fibonacci_leave_type),pointer::leave - allocate(leave) - call leave%set_content(content) - call this%push_by_leave(leave) - end subroutine fibonacci_stub_push_by_content - - subroutine fibonacci_stub_push_by_leave(this,new_leave) - class(fibonacci_stub_type),target,intent(inout) :: this - class(fibonacci_leave_type),pointer,intent(inout) :: new_leave - class(fibonacci_leave_type),pointer::old_leave - if(this%depth<1)then - if(associated(this%leftmost))then - old_leave=>this%leftmost - call this%init_by_leave(old_leave,new_leave) - else - this%leftmost=>new_leave - end if - else - call fibonacci_root_push_by_leave(this,new_leave) - end if - end subroutine fibonacci_stub_push_by_leave - - subroutine fibonacci_stub_pop_left(this,leave) - class(fibonacci_stub_type),target :: this - class(fibonacci_leave_type),pointer,intent(out) :: leave - if(this%depth<2)then - if(this%depth==1)then - leave=>this%leftmost - this%leftmost=>this%rightmost - nullify(this%rightmost) - nullify(this%right) - nullify(this%left) - this%depth=0 - this%is_valid_c=.false. - else - if(associated(this%leftmost))then - leave=>this%leftmost - nullify(this%leftmost) - end if - end if - else - call fibonacci_root_pop_left(this,leave) - end if - end subroutine fibonacci_stub_pop_left - - subroutine fibonacci_stub_pop_right(this,leave) - class(fibonacci_stub_type),target :: this - class(fibonacci_leave_type),pointer,intent(out) :: leave - if(this%depth<2)then - if(this%depth==1)then - this%is_valid_c=.false. - if(associated(this%rightmost))then - leave=>this%rightmost - nullify(this%rightmost) - nullify(this%right) - else - if(associated(this%leftmost))then - leave=>this%leftmost - nullify(this%leftmost) - nullify(this%left) - else - nullify(leave) - end if - end if - end if - else - call fibonacci_root_pop_right(this,leave) - end if - end subroutine fibonacci_stub_pop_right - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Type Bound Procedures for fibonacci_leave_type !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - SUBROUTINE fibonacci_leave_write_to_ring(this,ring,status) - CLASS(fibonacci_leave_type), INTENT(IN) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status -class(serializable_class),pointer::ser - ser=>this%XXXX - call xml_write_begin_tag(ring,"FIBONACCI_LEAVE_TYPE") - !call fibonacci_node_write_to_ring(this,ring,status) - call serialize_pointer(ser,ring,"XXXX") - call xml_write_end_tag(ring,"FIBONACCI_LEAVE_TYPE") - end SUBROUTINE fibonacci_leave_write_to_ring - - SUBROUTINE fibonacci_leave_read_from_ring(this,ring,status) - CLASS(fibonacci_leave_type),target,INTENT(out) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - class(serializable_class),pointer::ser - call xml_verify_begin_tag(ring,"FIBONACCI_LEAVE_TYPE",status) -! call fibonacci_node_read_from_ring(this,ring,status) - call deserialize_pointer(ser,ring) - select type(ser) - class is(measurable_class) - this%XXXX=>ser - end select - call xml_verify_end_tag(ring,"FIBONACCI_LEAVE_TYPE",status) - end SUBROUTINE fibonacci_leave_read_from_ring - - pure function fibonacci_leave_get_type() result(type)!FC = nagfor - character(:),allocatable::type!FC = nagfor - allocate(type,source="FIBONACCI_LEAVE_TYPE")!FC = nagfor - end function fibonacci_leave_get_type!FC = nagfor - - pure function fibonacci_leave_get_type()!FC = gfortran - character(32)::fibonacci_leave_get_type!FC = gfortran - fibonacci_leave_get_type="FIBONACCI_LEAVE_TYPE"!FC = gfortran - end function fibonacci_leave_get_type!FC = gfortran - - subroutine fibonacci_leave_print_to_unit(this,unit,parents,components,peers) - class(fibonacci_leave_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - class(serializable_class),pointer::ser - if(parents>0)call fibonacci_node_print_to_unit(this,unit,parents-1,components,-1) - write(unit,'("Components of fibonacci_leave_type:")') - ser=>this%XXXX - call serialize_print_comp_pointer(ser,unit,parents,components,peers,"Content:") - end subroutine fibonacci_leave_print_to_unit - - subroutine fibonacci_leave_get_left(this,leave) - class(fibonacci_leave_type),intent(in) :: this - class(fibonacci_leave_type),intent(out),pointer :: leave - class(fibonacci_node_type),pointer::node - node=>this%left - select type(node) - class is (fibonacci_leave_type) - leave=>node - end select - end subroutine fibonacci_leave_get_left - - subroutine fibonacci_leave_get_right(this,leave) - class(fibonacci_leave_type),intent(in) :: this - class(fibonacci_leave_type),intent(out),pointer :: leave - class(fibonacci_node_type),pointer::node -! print *,"fibonacci_leave_get_right" -! call this%XXXX%print_little - if(associated(this%right))then - node=>this%right -! call node%XXXX%print_little - select type(node) - class is (fibonacci_leave_type) - leave=>node - end select - else -! print *,"no right leave" - nullify(leave) - end if - end subroutine fibonacci_leave_get_right - - subroutine fibonacci_leave_deallocate_tree(this) - class(fibonacci_leave_type) :: this - end subroutine fibonacci_leave_deallocate_tree - - subroutine fibonacci_leave_deallocate_all(this) - class(fibonacci_leave_type) :: this - if (associated(this%XXXX)) then - deallocate(this%XXXX) - end if - end subroutine fibonacci_leave_deallocate_all - - subroutine fibonacci_leave_write_pstricks(this,unitnr) - class(fibonacci_leave_type),target :: this - integer,intent(in) :: unitnr - write(unitnr,'("\begin{psTree}{\Toval[linecolor=green]{\node{",i3,"}{",f9.3,"}}}")') this%depth,this%measure() - if (associated(this%left)) then - write(unitnr,'("\Tr[",a,"]{}")') le_kid - end if - if (associated(this%right)) then - write(unitnr,'("\Tr[",a,"]{}")') le_kid - end if - write(unitnr,'("\end{psTree}")') - end subroutine fibonacci_leave_write_pstricks - - subroutine fibonacci_leave_insert_leave_by_node(this,new_leave) - class(fibonacci_leave_type),target,intent(inout) :: this,new_leave - class(fibonacci_node_type),pointer :: parent,new_node - class(fibonacci_node_type),pointer::NAG_FIX!FC = nagfor - parent=>this%up - !print *,associated(this%left),associated(this%right) - if(thisthis!FC = nagfor - if(associated(parent%left,NAG_FIX))then!FC = nagfor - if(associated(parent%left,this))then!FC = gfortran - call parent%append_left(new_node) - else - call parent%append_right(new_node) - end if - call parent%repair() - end subroutine fibonacci_leave_insert_leave_by_node - - subroutine fibonacci_leave_copy_content(this,content) - class(fibonacci_leave_type) :: this - class(measurable_class),intent(in) :: content - allocate(this%XXXX,source=content) - end subroutine fibonacci_leave_copy_content - - subroutine fibonacci_leave_set_content(this,content) - class(fibonacci_leave_type) :: this - class(measurable_class),target,intent(in) :: content - this%XXXX => content - end subroutine fibonacci_leave_set_content - - subroutine fibonacci_leave_get_content(this,content) - class(fibonacci_leave_type),intent(in) :: this - class(measurable_class),pointer :: content - content => this%XXXX - end subroutine fibonacci_leave_get_content - - elemental logical function fibonacci_leave_is_inner() - fibonacci_leave_is_inner = .false. - end function fibonacci_leave_is_inner - - elemental logical function fibonacci_leave_is_leave() - fibonacci_leave_is_leave = .true. - end function fibonacci_leave_is_leave - - elemental logical function fibonacci_leave_is_left_short(this) - class(fibonacci_leave_type),intent(in) :: this - fibonacci_leave_is_left_short = .false. - end function fibonacci_leave_is_left_short - - elemental logical function fibonacci_leave_is_right_short(this) - class(fibonacci_leave_type),intent(in) :: this - fibonacci_leave_is_right_short = .false. - end function fibonacci_leave_is_right_short - - elemental logical function fibonacci_leave_is_unbalanced(this) - class(fibonacci_leave_type),intent(in) :: this - fibonacci_leave_is_unbalanced = .false. - end function fibonacci_leave_is_unbalanced - - elemental logical function fibonacci_leave_is_left_too_short(this) - class(fibonacci_leave_type),intent(in) :: this - fibonacci_leave_is_left_too_short = .false. - end function fibonacci_leave_is_left_too_short - - elemental logical function fibonacci_leave_is_right_too_short(this) - class(fibonacci_leave_type),intent(in) :: this - fibonacci_leave_is_right_too_short = .false. - end function fibonacci_leave_is_right_too_short - - elemental logical function fibonacci_leave_is_too_unbalanced(this) - class(fibonacci_leave_type),intent(in) :: this - fibonacci_leave_is_too_unbalanced = .false. - end function fibonacci_leave_is_too_unbalanced - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Non Type Bound Procedures !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine fibonacci_leave_write_content(this,unit) - class(fibonacci_leave_type) :: this - integer,optional,intent(in)::unit - call this%XXXX%print_all(unit) - end subroutine fibonacci_leave_write_content - - subroutine fibonacci_leave_write(this,unit) - class(fibonacci_leave_type) :: this - integer,optional,intent(in)::unit - call this%print_all(unit) - end subroutine fibonacci_leave_write - - subroutine fibonacci_leave_write_value(this,unit) - class(fibonacci_leave_type) :: this - integer,optional,intent(in)::unit - if(present(unit))then - write(unit,fmt=*)this%measure() - else - write(output_unit,fmt=*)this%measure() - end if -! call this%print_little(unit) - end subroutine fibonacci_leave_write_value - - subroutine fibonacci_node_spawn(new_node,left_leave,right_leave,left_left_leave,right_right_leave) - class(fibonacci_node_type),pointer,intent(out) :: new_node - class(fibonacci_leave_type),target,intent(inout) :: left_leave,right_leave - class(fibonacci_node_type),pointer,intent(inout) :: left_left_leave,right_right_leave - allocate(new_node) - new_node%depth=1 - if(associated(left_left_leave))then - left_left_leave%right=>left_leave - left_leave%left=>left_left_leave - else - nullify(left_leave%left) - end if - if(associated(right_right_leave))then - right_right_leave%left=>right_leave - right_leave%right=>right_right_leave - else - nullify(right_leave%right) - end if - new_node%left=>left_leave - new_node%right=>right_leave - new_node%XXXX=>left_leave%XXXX - new_node%depth=1 - left_leave%up=>new_node - right_leave%up=>new_node - left_leave%right=>right_leave - right_leave%left=>left_leave - end subroutine fibonacci_node_spawn - -end module fibonacci_tree_module - Index: branches/attic/boschmann_standalone/pri/lib/qcdtypes.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/qcdtypes.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/qcdtypes.f03.pri (revision 8609) @@ -1,494 +0,0 @@ -!!! module: qcdtypes_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-16 16:04:55 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -MODULE qcdtypes_module - use,intrinsic::iso_fortran_env - use arguments_module - use kinds - use common_module - use parameters_module - use misc_module - use basic_types_module - use error_stack_module - use tao_random_numbers - use remnant_interface_module - use remnant_module - use beam_remnant_module - use sample_fractions_module - use lin_approx_tree_module - implicit none - - logical,parameter::default_modify_pdfs=.true. - - type,extends(serializable_class)::qcd_2_2_type - private - integer::process_id=-1 - integer::integrand_id=-1 - real(kind=double),dimension(3)::momentum_fractions=[-1D0,-1D0,-1D0] - real(kind=double),dimension(3)::hyperbolic_fractions=[-1D0,-1D0,-1D0] - contains - !overridden serializable_class procedures - procedure::write_to_ring=>qcd_2_2_write_to_ring - procedure::read_from_ring=>qcd_2_2_read_from_ring - procedure::print_to_unit=>qcd_2_2_print_to_unit - procedure,nopass::get_type=>qcd_2_2_get_type - ! new type-bound-procedures - procedure::get_process_id=>qcd_2_2_get_process_id - procedure::get_integrand_id=>qcd_2_2_get_integrand_id - procedure::get_diagram_kind=>qcd_2_2_get_diagram_kind - procedure::get_io_kind=>qcd_2_2_get_io_kind - procedure::get_lha_flavors=>qcd_2_2_get_lha_flavors - procedure::get_pdg_flavors=>qcd_2_2_get_pdg_flavors - procedure::get_parton_kinds=>qcd_2_2_get_parton_kinds - procedure::get_pdf_int_kinds=>qcd_2_2_get_pdf_int_kinds - procedure::get_PTS=>qcd_2_2_get_PTS - procedure::get_PTS2=>qcd_2_2_get_PTS2 - procedure::get_GeV_PT=>qcd_2_2_get_GeV_PT - procedure::get_momentum_boost=>qcd_2_2_get_momentum_boost - procedure::get_hyperbolic_fractions=>qcd_2_2_get_hyperbolic_fractions - procedure::get_remnant_momentum_fractions=>qcd_2_2_get_remnant_momentum_fractions - procedure::get_total_momentum_fractions=>qcd_2_2_get_total_momentum_fractions - - procedure::qcd_2_2_initialize - generic::initialize=>qcd_2_2_initialize - end type qcd_2_2_type - - type,extends(qcd_2_2_type)::qcd_2_2_generator_type - private - logical,public::modify_pdfs=default_modify_pdfs - logical::finished=.false. - logical::exceeded=.false. - real(kind=double)::init_time=0D0 - real(kind=double)::pt_time=0D0 - real(kind=double)::partons_time=0D0 - real(kind=double)::confirm_time=0D0 - real(kind=double)::mean=1D0 - real(kind=double),dimension(16)::start_integrals=[0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0] -! real(kind=double)::time=0D0 - type(tao_random_state)::tao_rnd - type(qcd_2_2_type)::start_values - type(lin_approx_tree_type)::dsigma - type(sample_inclusive_type)::samples - type(beam_remnant_type)::beam - ! these pointers shall not be allocated, deallocated, serialized or deserialized explicitly. - class(lin_approx_node_class),pointer::start_node=>null() - class(lin_approx_node_class),pointer::node=>null() - contains - !overridden serializable_class procedures - procedure::write_to_ring=>qcd_2_2_generator_write_to_ring - procedure::read_from_ring=>qcd_2_2_generator_read_from_ring - procedure::print_to_unit=>qcd_2_2_generator_print_to_unit - procedure,nopass::get_type=>qcd_2_2_generator_get_type - ! new type-bound-procedures - !conversion - procedure::stop_trainer=>qcd_2_2_generator_stop_trainer - !initializing - procedure::qcd_2_2_generator_initialize - procedure::reset_timer=>qcd_2_2_generator_reset_timer - procedure::restart=>qcd_2_2_generator_restart - !generating - procedure::generate_pt=>qcd_2_2_generator_generate_pt - procedure::generate_partons=>qcd_2_2_generator_generate_partons - procedure::confirm=>qcd_2_2_generator_confirm - !getting components - procedure::is_finished=>qcd_2_2_generator_is_finished - !printing - procedure::print_timer=>qcd_2_2_generator_print_timer - end type qcd_2_2_generator_type - -contains - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! type bound procedures for qcd_2_2_type !!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !overridden serializable_class procedures - - SUBROUTINE qcd_2_2_write_to_ring (this,ring,status) - CLASS(qcd_2_2_type), INTENT(IN) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - call xml_write_begin_tag(ring,"QCD_2_2_TYPE") - call xml_write(ring,"process_id",this%process_id) - call xml_write(ring,"integrand_id",this%integrand_id) - call xml_write(ring,"momentum_fractions",this%momentum_fractions) - call xml_write(ring,"hyperbolic_fractions",this%hyperbolic_fractions) - call xml_write_end_tag(ring,"QCD_2_2_TYPE") - end SUBROUTINE qcd_2_2_write_to_ring - - SUBROUTINE qcd_2_2_read_from_ring (this,ring,status) - CLASS(qcd_2_2_type), INTENT(out) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - call xml_verify_begin_tag(ring,"qcd_2_2_type",status) - call xml_read(ring,"process_id",this%process_id,status) - call xml_read(ring,"integrand_id",this%integrand_id,status) - call xml_read(ring,"momentum_fractions",this%momentum_fractions,status) - call xml_read(ring,"hyperbolic_fractions",this%hyperbolic_fractions,status) - call xml_verify_end_tag(ring,"qcd_2_2_type",status) - end SUBROUTINE qcd_2_2_read_from_ring - - pure function qcd_2_2_get_type() result(type) - character(:),allocatable::type!FC = nagfor - allocate(type,source="QCD_2_2_TYPE")!FC = nagfor - character(32)::type!FC = gfortran - type="QCD_2_2_TYPE"!FC = gfortran - end function qcd_2_2_get_type - - subroutine qcd_2_2_print_to_unit(this,unit,parents,components,peers) - class(qcd_2_2_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - write(unit,'("Components of qcd_2_2_type:")') - write(unit,'("Process id is: ",I3)')this%get_process_id() - write(unit,'("Integrand id is: ",I3)')this%get_integrand_id() - write(unit,'("LHA Flavors are: ",4(I3))')this%get_lha_flavors() - write(unit,'("PDG Flavors are: ",4(I3))')this%get_pdg_flavors() - write(unit,'("Parton kinds are: ",2(I3))')this%get_parton_kinds() - write(unit,'("PDF int kinds are: ",2(I3))')this%get_pdf_int_kinds() - write(unit,'("Diagram kind is: ",2(I3))')this%get_diagram_kind() - write(unit,'("Evolution scale is ",E14.7)')this%get_PTS2() - write(unit,'("Momentum boost is: ",E14.7)')this%get_momentum_boost() - write(unit,'("Remant momentum fractions are: ",2(E14.7))')this%get_remnant_momentum_fractions() - write(unit,'("Total momentum fractions are: ",2(E14.7))')this%get_total_momentum_fractions() - end subroutine qcd_2_2_print_to_unit - - elemental function qcd_2_2_get_process_id(this) result(id) - class(qcd_2_2_type),intent(in)::this - integer::id - id=this%process_id - end function qcd_2_2_get_process_id - - elemental function qcd_2_2_get_integrand_id(this) result(id) - class(qcd_2_2_type),intent(in)::this - integer::id - id=this%integrand_id - end function qcd_2_2_get_integrand_id - - pure function qcd_2_2_get_lha_flavors(this) result(lha) - class(qcd_2_2_type),intent(in)::this - integer,dimension(4)::lha - lha=valid_processes(1:4,this%process_id) - end function qcd_2_2_get_lha_flavors - - pure function qcd_2_2_get_pdg_flavors(this) result(pdg) - class(qcd_2_2_type),intent(in)::this - integer,dimension(4)::pdg - pdg=this%get_lha_flavors() - where(pdg==0) pdg=21 - end function qcd_2_2_get_pdg_flavors - - pure function qcd_2_2_get_pdf_int_kinds(this) result(kinds) - class(qcd_2_2_type),intent(in)::this - integer,dimension(2)::kinds - kinds=double_pdf_kinds(1:2,this%integrand_id) - end function qcd_2_2_get_pdf_int_kinds - - pure function qcd_2_2_get_parton_kinds(this) result(kinds) - class(qcd_2_2_type),intent(in)::this - integer,dimension(2)::kinds - kinds=this%get_pdf_int_kinds() - kinds(1)=parton_kind_of_int_kind(kinds(1)) - kinds(2)=parton_kind_of_int_kind(kinds(2)) - end function qcd_2_2_get_parton_kinds - - elemental function qcd_2_2_get_io_kind(this) result(kind) - class(qcd_2_2_type),intent(in)::this - integer::kind - kind=valid_processes(5,this%process_id) - end function qcd_2_2_get_io_kind - - elemental function qcd_2_2_get_diagram_kind(this) result(kind) - class(qcd_2_2_type),intent(in)::this - integer::kind - kind=valid_processes(6,this%process_id) - end function qcd_2_2_get_diagram_kind - - elemental function qcd_2_2_get_PTS2(this) result(pts2) - class(qcd_2_2_type),intent(in)::this - real(kind=double)::pts2 - pts2=this%hyperbolic_fractions(3) - end function qcd_2_2_get_PTS2 - - elemental function qcd_2_2_get_PTS(this) result(pts) - class(qcd_2_2_type),intent(in)::this - real(kind=double)::pts - pts=sqrt(this%hyperbolic_fractions(3)) - end function qcd_2_2_get_PTS - - elemental function qcd_2_2_get_GeV_PT(this) result(pt) - class(qcd_2_2_type),intent(in)::this - real(kind=double)::pt - pt=sqrt(this%hyperbolic_fractions(3))*GeV_PT_MAX - end function qcd_2_2_get_GeV_PT - - elemental function qcd_2_2_get_momentum_boost(this) result(boost) - class(qcd_2_2_type),intent(in)::this - real(kind=double)::boost -! print('("qcd_2_2_get_momentum_boost: not yet implemented.")') -! boost=this%momentum_boost - end function qcd_2_2_get_momentum_boost - - pure function qcd_2_2_get_hyperbolic_fractions(this) result(fractions) - class(qcd_2_2_type),intent(in)::this - real(kind=double),dimension(3)::fractions - fractions=this%hyperbolic_fractions - end function qcd_2_2_get_hyperbolic_fractions - - pure function qcd_2_2_get_remnant_momentum_fractions(this) result(fractions) - class(qcd_2_2_type),intent(in)::this - real(kind=double),dimension(2)::fractions - fractions=this%hyperbolic_fractions(1:2) - end function qcd_2_2_get_remnant_momentum_fractions - - pure function qcd_2_2_get_total_momentum_fractions(this) result(fractions) - class(qcd_2_2_type),intent(in)::this - real(kind=double),dimension(2)::fractions -! fractions=this%hyperbolic_fractions(1:2)*this%beam%get_proton_remnant_momentum_fractions() - end function qcd_2_2_get_total_momentum_fractions - - subroutine qcd_2_2_initialize(this,process_id,integrand_id) - class(qcd_2_2_type),intent(inout)::this - integer,intent(in)::process_id,integrand_id - this%process_id=process_id - this%integrand_id=integrand_id - end subroutine qcd_2_2_initialize - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! type bound procedures for qcd_2_2_generator_type !!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !overridden serializable_class procedures - - SUBROUTINE qcd_2_2_generator_write_to_ring(this,ring,status) - CLASS(qcd_2_2_generator_type), INTENT(IN) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - integer::n - call xml_write_begin_tag(ring,"QCD_2_2_GENERATOR_TYPE") - call qcd_2_2_write_to_ring(this,ring,status) - call xml_write(ring,"modify_pdfs",this%modify_pdfs) - call xml_write(ring,"finished",this%finished) - call xml_write(ring,"init_time",this%init_time) - call xml_write(ring,"pt_time",this%pt_time) - call xml_write(ring,"partons_time",this%partons_time) - call xml_write(ring,"confirm_time",this%confirm_time) - call this%start_values%serialize(ring,"start_values") - call this%dsigma%serialize(ring,"dsigma") - call this%samples%serialize(ring,"samples") - call this%beam%serialize(ring,"beam") - call xml_write_end_tag(ring,"QCD_2_2_GENERATOR_TYPE") - end SUBROUTINE qcd_2_2_generator_write_to_ring - - SUBROUTINE qcd_2_2_generator_read_from_ring(this,ring,status) - CLASS(qcd_2_2_generator_type), INTENT(out) :: this - class(page_ring_type),intent(inout)::ring - integer,intent(out)::status - - integer::n - class(serializable_class),pointer::ser - call xml_verify_begin_tag(ring,"QCD_2_2_GENERATOR_TYPE",status) - call xml_read(ring,"modify_pdfs",this%modify_pdfs,status) - call xml_read(ring,"finished",this%finished,status) - call xml_read(ring,"init_time",this%init_time,status) - call xml_read(ring,"pt_time",this%pt_time,status) - call xml_read(ring,"partons_time",this%partons_time,status) - call xml_read(ring,"confirm_time",this%confirm_time,status) - call this%start_values%deserialize(ring) - call this%dsigma%deserialize(ring) - call this%samples%deserialize(ring) - call this%beam%deserialize(ring) - call xml_verify_end_tag(ring,"QCD_2_2_GENERATOR_TYPE",status) - end SUBROUTINE qcd_2_2_generator_read_from_ring - - subroutine qcd_2_2_generator_print_to_unit(this,unit,parents,components,peers) - class(qcd_2_2_generator_type),intent(in)::this - integer,intent(in)::unit,parents,components,peers - integer::ite - if(parents>0)call qcd_2_2_print_to_unit(this,unit,parents-1,components,peers) - write(unit,'("Components of qcd_2_2_generator_type")') - - end subroutine qcd_2_2_generator_print_to_unit - - pure function qcd_2_2_generator_get_type() result(type) - character(:),allocatable::type!FC = nagfor - allocate(type,source="qcd_2_2_generator_type")!FC = nagfor - character(32)::type!FC = gfortran - type="qcd_2_2_generator_type"!FC = gfortran - end function qcd_2_2_generator_get_type - - subroutine qcd_2_2_generator_stop_trainer(this) - class(qcd_2_2_generator_type),intent(inout)::this - end subroutine qcd_2_2_generator_stop_trainer - - subroutine qcd_2_2_generator_initialize(this,dsigma_ring,samples_ring,tao_seed) - class(qcd_2_2_generator_type),intent(out)::this - class(page_ring_type),optional,intent(inout)::dsigma_ring,samples_ring - integer,intent(in),optional::tao_seed - real(kind=double)::time - call cpu_time(time) - this%init_time=-time - if(present(dsigma_ring))then - call this%dsigma%deserialize(dsigma_ring) - end if - if(present(samples_ring))then - call this%samples%deserialize(samples_ring) - else - call this%samples%initialize(4,int_sizes_all,int_all,1D-2) - end if - if(present(tao_seed))then - call tao_random_create(this%tao_rnd,tao_seed) - else - call tao_random_create(this%tao_rnd,1) - end if - call this%restart() - call cpu_time(time) - this%init_time=this%init_time+time - end subroutine qcd_2_2_generator_initialize - - subroutine qcd_2_2_generator_reset_timer(this) - class(qcd_2_2_generator_type),intent(inout)::this - this%init_time=0D0 - this%pt_time=0D0 - this%partons_time=0D0 - this%confirm_time=0D0 - end subroutine qcd_2_2_generator_reset_timer - - subroutine qcd_2_2_generator_restart(this) - class(qcd_2_2_generator_type),intent(inout)::this - call this%dsigma%get_rightmost(this%start_node) - call this%beam%reset() - nullify(this%node) - this%finished=.false. - this%process_id=-1 - this%integrand_id=-1 - this%momentum_fractions=[-1D0,-1D0,-1D0] - this%hyperbolic_fractions=[-1D0,-1D0,-1D0] - this%start_values%process_id=-1 - this%start_values%integrand_id=-1 - this%start_values%momentum_fractions=[-1D0,-1D0,1D0] - this%start_values%hyperbolic_fractions=[-1D0,-1D0,1D0] - end subroutine qcd_2_2_generator_restart - - subroutine qcd_2_2_generator_generate_pt(this) - class(qcd_2_2_generator_type),intent(inout)::this - real(kind=double)::tmp_pts,rnd - integer::tmp_int_kind - class(lin_approx_node_class),pointer::tmp_node - ! call start_node%print_all - ! print *,start_pts - associate(pts=>this%hyperbolic_fractions(3)) - pts=-1D0 - do tmp_int_kind=1,16 - call tao_random_number(this%tao_rnd,rnd) - call generate_single_pts(& - tmp_int_kind,& - this%start_integrals(tmp_int_kind),& - this%beam%get_pdf_int_weights(double_pdf_kinds(1:2,tmp_int_kind)),& - rnd,& - this%dsigma,& - tmp_pts,& - tmp_node) - if(tmp_pts>pts)then - pts=tmp_pts - this%integrand_id=tmp_int_kind - this%node=>tmp_node - end if - end do - if(pts>0)then - pts=pts**2 - else - this%finished=.true. - end if - end associate - contains - subroutine generate_single_pts(int_kind,start_int,weight,rnd,int_tree,pts,node) - integer,intent(in)::int_kind - real(kind=double),intent(in)::start_int,weight,rnd - ! class(lin_approx_node_class),intent(in)::start_node - type(lin_approx_tree_type),intent(in)::int_tree - real(kind=double),intent(out)::pts - class(lin_approx_node_class),pointer,intent(out)::node - real(kind=double)::arg - arg=start_int-log(rnd)/weight - call int_tree%find_decreasing(arg,int_kind,r_integral_index,node) - if(node%get_l_integral(int_kind)>arg)then - pts=node%approx_position_by_integral(int_kind,arg) - else - pts=-1D0 - end if - end subroutine generate_single_pts - end subroutine qcd_2_2_generator_generate_pt - - subroutine qcd_2_2_generator_generate_partons(this) - class(qcd_2_2_generator_type),intent(inout)::this -! real(kind=double)::hallo -! hallo=this%hyperbolic_fractions(3) - print *,& -! hallo,& - this%hyperbolic_fractions(3),& - this%mean,& - this%integrand_id,& - this%process_id,& - this%hyperbolic_fractions - call sample_inclusive_mcgenerate_hit(& - this%samples,& - this%hyperbolic_fractions(3),& -! hallo,& - this%mean,& - this%integrand_id,& - this%tao_rnd,& - this%process_id,& - this%hyperbolic_fractions) - end subroutine qcd_2_2_generator_generate_partons - - subroutine qcd_2_2_generator_confirm(this) - class(qcd_2_2_generator_type),intent(inout) :: this - this%start_node=>this%node - this%start_values%process_id=this%process_id - this%start_values%integrand_id=this%integrand_id - this%start_values%momentum_fractions=this%momentum_fractions - this%start_values%hyperbolic_fractions=this%hyperbolic_fractions - this%mean=this%node%approx_value_n(this%get_pts(),this%integrand_id) - print *,associated(this%start_node) - this%start_integrals=this%start_node%approx_integral(this%get_pts()) - end subroutine qcd_2_2_generator_confirm - - elemental function qcd_2_2_generator_is_finished(this) result(res) - logical::res - class(qcd_2_2_generator_type),intent(in) :: this - res=this%finished - end function qcd_2_2_generator_is_finished - - subroutine qcd_2_2_generator_print_timer(this) - class(qcd_2_2_generator_type),intent(in) :: this - print('("Init time: ",E20.10)'),this%init_time - print('("PT gen time: ",E20.10)'),this%pt_time - print('("Partons time: ",E20.10)'),this%partons_time - print('("Confirm time: ",E20.10)'),this%confirm_time - print('("Overall time: ",E20.10)'),this%init_time+this%pt_time+this%partons_time+this%confirm_time - end subroutine qcd_2_2_generator_print_timer - -end MODULE qcdtypes_module - Index: branches/attic/boschmann_standalone/pri/lib/cuba_types.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/lib/cuba_types.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/lib/cuba_types.f03.pri (revision 8609) @@ -1,1043 +0,0 @@ -!!! module: cuba_types_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-20 11:26:03 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module cuba_types_module - use kinds - use momentum_module - use basic_types_module - implicit none - -!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! Parameter Definition !!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - integer, parameter :: max_maxeval = 214748364 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! Derived Type Definitions !!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type,extends(serializable_class), abstract :: cuba_class - ! private - real(kind=double) :: start_time=0D0 - real(kind=double) :: stop_time=0D0 - real(kind=double) :: run_time=0D0 - ! common input - integer :: dim_x = 2 - integer :: dim_f = 1 - type(transversal_momentum_type) :: userdata - real(kind=double) :: eps_rel = 1D-3 - real(kind=double) :: eps_abs = 0D0 - integer :: flags = 0 - integer :: seed = 1 - integer :: min_eval = 0 - integer :: max_eval = max_maxeval - ! common output - integer :: neval = 0 - integer,public :: fail = -1 - integer :: nregions = 0 - real(kind=double), dimension(:), allocatable :: integral - real(kind=double), dimension(:), allocatable :: error - real(kind=double), dimension(:), allocatable :: prob - ! - procedure(integrand_interface),nopass,pointer::integrand - contains - ! overridden serializable procedures - procedure::write_to_ring=>cuba_write_to_ring - procedure::read_from_ring=>cuba_read_from_ring - procedure::print_to_unit=>cuba_print_to_unit - ! new procedures - procedure :: get_integral_array => cuba_get_integral_array - procedure :: get_integral_1 => cuba_get_integral_1 - generic :: get_integral=>get_integral_array,get_integral_1!FC = nagfor - procedure :: copy_common => cuba_copy_common - - procedure :: set_common => cuba_set_common - procedure :: set_dim_f => cuba_set_dim_f - procedure :: set_dim_x => cuba_set_dim_x - procedure :: reset_timer=>cuba_reset_timer - - procedure :: integrate_with_timer => cuba_integrate_with_timer - procedure :: integrate_associated => cuba_integrate_associated - procedure(integrate_interface), deferred :: integrate_nd - procedure(integrate_ud_interface), deferred :: integrate_ud - procedure(cuba_copy_interface), deferred :: copy - - procedure :: dealloc_dim_f => cuba_dealloc_dim_f - procedure :: alloc_dim_f => cuba_alloc_dim_f - procedure :: dealloc => cuba_dealloc - procedure :: alloc => cuba_alloc - generic :: integrate=>integrate_nd,integrate_ud - end type cuba_class - - type, extends(cuba_class) :: cuba_cuhre_type - private - integer :: key = 13 - contains - ! overridden serializable procedures - procedure::write_to_ring=>cuba_cuhre_write_to_ring - procedure::read_from_ring=>cuba_cuhre_read_from_ring - procedure::print_to_unit=>cuba_cuhre_print_to_unit - procedure,nopass::get_type=>cuba_cuhre_get_type - ! overridden cuba procedures - procedure :: integrate_nd => integrate_cuhre - procedure :: integrate_ud => integrate_cuhre_ud - procedure :: copy=>cuba_cuhre_copy - procedure :: set_deferred => cuba_cuhre_set_deferred - end type cuba_cuhre_type - - type, extends(cuba_class) :: cuba_suave_type - private - integer :: nnew = 10000 !1000 - integer :: flatness = 5 !50 - contains - ! overridden serializable procedures - procedure::write_to_ring=>cuba_suave_write_to_ring - procedure::read_from_ring=>cuba_suave_read_from_ring - procedure::print_to_unit=>cuba_suave_print_to_unit - procedure,nopass::get_type=>cuba_suave_get_type - ! overridden cuba procedures - procedure :: integrate_nd => integrate_suave - procedure :: integrate_ud => integrate_suave_ud - procedure :: copy=>cuba_suave_copy - end type cuba_suave_type - - type, extends(cuba_class) :: cuba_divonne_type - private - integer :: key1 = 13 - integer :: key2 = 13 - integer :: key3 = 13 - integer :: maxpass = 2 - real(kind=double) :: border = 0D0 - real(kind=double) :: maxchisq = 10D0 - real(kind=double) :: mindeviation = .25D0 - integer :: ngiven = 0 - integer :: ldxgiven = 0 - ! real(kind=double), dimension(ldxgiven,ngiven) :: & - ! & xgiven = reshape( source = (/0.0,0.0/), shape = (/2,1/)) - real(kind=double),dimension(:,:),allocatable :: xgiven - ! real(kind=double),dimension(2) :: xgiven = [1d-1,5d-1] - integer :: nextra = 0 - contains - ! overridden serializable procedures - procedure::write_to_ring=>cuba_divonne_write_to_ring - procedure::read_from_ring=>cuba_divonne_read_from_ring - procedure::print_to_unit=>cuba_divonne_print_to_unit - procedure,nopass::get_type=>cuba_divonne_get_type - ! overridden cuba procedures - procedure :: integrate_nd => integrate_divonne - procedure :: integrate_ud => integrate_divonne_ud - procedure :: copy=>cuba_divonne_copy - procedure :: set_deferred => cuba_divonne_set_deferred - end type cuba_divonne_type - - type, extends(cuba_class) :: cuba_vegas_type - private - integer :: nstart = 500 - integer :: nincrease = 1000 - integer :: nbatch = 1000 - integer :: gridno = 0 - character(len=8),pointer :: statefile => null() - contains - ! overridden serializable procedures - procedure::write_to_ring=>cuba_vegas_write_to_ring - procedure::read_from_ring=>cuba_vegas_read_from_ring - procedure::print_to_unit=>cuba_vegas_print_to_unit - procedure,nopass::get_type=>cuba_vegas_get_type - ! overridden cuba procedures - procedure :: integrate_nd => integrate_vegas - procedure :: integrate_ud => integrate_vegas_ud - procedure :: copy=>cuba_vegas_copy - procedure :: set_deferred => cuba_vegas_set_deferred - end type cuba_vegas_type - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! Interface Definitions !!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - interface - subroutine integrand_interface(dim_x, x, dim_f, f,ud) - use kinds - use momentum_module - integer, intent(in) :: dim_x, dim_f - real(kind=double), dimension(dim_x), intent(in) :: x - real(kind=double), dimension(dim_f), intent(out) :: f - type(transversal_momentum_type), intent(in) :: ud - end subroutine integrand_interface - end interface - interface - subroutine cuba_copy_interface(this,source) - import :: cuba_class - class(cuba_class),intent(out)::this - class(cuba_class),intent(in)::source - end subroutine cuba_copy_interface - subroutine ca_plain(this) - import :: cuba_class - class(cuba_class) :: this - end subroutine ca_plain - subroutine integrate_interface(this, integrand) - import :: cuba_class - class(cuba_class) :: this - interface - subroutine integrand(dim_x, x, dim_f, f,ud) - use kinds - use momentum_module - integer, intent(in) :: dim_x, dim_f - real(kind=double), dimension(dim_x), intent(in) :: x - real(kind=double), dimension(dim_f), intent(out) :: f - type(transversal_momentum_type), intent(in) :: ud - end subroutine integrand - end interface - end subroutine integrate_interface - end interface - interface - subroutine integrate_ud_interface(this, integrand,ud) - use momentum_module - import :: cuba_class - class(cuba_class) :: this - interface - subroutine integrand(dim_x, x, dim_f, f,ud) - use kinds - use momentum_module - integer, intent(in) :: dim_x, dim_f - real(kind=double), dimension(dim_x), intent(in) :: x - real(kind=double), dimension(dim_f), intent(out) :: f - type(transversal_momentum_type), intent(in) :: ud - end subroutine integrand - end interface - type(transversal_momentum_type),intent(in)::ud - end subroutine integrate_ud_interface - end interface - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! Module Procedure Definition !!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -contains - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! Type Bound Procedures for cuba_class !!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - SUBROUTINE cuba_write_to_ring(this,ring,status) - CLASS(cuba_class),INTENT(IN) :: this - class(page_ring_type), intent(inout) :: ring - integer,intent(out)::status - call xml_write_begin_tag(ring,"CUBA_CLASS") - call xml_write(ring,"dim_x",this%dim_x) - call xml_write(ring,"dim_f",this%dim_f) - call xml_write(ring,"eps_rel",this%eps_rel) - call xml_write(ring,"eps_abs",this%eps_abs) - call xml_write(ring,"flags",this%flags) - call xml_write(ring,"min_eval",this%min_eval) - call xml_write(ring,"max_eva",this%max_eval) - call xml_write(ring,"neval",this%neval) - call xml_write(ring,"fail",this%fail) - call xml_write(ring,"nregions",this%nregions) - if(allocated(this%integral))then - call xml_write(ring,"integral",this%integral) - else - call xml_write_null_component(ring,"integral") - end if - if(allocated(this%error))then - call xml_write(ring,"error",this%error) - else - call xml_write_null_component(ring,"error") - end if - if(allocated(this%prob))then - call xml_write(ring,"prob",this%prob) - else - call xml_write_null_component(ring,"prob") - end if - call xml_write_end_tag(ring,"CUBA_CLASS") - END SUBROUTINE cuba_write_to_ring - - SUBROUTINE cuba_read_from_ring(this,ring,status) - CLASS(cuba_class),INTENT(OUT) :: this - class(page_ring_type), intent(inout) :: ring - integer,intent(out)::status - call xml_verify_begin_tag(ring,"CUBA_CLASS",status) - call xml_read(ring,this%dim_x) - call xml_read(ring,this%dim_f) - call xml_read(ring,this%eps_rel) - call xml_read(ring,this%eps_abs) - call xml_read(ring,this%flags) - call xml_read(ring,this%min_eval) - call xml_read(ring,this%max_eval) - call xml_read(ring,this%neval) - call xml_read(ring,this%fail) - call xml_read(ring,this%nregions) - call xml_verify_null_component(ring,"integral",status) - if(allocated(this%integral))deallocate(this%integral) - if(status==serialize_ok)then - allocate(this%integral(this%dim_f)) - call xml_read(ring,this%integral) - end if - call xml_verify_null_component(ring,"error",status) - if(allocated(this%error))deallocate(this%error) - if(status==serialize_ok)then - allocate(this%error(this%dim_f)) - call xml_read(ring,this%error) - end if - call xml_verify_null_component(ring,"prop",status) - if(allocated(this%prob))deallocate(this%prob) - if(status==serialize_ok)then - allocate(this%prob(this%dim_f)) - call xml_read(ring,this%prob) - end if - call xml_verify_end_tag(ring,"CUBA_CLASS",status) - END SUBROUTINE cuba_read_from_ring - - subroutine cuba_print_to_unit(this,unit,parents,components,peers) - class(cuba_class) :: this - INTEGER, INTENT(IN) :: unit,parents,components,peers - character(11)::n - write(n,'("(",I2,"(E12.4))")')this%dim_f - write(unit,'("Components of cuba_class:")') - write(unit,'("Parameters:")') - write(unit,'("dim_f: ",I10)') this%dim_f - write(unit,'("dim_x: ",I10)') this%dim_x - call this%userdata%print() - write(unit,'("eps_rel: ",E10.4)') this%eps_rel - write(unit,'("eps_abs: ",E10.4)') this%eps_abs - write(unit,'("flags: ",I10)') this%flags - write(unit,'("seed: ",I10)') this%seed - write(unit,'("min_eval: ",I10)') this%min_eval - write(unit,'("max_eval: ",I10)') this%max_eval - write(unit,'("Results:")') - write(unit,'("neval: ",I10)') this%neval - write(unit,'("fail: ",I10)') this%fail - write(unit,'("integral: ")',advance="no") - write(unit,fmt=n)this%integral - write(unit,'("error: ")',advance="no") - write(unit,fmt=n)this%error - write(unit,'("prob: ")',advance="no") - write(unit,fmt=n)this%prob - write(unit,'("time: ",E10.4)') this%stop_time-this%start_time - ! write(unit,'("time: ",E10.4)') this%run_time - end subroutine cuba_print_to_unit - -! new procedures - - subroutine cuba_integrate_associated(this) - class(cuba_class),intent(inout)::this - call cuba_integrate_with_timer(this,this%integrand) - end subroutine cuba_integrate_associated - - subroutine cuba_integrate_with_timer(this,integrand) - class(cuba_class),intent(inout)::this - procedure(integrand_interface)::integrand - call cpu_time(this%start_time) - call this%integrate(integrand) - call cpu_time(this%stop_time) - this%run_time=this%run_time+this%stop_time-this%start_time - end subroutine cuba_integrate_with_timer - - subroutine cuba_reset_timer(this) - class(cuba_class),intent(inout)::this - this%start_time=0D0 - this%stop_time=0D0 - this%run_time=0D0 - end subroutine cuba_reset_timer - - subroutine cuba_get_integral_array(this,integral) - class(cuba_class) :: this - real(kind=double),intent(out),dimension(:) :: integral - integral=this%integral - end subroutine cuba_get_integral_array - - subroutine cuba_get_integral_1(this,integral) - class(cuba_class) :: this - real(kind=double),intent(out) :: integral - integral=this%integral(1) - end subroutine cuba_get_integral_1 - - subroutine cuba_dealloc_dim_f(this) - class(cuba_class) :: this - ! print '("cuba_dealloc_dim_f...")' - if (allocated(this%integral)) then - deallocate(this%integral) - end if - if (allocated(this%error)) then - deallocate(this%error) - end if - if (allocated(this%prob)) then - deallocate(this%prob) - end if - ! print '("done")' - end subroutine cuba_dealloc_dim_f - - subroutine cuba_dealloc(this) - class(cuba_class) :: this - call this%dealloc_dim_f - end subroutine cuba_dealloc - - subroutine cuba_alloc_dim_f(this) - class(cuba_class) :: this - call this%dealloc_dim_f() - allocate(this%integral(this%dim_f)) - allocate(this%error(this%dim_f)) - allocate(this%prob(this%dim_f)) - end subroutine cuba_alloc_dim_f - - subroutine cuba_alloc(this) - class(cuba_class) :: this - call this%alloc_dim_f - end subroutine cuba_alloc - - subroutine cuba_set_common(this,dim_x,dim_f,eps_rel,eps_abs,flags,seed,min_eval,max_eval,integrand,userdata) - class(cuba_class),intent(inout) :: this - integer,intent(in),optional :: dim_x,dim_f,flags,min_eval,max_eval,seed - real(kind=double),intent(in),optional :: eps_rel,eps_abs - type(transversal_momentum_type),intent(in),optional :: userdata - procedure(integrand_interface),optional::integrand - if(present(dim_x))then - call this%set_dim_x(dim_x) - end if - if(present(dim_f))then - call this%set_dim_f(dim_f) - end if - if(present(flags))then - this%flags=flags - end if - if(present(seed))then - this%seed=seed - end if - if(present(min_eval))then - this%min_eval=min_eval - end if - if(present(max_eval))then - if(max_evalintegrand - if(present(userdata))this%userdata=userdata - end subroutine cuba_set_common - - subroutine cuba_set_dim_f(this,new_dim_f) - class(cuba_class) :: this - integer,intent(in) :: new_dim_f - ! print '("cuba_set_dim_f")' - if (new_dim_f>0) then - this%dim_f = new_dim_f - call this%alloc_dim_f - ! print '("cuba_set_dim_f")' - else - ! this%scaled = .false. - !V - 1 1 !V write (!V,'("cuba_set_ndim: New value for ndim is negative. ndim is not set.")') - end if - end subroutine cuba_set_dim_f - - subroutine cuba_set_dim_x(this,new_dim_x) - class(cuba_class) :: this - integer,intent(in) :: new_dim_x - if (new_dim_x>0) then - this%dim_x = new_dim_x - else - write (*,'("cuba_set_dim_x: New value for dim_x is negative. dim_x is not set.")') - end if - end subroutine cuba_set_dim_x -!!$ subroutine cuba_get_scaled_int_vec(this,scaled_int) -!!$ class(cuba_class) :: this -!!$ real(kind=double),dimension(:),intent(out) :: scaled_int -!!$ scaled_int = this%integral*this%scale_scalar -!!$ end subroutine cuba_get_scaled_int_vec -!!$ -!!$ subroutine cuba_get_scaled_int_comp(this,dim,scaled_int) -!!$ class(cuba_class) :: this -!!$ integer,intent(in) :: dim -!!$ real(kind=double),intent(out) :: scaled_int -!!$ scaled_int = this%integral(dim)*this%scale_scalar -!!$ end subroutine cuba_get_scaled_int_comp - - subroutine cuba_copy_common(this,source) - class(cuba_class),intent(out) :: this - class(cuba_class),intent(in) :: source - this%dim_x = source%dim_x - this%dim_f = source%dim_f - this%eps_rel = source%eps_rel - this%eps_abs = source%eps_abs - this%flags = source%flags - this%min_eval = source%min_eval - this%max_eval = source%max_eval - call this%alloc() - end subroutine cuba_copy_common - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! type bound procedures for vegas_type !!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - SUBROUTINE cuba_vegas_write_to_ring(this,ring,status) - CLASS(cuba_vegas_type),INTENT(IN) :: this - class(page_ring_type), intent(inout) :: ring - integer,intent(out)::status - call xml_write_begin_tag(ring,"CUBA_VEGAS_TYPE") - call cuba_write_to_ring(this,ring,status) - call xml_write(ring,"nstart",this%nstart) - call xml_write(ring,"nincrease",this%nincrease) - call xml_write_end_tag(ring,"CUBA_VEGAS_TYPE") - END SUBROUTINE cuba_vegas_write_to_ring - - SUBROUTINE cuba_vegas_read_from_ring(this,ring,status) - CLASS(cuba_vegas_type),INTENT(OUT) :: this - class(page_ring_type), intent(inout) :: ring - integer,intent(out)::status - call xml_verify_begin_tag(ring,"CUBA_VEGAS_TYPE",status) - call cuba_read_from_ring(this,ring,status) - call xml_read(ring,this%nstart) - call xml_read(ring,this%nincrease) - call xml_verify_end_tag(ring,"CUBA_VEGAS_TYPE",status) - END SUBROUTINE cuba_vegas_read_from_ring - - subroutine cuba_vegas_print_to_unit(this,unit,parents,components,peers) - class(cuba_vegas_type) :: this - INTEGER, INTENT(IN) :: unit,parents,components,peers - if(parents>0)call cuba_print_to_unit(this,unit,parents-1,components,peers) - write(unit,'("Components of cuba_vegas_type:")') - write(unit,'("nstart: ",I10)') this%nstart - write(unit,'("nincrease: ",I10)') this%nincrease - write(unit,'("nbatch: ",I10)') this%nbatch - write(unit,'("gridno: ",I10)') this%gridno - if(associated(this%statefile))then - write(unit,'("statefile:",a)') this%statefile - else - write(unit,'("statefile:",a)') "not associated" - end if - end subroutine cuba_vegas_print_to_unit - - pure function cuba_vegas_get_type() result(t) - character(:),allocatable::t!FC = nagfor - allocate(t,source="CUBA_VEGAS_TYPE")!FC = nagfor - character(32)::t!FC = gfortran - t="CUBA_VEGAS_TYPE"!FC = gfortran - end function cuba_vegas_get_type - - subroutine cuba_vegas_set_deferred(this,n_start,n_increase,nbatch,gridno,statefile) - class(cuba_vegas_type),intent(inout) :: this - integer,intent(in),optional :: n_start,n_increase,nbatch,gridno - character(len=*),intent(in),target,optional::statefile - if(present(n_start))this%nstart=n_start - if(present(n_increase))this%nincrease=n_increase - if(present(nbatch))this%nbatch=nbatch - if(present(gridno))this%gridno=gridno - if(present(statefile))this%statefile=>statefile - end subroutine cuba_vegas_set_deferred - - subroutine cuba_vegas_copy(this,source) - class(cuba_vegas_type),intent(out) :: this - class(cuba_class),intent(in) :: source - select type(source) - class is (cuba_vegas_type) - call this%copy_common(source) - this%nstart=source%nstart - this%nincrease=source%nincrease - class default - print *,"cuba_vegas_copy: type of source is not type compatible with cuba_vegas_type." - end select - end subroutine cuba_vegas_copy - - subroutine integrate_vegas(this,integrand) - class(cuba_vegas_type) :: this - procedure(integrand_interface)::integrand - ! print '("vegas")' - call vegas(& - this%dim_x, & - this%dim_f, & - integrand, & - this%userdata, & - this%eps_rel, & - this%eps_abs, & - this%flags, & - this%seed, & - this%min_eval, & - this%max_eval, & - this%nstart, & - this%nincrease, & - this%nbatch, & - this%gridno, & - this%statefile, & - this%neval, & - this%fail, & - this%integral, & - this%error, & - this%prob) - end subroutine integrate_vegas - - subroutine integrate_vegas_ud(this,integrand,ud) - class(cuba_vegas_type) :: this - procedure(integrand_interface)::integrand - type(transversal_momentum_type),intent(in)::ud - ! print '("vegas")' - call vegas(& - this%dim_x, & - this%dim_f, & - integrand, & - ud, & - this%eps_rel, & - this%eps_abs, & - this%flags, & - this%seed, & - this%min_eval, & - this%max_eval, & - this%nstart, & - this%nincrease, & - this%nbatch, & - this%gridno, & - this%statefile, & - this%neval, & - this%fail, & - this%integral, & - this%error, & - this%prob) - end subroutine integrate_vegas_ud - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! type bound procedures for cuba_suave_type !!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - SUBROUTINE cuba_suave_write_to_ring(this,ring,status) - CLASS(cuba_suave_type),INTENT(IN) :: this - class(page_ring_type), intent(inout) :: ring - integer,intent(out)::status - call xml_write_begin_tag(ring,"CUBA_SUAVE_TYPE") - call cuba_write_to_ring(this,ring,status) - call xml_write(ring,"nnew",this%nnew) - call xml_write(ring,"flatness",this%flatness) - call xml_write_end_tag(ring,"CUBA_SUAVE_TYPE") - END SUBROUTINE cuba_suave_write_to_ring - - SUBROUTINE cuba_suave_read_from_ring(this,ring,status) - CLASS(cuba_suave_type),INTENT(OUT) :: this - class(page_ring_type), intent(inout) :: ring - integer,intent(out)::status - call xml_verify_begin_tag(ring,"CUBA_SUAVE_TYPE",status) - call cuba_read_from_ring(this,ring,status) - call xml_read(ring,this%nnew) - call xml_read(ring,this%flatness) - call xml_verify_end_tag(ring,"CUBA_SUAVE_TYPE",status) - END SUBROUTINE cuba_suave_read_from_ring - - subroutine cuba_suave_print_to_unit(this,unit,parents,components,peers) - class(cuba_suave_type) :: this - INTEGER, INTENT(IN) :: unit,parents,components,peers - if(parents>0)call cuba_print_to_unit(this,unit,parents-1,components,peers) - write(unit,'("Components of cuba_suave_type:")') - write(unit,'("nnew: ",I10)') this%nnew - write(unit,'("flatness: ",I10)') this%flatness - end subroutine cuba_suave_print_to_unit - - pure function cuba_suave_get_type() result(t) - character(:),allocatable::t!FC = nagfor - allocate(t,source="CUBA_SUAVE_TYPE")!FC = nagfor - character(32)::t!FC = gfortran - t="CUBA_SUAVE_TYPE"!FC = gfortran - end function cuba_suave_get_type - - subroutine integrate_suave(this,integrand) - class(cuba_suave_type) :: this - procedure(integrand_interface)::integrand - ! print '("suave")' - call suave(& - this%dim_x, & - this%dim_f, & - integrand, & - this%userdata, & - this%eps_rel, & - this%eps_abs, & - this%flags, & - this%seed, & - this%min_eval, & - this%max_eval, & - this%nnew, & - this%flatness, & - this%nregions, & - this%neval, & - this%fail, & - this%integral, & - this%error, & - this%prob) - end subroutine integrate_suave - - subroutine integrate_suave_ud(this,integrand,ud) - class(cuba_suave_type) :: this - procedure(integrand_interface)::integrand - type(transversal_momentum_type),intent(in)::ud - ! print '("suave")' - call suave(& - this%dim_x, & - this%dim_f, & - integrand, & - ud, & - this%eps_rel, & - this%eps_abs, & - this%flags, & - this%seed, & - this%min_eval, & - this%max_eval, & - this%nnew, & - this%flatness, & - this%nregions, & - this%neval, & - this%fail, & - this%integral, & - this%error, & - this%prob) - end subroutine integrate_suave_ud - - subroutine cuba_suave_copy(this,source) - class(cuba_suave_type),intent(out) :: this - class(cuba_class),intent(in) :: source - select type(source) - class is (cuba_suave_type) - call this%copy_common(source) - this%nnew = source%nnew - this%flatness = source%flatness - class default - print *,"cuba_suave_copy: type of source is not type compatible with cuba_suave_type." - end select - end subroutine cuba_suave_copy - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! type bound procedures for cuba_divonne_type !!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - SUBROUTINE cuba_divonne_write_to_ring(this,ring,status) - CLASS(cuba_divonne_type),INTENT(IN) :: this - class(page_ring_type), intent(inout) :: ring - integer,intent(out)::status - call xml_write_begin_tag(ring,"CUBA_DIVONNE_TYPE") - call cuba_write_to_ring(this,ring,status) - call xml_write(ring,"key1",this%key1) - call xml_write(ring,"key2",this%key2) - call xml_write(ring,"key3",this%key3) - call xml_write(ring,"maxpass",this%maxpass) - call xml_write(ring,"border",this%border) - call xml_write(ring,"maxchisq",this%maxchisq) - call xml_write(ring,"mindeviation",this%mindeviation) - call xml_write(ring,"ngiven",this%ngiven) - call xml_write(ring,"ldxgiven",this%ldxgiven) - call xml_write(ring,"nextra",this%nextra) - call xml_write(ring,"XGIVEN",this%xgiven) - call xml_write_end_tag(ring,"CUBA_DIVONNE_TYPE") - END SUBROUTINE cuba_divonne_write_to_ring - - SUBROUTINE cuba_divonne_read_from_ring(this,ring,status) - CLASS(cuba_divonne_type),INTENT(OUT) :: this - class(page_ring_type), intent(inout) :: ring - integer,intent(out)::status - call xml_verify_begin_tag(ring,"CUBA_DIVONNE_TYPE",status) - call cuba_read_from_ring(this,ring,status) - call xml_read(ring,this%key1) - call xml_read(ring,this%key2) - call xml_read(ring,this%key3) - call xml_read(ring,this%maxpass) - call xml_read(ring,this%border) - call xml_read(ring,this%maxchisq) - call xml_read(ring,this%mindeviation) - call xml_read(ring,this%ngiven) - call xml_read(ring,this%ldxgiven) - call xml_read(ring,this%nextra) - if(allocated(this%xgiven))deallocate(this%xgiven) - allocate(this%xgiven(this%ldxgiven,this%ngiven)) - call xml_read(ring,"xgiven",this%xgiven,status) - call xml_verify_end_tag(ring,"CUBA_DIVONNE_TYPE",status) - END SUBROUTINE cuba_divonne_read_from_ring - - subroutine cuba_divonne_print_to_unit(this,unit,parents,components,peers) - class(cuba_divonne_type) :: this - INTEGER, INTENT(IN) :: unit,parents,components,peers - if(parents>0)call cuba_print_to_unit(this,unit,parents-1,components,peers) - write(unit,'("Components of cuba_divonne_type:")') - write(unit,'("key1: ",I10)') this%key1 - write(unit,'("key2: ",I10)') this%key2 - write(unit,'("key3: ",I10)') this%key3 - write(unit,'("maxpass: ",I10)') this%maxpass - write(unit,'("ngiven: ",I10)') this%ngiven - write(unit,'("ldxgiven: ",I10)') this%ldxgiven - write(unit,'("nextra: ",I10)') this%nextra - write(unit,'("border: ",E10.4)') this%border - write(unit,'("maxchisq: ",E10.4)') this%maxchisq - write(unit,'("mindeviation:",E10.4)') this%mindeviation - write(unit,'("xgiven: ",2(E10.4))') this%xgiven - end subroutine cuba_divonne_print_to_unit - - pure function cuba_divonne_get_type() result(t) - character(:),allocatable::t!FC = nagfor - allocate(t,source="CUBA_DIVONNE_TYPE")!FC = nagfor - character(32)::t!FC = gfortran - t="CUBA_DIVONNE_TYPE"!FC = gfortran - end function cuba_divonne_get_type - - subroutine integrate_divonne(this,integrand) - class(cuba_divonne_type) :: this - procedure(integrand_interface)::integrand - ! call this%reset_output() - ! print '("divonne")' - call divonne(& - & this%dim_x, & - & this%dim_f, & - & integrand, & - & this%userdata,& - & this%eps_rel, & - & this%eps_abs, & - & this%flags, & - & this%seed, & - & this%min_eval, & - & this%max_eval, & - & this%key1, & - & this%key2, & - & this%key3, & - & this%maxpass, & - & this%border, & - & this%maxchisq, & - & this%mindeviation, & - & this%ngiven, & - & this%ldxgiven, & - & this%xgiven, & - & this%nextra, & - ! & this%peakfinder, & - & 0,& - & this%nregions, & - & this%neval, & - & this%fail, & - & this%integral, & - & this%error, & - & this%prob) - end subroutine integrate_divonne - -subroutine integrate_divonne_ud(this,integrand,ud) - class(cuba_divonne_type) :: this - procedure(integrand_interface)::integrand - type(transversal_momentum_type),intent(in)::ud - ! call this%reset_output() - ! print '("divonne")' - call divonne(& - & this%dim_x, & - & this%dim_f, & - & integrand, & - & ud,& - & this%eps_rel, & - & this%eps_abs, & - & this%flags, & - & this%seed, & - & this%min_eval, & - & this%max_eval, & - & this%key1, & - & this%key2, & - & this%key3, & - & this%maxpass, & - & this%border, & - & this%maxchisq, & - & this%mindeviation, & - & this%ngiven, & - & this%ldxgiven, & - & this%xgiven, & - & this%nextra, & - ! & this%peakfinder, & - & 0,& - & this%nregions, & - & this%neval, & - & this%fail, & - & this%integral, & - & this%error, & - & this%prob) - end subroutine integrate_divonne_ud - - subroutine cuba_divonne_copy(this,source) - class(cuba_divonne_type),intent(out) :: this - class(cuba_class),intent(in) :: source - select type(source) - class is (cuba_divonne_type) - call this%copy_common(source) - call this%set_deferred(& - &source%key1,& - &source%key2,& - &source%key3,& - &source%maxpass,& - &source%border,& - &source%maxchisq,& - &source%mindeviation,& - &source%xgiven& - &) - class default - print *,"cuba_divonne_copy: type of source is not type compatible with cuba_divonne_type." - end select - end subroutine cuba_divonne_copy - - subroutine cuba_divonne_set_deferred(this,key1,key2,key3,maxpass,border,maxchisq,mindeviation,xgiven,xgiven_flat) - class(cuba_divonne_type) :: this - integer,optional,intent(in)::key1,key2,key3,maxpass - real(kind=double),optional,intent(in)::border,maxchisq,mindeviation - real(kind=double),dimension(:,:),optional,intent(in)::xgiven - real(kind=double),dimension(:),optional,intent(in)::xgiven_flat - integer,dimension(2)::s - if(present(key1))this%key1=key1 - if(present(key2))this%key2=key2 - if(present(key3))this%key3=key3 - if(present(maxpass))this%maxpass=maxpass - if(present(border))this%border=border - if(present(maxchisq))this%maxchisq=maxchisq - if(present(mindeviation))this%mindeviation=mindeviation - if(present(xgiven))then - if(allocated(this%xgiven))deallocate(this%xgiven) - s=shape(xgiven) - if(s(1)==this%dim_x)then - allocate(this%xgiven(s(1),s(2)),source=xgiven) - this%ldxgiven=s(1) - this%ngiven=s(2) - else - print *,"cuba_divonne_set_deferred: shape of xgiven is not [dim_x,:]." - this%ngiven=0 - end if - end if - if(present(xgiven_flat))then - if(allocated(this%xgiven))deallocate(this%xgiven) - if(mod(size(xgiven_flat),this%dim_x)==0)then - this%ngiven=size(xgiven_flat)/this%dim_x - this%ldxgiven=this%dim_x - allocate(this%xgiven(this%ldxgiven,this%ngiven),source=reshape(xgiven_flat,[this%ldxgiven,this%ngiven])) - else - print *,"cuba_divonne_set_deferred: size of xgiven_flat is no multiple of dim_x." - this%ngiven=0 - end if - end if - end subroutine cuba_divonne_set_deferred - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! type bound procedures for cuba_cuhre_type !!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - SUBROUTINE cuba_cuhre_write_to_ring(this,ring,status) - CLASS(cuba_cuhre_type),INTENT(IN) :: this - class(page_ring_type), intent(inout) :: ring - integer,intent(out)::status - call xml_write_begin_tag(ring,"CUBA_CUHRE_TYPE") - call cuba_write_to_ring(this,ring,status) - call xml_write(ring,"KEY",this%key) - call xml_verify_end_tag(ring,"CUBA_CUHRE_TYPE",status) - END SUBROUTINE cuba_cuhre_write_to_ring - - SUBROUTINE cuba_cuhre_read_from_ring(this,ring,status) - CLASS(cuba_cuhre_type),INTENT(OUT) :: this - class(page_ring_type), intent(inout) :: ring - integer,intent(out)::status - call xml_verify_begin_tag(ring,"CUBA_CUHRE_TYPE",status) - call cuba_read_from_ring(this,ring,status) - call xml_read(ring,this%key) - call xml_verify_end_tag(ring,"CUBA_CUHRE_TYPE",status) - END SUBROUTINE cuba_cuhre_read_from_ring - - subroutine cuba_cuhre_print_to_unit(this,unit,parents,components,peers) - class(cuba_cuhre_type) :: this - INTEGER, INTENT(IN) :: unit,parents,components,peers - if(parents>0)call cuba_print_to_unit(this,unit,parents-1,components,peers) - write(unit,'("Components of cuba_cuhre_type:")') - write(unit,'("key: ",I10)') this%key - end subroutine cuba_cuhre_print_to_unit - - pure function cuba_cuhre_get_type() result(t) - character(:),allocatable::t!FC = nagfor - allocate(t,source="CUBA_CUHRE_TYPE")!FC = nagfor - character(32)::t!FC = gfortran - t="CUBA_CUHRE_TYPE"!FC = gfortran - end function cuba_cuhre_get_type - - subroutine integrate_cuhre(this,integrand) - class(cuba_cuhre_type) :: this - procedure(integrand_interface)::integrand - !c print '("cuhre")' - call cuhre(& - this%dim_x, & - this%dim_f, & - integrand, & - this%userdata, & - this%eps_rel, & - this%eps_abs, & - this%flags, & -! this%seed, & - this%min_eval, & - this%max_eval, & - this%key, & - this%nregions, & - this%neval, & - this%fail, & - this%integral, & - this%error, & - this%prob) - end subroutine integrate_cuhre - - subroutine integrate_cuhre_ud(this,integrand,ud) - class(cuba_cuhre_type) :: this - procedure(integrand_interface)::integrand - type(transversal_momentum_type),intent(in)::ud - !c print '("cuhre")' - call cuhre(& - this%dim_x, & - this%dim_f, & - integrand, & - ud, & - this%eps_rel, & - this%eps_abs, & - this%flags, & -! this%seed, & - this%min_eval, & - this%max_eval, & - this%key, & - this%nregions, & - this%neval, & - this%fail, & - this%integral, & - this%error, & - this%prob) - end subroutine integrate_cuhre_ud - - subroutine cuba_cuhre_copy(this,source) - class(cuba_cuhre_type),intent(out) :: this - class(cuba_class),intent(in) :: source - select type(source) - class is (cuba_cuhre_type) - call this%copy_common(source) - this%key=source%key - class default - print *,"cuba_cuhre_copy: type of source is not type compatible with cuba_cuhre_type." - end select - end subroutine cuba_cuhre_copy - - subroutine cuba_cuhre_set_deferred(this,key) - class(cuba_cuhre_type),intent(inout) :: this - integer, intent(in) :: key - this%key = key - end subroutine cuba_cuhre_set_deferred - -end module cuba_types_module - Index: branches/attic/boschmann_standalone/pri/bin/coordinate_plots.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/bin/coordinate_plots.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/bin/coordinate_plots.f03.pri (revision 8609) @@ -1,452 +0,0 @@ -!!! program: coordinate_plots -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-09 13:54:08 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -PROGRAM coordinate_plots - use kinds -! use momentum_module - use arguments_module - use common_module - use coordinates_module - use basic_types_module - use cuba_types_module - use misc_module - use beam_remnant_module - use remnant_module - use remnant_interface_module - use sample_fractions_module - use parameters_module - use lin_approx_tree_module - use error_stack_module -! use qcdtypes_module - use cplots_module - implicit none - character(6),dimension(2),parameter::dnames=["c_to_h","h_to_c"] - character(3),dimension(4),parameter::cnames=["cc_","cd_","cs_","cv_"] - character(3),dimension(4),parameter::tnames=["tc_","to_","tp_","ts_"] - character(4),dimension(6),parameter::pnames=["pmin","0001","0010","0100","1000","5000"] - real(kind=double),dimension(6),parameter::pvalues=[8D-1,1D0,1D1,1D2,1D3,5D3] - real(kind=double),dimension(6),parameter::ptvalues=(pvalues/7000) - real(kind=double),dimension(6),parameter::pt2values=ptvalues**2 - - type(cuba_cuhre_type),dimension(0:4)::cc - type(cuba_divonne_type),dimension(0:4)::cd - type(cuba_suave_type),dimension(0:4)::cs - type(cuba_vegas_type),dimension(0:4)::cv - - integer,dimension(4,4,6)::cunits - integer::t,p,c - integer::i,c1,c2,c3,c4,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,u15,u16,u17 -! integer,dimension(4,11)::uds - real(kind=double)::tmp_double - call common_run() - call coordinates_module_init() -! call plot_trafo() -! call plot_int11() - - call plot_dddsigma_inout() -! call init_cuba -! call compare_cuba - -!!$! !$OMP PARALLEL DO -!!$ do p=1,6 -!!$ call momentum_set_GEV_scale(pvalues(p)) -!!$ call open_there_or_here("plots/dsigma/dsigma/",tnames(1)//pnames(p),cunits(1,1,p)) -!!$ call open_there_or_here("plots/dsigma/dsigma/",tnames(2)//pnames(p),cunits(1,2,p)) -!!$ call open_there_or_here("plots/dsigma/dsigma/",tnames(3)//pnames(p),cunits(1,3,p)) -!!$ call open_there_or_here("plots/dsigma/dsigma/",tnames(4)//pnames(p),cunits(1,4,p)) -!!$ call plot_cuba_2(11,cunits(1,1,p),coordinates_proton_proton_integrand_cart_11,[0D0,1D0],[0D0,1D0]) -!!$ call plot_cuba_2(11,cunits(1,2,p),coordinates_proton_proton_integrand_ort_11,[0D0,3D-2],[49D-2,51D-2]) -!!$ call plot_cuba_2(11,cunits(1,3,p),coordinates_proton_proton_integrand_param_11,[0D0,3D-2],[49D-2,51D-2]) -!!$ call plot_cuba_2(11,cunits(1,4,p),coordinates_proton_proton_integrand_smooth_11,[0D0,3D-2],[49999D-5,50001D-5]) -!!$ close(cunits(1,1,p)) -!!$ close(cunits(1,2,p)) -!!$ close(cunits(1,3,p)) -!!$ close(cunits(1,4,p)) -!!$ end do -!!$! !$OMP END PARALLEL DO - -!!$ call open_there_or_here("plots/coord/id","ort",u9) -!!$ call open_there_or_here("plots/coord/id","noparam",u10) -!!$ call open_there_or_here("plots/coord/id","param_01",u11) -!!$ call open_there_or_here("plots/coord/id","smooth_01",u12) -!!$ call open_there_or_here("plots/dsigma/inout","gggg_smooth_01",u13) -!!$ call open_there_or_here("plots/dsigma/inout","gggg_param_01",u14) -!!$ call open_there_or_here("plots/dsigma/inout","gggg_ort_01",u15) -!!$ call open_there_or_here("plots/dsigma/inout","gggg_cart_01",u16) -!!$ call open_there_or_here("plots/dsigma/inout","all_smooth_01",u17) -!!$ - -!!$ call plot_id(u9,c_to_h_ort_def,h_to_c_ort_def) -!!$ !$OMP SECTION -!!$ call plot_id(u10,c_to_h_noparam,h_to_c_noparam) -!!$ !$OMP SECTION -!!$ call plot_id(u11,c_to_h_param_def,h_to_c_param_def) -!!$ !$OMP SECTION -!!$ call plot_id(u12,c_to_h_smooth_def,h_to_c_smooth_def) -!!$ !$OMP SECTION -!!$ call plot_cuba_2(11,u17,coordinates_proton_proton_integrand_11) -!!$ close(u17) -!!$ !$OMP SECTION -!!$ call plot_cuba_2(1,u13,cuba_gg_me_smooth) -!!$ close(u13) -!!$ !$OMP SECTION -!!$ call plot_cuba_2(1,u14,cuba_gg_me_param) -!!$ close(u14) -!!$ !$OMP SECTION -!!$ call plot_cuba_2(1,u15,cuba_gg_me_ort) -!!$ close(u15) -!!$ !$OMP SECTION -!!$ call plot_cuba_2(1,u16,cuba_gg_me_cart) -!!$ close(u16) -!!$ !$OMP END PARALLEL SECTIONS -!!$ close(u1) -!!$ close(u2) -!!$ close(u3) -!!$ close(u4) -!!$ close(u5) -!!$ close(u6) -!!$ close(u7) -!!$ close(u8) -!!$ close(u9) -!!$ close(u10) -!!$ close(u11) -!!$ close(u12) -!!$ !$OMP SECTION -!!$ call test_int(u7, c_to_h_ort_def, h_to_c_ort_def, voxel_c_to_h_ort_def, voxel_h_to_c_ort_def) -!!$ !$OMP SECTION -!!$ call test_int(u8, c_to_h_param_def, h_to_c_param_def, voxel_c_to_h_param_def, voxel_h_to_c_param_def) -!!$ !$OMP SECTION -!!$ call test_int(u9,c_to_h_smooth_def,h_to_c_smooth_def,voxel_c_to_h_smooth_def,voxel_h_to_c_smooth_def) -!!$ !$OMP SECTION -!!$ call plot_denom(u10,denom_cart) -!!$ !$OMP SECTION -!!$ call plot_denom(u11,denom_ort) -!!$ !$OMP SECTION -!!$ call plot_denom(u12,denom_param_save) -!!$ !$OMP SECTION -!!$ call plot_denom(u13,denom_smooth_save) -!!$ !$OMP END PARALLEL SECTIONS -!!$ close(u1) -!!$ close(u2) -!!$ close(u3) -!!$ close(u4) -!!$ close(u5) -!!$ close(u6) -!!$ close(u7) -!!$ close(u8) -!!$ close(u9) -!!$ close(u10) -!!$ close(u11) -!!$ close(u12) -!!$ close(u13) - -!!$ do i=1,999 -!!$ call coordinates_set_parameter(i/1D3) -!!$ call find_cut(h_to_c_ort_def) -!!$ call find_cut(h_to_c_param_def) -!!$ end do -contains - subroutine init_cuba() - do p=1,6 - do t=1,4 - do c=1,4 - call open_there_or_here(home_dir%get_actual_value()//"/plots/coord/cuba",cnames(c)//"_"//tnames(t)//"_"//pnames(p),cunits(c,t,p)) - end do - end do - end do -! call cuba_set_common(cc(1),2,11,1d-2,max_eval=10000000,integrand=coordinates_proton_proton_integrand_cart_11) -! call cuba_set_common(cc(2),2,11,1d-2,max_eval=10000000,integrand=coordinates_proton_proton_integrand_ort_11) -! call cuba_set_common(cc(3),2,11,1d-2,max_eval=10000000,integrand=coordinates_proton_proton_integrand_param_11) -! call cuba_set_common(cc(4),2,11,1d-2,max_eval=10000000,integrand=coordinates_proton_proton_integrand_smooth_11) -! call cuba_set_common(cd(1),2,11,1d-2,max_eval=10000000,integrand=coordinates_proton_proton_integrand_cart_11) -! call cuba_set_common(cd(2),2,11,1d-2,max_eval=10000000,integrand=coordinates_proton_proton_integrand_ort_11) -! call cuba_set_common(cd(3),2,11,1d-2,max_eval=10000000,integrand=coordinates_proton_proton_integrand_param_11) -! call cuba_set_common(cd(4),2,11,1d-2,max_eval=10000000,integrand=coordinates_proton_proton_integrand_smooth_11) -! call cuba_set_common(cs(1),2,11,1d-2,max_eval=10000000,integrand=coordinates_proton_proton_integrand_cart_11) -! call cuba_set_common(cs(2),2,11,1d-2,max_eval=10000000,integrand=coordinates_proton_proton_integrand_ort_11) -! call cuba_set_common(cs(3),2,11,1d-2,max_eval=10000000,integrand=coordinates_proton_proton_integrand_param_11) -! call cuba_set_common(cs(4),2,11,1d-2,max_eval=10000000,integrand=coordinates_proton_proton_integrand_smooth_11) -! call cuba_set_common(cv(1),2,11,1d-2,max_eval=10000000,integrand=coordinates_proton_proton_integrand_cart_11) -! call cuba_set_common(cv(2),2,11,1d-2,max_eval=10000000,integrand=coordinates_proton_proton_integrand_ort_11) -! call cuba_set_common(cv(3),2,11,1d-2,max_eval=10000000,integrand=coordinates_proton_proton_integrand_param_11) -! call cuba_set_common(cv(4),2,11,1d-2,max_eval=10000000,integrand=coordinates_proton_proton_integrand_smooth_11) -! call cd(1)%set_deferred(xgiven_flat=sqrt(pvalues(p)+1D-6)*[1D0,1D0]) -! call cd(2)%set_deferred(xgiven_flat=[1D-6,5D-1]) -! call cd(3)%set_deferred(xgiven_flat=[1D-1,3D-1,1D-1,7D-1]) -! Call cd(4)%set_deferred(xgiven_flat=[1D-1,5D-1]) - end subroutine init_cuba - - subroutine compare_cuba - do p=4,6 -! call momentum_set_GEV_scale(pvalues(p)) - ! !$OMP PARALLEL DO - do t=1,4 - do c=1,4 - select case (c) - case (1) - print *,"start ",cnames(c),tnames(t),pnames(p),cunits(c,t,p) - ! call cc(t)%integrate_associated() -! call cc(t)%integrate(coordinates_proton_proton_integrand_param_11) -! call cc(t)%print_to_unit(cunits(c,t,p),3,3,3) - close(cunits(c,t,p)) - print *,"done ",cnames(c),tnames(t),pnames(p),cunits(c,t,p) - case (2) - print *,"start ",cnames(c),tnames(t),pnames(p),cunits(c,t,p) - ! call cd(t)%integrate_associated() - ! call cd(t)%integrate(coordinates_proton_proton_integrand_param_11) -! call cd(t)%print_to_unit(cunits(c,t,p),3,3,3) - close(cunits(c,t,p)) - print *,"done ",cnames(c),tnames(t),pnames(p),cunits(c,t,p) - case(3) - ! print *,"start ",cnames(c),tnames(t),pnames(p),cunits(c,t,p) - ! call cs(t)%integrate_associated() - ! call cs(t)%integrate(coordinates_proton_proton_integrand_param_11) - ! call cs(t)%print_to_unit(cunits(c,t,p),3,3,3) - ! close(cunits(c,t,p)) - ! print *,"done ",cnames(c),tnames(t),pnames(p),cunits(c,t,p) - case(4) - print *,"start ",cnames(c),tnames(t),pnames(p),cunits(c,t,p) - ! call cv(t)%integrate_associated() -! call cv(t)%integrate(coordinates_proton_proton_integrand_param_11) -! call cv(t)%print_to_unit(cunits(c,t,p),3,3,3) - close(cunits(c,t,p)) - print *,"done ",cnames(c),tnames(t),pnames(p),cunits(c,t,p) - end select - end do - end do - ! !$OMP END PARALLEL DO - end do - end subroutine compare_cuba - - subroutine plot_dddsigma_inout() - use OMP_LIB!FC = gfortran -! use momentum_module - integer::int_id,proc_num,proc_id,pt_id,nx,ny - integer,save::unit1,unit2 - integer::first_id=0 - character(2)::int_c - character(3),save::num_c - character(4),save::proc_c - real(kind=double)::rx,ry,dddsigma - real(kind=double),dimension(3)::cart - real(kind=double),dimension(17)::dddsigma_17 - do pt_id=1,6 -! call momentum_set_pts2_scale(pt2values(pt_id)) - call open_and_echo(plot_dir%get_actual_value()//"/dddsigma/hyp/dddsigma_all_smooth_"//pnames(pt_id)//".plot",unit1) - call open_and_echo(plot_dir%get_actual_value()//"/dddsigma/hyp/dddsigma_all_param_"//pnames(pt_id)//".plot",unit2) - do nx=1,199 - rx=nx/32D2 - do ny=1501,1699 - ry=ny/32D2 -! call coordinates_proton_proton_integrand_smooth_17_reg(2,[rx,ry],17,dddsigma_17,pt2values(pt_id)) - write(unit1,fmt=*)rx,ry,dddsigma_17 -! call coordinates_proton_proton_integrand_param_17_reg(2,[rx,ry],17,dddsigma_17,pt2values(pt_id)) - write(unit2,fmt=*)rx,ry,dddsigma_17 - end do - write(unit1,fmt=*)"" - write(unit2,fmt=*)"" - end do - close(unit1) - close(unit2) - end do -! !$OMP THREADPRIVATE(unit,num_c,proc_c) -! !$OMP PARALLEL DO SHARED(int_c) - do int_id=1,16 - call integer_with_leading_zeros(int_id,2,int_c) - do proc_num=1,int_sizes_all(int_id) - call integer_with_leading_zeros(proc_num,3,num_c) - proc_id=int_all(first_id+proc_num) - call integer_with_leading_zeros(proc_id,4,proc_c) - do pt_id=1,6 - ! !$OMP CRITICAL - ! print *,omp_get_thread_num() - call open_and_echo(plot_dir%get_actual_value()//"/dddsigma/hyp/dddsigma_"//int_c//"_"//num_c//"_"//proc_c//"_"//pnames(pt_id)//".plot",unit1) - call open_and_echo(plot_dir%get_actual_value()//"/dddsigma/cart/dddsigma_"//int_c//"_"//num_c//"_"//proc_c//"_"//pnames(pt_id)//".plot",unit2) - do nx=2,99 - rx=nx/1D2 - do ny=1,99 - ry=ny/1D2 - call coordinates_dddsigma(proc_id,int_id,[rx,ry,pt2values(pt_id)],cart,dddsigma) - write(unit1,fmt=*)nx,ny,dddsigma - call coordinates_dddsigma_cart(proc_id,int_id,[rx,ry,pt2values(pt_id)],dddsigma) - write(unit2,fmt=*)nx,ny,dddsigma - end do - write(unit1,fmt=*)"" - write(unit2,fmt=*)"" - end do -! !$OMP END CRITICAL - close(unit1) - close(unit2) - end do - end do - first_id=first_id+int_sizes_all(int_id) - print *,"" - end do -! !$OMP END PARALLEL DO - end subroutine plot_dddsigma_inout - - subroutine plot_trafo - integer::p,t,d,utgp,uvgp - integer,dimension(2,4,6)::ut,uv - call open_there_or_here("plots/coord/trafo","trafo_all.gp",utgp) - call open_there_or_here("plots/coord/voxel","voxel_all.gp",uvgp) - write(utgp,fmt=*)"set terminal postscript color enhanced eps solid size 18cm,18cm" - write(utgp,fmt=*)'set hidden3d' - write(utgp,fmt=*)'set xrange [-0.05:1.05]' - write(utgp,fmt=*)'set yrange [-0.05:1.05]' - write(utgp,fmt=*)'set xlabel "x_1"' - write(utgp,fmt=*)'set ylabel "x_2"' - write(utgp,fmt=*)'unset key' - write(uvgp,fmt=*)"set terminal postscript color enhanced eps solid size 18cm,18cm" - write(uvgp,fmt=*)'set hidden3d' - write(uvgp,fmt=*)'set xrange [0:1]' - write(uvgp,fmt=*)'set yrange [0:1]' - write(uvgp,fmt=*)'set xlabel "x_1"' - write(uvgp,fmt=*)'set ylabel "x_2"' - write(uvgp,fmt=*)'unset key' - do d=1,2 - do p=1,6 - do t=2,4 - write(utgp,fmt=*)"file='"//dnames(d)//"_"//tnames(t)//pnames(p)//"'" - write(utgp,fmt=*)'set output "trafo_'//dnames(d)//"_"//tnames(t)//pnames(p)//'.eps"' - write(utgp,fmt=*)'set multiplot' - write(utgp,fmt=*)'plot file using 1:2 with lines lc rgb "blue"' - write(utgp,fmt=*)'plot file using 3:4 with lines lc rgb "blue"' - write(utgp,fmt=*)'plot file using 5:6 with lines lc rgb "blue"' - write(utgp,fmt=*)'plot file using 7:8 with lines lc rgb "blue"' - write(utgp,fmt=*)'plot file using 9:10 with lines lc rgb "blue"' - write(utgp,fmt=*)'plot file using 11:12 with lines lc rgb "blue"' - write(utgp,fmt=*)'plot file using 13:14 with lines lc rgb "blue"' - write(utgp,fmt=*)'plot file using 15:16 with lines lc rgb "blue"' - write(utgp,fmt=*)'plot file using 17:18 with lines lc rgb "blue"' - write(utgp,fmt=*)'plot file using 19:20 with lines lc rgb "blue"' - write(utgp,fmt=*)'plot file using 21:22 with lines lc rgb "blue"' - write(utgp,fmt=*)'plot file using 23:24 with lines lc rgb "red"' - write(utgp,fmt=*)'plot file using 25:26 with lines lc rgb "red"' - write(utgp,fmt=*)'plot file using 27:28 with lines lc rgb "red"' - write(utgp,fmt=*)'plot file using 29:30 with lines lc rgb "red"' - write(utgp,fmt=*)'plot file using 31:32 with lines lc rgb "red"' - write(utgp,fmt=*)'plot file using 33:34 with lines lc rgb "red"' - write(utgp,fmt=*)'plot file using 35:36 with lines lc rgb "red"' - write(utgp,fmt=*)'plot file using 37:38 with lines lc rgb "red"' - write(utgp,fmt=*)'plot file using 39:40 with lines lc rgb "red"' - write(utgp,fmt=*)'plot file using 41:42 with lines lc rgb "red"' - write(utgp,fmt=*)'plot file using 43:44 with lines lc rgb "red"' - write(utgp,fmt=*)'unset multiplot' - flush(utgp) - write(uvgp,fmt=*)"file='"//dnames(d)//"_"//tnames(t)//pnames(p)//"'" - write(uvgp,fmt=*)'set output "voxel_'//dnames(d)//"_"//tnames(t)//pnames(p)//'.eps"' - write(uvgp,fmt=*)"splot file with lines" - flush(uvgp) - call open_there_or_here("plots/coord/trafo",dnames(d)//"_"//tnames(t)//pnames(p),ut(d,t,p)) - call open_there_or_here("plots/coord/voxel",dnames(d)//"_"//tnames(t)//pnames(p),uv(d,t,p)) - end do - end do - write(utgp,fmt=*)'set xlabel "h_1"' - write(utgp,fmt=*)'set ylabel "h_2"' - write(uvgp,fmt=*)'set xlabel "h_1"' - write(uvgp,fmt=*)'set ylabel "h_2"' - end do - close(utgp) - close(uvgp) - !$OMP PARALLEL DO - do p=1,6 - call cplot_coords(ut(2,2,p),h_to_c_ort,pt2values(p)) - call cplot_coords(ut(1,2,p),c_to_h_ort,pt2values(p)) - call cplot_coords(ut(2,3,p),h_to_c_param,pt2values(p)) - call cplot_coords(ut(1,3,p),c_to_h_param,pt2values(p)) - call cplot_coords(ut(2,4,p),h_to_c_smooth,pt2values(p)) - call cplot_coords(ut(1,4,p),c_to_h_smooth,pt2values(p)) - call cplot_voxel(uv(2,2,p),voxel_h_to_c_ort,pt2values(p)) - call cplot_voxel(uv(1,2,p),voxel_c_to_h_ort,pt2values(p)) - call cplot_voxel(uv(2,3,p),voxel_h_to_c_param,pt2values(p)) - call cplot_voxel(uv(1,3,p),voxel_c_to_h_param,pt2values(p)) - call cplot_voxel(uv(2,4,p),voxel_h_to_c_smooth,pt2values(p)) - call cplot_voxel(uv(1,4,p),voxel_c_to_h_smooth,pt2values(p)) - end do - !$OMP END PARALLEL DO - do p=1,6 - do t=2,4 - do d=1,2 - close(ut(d,t,p)) - close(uv(d,t,p)) - end do - end do - end do - end subroutine plot_trafo - - subroutine plot_voxel - integer::p - integer,dimension(6,6)::u - do p=1,6 - call open_there_or_here("plots/coord/voxel","h_c_ort_"//pnames(p),u(1,p)) - call open_there_or_here("plots/coord/voxel","c_h_ort_"//pnames(p),u(2,p)) - call open_there_or_here("plots/coord/voxel","h_c_param_"//pnames(p),u(3,p)) - call open_there_or_here("plots/coord/voxel","c_h_param_"//pnames(p),u(4,p)) - call open_there_or_here("plots/coord/voxel","h_c_smooth_"//pnames(p),u(5,p)) - call open_there_or_here("plots/coord/voxel","c_h_smooth_"//pnames(p),u(6,p)) - end do - !$OMP PARALLEL DO - do p=1,6 - end do - !$OMP END PARALLEL DO - end subroutine plot_voxel - - subroutine plot_int11 - integer::p,t,i - integer,dimension(4,6)::u - do p=1,6 - do t=1,4 - call open_there_or_here("plots/coord/int11",tnames(t)//pnames(p)//".gp",u(t,p)) - write(u(t,p),fmt=*)"set terminal postscript color enhanced eps solid size 18cm,18cm" - write(u(t,p),fmt=*)"file='"//tnames(t)//pnames(p)//"'" - write(u(t,p),fmt=*)'set hidden3d' - write(u(t,p),fmt=*)'set xlabel "h_1"' - write(u(t,p),fmt=*)'set ylabel "h_2"' - write(u(t,p),fmt=*)'unset key' - do i=2,11 -! write(u(t,p),'(a,I0,a)'),'set title "d W/d p \n Int Kind ',i,'"' - write(u(t,p),fmt='(a,I0,a)')'set output "int11_'//tnames(t)//pnames(p)//"_",i,'.eps"' - write(u(t,p),'(a,I0,a)')'splot file using 1:2:',i+2,' with lines' - end do - close(u(t,p)) - call open_there_or_here("plots/coord/int11",tnames(t)//pnames(p),u(t,p)) - end do - end do - do p=1,6 -! call momentum_set_gev_scale(pvalues(p)) -! !$OMP PARALLEL SECTIONS -! !$OMP SECTION -! call plot_cuba_2(11,u(1,p),coordinates_proton_proton_integrand_cart_11,[9D-1*(ptvalues(p)-ptvalues(1)),1D-1+ptvalues(p)],[9D-1*(ptvalues(p)-ptvalues(1)),1D-1+ptvalues(p)]) -! call plot_cuba_2(11,u(1,p),coordinates_proton_proton_integrand_cart_11,[0D0,1D0],[0D0,1D0]) -! !$OMP SECTION -! call plot_cuba_2(11,u(2,p),coordinates_proton_proton_integrand_ort_11,[0D0,1D0],[0D0,1D0]) -! !$OMP SECTION -! call plot_cuba_2(11,u(3,p),coordinates_proton_proton_integrand_param_11,[0D0,1D0],[0D0,1D0]) -! !$OMP SECTION -! call plot_cuba_2(11,u(4,p),coordinates_proton_proton_integrand_smooth_11,[0D0,1D0],[0D0,1D0]) -! !$OMP END PARALLEL SECTIONS - end do - end subroutine plot_int11 - -end PROGRAM coordinate_plots - Index: branches/attic/boschmann_standalone/pri/bin/generate_sigma.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/bin/generate_sigma.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/bin/generate_sigma.f03.pri (revision 8609) @@ -1,128 +0,0 @@ -!!! program: generate_sigma -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-28 15:46:52 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -program generate_sigma - use,intrinsic::ieee_arithmetic!FC = nagfor - use,intrinsic::iso_fortran_env - use arguments_module - use kinds - use common_module - use remnant_interface_module - use remnant_module - use beam_remnant_module - use cuba_types_module - use parameters_module - use aqd_sigma_module - use fibonacci_tree_module - use lin_approx_tree_module - use aqa_module - use misc_module - use momentum_module - implicit none - type(aqd_sigma_type) :: aq_sigma - type(string_argument_type),target,save::dsigma_plot_subdir,dsigma_data_subdir - type(real_argument_type),target,save::dsigma_goal_argument,dsigma_cuba_goal_argument - type(integer_argument_type),target,save::dsigma_max_nodes_argument - call help_arg%write_to_unit(output_unit) - call initialize() - call generate() - call write(& - home_dir%get_actual_value()//"/"//data_dir%get_actual_value()//"/"//dsigma_data_subdir%get_actual_value(),& - home_dir%get_actual_value()//"/"//plot_dir%get_actual_value()//"/"//dsigma_plot_subdir%get_actual_value()) - call read(& - home_dir%get_actual_value()//"/"//data_dir%get_actual_value()//"/"//dsigma_data_subdir%get_actual_value(),& - home_dir%get_actual_value()//"/"//plot_dir%get_actual_value()//"/"//dsigma_plot_subdir%get_actual_value()) - -contains - - subroutine initialize() - call dsigma_plot_subdir%initialize("dsigma",args,long="plot_subdir",named_option="") - call dsigma_data_subdir%initialize("dsigma",args,long="data_subdir",named_option="") - call dsigma_goal_argument%initialize(1D-5,epsilon(1D0),1D0,args,long="dsigma_goal",named_option="") - call dsigma_cuba_goal_argument%initialize(1D-6,epsilon(1D0),1D0,args,long="dsigma_cuba_goal",named_option="") - call dsigma_max_nodes_argument%initialize(10000,1,huge(1),args,long="max_nodes",named_option="") - call common_run() - print *,"Initializing Integration Environment..." - call aq_sigma%initialize(0,"dsigma / dpts",& - dsigma_goal_argument%get_actual_value(),& - dsigma_max_nodes_argument%get_actual_value(),& - 17,& - dsigma_cuba_goal_argument%get_actual_value()) - call aq_sigma%print_parents() - end subroutine initialize - - subroutine generate() - print *,"Starting Integration..." - call aq_sigma%run() - call aq_sigma%integrate() - print *,"Results:" - call aq_sigma%print_parents() - print *,"Time Consumption:" - call aq_sigma%print_times() - end subroutine generate - - subroutine write(data_dir,plot_dir) - character(len=*),intent(in) :: data_dir,plot_dir - type(page_ring_type)::ring - class(lin_approx_list_type),pointer :: root_list - integer::unit,status - print *,"Serialize Root Function..." - call ring%open(data_dir//"/int_tree.xml",action="write",status="replace") - call aq_sigma%int_tree%serialize(ring,"INT_TREE") - call ring%close - print *,"done." - print *,"Serialize Integration Environment..." - call ring%open(data_dir//"/dsigma.xml",action="write",status="replace") - call aq_sigma%serialize(ring,"AQD_SIGMA") - call ring%close - print *,"done." - print *,"Creating plots..." - call aq_sigma%int_tree%get_left_list(root_list) - call root_list%gnuplot(plot_dir) - call open_and_echo(plot_dir//"/convergence.plot",unit) - call aq_sigma%write_convergence(unit) - close(unit) - print *,"done." - end subroutine write - - subroutine read(data_dir,plot_dir) - character(len=*),intent(in) :: data_dir,plot_dir - type(aqd_sigma_type) :: aq_sigma - type(lin_approx_tree_type)::tree - class(lin_approx_list_type),pointer :: root_list - type(page_ring_type)::ring - call reset_heap_stack - print *,"Trying to deserialize Root Function..." - call ring%open(data_dir//"/int_tree.xml",action="read",status="old") - call tree%deserialize(ring) - call ring%close - print *,"done." - print *,"Trying to deserialize Integration Environment..." - call ring%open(data_dir//"/dsigma.xml",action="read",status="old") - call aq_sigma%deserialize(ring) - call ring%close - print *,"done." -! call tree%get_left_list(root_list) -! call root_list%gnuplot(plot_dir) - end subroutine read - -end program generate_sigma Index: branches/attic/boschmann_standalone/pri/bin/generate_chain.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/bin/generate_chain.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/bin/generate_chain.f03.pri (revision 8609) @@ -1,201 +0,0 @@ -!!! program: generate_chain -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-02-03 10:30:22 CET(+0100) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -program generate_chain - use,intrinsic::iso_fortran_env - use,intrinsic::ieee_arithmetic!FC = nagfor - use arguments_module - use kinds - use basic_types_module - use common_module - use remnant_interface_module - use remnant_module - use remnant_plots_module - use beam_remnant_module - use cuba_types_module - use fibonacci_tree_module -! use qcdtypes_module - use lin_approx_tree_module - use misc_module - use momentum_module - use parameters_module - use sample_fractions_module - use error_stack_module - implicit none - type(lin_approx_tree_type),target :: root_tree - call common_run() -! call generate() -!contains - -!!$ subroutine generate() -!!$ type(qcd_2_2_generator_type)::int -!!$ integer,parameter :: runs = 1000000 -!!$ integer,parameter :: print_every = 10000 -!!$ integer,parameter :: max_loops = runs/print_every -!!$ ! binning -!!$ integer,parameter::pt_bins=100 -!!$ integer,parameter::x_bins=25 -!!$ real(kind=double),parameter :: min_pt = 0.8D0 -!!$ real(kind=double),parameter :: max_pt = 1D2 -!!$ real(kind=double),parameter :: d_pt=(max_pt/min_pt)**(1D0/pt_bins) -!!$ real(kind=double),parameter :: log_pt = log(d_pt) -!!$ integer,dimension(0:2,0:x_bins,0:x_bins,0:pt_bins,1:11)::bin_array -!!$ ! loops -!!$ integer::print_loop,outer_loop -!!$ ! general statistic -!!$ integer,parameter::dim_chain_length=20 -!!$ integer,dimension(0:11)::exceeds -!!$ integer,dimension(-1:dim_chain_length)::chain_length_array -!!$ integer::n_total -!!$ ! timing -!!$ real(kind=double) :: time0,time1,timed -!!$ ! units -!!$ integer::chain_unit,sample_unit -!!$ ! results -!!$ real(kind=double)::pt -!!$ integer::sample_id,pt_bin,swap,chain_length,x1_bin,x2_bin -!!$ real(kind=double),dimension(2)::x -!!$ ! namelist -!!$ integer::n_runs=runs -!!$ integer::n_pt_bins=pt_bins -!!$ integer::n_x_bins=x_bins -!!$ integer::n_chain_lengths=dim_chain_length -!!$ real(kind=double)::gev_min_pt=min_pt -!!$ real(kind=double)::gev_d_pt=d_pt -!!$ namelist/parameters/n_runs,n_x_bins,n_pt_bins,n_chain_lengths,gev_min_pt,gev_d_pt -!!$ forall(swap=0:2,x1_bin=0:x_bins,x2_bin=0:x_bins,pt_bin=0:pt_bins,sample_id=1:11) -!!$ bin_array(swap,x1_bin,x2_bin,pt_bin,sample_id)=0 -!!$ end forall -!!$ forall(chain_length=-1:dim_chain_length) -!!$ chain_length_array(chain_length)=0 -!!$ end forall -!!$ call coordinates_module_init() -!!$ call open_there_or_here(data_dir%get_actual_value(),"/generator",sample_unit) -!!$ call int%deserialize(sample_unit) -!!$! call open_and_echo("generator",generator_unit) -!!$! call int%deserialize(generator_unit) -!!$ call int%reset_timer() -!!$! close(generator_unit) -!!$ int%modify_pdfs=.false. -!!$! call remnand%set_pdf_weight([1D0,1D0,1D0,0D0,1D0,1D0,1D0,0D0]) -!!$ call cpu_time(time0) -!!$ outer: do outer_loop=1,max_loops -!!$ print ('(I10," of ",I10)'),outer_loop,max_loops -!!$ print: do print_loop = 1,print_every -!!$ call int%restart() -!!$! call int%generate_pts2() -!!$ call qcd_2_2_generator_generate_pts2_sequentiel(int) -!!$ chain_length=0 -!!$ chain: do while (.not.int%is_finished()) -!!$ call int%generate_partons() -!!$ call int%confirm() -!!$ ! results -!!$ chain_length=chain_length+1 -!!$ sample_id=int%get_integrand_id() -!!$ pt=int%get_GeV_pt() -!!$ x=int%get_remnant_momentum_fractions() -!!$ swap=int%is_swapped() -!!$ ! binning -!!$ pt_bin=min(ceiling(log(pt/min_pt)/log_pt),pt_bins) -!!$ x1_bin=min(ceiling(x(1)*x_bins),x_bins) -!!$ x2_bin=min(ceiling(x(2)*x_bins),x_bins) -!!$ bin_array(swap,x1_bin,x2_bin,pt_bin,sample_id)=bin_array(swap,x1_bin,x2_bin,pt_bin,sample_id)+1 -!!$ call qcd_2_2_generator_generate_pts2_sequentiel(int) -!!$! call int%generate_pts2() -!!$ end do chain -!!$ chain_length=min(chain_length,dim_chain_length) -!!$ chain_length_array(chain_length)=chain_length_array(chain_length)+1 -!!$ ! print('("")') -!!$ end do print -!!$ !print('(I10," generated interactions so far.")'),n_total -!!$ call int%print_timer() -!!$ call cpu_time(time1) -!!$ print *,"Actual time:",floor(time1-time0),"s = ",floor((time1-time0)/6D1),"m = ",floor((time1-time0)/36D2),"h" -!!$ timed=(time1-time0)*runs/(print_every*outer_loop) -!!$ end do outer -!!$ print *,"Calculating Sums..." -!!$ chain_length_array(-1)=sum(chain_length_array(0:dim_chain_length)) -!!$ do sample_id=11,1,-1 -!!$ do pt_bin=pt_bins,0,-1 -!!$ do x1_bin=x_bins,0,-1 -!!$ do x2_bin=x_bins,0,-1 -!!$ do swap=2,0,-1 -!!$ if(swap==0)then -!!$ bin_array(swap,x1_bin,x2_bin,pt_bin,sample_id)=sum(bin_array(1:2,x1_bin,x2_bin,pt_bin,sample_id)) -!!$ else -!!$ if(x1_bin==0)then -!!$ bin_array(swap,x1_bin,x2_bin,pt_bin,sample_id)=sum(bin_array(swap,1:x_bins,x2_bin,pt_bin,sample_id)) -!!$ else -!!$ if(x2_bin==0)then -!!$ bin_array(swap,x1_bin,x2_bin,pt_bin,sample_id)=sum(bin_array(swap,x1_bin,1:x_bins,pt_bin,sample_id)) -!!$ else -!!$ if(pt_bin==0)then -!!$ bin_array(swap,x1_bin,x2_bin,pt_bin,sample_id)=sum(bin_array(swap,x1_bin,x2_bin,1:pt_bins,sample_id)) -!!$ else -!!$ if(sample_id==1)then -!!$ bin_array(swap,x1_bin,x2_bin,pt_bin,sample_id)=sum(bin_array(swap,x1_bin,x2_bin,pt_bin,2:11)) -!!$ end if -!!$ end if -!!$ end if -!!$ end if -!!$ end if -!!$ end do -!!$ end do -!!$ end do -!!$ end do -!!$ end do -!!$ print *,"Serializing Generator Environment..." -!!$ call open_there_or_here("output","chains",chain_unit) -!!$ write(chain_unit,nml=parameters) -!!$ write(chain_unit,fmt=*)chain_length_array(-1:dim_chain_length) -!!$ do sample_id=1,11 -!!$ do pt_bin=0,pt_bins -!!$ do x2_bin=0,x_bins -!!$ do x1_bin=0,x_bins -!!$ write(chain_unit,fmt=*)bin_array(0:2,x1_bin,x2_bin,pt_bin,sample_id) -!!$ end do -!!$ end do -!!$ end do -!!$ end do -!!$ print *,shape(bin_array) -!!$ -!!$ do sample_id=1,11 -!!$ do pt_bin=0,pt_bins -!!$ do x2_bin=0,x_bins -!!$ do x1_bin=0,x_bins -!!$ do swap=0,2 -!!$ write(chain_unit,fmt=*)bin_array(swap,x1_bin,x2_bin,pt_bin,sample_id) -!!$ end do -!!$ write(chain_unit,fmt=*)"" -!!$ end do -!!$ write(chain_unit,fmt=*)"" -!!$ end do -!!$ write(chain_unit,fmt=*)"" -!!$ end do -!!$ write(chain_unit,fmt=*)"" -!!$ end do -!!$ -!!$ close(chain_unit) -!!$ print *,"Done." -!!$ end subroutine generate - -end program generate_chain Index: branches/attic/boschmann_standalone/pri/bin/gnuplot_dsigma.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/bin/gnuplot_dsigma.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/bin/gnuplot_dsigma.f03.pri (revision 8609) @@ -1,71 +0,0 @@ -!!! program: gnuplot_dsigma -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-20 11:29:12 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -program gnuplot_dsigma -!!$ use misc_module -!!$ use lin_approx_tree_module -!!$ implicit none -!!$ integer,parameter::n_pt=1000 -!!$ character(*),parameter::dir="output/" -!!$ character(*),parameter::tree_file="dsigma.lin.tree" -!!$ character(*),parameter::val_file="dsigma_val.plot" -!!$ character(*),parameter::int_file="dsigma_int.plot" -!!$ character(*),parameter::prop_file="dsigma_prop.plot" -!!$ real(kind=double)::d_pt,pt -!!$ real(kind=double),dimension(:),allocatable::val,int,prop -!!$ integer::unit_ds,unit_val,unit_int,unit_prop,n,dim -!!$ real(kind=double)::min_pt,max_pt -!!$ type(lin_approx_tree_type)::dsigma -!!$ class(lin_approx_list_type),pointer::list -!!$ class(lin_approx_node_class),pointer::node -!!$ call open_there_or_here(dir,tree_file,unit_ds) -!!$ call dsigma%deserialize(unit_ds) -!!$ close(unit_ds) -!!$ call dsigma%get_left_list(list) -!!$ min_pt=list%get_l_position() -!!$ call dsigma%get_right_list(list) -!!$ max_pt=list%get_r_position() -!!$ dim=list%get_dimension() -!!$ allocate(val(dim)) -!!$ allocate(int(dim)) -!!$ allocate(prop(dim)) -!!$ d_pt=(max_pt/min_pt)**(1D0/n_pt) -!!$ print *,min_pt,max_pt,d_pt -!!$ call open_there_or_here(dir,val_file,unit_val) -!!$ call open_there_or_here(dir,int_file,unit_int) -!!$ call open_there_or_here(dir,prop_file,unit_prop) -!!$ pt=min_pt -!!$ do n=0,n_pt -!!$ call dsigma%find_by_position(pt,node) -!!$ val=node%approx_value(pt) -!!$ int=node%approx_integral(pt) -!!$ prop=node%approx_propability(pt) -!!$ write(unit_val,fmt=*)pt,val -!!$ flush(unit_val) -!!$ write(unit_int,fmt=*)pt,int -!!$ flush(unit_int) -!!$ write(unit_prop,fmt=*)pt,prop -!!$ flush(unit_prop) -!!$ print *,pt -!!$ pt=pt*d_pt -!!$ end do -end program gnuplot_dsigma Index: branches/attic/boschmann_standalone/pri/bin/mi_testshower.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/bin/mi_testshower.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/bin/mi_testshower.f03.pri (revision 8609) @@ -1,189 +0,0 @@ -!!! program: mi_testshower -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-02-03 10:33:08 CET(+0100) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -PROGRAM mi_testshower - use,intrinsic::iso_fortran_env - use kinds - use basic_types_module - use common_module - use lin_approx_tree_module - use parameters_module - use remnant_interface_module - use remnant_module - use beam_remnant_module - use cuba_types_module - use sample_fractions_module - use misc_module - use fibonacci_tree_module - use momentum_module -! use qcdtypes_module - use shower_basics_module - use shower_particle_module - use shower_module - use,intrinsic::IEEE_ARITHMETIC!FC = nagfor - implicit none - type(particle_t), pointer :: prt1, prt2, prt3, prt4, had1, had2 - type(lin_approx_tree_type),target :: root_tree - type(shower_t) :: shower -! type(qcd_2_2_generator_type)::int - integer :: i - real(kind=double)::interaction_argument,gev_next_interaction_pt,gev_next_shower_pt,dsigma - logical::continue_mi,continue_branching - type(particle_pointer_t) :: temppp - - CALL IEEE_SET_HALTING_MODE(IEEE_ALL,.FALSE.) !FC = nagfor -! call random_seed() ! this is all you need for a random seed! - - isr_pt_ordered = .false. - call shower_create(shower) - - call coordinates_module_init() -! call int%initialize() - - call find_initial_interaction ! the interesting part - call main_loop ! the interesting part - - call shower_boost_to_labframe(shower) - call shower_print(shower) - print *, " before prim" - call shower_generate_primordial_kt(shower) - call shower_update_beamremnants(shower) - call shower_print(shower) - call shower_final(shower) - -contains - - subroutine find_initial_interaction - logical::in_range - allocate(had1) - allocate(had2) - - had1%nr=200 - had1%typ=hadron_A_kind - call particle_set_momentum(had1, gev_pt_max, 0._double, 0._double,sqrt((gev_pt_max)**2 - particle_mass_squared(had1))) - had1%t=particle_p4square(had1) - - had2%nr=201 - had2%typ=hadron_B_kind - call particle_set_momentum(had2, gev_pt_max, 0._double, 0._double,-sqrt((gev_pt_max)**2 - particle_mass_squared(had2))) - had2%t=particle_p4square(had2) - -! call int%restart() -! call int%generate_pts2() -! gev_next_interaction_pt=int%get_gev_pt() -! do while (int%is_finished()) -! call int%restart() -! call int%generate_pts2() -! gev_next_interaction_pt=int%get_gev_pt() -! end do -! call int%confirm() -! continue_mi=.not.int%is_finished() - call execute_interaction ! add the last generated interaction to the shower - call shower_set_max_ISR_scale(shower,gev_next_interaction_pt) - call next_interaction ! generate the hard interaction with greatest pt < gev_next_interaction_pt - call next_branching ! generate next isr branching, starting at gev_next_interaction_pt - end subroutine find_initial_interaction - - subroutine main_loop ! self-explanatory - do while(continue_mi.or.continue_branching) - print('("Next Interaction | Branching at:",F16.7,"GeV ",F16.7,"GeV ")'),& - &gev_next_interaction_pt,gev_next_shower_pt - if(gev_next_interaction_pt>gev_next_shower_pt)then - print('("execute_interaction")') - call execute_interaction - print('("next_interaction")') - call next_interaction - else - print('("execute_branching")') - call execute_branching - print('("next_branching")') - call next_branching - end if - print('("Continue Interaction | Branching ",L2," ",L2)'),& - &continue_mi,continue_branching - end do - end subroutine main_loop - - subroutine next_interaction() -! call int%generate_pts2() -! gev_next_interaction_pt=int%get_gev_pt() -! continue_mi=.not.int%is_finished() - end subroutine next_interaction - - subroutine execute_interaction - integer,dimension(4)::partons ! the interaction partons - real(kind=double),dimension(2)::fractions ! [x1,x2,(2*pt)^2/s^2] - real(kind=double)::gev_shat ! x1*x2*s - -! call int%generate_partons() -! call int%confirm() - -! partons=int%get_pdg_flavors() -! fractions=int%get_remnant_momentum_fractions() -! gev_shat=int%get_gev_beam_shat() - - allocate(prt1) - allocate(prt2) - allocate(prt3) - allocate(prt4) - - prt1%nr=shower_get_next_free_nr(shower) - prt1%typ=partons(1) - call particle_set_momentum(prt1, gev_next_interaction_pt, 0._double, 0._double, 0.5_double*gev_shat) ! !0.5_double*gev_shat - prt1%x=fractions(1) - prt1%initial=>had1 ! What should we do here? - - prt2%nr=shower_get_next_free_nr(shower) - prt2%typ=partons(2) - call particle_set_momentum(prt2, gev_next_interaction_pt, 0._double, 0._double, -0.5_double*gev_shat) - prt2%x=fractions(2) - prt2%initial=>had2 ! What should we do here? - - prt3%nr=shower_get_next_free_nr(shower) - prt3%typ=partons(3) - call particle_set_momentum(prt3, gev_next_interaction_pt, 0._double, 0._double, -0.5_double*gev_shat) - - prt4%nr=shower_get_next_free_nr(shower) - prt4%typ=partons(4) - call particle_set_momentum(prt4, gev_next_interaction_pt, 0._double, 0._double, -0.5_double*gev_shat) - call shower_add_interaction(shower, prt1, prt2, prt3, prt4) - end subroutine execute_interaction - - subroutine next_branching() - continue_branching=.not.shower_is_finished(shower) - if(continue_branching)then - temppp=shower_generate_next_isr_branching(shower) - if(associated(temppp%p)) then - gev_next_shower_pt=abs(temppp%p%t) - else - gev_next_shower_pt=0._double - continue_branching=.false. - end if - end if - end subroutine next_branching - - subroutine execute_branching - call shower_execute_next_isr_branching(shower, temppp) - end subroutine execute_branching - -end PROGRAM mi_testshower - Index: branches/attic/boschmann_standalone/pri/bin/gnuplot_chains.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/bin/gnuplot_chains.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/bin/gnuplot_chains.f03.pri (revision 8609) @@ -1,136 +0,0 @@ -!!! program: gnuplot_chains -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2010 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2010-10-28 15:10:50 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -PROGRAM gnuplot_chains - use misc_module - use kinds - implicit none - integer,parameter::dim_swap=3 - real(kind=double)::gev_min_pt,gev_d_pt,gev_pt - integer::sample_id,x1_bin,x2_bin,pt_bin,swap - integer::n_runs - integer::n_pt_bins - integer::n_x_bins - integer::n_chain_lengths - integer,dimension(:),allocatable::chain_length_array - integer,dimension(:,:,:,:,:),allocatable::bin_array - call read("chains") - call write_lenghts_plot("chain_lengths") - call write_pt_plot("pt_chains") - call write_some_x_plots() -contains - subroutine read(name) - character(*),intent(in)::name - integer::unit - namelist/parameters/n_runs,n_x_bins,n_pt_bins,n_chain_lengths,gev_min_pt,gev_d_pt - call open_and_echo("output/"//name,unit) - read(unit,nml=parameters) - write(6,nml=parameters) - allocate(chain_length_array(-1:n_chain_lengths)) - read(unit,fmt=*)chain_length_array - allocate(bin_array(0:2,0:n_x_bins,0:n_x_bins,0:n_pt_bins,11)) - print *,shape(bin_array) - do sample_id=1,11 - do pt_bin=0,n_pt_bins - do x2_bin=0,n_x_bins - do x1_bin=0,n_x_bins - read(unit,fmt=*)bin_array(0:2,x1_bin,x2_bin,pt_bin,sample_id) - end do - end do - end do - end do - close(unit) - print *,"Done." - end subroutine read - - subroutine write_pt_plot(name) - character(*),intent(in)::name - integer::unit - call open_and_echo(name,unit) - gev_pt=gev_min_pt - do pt_bin=1,n_pt_bins-1 - write(unit,fmt=*)gev_pt,bin_array(0,0,0,pt_bin,1:11)/(gev_pt*(gev_d_pt-1D0)) - gev_pt=gev_pt*gev_d_pt - end do - close(unit) - end subroutine write_pt_plot - - subroutine write_x_plot(name,par,pt,chan) - character(*),intent(in)::name - integer,intent(in)::par,pt,chan - integer::unit,x1,x2 - call open_there_or_here("plots/x",name,unit) - do x2=1,n_x_bins - do x1=1,n_x_bins - write(unit,fmt=*)bin_array(par,x1,x2,pt,chan) - end do - write(unit,fmt=*)"" - end do - close(unit) - end subroutine write_x_plot - - subroutine write_some_x_plots() - call write_x_plot("all_all_all",0,0,1) - call write_x_plot("evenall_all",1,0,1) - call write_x_plot("odd_all_all",2,0,1) - call write_x_plot("all_all_2",0,0,2) - call write_x_plot("evenall_2",1,0,2) - call write_x_plot("odd_all_2",2,0,2) - call write_x_plot("all_all_3",0,0,3) - call write_x_plot("evenall_3",1,0,3) - call write_x_plot("odd_all_3",2,0,3) - call write_x_plot("all_all_4",0,0,4) - call write_x_plot("evenall_4",1,0,4) - call write_x_plot("odd_all_4",2,0,4) - call write_x_plot("all_all_5",0,0,5) - call write_x_plot("evenall_5",1,0,5) - call write_x_plot("odd_all_5",2,0,5) - call write_x_plot("all_all_6",0,0,6) - call write_x_plot("evenall_6",1,0,6) - call write_x_plot("odd_all_6",2,0,6) - call write_x_plot("all_all_7",0,0,7) - call write_x_plot("evenall_7",1,0,7) - call write_x_plot("odd_all_7",2,0,7) - call write_x_plot("all_all_8",0,0,8) - call write_x_plot("evenall_8",1,0,8) - call write_x_plot("odd_all_8",2,0,8) - call write_x_plot("all_all_9",0,0,9) - call write_x_plot("evenall_9",1,0,9) - call write_x_plot("odd_all_9",2,0,9) - call write_x_plot("all_all_10",0,0,10) - call write_x_plot("evenall_10",1,0,10) - call write_x_plot("odd_all_10",2,0,10) - call write_x_plot("all_all_11",0,0,11) - call write_x_plot("evenall_11",1,0,11) - call write_x_plot("odd_all_11",2,0,11) - end subroutine write_some_x_plots - - subroutine write_lenghts_plot(name) - character(*),intent(in)::name - character::a - integer::unit - call open_and_echo(name,unit) - write(unit,fmt='(I0)')chain_length_array - end subroutine write_lenghts_plot - -end PROGRAM gnuplot_chains - Index: branches/attic/boschmann_standalone/pri/bin/generate_samples.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/bin/generate_samples.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/bin/generate_samples.f03.pri (revision 8609) @@ -1,242 +0,0 @@ -!!! program: generate_samples -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-06-20 11:09:22 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -program generate_samples - use OMP_LIB!FC = gfortran - use sample_fractions_module - use dynamic_binning_3_module,only:log_color_code - use common_module,tao_rnd=>sequentiel_tao_state - use misc_module - use coordinates_module - use lin_approx_tree_module - use beam_remnant_module - use parameters_module - use qcdtypes_module - - !use,intrinsic::ieee_arithmetic!FC = nagfor - implicit none - integer(kind=i64)::n_runs - integer(kind=i64)::n_print - integer(kind=i64)::n_inner - real(kind=double)::boost - integer::integrand_kind - type(sample_inclusive_type)::s - call initialize() -! call read() - call run() -! call write() -! call sample_int_kind_analyse(& -! s%int_kinds(integrand_kind),& -! plot_dir%get_actual_value()//"/analyse_samples/01",& -! "") -! call s%analyse("analyse_samples",.true.) - -contains - - subroutine initialize() - type(integer_argument_type),target,save::runs_arg,print_arg,integrand_kind_arg,limit_boost_arg - call runs_arg%initialize(1000,1,100000000,args,long="runs",named_option="", description="Total number of generated chains.") - call print_arg%initialize(100,1,100000000,args,long="print_every",named_option="", description="Print statistics every generated chains") - call integrand_kind_arg%initialize(1,1,16,args,long="int_kind",named_option="", description="Generate chains for integrand kind .") - call limit_boost_arg%initialize(1,1,2**30,args,long="limit_boost",named_option="", description="The mean value times this boost factor will be the MCG limit.") - call common_run() - n_runs=runs_arg%get_actual_value() - n_print=print_arg%get_actual_value() - integrand_kind=integrand_kind_arg%get_actual_value() - boost=real(limit_boost_arg%get_actual_value(),kind=double) - n_inner=n_runs/n_print - print *,n_runs,n_print,n_inner,integrand_kind,boost - end subroutine initialize - - pure function testfunction(x,process_id) - real(kind=double),dimension(3),intent(in)::x - integer,intent(in)::process_id - real(kind=double)::testfunction - real(kind=double),dimension(3),parameter::mean=[0.5D0,0.5D0,5d-1] - real(kind=double),dimension(3),parameter::var=[1D-2,1D-2,1D2] - if(process_id==1)then - testfunction=(exp(-sum((x-mean)**2/(2*var)))/(15.7496D0*sqrt(product(var)))) - else - testfunction=0D0 - end if - end function testfunction - - subroutine plot_testfunction() - integer::n,m - open(13,file="test") - do n=0,10 - do m=0,10 - write(13,fmt=*)n*1D-1,m*1D-1,testfunction([n*1D-1,m*1D-1,5d-1],1) - end do - write(13,fmt=*)"" - end do - close(13) - end subroutine plot_testfunction - - subroutine run() - type(lin_approx_tree_type)::int_tree - type(beam_remnant_type)::beam - class(lin_approx_node_class),pointer::start_node=>null() - class(lin_approx_node_class),pointer,save::s_node=>null() - class(lin_approx_node_class),pointer,save::node=>null() - - integer,save::t_slice,t_region,t_proc,t_subproc,t_max_n=0 - integer(kind=i64)::n_p,n_i,n_m - integer::n,m,u,unit=0 - integer(kind=i64)::n_tries=0 - integer(kind=i64)::n_hits=0 - integer(kind=i64)::n_over=0 - integer(kind=i64)::n_miss=0 - real(kind=double),save,dimension(3)::cart_hit - integer,save,dimension(4)::t_i_rnd -! integer,save,dimension(5)::r_n_proc - real(kind=double),dimension(16)::d_rnd - real(kind=double),save::t_area,t_dddsigma,t_rnd,t_weight,t_arg - real(kind=double)::mean=0D0 - real(kind=double)::time=0D0 - real(kind=double)::time1=0D0 - real(kind=double)::time2=0D0 - real(kind=double)::time3=0D0 - real(kind=double)::pts,s_pts=1D0 - real(kind=double)::pts2=1D0 - real(kind=double)::rnd - logical::running - character(3)::num - integer::success=-1 - integer::chain_length=0 - integer::int_kind - integer::process_id - real(kind=double),dimension(0:16)::integral - type(page_ring_type)::ring - call ring%open(home_dir%get_actual_value()//"/"//data_dir%get_actual_value()//"/dsigma/int_tree.xml",action="read") - call int_tree%deserialize(ring) - call ring%close - call coordinates_module_init() - call s%initialize(4,int_sizes_all,int_all,1D0/boost) - print *,time,time1,time2 - print:do n_p=1,n_print - inner:do n_i=1,n_inner - running=.true. - chain_length=0 - int_kind=-1 - call cpu_time(time) - time1=time1-time - pts=1D0 - call int_tree%get_rightmost(node) -! print *,"new chain" - chain:do - s_pts=pts - s_node=>node - call tao_random_number(tao_rnd,d_rnd) - call generate_pts(s_pts,s_node,d_rnd,int_tree,beam,int_kind,pts,mean,node) - if(int_kind<0) exit chain - chain_length=chain_length+1 - pts2=pts**2 - call cpu_time(time) - time1=time1+time - time2=time2-time - call s%int_kinds(integrand_kind)%mcgenerate_hit(pts2,mean,integrand_kind,tao_rnd,process_id,cart_hit) - call cpu_time(time) - time3=time3+time -! print *,pts,cart_hit - end do chain - print *,chain_length - end do inner -! print('(7(I11," "),5(E14.7," "))'),n_p,n_print,n_tries,n_hits,n_over,int((n_hits*1D3)/n_tries),int((n_over*1D6)/n_tries),n_hits/real(n_over),time1,time2,time3,s%int_kinds(integrand_kind)%overall_boost - end do print -end subroutine run - -subroutine generate_pts(start_pts,start_node,rnd,int_tree,beam,int_kind,pts,mean,node) - real(kind=double),intent(in)::start_pts - class(lin_approx_node_class),intent(in)::start_node - real(kind=double),dimension(16),intent(in)::rnd - type(lin_approx_tree_type),intent(in)::int_tree - type(beam_remnant_type),intent(in)::beam - integer,intent(out)::int_kind - real(kind=double),intent(out)::pts,mean - class(lin_approx_node_class),pointer,intent(out)::node - class(lin_approx_node_class),pointer::tmp_node - real(kind=double),dimension(16)::start_int - real(kind=double)::tmp_pts - integer::tmp_int_kind -! call start_node%print_all -! print *,start_pts - start_int=start_node%approx_integral(start_pts) - int_kind=-1 - pts=-1D0 - do tmp_int_kind=1,16 - call generate_single_pts(& - tmp_int_kind,& - start_int(tmp_int_kind),& - beam_remnant_get_pdf_int_weight(beam,double_pdf_kinds(1,integrand_kind),double_pdf_kinds(2,integrand_kind)),& - rnd(tmp_int_kind),& - int_tree,& - tmp_pts,& - tmp_node) - if(tmp_pts>pts)then - pts=tmp_pts - int_kind=tmp_int_kind - node=>tmp_node - end if - end do - if(pts>0)mean=node%approx_value_n(pts,integrand_kind) -end subroutine generate_pts - -subroutine generate_single_pts(int_kind,start_int,weight,rnd,int_tree,pts,node) - integer,intent(in)::int_kind - real(kind=double),intent(in)::start_int,weight,rnd -! class(lin_approx_node_class),intent(in)::start_node - type(lin_approx_tree_type),intent(in)::int_tree - real(kind=double),intent(out)::pts - class(lin_approx_node_class),pointer,intent(out)::node - real(kind=double)::arg - arg=start_int-2*log(rnd)/weight - call int_tree%find_decreasing(arg,int_kind,r_integral_index,node) - if(node%get_l_integral(int_kind)>arg)then - pts=node%approx_position_by_integral(int_kind,arg) - else - pts=-1D0 - end if -end subroutine generate_single_pts - -subroutine read() - type(page_ring_type)::ring - integer::sample - character(2)::name - call s%initialize(0,int_sizes_all,int_all,1D0/boost) - do sample=1,16 - call integer_with_leading_zeros(sample,2,name) - call ring%open(output_dir%get_actual_value()//"/sample"//name//".xml",action="read") - call s%int_kinds(sample)%deserialize(ring) - call ring%close() - end do -end subroutine read - - subroutine write() - integer::unit - character(2)::name - call integer_with_leading_zeros(integrand_kind,2,name) - call open_and_echo(output_dir%get_actual_value()//"/sample"//name//".xml",unit) - call s%int_kinds(integrand_kind)%serialize(unit,"SAMPLES") - close(unit) - end subroutine write - -end program generate_samples Index: branches/attic/boschmann_standalone/pri/bin/test.f03.pri =================================================================== --- branches/attic/boschmann_standalone/pri/bin/test.f03.pri (revision 8608) +++ branches/attic/boschmann_standalone/pri/bin/test.f03.pri (revision 8609) @@ -1,94 +0,0 @@ -!!! program: test -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2011 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2011-04-29 11:54:15 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -program test - use common_module,tao_rnd=>sequentiel_tao_state - use coordinates_module - use cuba_types_module - implicit none - integer::x,y - real(kind=double)::rx,ry,res - real(kind=double),target::gev_pt=1D0 - type(cuba_vegas_type)::cv - type(cuba_suave_type)::cs - type(cuba_divonne_type)::cd - type(cuba_cuhre_type)::cc - call common_run() - call coordinates_module_init() -! call cd%set_common(1,2,1d-4,flags=7,userdata=gev_pt) -! call cv%set_deferred(100000,100000) -! call cc%set_deferred(9) -! call cd%set_deferred(9,9,9) -! call cd%integrate(val_sum) -! call cd%print_all() -! res=0D0 -! do x=1,1000 -! rx=x/1D3 -! do y=1,1000 -! ry=y/1D3 -! res=res+f1(rx,ry) -! end do -! end do -! res=res/1D6 -! print *,res -contains - function f1(x1,x2) result(f) - real(kind=double)::f - real(kind=double),intent(in)::x1,x2 - real(kind=double),dimension(-6:6)::pdf -! call evolvepdf(x1,1D0,pdf) - f=sum(pdf) - end function f1 -end program test - -module hallo_m - use kinds -contains - - subroutine val_sum(nx,x,nf,f,ud) - integer,intent(in)::nx,nf - real(kind=double),dimension(nx),intent(in)::x - real(kind=double),dimension(nf),intent(out)::f - real(kind=double),intent(in)::ud - real(kind=double),dimension(-6:6)::pdf -! call evolvepdf(x(1),uc,pdf) - f(1)=(pdf(1)-pdf(-1))/x(1) - f(2)=(pdf(2)-pdf(-2))/x(1) - end subroutine val_sum - subroutine hallo(nx,x,nf,f,ud) - integer,intent(in)::nx,nf - real(kind=double),dimension(nx),intent(in)::x - real(kind=double),dimension(nf),intent(out)::f - real(kind=double),intent(in)::ud - real(kind=double),dimension(-6:6)::pdf1,pdf2 - integer::i,j - f(1)=0D0 - if(x1+x2<1D0)then -! call evolvepdf(x(1),uc,pdf1) -! call evolvepdf(x(2)/x(1),uc,pdf2) - do i=-6,6 - do j=-6,6 - f(1)=f(1)+pdf1(i)*pdf2(j)/x(1) - end do - end do - end if - end subroutine hallo -end module hallo_m Index: branches/attic/boschmann_standalone/makefile =================================================================== --- branches/attic/boschmann_standalone/makefile (revision 8608) +++ branches/attic/boschmann_standalone/makefile (revision 8609) @@ -1 +0,0 @@ -link nagfor_makefile \ No newline at end of file Index: branches/attic/boschmann_standalone/gfortran_makefile =================================================================== --- branches/attic/boschmann_standalone/gfortran_makefile (revision 8608) +++ branches/attic/boschmann_standalone/gfortran_makefile (revision 8609) @@ -1,16 +0,0 @@ -SRC_BIN_DIR=src/bin -SRC_LIB_DIR=src/lib -include common_makefile -FC=gfortran -FCS=nagfor gfortran -NFCS=nagfor - -#FC_COMMON_FLAGS= $< -std=f2003 -ffree-form -ffree-line-length-0 -ggdb -J$(MOD_DIR) -I$(MOD_DIR) -I/usr/include -w #-C=all -FC_COMMON_FLAGS= $< -std=f2003 -ffree-form -ffree-line-length-0 -gdwarf-2 -J$(MOD_DIR) -I$(MOD_DIR) -I/usr/include -w #-fopenmp #-C=all -FC_OBJECT_FLAGS= -fpic -c -o $(LIB_DIR)/$@ -FC_STATIC_FLAGS= -c -o $(LIB_DIR)/$@ -FC_SHARED_FLAGS= -c -o $(LIB_DIR)/$@ -fpic -shared - -$(SHARED_TARGETS): $$($$(basename $$@)_DEPENDENCE) - $(FC) $(FC_COMMON_FLAGS) $(FC_SHARED_FLAGS) - Index: branches/attic/boschmann_standalone/common_makefile =================================================================== --- branches/attic/boschmann_standalone/common_makefile (revision 8608) +++ branches/attic/boschmann_standalone/common_makefile (revision 8609) @@ -1,100 +0,0 @@ -PREFIX=build -BIN_DIR=$(PREFIX)/bin -MOD_DIR=$(PREFIX)/mod -LIB_DIR=$(PREFIX)/lib -PRI_DIR=pri - -OPT_LIB_DIR_FLAGS=$(patsubst %,-L%,$(OPT_LIB_DIRS)) - -vpath % $(BIN_DIR) -vpath %.f03.pri $(PRI_DIR)/lib $(PRI_DIR)/bin -vpath %.f03 $(SRC_LIB_DIR) $(SRC_BIN_DIR) -vpath %.f90 $(SRC_LIB_DIR) $(SRC_BIN_DIR) -vpath %.mod $(MOD_DIR) -vpath %.o $(LIB_DIR) -vpath %.a $(LIB_DIR) -vpath %.so $(LIB_DIR) -vpath %.dummy $(DUMMY_DIR) - -PRI_LIB_SOURCES=$(wildcard $(PRI_DIR)/lib/*.pri) -PRI_BIN_SOURCES=$(wildcard $(PRI_DIR)/bin/*.pri) -F03_LIB_SOURCES=$(patsubst %.pri,%,$(notdir $(PRI_LIB_SOURCES))) -F03_BIN_SOURCES=$(patsubst %.pri,%,$(notdir $(PRI_BIN_SOURCES))) - -WHIZARD_LIB_SOURCES=kinds.f90 constants.f90 lorentz.f90 tao_random_numbers.f90 -FORTRAN_LIB_TARGETS+=parameters.f03 basic_types.f03 momentum.f03 cuba_types.f03 misc.f03 arguments.f03 common.f03 error_stack.f03 phase_space_matrices.f03 remnant_interface.f03 coordinates.f03 remnant.f03 beam_remnant.f03 fibonacci_tree.f03 lin_approx_tree.f03 dynamic_binning.f03 dynamic_binning_3.f03 sample_fractions.f03 qcdtypes.f03 tree_conversion.f03 aqa.f03 aq_sigma.f03 aqd_sigma.f03 remnant_plots.f03 cplots.f03 -SHOWER_LIB_SOURCES=shower_basics.f90 shower_particle.f90 shower_module.f90 -FORTRAN_LIB_SOURCES=$(WHIZARD_LIB_SOURCES) $(FORTRAN_LIB_TARGETS) $(SHOWER_LIB_SOURCES) -PRIMITIVE_SOURCES=$(patsubst %,%.pri,$(FORTRAN_LIB_TARGETS)) -FORTRAN_BIN_SOURCES=$(notdir $(wildcard $(SRC_BIN_DIR)/*.f03) $(wildcard $(SRC_BIN_DIR)/*.f90)) -FORTRAN_SOURCES=$(FORTRAN_LIB_SOURCES) $(FORTRAN_BIN_SOURCES) - -LIB_TARGETS=$(patsubst %,lib%,$(basename $(FORTRAN_LIB_SOURCES))) -OBJECT_TARGETS=$(patsubst %,%.o,$(LIB_TARGETS)) -STATIC_TARGETS=$(patsubst %,%.a,$(LIB_TARGETS)) -SHARED_TARGETS=$(patsubst %,%.so,$(LIB_TARGETS)) -PROGRAM_TARGETS=$(basename $(FORTRAN_BIN_SOURCES)) -DBG_BIN_TARGETS=$(patsubst %,%.g90,$(basename $(FORTRAN_BIN_SOURCES))) -DBG_LIB_TARGETS=$(patsubst %,%.g90,$(basename $(FORTRAN_LIB_SOURCES))) - -include dependence_makefile - -FC_MI_LINKER_FLAGS=$(patsubst %,-l%,$(basename $(FORTRAN_LIB_SOURCES))) -FC_ALIEN_LINKER_FLAGS= -lcuba -lLHAPDF -FC_LINKER_FLAGS=$(FC_MI_LINKER_FLAGS) $(FC_ALIEN_LINKER_FLAGS) - -.PHONY: all sources echo clean shared static programs - -all: shared programs - -sources: $(F03_LIB_SOURCES) $(F03_BIN_SOURCES) - -shared: $(SHARED_TARGETS) - -static: $(STATIC_TARGETS) - -programs: $(PROGRAM_TARGETS) - -clean: - @rm -f $(MOD_DIR)/* - @rm -f $(LIB_DIR)/* - @rm -f $(BIN_DIR)/* - @cd $(SRC_LIB_DIR) && rm -f $(DBG_LIB_TARGETS) && rm -f $(F03_LIB_SOURCES) - @cd $(SRC_BIN_DIR) && rm -f $(DBG_BIN_TARGETS) && rm -f $(F03_BIN_SOURCES) - -echo: - @echo "PREFIX= $(PREFIX)" - @echo "BIN_DIR= $(BIN_DIR)" - @echo "MOD_DIR= $(MOD_DIR)" - @echo "LIB_DIR= $(LIB_DIR)" - @echo "SRC_BIN_DIR= $(SRC_BIN_DIR)" - @echo "SRC_LIB_DIR= $(SRC_LIB_DIR)" - @echo "PRI_LIB_SOURCES=$(PRI_LIB_SOURCES)" - @echo "PRI_BIN_SOURCES=$(PRI_BIN_SOURCES)" - @echo "LIB_SRC_TARGETS=$(FORTRAN_LIB_TARGETS)" - @echo "LIB_SOURCES= $(FORTRAN_LIB_SOURCES)" - @echo "BIN_SOURCES= $(FORTRAN_BIN_SOURCES)" - @echo "LIB_TARGETS= $(LIB_TARGETS)" - @echo "OBJECT_TARGETS= $(OBJECT_TARGETS)" - @echo "STATIC_TARGETS= $(STATIC_TARGETS)" - @echo "SHARED_TARGETS= $(SHARED_TARGETS)" - @echo "PROGRAM_TARGETS=$(PROGRAM_TARGETS)" - @echo "DBG_TARGETS= $(DBG_TARGETS)" - -.SECONDEXPANSION: - -$(F03_LIB_SOURCES): $$(@F).pri - cat $< | awk 'BEGIN{FS="!"} {if ($$NF=="FC = $(NFCS)") {print "!" $$0} else {print $$0}}' > $(SRC_LIB_DIR)/$(@F) - -$(F03_BIN_SOURCES): $$(@F).pri - cat $< | awk 'BEGIN{FS="!"} {if ($$NF=="FC = $(NFCS)") {print "!" $$0} else {print $$0}}' > $(SRC_BIN_DIR)/$(@F) - -$(OBJECT_TARGETS): $$($$(basename $$@)_DEPENDENCE) - $(FC) $(FC_COMMON_FLAGS) $(FC_OBJECT_FLAGS) - -$(STATIC_TARGETS): $$($$(basename $$@)_DEPENDENCE) - $(FC) $(FC_COMMON_FLAGS) $(FC_STATIC_FLAGS) - -$(PROGRAM_TARGETS): $$@.f03 - $(FC) $(FC_COMMON_FLAGS) -o $(BIN_DIR)/$@ -L$(LIB_DIR) $(OPT_LIB_DIR_FLAGS) $(FC_LINKER_FLAGS) - Index: branches/attic/boschmann_standalone/dependence_makefile =================================================================== --- branches/attic/boschmann_standalone/dependence_makefile (revision 8608) +++ branches/attic/boschmann_standalone/dependence_makefile (revision 8609) @@ -1,37 +0,0 @@ -libaqa_DEPENDENCE=aqa.f03 -libaq_sigma_DEPENDENCE=aq_sigma.f03 -libaqd_sigma_DEPENDENCE=aqd_sigma.f03 -libarguments_DEPENDENCE=arguments.f03 -libbasic_types_DEPENDENCE=basic_types.f03 -libbeam_remnant_DEPENDENCE=beam_remnant.f03 -libcommon_DEPENDENCE=common.f03 -libconstants_DEPENDENCE=constants.f90 -libcoordinates_DEPENDENCE=coordinates.f03 -libcplots_DEPENDENCE=cplots.f03 -libcuba_types_DEPENDENCE=cuba_types.f03 -libdecision_tree_DEPENDENCE=decision_tree.f03 -libdynamic_binning_DEPENDENCE=dynamic_binning.f03 -libdynamic_binning_3_DEPENDENCE=dynamic_binning_3.f03 -liberror_stack_DEPENDENCE=error_stack.f03 -libfibonacci_tree_DEPENDENCE=fibonacci_tree.f03 -libprint_ieee_support_DEPENDENCE=print_ieee_support.f03 -libkinds_DEPENDENCE=kinds.f03 -liblin_approx_tree_DEPENDENCE=lin_approx_tree.f03 -liblorentz_DEPENDENCE=lorentz.f90 -libmisc_DEPENDENCE=misc.f03 -libmomentum_DEPENDENCE=momentum.f03 -libparameters_DEPENDENCE=parameters.f03 -libphase_space_matrices_DEPENDENCE=phase_space_matrices.f03 -libqcdtypes_DEPENDENCE=qcdtypes.f03 -libremnant_DEPENDENCE=remnant.f03 -libremnant_interface_DEPENDENCE=remnant_interface.f03 -libremnant_plots_DEPENDENCE=remnant_plots.f03 -libsample_fractions_DEPENDENCE=sample_fractions.f03 -libsample_fractions_new_DEPENDENCE=sample_fractions_new.f03 -libtao_random_numbers_DEPENDENCE=tao_random_numbers.f90 -libtestfunctions_DEPENDENCE=testfunctions.f03 -libtree_conversion_DEPENDENCE=tree_conversion.f03 -libshower_basics_DEPENDENCE=shower_basics.f90 -libshower_module_DEPENDENCE=shower_module.f90 -libshower_particle_DEPENDENCE=shower_particle.f90 - Index: branches/attic/boschmann_standalone/src/lib/shower_particle.f90 =================================================================== --- branches/attic/boschmann_standalone/src/lib/shower_particle.f90 (revision 8608) +++ branches/attic/boschmann_standalone/src/lib/shower_particle.f90 (revision 8609) @@ -1,974 +0,0 @@ -!!! module: shower_particle_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2010 Sebastian Schmidt -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: Fri Mar 26 14:50:53 2010 Time zone: 3600 seconds -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module shower_particle_module - - ! WHIZARD modules - use kinds, only: double - use constants, only: pi, twopi - use lorentz - ! my modules - use shower_basics_module - - implicit none - - type :: particle_t -! private - integer :: nr=0 ! numbering the partons - integer :: typ=0 ! kF-Code of the particle - type(vector4_t) :: momentum = vector4_null - real(kind=double) :: t = 0._double - real(kind=double) :: scale = 0._double ! needed for pt-ordered showers - real(kind=double) :: z = 0._double - real(kind=double) :: costheta = 0._double - real(kind=double) :: x=0._double ! x-value of the parton, only needed for spacelike shower - logical :: simulated=.false. - logical :: belongstoFSR=.true. - logical :: belongstointeraction=.false. - type(particle_t), pointer :: parent => null () - type(particle_t), pointer :: child1 => null () - type(particle_t), pointer :: child2 => null () - type(particle_t), pointer :: initial => null () ! only needed for particles in initial showers, points to the hadron the parton is coming from - type(particle_t), pointer :: colorpartner => null () - type(particle_t), pointer :: anticolorpartner => null () - end type particle_t - - type :: particle_pointer_t - type(particle_t), pointer :: p => null () - end type particle_pointer_t - -contains - - function particle_get_costheta(prt) result(costheta) ! returns the angle between the daughters assuming them to be massless - type(particle_t), intent(in) :: prt - real(kind=double) :: costheta - - if(prt%z*(1.-prt%z)*vector4_get_component(prt%momentum, 0)**2 .gt. 0._double) then - costheta = 1.-prt%t/(2.*prt%z*(1.-prt%z)*vector4_get_component(prt%momentum,0)**2) - else - costheta = -1._double - end if - end function particle_get_costheta - - function particle_get_costheta_korrekt(prt) result(costheta) ! returns the angle between the daughters for massive daughters - type(particle_t), intent(in) :: prt - real(kind=double) :: costheta - - if (particle_is_branched(prt)) then - if (particle_is_simulated(prt%child1) .and. particle_is_simulated(prt%child2) .and. sqrt(max(0._double, prt%z*prt%z*vector4_get_component(prt%momentum,0)*vector4_get_component(prt%momentum,0) - prt%child1%t)) * sqrt(max(0._double, (1.-prt%z)*(1.-prt%z)*vector4_get_component(prt%momentum,0)*vector4_get_component(prt%momentum,0) - prt%child2%t)) > 0._double) then - costheta=(prt%t-prt%child1%t-prt%child2%t - 2.*prt%z*(1.-prt%z)*& -vector4_get_component(prt%momentum,0)**2)/(-2.* sqrt(prt%z*prt%z*vector4_get_component(prt%momentum,0)**2 - prt%child1%t) * sqrt( (1.-prt%z)*(1.-prt%z)*vector4_get_component(prt%momentum,0)**2 - prt%child2%t)) - else - costheta = particle_get_costheta(prt) - end if - else - costheta = particle_get_costheta(prt) - end if - end function particle_get_costheta_korrekt - - function particle_get_costheta_motherfirst(prt) result(costheta) ! returns the angle between the momentum vectors of the particle and 1st daughter - type(particle_t), intent(in) :: prt - real(kind=double) :: costheta - - if (particle_is_branched(prt)) then - if ((particle_is_simulated(prt%child1).or.particle_is_final(prt%child1).or.particle_is_branched(prt%child1)) .and. (particle_is_simulated(prt%child2).or.particle_is_final(prt%child2).or.particle_is_branched(prt%child2)) .and. (space_part_norm(prt%momentum)*space_part_norm(prt%child1%momentum) > 0._double) ) then - costheta=(space_part(prt%momentum)*space_part(prt%child1%momentum))/(space_part_norm(prt%momentum)*space_part_norm(prt%child1%momentum)) - else - costheta=-2._double - end if - else - costheta = -2._double - end if - end function particle_get_costheta_motherfirst - - function get_beta(t,E) result(beta) - real(kind=double), intent(in) :: t,E - real(kind=double) :: beta - - beta=sqrt(max(0.000001_double , 1._double-t/(E*E))) - end function get_beta - - function particle_get_beta(prt) result(beta) - type(particle_t), intent(in) :: prt - real(kind=double) :: beta - - beta = get_beta(prt%t, vector4_get_component(prt%momentum,0)) - end function particle_get_beta - - subroutine particle_print(prt) - type(particle_t), intent(in) :: prt - - write(*,100, ADVANCE = "NO") prt%nr -100 format(1x, I5) - if(particle_is_final(prt)) then -110 format(1x,' ', I5, ' ') - write(*, 110, ADVANCE="NO") prt%typ - else -111 format(1x,'(', I5, ')') - write(*, 111, ADVANCE="NO") prt%typ - end if -101 format(I5) -102 format(5x) - if (associated(prt%parent)) then - write(*,101, ADVANCE="NO") prt%parent%nr - else - write(*,102, ADVANCE="NO") - end if -103 format(1x, F9.3, F9.3, F9.3, F10.3, F14.5, F14.5, F14.5) - write(*,103, ADVANCE="NO") vector4_get_component(prt%momentum,1), vector4_get_component(prt%momentum,2), vector4_get_component(prt%momentum,3), vector4_get_component(prt%momentum,0), particle_p4square(prt), prt%t, prt%scale - - ! TODO always print x - if (particle_is_branched(prt)) then -104 format(1x, F8.5, F8.5, F8.5, F8.5, F8.5, 1x, A1) - if(prt%belongstoFSR) then - write(*,104, ADVANCE="NO") prt%z, particle_get_costheta(prt), particle_get_costheta_korrekt(prt), prt%costheta, particle_get_costheta_motherfirst(prt), 'b' - else - write(*,104, ADVANCE="NO") prt%z, prt%x, particle_get_costheta_korrekt(prt), prt%costheta, particle_get_costheta_motherfirst(prt), 'b' - end if - else - if(prt%belongstoFSR) then -105 format(43x) - write(*,105, ADVANCE="NO") - else -106 format(9x, F8.5, 26x) - write(*,106, ADVANCE="NO") prt%x - end if - end if -107 format(A1) - if(prt%belongstoFSR) then - write(*,107, ADVANCE="NO") "F" - else - write(*,107, ADVANCE="NO") "I" - end if - if(particle_is_final(prt)) then - write(*,107, ADVANCE="NO") "f" - else - write(*,107, ADVANCE="NO") " " - end if - - if(particle_is_simulated(prt)) then - write(*,107, ADVANCE="NO") "s" - else - write(*,107, ADVANCE="NO") " " - end if - if(associated(prt%child1).and.associated(prt%child2)) then -108 format(" C:", I3, I3) - write(*,108, ADVANCE="NO") prt%child1%nr,prt%child2%nr - else if(associated(prt%child1)) then -109 format(" C:", I3) - write(*,109, ADVANCE="NO") prt%child1%nr - end if - if(associated(prt%initial)) then -112 format(" I:", I4) - write(*,112, ADVANCE="NO") prt%initial%nr - end if - if(prt%belongstointeraction .eqv. .true.) then - write(*,107, ADVANCE="NO") "T" - end if -113 format(A4) -114 format(I4) - write(*, 113, ADVANCE = "NO") " CPP: " - if(associated(prt%colorpartner)) then - write(*, 114, ADVANCE="NO") prt%colorpartner%nr - else - write(*, 113, ADVANCE="NO") " " - end if - if(associated(prt%anticolorpartner)) then - write(*, 114, ADVANCE="NO") prt%anticolorpartner%nr - else - write(*, 113, ADVANCE="NO") " " - end if - write(*,*) - end subroutine particle_print - - function particle_is_final(prt) result(is_final) - type(particle_t), intent(in) :: prt - logical :: is_final - - is_final=((.not. associated(prt%child1)).and. (prt%nr/=-1) .and. (prt%nr/=-2) .and. (prt%belongstointeraction.eqv..false.)) - end function particle_is_final - - function particle_is_branched(prt) result(is_branched) - type(particle_t), intent(in) :: prt - logical :: is_branched - - is_branched = (associated(prt%child1).and.associated(prt%child2)) - end function particle_is_branched - - subroutine particle_set_simulated(prt, sim) - type(particle_t), intent(inout) :: prt - logical, intent(in), optional :: sim - - if(present(sim)) then - prt%simulated=sim - else - prt%simulated=.true. - end if - end subroutine particle_set_simulated - - function particle_is_simulated(prt) result(is_simulated) - type(particle_t), intent(in) :: prt - logical :: is_simulated - - is_simulated = prt%simulated - end function particle_is_simulated - - function particle_get_momentum(prt, i) result(mom) - type(particle_t), intent(in) :: prt - integer, intent(in) :: i - real(kind=double) :: mom - - select case (i) - case(0) - mom=vector4_get_component(prt%momentum,0) - case(1) - mom=vector4_get_component(prt%momentum,1) - case(2) - mom=vector4_get_component(prt%momentum,2) - case(3) - mom=vector4_get_component(prt%momentum,3) - case default - mom=0 - end select - end function particle_get_momentum - - subroutine particle_set_momentum(prt, EE, ppx, ppy, ppz) - type(particle_t), intent(inout) :: prt - real(kind=double), intent(in) :: EE, ppx, ppy, ppz - - prt%momentum = vector4_moving(EE, vector3_moving( (/ppx, ppy, ppz/) ) ) - end subroutine particle_set_momentum - - subroutine particle_set_energy(prt, E) - type(particle_t), intent(inout) :: prt - real(kind=double), intent(in) :: E - - prt%momentum = vector4_moving(E, space_part(prt%momentum)) - end subroutine particle_set_energy - - function particle_get_energy(prt) result(E) - type(particle_t), intent(inout) :: prt - real(kind=double) :: E - - E = vector4_get_component(prt%momentum, 0) - end function particle_get_energy - - subroutine particle_set_parent(prt, parent) - type(particle_t), intent(inout) :: prt - type(particle_t), intent(in) , target :: parent - - prt%parent=>parent - end subroutine particle_set_parent - - function particle_get_parent(prt) result(parent) - type(particle_t), intent(in) :: prt - type(particle_t), pointer :: parent - - parent=>prt%parent - end function particle_get_parent - - subroutine particle_set_child(prt, child, i) - type(particle_t), intent(inout) :: prt - type(particle_t), intent(in), target :: child - integer, intent(in) :: i - if (i .eq. 1) then - prt%child1 => child - else - prt%child2 => child - end if - end subroutine particle_set_child - - function particle_get_child(prt,i) result(child) - type(particle_t), intent(in) :: prt - integer, intent(in) :: i - type(particle_t), pointer :: child - - child => null() - if(i.eq.1) then - child=>prt%child1 - else - child=>prt%child2 - end if - end function particle_get_child - - recursive subroutine particle_update_color_connections(prt) - type(particle_t), intent(in) ::prt - - if( (.not. associated(prt%child1)) .or. (.not. associated(prt%child2)) ) return - - if(particle_is_gluon(prt)) then - if(particle_is_quark(prt%child1)) then - ! give the quark the colorpartner and the antiquark the anticolorpartner - if(prt%child1%typ>0) then - ! child1 is quark, child2 is antiquark - prt%child1%colorpartner => prt%colorpartner - prt%child1%colorpartner%anticolorpartner => prt%child1 - prt%child2%anticolorpartner => prt%anticolorpartner - prt%child2%anticolorpartner%colorpartner => prt%child2 - else - ! child1 is antiquark, child2 is quark - prt%child1%anticolorpartner => prt%anticolorpartner - prt%child1%anticolorpartner%colorpartner => prt%child1 - prt%child2%colorpartner => prt%colorpartner - prt%child2%colorpartner%anticolorpartner => prt%child2 - end if - else - ! g -> gg splitting -> random choosing of partners - if(DoubleRand() > 0.5_double) then - prt%child1%colorpartner => prt%colorpartner - prt%child1%colorpartner%anticolorpartner => prt%child1 - prt%child1%anticolorpartner => prt%child2 - prt%child2%colorpartner => prt%child1 - prt%child2%anticolorpartner => prt%anticolorpartner - prt%child2%anticolorpartner%colorpartner => prt%child2 - else - prt%child1%anticolorpartner => prt%anticolorpartner - prt%child1%anticolorpartner%colorpartner => prt%child1 - prt%child1%colorpartner => prt%child2 - prt%child2%anticolorpartner => prt%child1 - prt%child2%colorpartner => prt%colorpartner - prt%child2%colorpartner%anticolorpartner => prt%child2 - end if - end if - else if(particle_is_quark(prt)) then - if(particle_is_quark(prt%child1)) then - if(prt%child1%typ>0) then - prt%child1%colorpartner => prt%child2 - prt%child2%anticolorpartner => prt%child1 - prt%child2%colorpartner => prt%colorpartner - prt%colorpartner%anticolorpartner => prt%child2 - else - prt%child1%anticolorpartner => prt%child2 - prt%child2%colorpartner => prt%child1 - prt%child2%anticolorpartner => prt%anticolorpartner - prt%anticolorpartner%colorpartner => prt%child2 - end if - else - if(prt%child2%typ>0) then - prt%child2%colorpartner => prt%child1 - prt%child1%anticolorpartner => prt%child2 - prt%child1%colorpartner => prt%colorpartner - prt%colorpartner%anticolorpartner => prt%child1 - else - prt%child2%anticolorpartner => prt%child1 - prt%child1%colorpartner => prt%child2 - prt%child1%anticolorpartner => prt%anticolorpartner - prt%anticolorpartner%colorpartner => prt%child1 - end if - end if - end if - - call particle_update_color_connections(prt%child1) - call particle_update_color_connections(prt%child2) - end subroutine particle_update_color_connections - - function particle_is_quark(prt) result(is_quark) - type(particle_t), intent(in) ::prt - logical :: is_quark - - is_quark=((abs(prt%typ) <= 6) .and. (prt%typ.ne.0)) - end function particle_is_quark - - function particle_is_gluon(prt) result(is_gluon) - type(particle_t), intent(in) :: prt - logical :: is_gluon - - is_gluon = (prt%typ .eq. 21) - end function particle_is_gluon - - function particle_is_hadron(prt) result(is_hadron) - type(particle_t), intent(in) ::prt - logical :: is_hadron - - is_hadron=(abs(prt%typ) .eq. 2212) ! only proton implemented yet - end function particle_is_hadron - - function particle_p4square(prt) result(p4square) - type(particle_t), intent(in) :: prt - real(kind=double) :: p4square - - p4square=prt%momentum**2 - end function particle_p4square - - function particle_p3square(prt) result(p3square) - type(particle_t), intent(in) :: prt - real(kind=double) :: p3square - - p3square=particle_p3abs(prt)**2 - end function particle_p3square - - function particle_p3abs(prt) result(p3abs) - type(particle_t), intent(in) :: prt - real(kind=double) :: p3abs - - p3abs=space_part_norm(prt%momentum) - end function particle_p3abs - - function particle_mass(prt) result(mass) - type(particle_t), intent(in) :: prt - real(kind=double) :: mass - - mass=mass_typ(prt%typ) - end function particle_mass - - function particle_mass_squared(prt) result(mass_squared) - type(particle_t), intent(in) :: prt - real(kind=double) :: mass_squared - - mass_squared=mass_squared_typ(prt%typ) - end function particle_mass_squared - - function P_prt_to_child1(prt) result(retvalue) - type(particle_t), intent(in) :: prt - real(kind=double) :: retvalue - - if(particle_is_gluon(prt)) then - if(particle_is_quark(prt%child1)) then - retvalue=P_gqq(prt%z) - else if(particle_is_gluon(prt%child1)) then - retvalue=P_ggg(prt%z)+P_ggg(1._double-prt%z) - end if - else if(particle_is_quark(prt)) then - if(particle_is_quark(prt%child1)) then - retvalue=P_qqg(prt%z) - else if(particle_is_gluon(prt%child1)) then - retvalue=P_qqg(1._double-prt%z) - end if - end if - end function P_prt_to_child1 - - function thetabar(prt) result(retvalue) - ! returns whether kinematics of branching of prt into its daughters are allowed - type(particle_t), intent(inout) :: prt - logical :: retvalue - - real(kind=double) :: ctheta, cthetachild1 - real(kind=double) p1, p2, p3 - - p1=sqrt(vector4_get_component(prt%momentum,0)**2-prt%t) - if( (prt%child1%nr.eq.-1).or.(prt%child1%nr.eq.-2) ) then - p2=sqrt(vector4_get_component(prt%child1%momentum, 1)**2+vector4_get_component(prt%child1%momentum, 2)**2+vector4_get_component(prt%child1%momentum, 3)**2) - else - p2=sqrt(vector4_get_component(prt%child1%momentum, 0)**2-prt%child1%t) - end if - p3=sqrt(max(0._double, vector4_get_component(prt%child2%momentum, 0)**2-prt%child2%t)) - - if(p3>0._double) then - retvalue=( (p2+p3 .ge. p1) .and. (p1 .ge. abs(p2-p3)) ) - if (retvalue .eqv. .true.) then - ! check angular ordering - if(associated(prt%child1)) then - if(associated(prt%child1%child2)) then - ctheta=( prt%child1%t + prt%child2%t + 2._double*prt%z*(1._double-prt%z)*(vector4_get_component(prt%momentum,0)**2)-prt%t )/( 2._double*p2*p3 ) - cthetachild1=( prt%child1%child1%t + prt%child1%child2%t + 2._double*prt%child1%z*(1._double-prt%child1%z)*(vector4_get_component(prt%child1%momentum, 0)**2)-prt%child1%t )/( 2._double*sqrt(prt%child1%z**2*vector4_get_component(prt%child1%momentum, 0)**2 - prt%child1%child1%t)*sqrt((1._double-prt%child1%z)**2*vector4_get_component(prt%child1%momentum, 0)**2-prt%child1%child2%t) ) - retvalue= (ctheta > cthetachild1) - end if - end if - end if - else - retvalue=.false. - end if - end function thetabar - - recursive subroutine particle_apply_z(prt, newz) - type(particle_t), intent(inout) :: prt - real(kind=double), intent(in) :: newz - - if (D_print) print *, "old z:", prt%z , " new z: ", newz - prt%z=newz - if(associated(prt%child1) .and. associated(prt%child2) ) then - call particle_set_energy(prt%child1, newz*vector4_get_component(prt%momentum,0)) - call particle_apply_z(prt%child1, prt%child1%z) - call particle_set_energy(prt%child2, (1.-newz)*vector4_get_component(prt%momentum,0)) - call particle_apply_z(prt%child2, prt%child2%z) - end if - end subroutine particle_apply_z - - recursive subroutine particle_apply_costheta(prt) - type(particle_t), intent(inout) :: prt - - prt%z=0.5_double*(1._double+particle_get_beta(prt)*prt%costheta) - if(associated(prt%child1) .and. associated(prt%child2) ) then - if(particle_is_simulated(prt%child1) .and. particle_is_simulated(prt%child2)) then - prt%z=0.5_double*(1._double+(prt%child1%t-prt%child2%t)/prt%t+particle_get_beta(prt)*prt%costheta*sqrt( (prt%t - prt%child1%t - prt%child2%t)**2 - 4 *prt%child1%t*prt%child2%t)/prt%t) - if(prt%typ .ne. 94) then - call particle_set_energy(prt%child1, prt%z*vector4_get_component(prt%momentum,0)) - call particle_set_energy(prt%child2, (1._double-prt%z)*vector4_get_component(prt%momentum,0)) - end if - call particle_generate_ps(prt) - call particle_apply_costheta(prt%child1) - call particle_apply_costheta(prt%child2) - end if - end if - end subroutine particle_apply_costheta - - subroutine particle_apply_lorentztrafo(prt, L) - type(particle_t), intent(inout) :: prt - type(lorentz_transformation_t), intent(in) :: L - - prt%momentum = L*prt%momentum - end subroutine particle_apply_lorentztrafo - - recursive subroutine particle_apply_lorentztrafo_recursiv(prt, L) - type(particle_t), intent(inout) :: prt - type(lorentz_transformation_t) ,intent(in) :: L - - if(prt%typ/=2212.and.prt%typ/=9999) then ! don't boost hadrons and beam-remnants - call particle_apply_lorentztrafo(prt, L) - end if - if(associated(prt%child1) .and. associated(prt%child2)) then - if(particle_p3abs(prt%child1).eq.0._double .and. particle_p3abs(prt%child2).eq.0._double) then - ! don't boost unevolved timelike particles - else - call particle_apply_lorentztrafo_recursiv(prt%child1, L) - call particle_apply_lorentztrafo_recursiv(prt%child2, L) - end if - else - if(associated(prt%child1)) then - call particle_apply_lorentztrafo_recursiv(prt%child1, L) - end if - if(associated(prt%child2)) then - call particle_apply_lorentztrafo_recursiv(prt%child2, L) - end if - end if - end subroutine particle_apply_lorentztrafo_recursiv - - subroutine particle_generate_ps(prt) - ! takes the three-momentum of a particle and generates three-momenta of its children - type(particle_t), intent(inout) :: prt - real(kind=double), dimension(1:3, 1:3) :: directions - integer i,j - real(kind=double) :: scprodukt, pbetrag, p1betrag, p2betrag, x, pTbetrag, phi - real(kind=double), dimension(1:3) :: momentum - - type(vector3_t) :: pchild1_direction - type(lorentz_transformation_t) :: L, rotation - - if(D_print) print *, " generate_ps for particle " , prt%nr - if(.not. (associated(prt%child1) .and. associated(prt%child2))) then - print *, "no children for generate_ps" - return - end if - ! test if particle is a virtual parton from the imagined parton shower history - if(prt%typ .eq. 94) then - L = inverse(boost(prt%momentum, sqrt(prt%t))) ! boost to restframe of mother - call particle_apply_lorentztrafo(prt, L) - call particle_apply_lorentztrafo(prt%child1, L) - call particle_apply_lorentztrafo(prt%child2, L) - - ! store child1's momenta - pchild1_direction = direction(space_part(prt%child1%momentum)) - - ! redistribute energy - call particle_set_energy(prt%child1, (vector4_get_component(prt%momentum, 0)**2-prt%child2%t+prt%child1%t)/(2._double*vector4_get_component(prt%momentum, 0))) - call particle_set_energy(prt%child2, vector4_get_component(prt%momentum, 0)-vector4_get_component(prt%child1%momentum, 0)) - - ! rescale momenta and set momenta to be along z-axis - prt%child1%momentum = vector4_moving( vector4_get_component(prt%child1%momentum, 0), vector3_moving( (/ 0._double, 0._double, sqrt(vector4_get_component(prt%child1%momentum,0)**2-prt%child1%t) /) ) ) - prt%child2%momentum = vector4_moving( vector4_get_component(prt%child2%momentum, 0), vector3_moving( (/ 0._double, 0._double, -sqrt(vector4_get_component(prt%child2%momentum,0)**2-prt%child2%t) /) ) ) - - ! rotate so that total momentum is along former total momentum - rotation = rotation_to_2nd(space_part(prt%child1%momentum), pchild1_direction) - call particle_apply_lorentztrafo(prt%child1, rotation) - call particle_apply_lorentztrafo(prt%child2, rotation) - - L = inverse(L) ! inverse of the boost to restframe of mother - call particle_apply_lorentztrafo(prt, L) - call particle_apply_lorentztrafo(prt%child1, L) - call particle_apply_lorentztrafo(prt%child2, L) - else - ! directions(1,:) -> direction of the parent parton - if(particle_p3abs(prt) .eq. 0._double) return - do i=1,3 - directions(1,i) = particle_get_momentum(prt,i)/particle_p3abs(prt) - end do - ! directions(2,:) and directions(3,:) -> two random directions perpendicular to the direction of the parent parton - do i=1,3 - do j=2,3 - directions(j,i) = DoubleRand() - end do - end do - do i=2,3 - scprodukt=0._double - do j=1, i-1 - scprodukt = directions(i,1)*directions(j,1)+directions(i,2)*directions(j,2)+directions(i,3)*directions(j,3) - directions(i,1)=directions(i,1)-directions(j,1)*scprodukt - directions(i,2)=directions(i,2)-directions(j,2)*scprodukt - directions(i,3)=directions(i,3)-directions(j,3)*scprodukt - end do - scprodukt=directions(i,1)**2+directions(i,2)**2+directions(i,3)**2 - do j=1,3 - directions(i,j) = directions(i,j)/sqrt(scprodukt) - end do - end do - ! enforce righthanded system - if((directions(1,1)*(directions(2,2)*directions(3,3)-directions(2,3)& -*directions(3,2))+directions(1,2)*(directions(2,3)*directions(3,1)-& -directions(2,1)*directions(3,3))+directions(1,3)*(directions(2,1)*directions(3,2)& --directions(2,2)*directions(3,1)))<0) then - directions(3,1)=-directions(3,1) - directions(3,2)=-directions(3,2) - directions(3,3)=-directions(3,3) - end if - - pbetrag=particle_p3abs(prt) - if( (vector4_get_component(prt%child1%momentum, 0)**2-prt%child1%t < 0) .or. (vector4_get_component(prt%child2%momentum, 0)**2 - prt%child2%t < 0)) then - if(D_print) print *, "err: error at generate_ps(), E^2 < t" - return - end if - p1betrag = sqrt(vector4_get_component(prt%child1%momentum, 0)**2-prt%child1%t) - p2betrag = sqrt(vector4_get_component(prt%child2%momentum, 0)**2-prt%child2%t) - x=(pbetrag*pbetrag +p1betrag*p1betrag - p2betrag*p2betrag)/(2.*pbetrag) - if(particle_p3abs(prt)>p1betrag+p2betrag .or. particle_p3abs(prt) < abs(p1betrag-p2betrag)) then - if(D_print) then - print *,"error at generate_ps, Dreiecksungleichung for particle ",prt%nr, " ", particle_p3abs(prt)," ",p1betrag," ",p2betrag - call particle_print(prt) - call particle_print(prt%child1) - call particle_print(prt%child2) - end if - return - end if - pTbetrag=sqrt(max(p1betrag*p1betrag - x*x, 0._double)) ! due to numerical problems transverse momentum could be imaginary -> set transverse momentum to zero - phi=2.*pi*DoubleRand() - do i=1,3 - momentum(i) = x*directions(1,i)+pTbetrag*(cos(phi)*directions(2,i)+sin(phi)*directions(3,i)) - end do - call particle_set_momentum(prt%child1, vector4_get_component(prt%child1%momentum, 0), momentum(1), momentum(2), momentum(3)) - do i=1,3 - momentum(i) = (particle_p3abs(prt)-x)*directions(1,i)-pTbetrag*(cos(phi)*directions(2,i)+sin(phi)*directions(3,i)) - end do - call particle_set_momentum(prt%child2, vector4_get_component(prt%child2%momentum, 0), momentum(1), momentum(2), momentum(3)) - end if - end subroutine particle_generate_ps - - subroutine particle_generate_ps_ini(prt) - ! takes the three-momentum of a particles first child as fixed and generates the two remaining three-momenta, similar to particle_generate_ps, but now for ISR - type(particle_t), intent(inout) :: prt - real(kind=double), dimension(1:3, 1:3) :: directions - integer i,j - real(kind=double) :: scprodukt, pbetrag, p1betrag, p2betrag, x, pTbetrag, phi - real(kind=double), dimension(1:3) :: momentum - - if(D_print) print *, " generate_ps_ini for particle " , prt%nr - if(.not. (associated(prt%child1) .and. associated(prt%child2))) then - print *, "error in particle_generate_ps_ini" - return - end if - - if(particle_is_hadron(prt) .eqv. .false.) then ! generate ps for normal particles - do i=1,3 - directions(1,i) = particle_get_momentum(prt%child1,i)/particle_p3abs(prt%child1) - end do - do i=1,3 - do j=2,3 - directions(j,i) = DoubleRand() - end do - end do - do i=2,3 - scprodukt=0._double - do j=1, i-1 - scprodukt = directions(i,1)*directions(j,1)+directions(i,2)*directions(j,2)+directions(i,3)*directions(j,3) - directions(i,1)=directions(i,1)-directions(j,1)*scprodukt - directions(i,2)=directions(i,2)-directions(j,2)*scprodukt - directions(i,3)=directions(i,3)-directions(j,3)*scprodukt - end do - scprodukt=directions(i,1)**2+directions(i,2)**2+directions(i,3)**2 - do j=1,3 - directions(i,j) = directions(i,j)/sqrt(scprodukt) - end do - end do - ! enforce righthanded system - if((directions(1,1)*(directions(2,2)*directions(3,3)-directions(2,3)& - *directions(3,2))+directions(1,2)*(directions(2,3)*directions(3,1)-& - directions(2,1)*directions(3,3))+directions(1,3)*(directions(2,1)*directions(3,2)& - -directions(2,2)*directions(3,1)))<0) then - directions(3,1)=-directions(3,1) - directions(3,2)=-directions(3,2) - directions(3,3)=-directions(3,3) - end if - - pbetrag=particle_p3abs(prt%child1) - p1betrag = sqrt(vector4_get_component(prt%momentum,0)**2-prt%t) - p2betrag = sqrt(max(0._double, vector4_get_component(prt%child2%momentum, 0)**2-prt%child2%t)) - - x=(pbetrag*pbetrag +p1betrag*p1betrag - p2betrag*p2betrag)/(2.*pbetrag) - if(pbetrag>p1betrag+p2betrag .or.& - pbetrag < abs(p1betrag-p2betrag)) then - ! if(D_print) - print *,"error at generate_ps, Dreiecksungleichung for particle ",prt%nr, " ", pbetrag," ",p1betrag," ",p2betrag - call particle_print(prt) - call particle_print(prt%child1) - call particle_print(prt%child2) - return - end if - if(D_print) print *, "x:",x - pTbetrag=sqrt(p1betrag*p1betrag - x*x) - phi=2.*pi*DoubleRand() - do i=1,3 - momentum(i) = x*directions(1,i)+pTbetrag*(cos(phi)*directions(2,i)+sin(phi)*directions(3,i)) - end do - call particle_set_momentum(prt, vector4_get_component(prt%momentum,0), momentum(1), momentum(2), momentum(3)) - do i=1,3 - momentum(i) = (x-pbetrag)*directions(1,i)+pTbetrag*(cos(phi)& - *directions(2,i)+sin(phi)*directions(3,i)) - end do - call particle_set_momentum(prt%child2, vector4_get_component(prt%child2%momentum, 0), momentum(1), momentum(2), momentum(3)) - else ! for first particles just set beam remnants momentum - prt%child2%momentum = prt%momentum - prt%child1%momentum - end if - end subroutine particle_generate_ps_ini - -! ---------------------analytic FSR----------------- - - function cmax(prt, tt) result(cma) - type(particle_t), intent(in) :: prt - real(kind=double), intent(in), optional :: tt - real(kind=double) :: cma - - real(kind=double) :: t, cost - - if(present(tt)) then - t = tt - else - t = prt%t - end if - - if(associated(prt%parent)) then - cost = particle_get_costheta(prt%parent) - cma = min(0.99999_double, sqrt( max(0._double, 1._double - t/(particle_get_beta(prt)*vector4_get_component(prt%momentum,0))**2 * (1._double+cost)/(1._double-cost) ))) - else - cma = 0.99999_double - end if - end function cmax - - subroutine particle_next_t_ana(prt) - type(particle_t), intent(inout) :: prt - integer :: gtoqq - - real(kind=double) :: integral, zufall - - if(D_print) then - print *, "next_t_ana for particle " , prt%nr - end if - - ! check if branchings are possible at all - prt%t=min(prt%t, abs(prt%parent%t) ) - if(min(prt%t, vector4_get_component(prt%momentum, 0)**2) int(x) will be the quark flavour or zero for g -> gg - end if - exit - end if - end do - end subroutine particle_next_t_ana - - subroutine particle_simulate_stept(prt, integral, zufall, gtoqq, lookatsister) - type(particle_t), intent(inout) :: prt - real(kind=double), intent(inout) :: integral - real(kind=double), intent(inout) :: zufall - integer, intent(out) :: gtoqq - logical, intent(in), optional :: lookatsister ! take limitations by sister into account, if not given assume .true. - - type(particle_t), pointer :: sister - real(kind=double) :: tstep,tmin, oldt - real(kind=double) :: c, cstep - real(kind=double) :: z(3), P(3) - real(kind=double) :: zuintegral - real(kind=double) :: a11,a12,a13,a21,a22,a23 - real(kind=double) :: cmax_t - - ! values for integration - real(kind=double) :: a(3),x(3) - - ! higher values -> faster but coarser - real(kind=double), parameter :: tstepfactor=0.02_double - real(kind=double), parameter :: tstepmin=0.5_double - real(kind=double), parameter :: cstepfactor=0.8_double - real(kind=double), parameter :: cstepmin=0.03_double - - gtoqq = 111 ! illegal value - call particle_set_simulated(prt, .false.) - - sister=>null() - if(present(lookatsister)) then - if(lookatsister .eqv. .true.) then - if(prt%nr.eq.prt%parent%child1%nr) then - sister => prt%parent%child2 - else - sister => prt%parent%child1 - end if - end if - else - if(prt%nr.eq.prt%parent%child1%nr) then - sister => prt%parent%child2 - else - sister => prt%parent%child1 - end if - end if - - tmin=D_Min_t+particle_mass_squared(prt) - if(particle_is_quark(prt)) then - zuintegral = 3._double*pi*log(1._double/zufall) - else if(particle_is_gluon(prt)) then - zuintegral = 4._double*pi*log(1._double/zufall) - else - stop "Bug: neither quark nor gluon (particle_simulate_stept)" - end if - - if(associated(sister)) then - if(sqrt(prt%t) > sqrt(prt%parent%t) - sqrt(particle_mass_squared(sister))) then - prt%t=(sqrt(prt%parent%t) - sqrt(particle_mass_squared(sister)))**2 - end if - end if - if(prt%t>vector4_get_component(prt%momentum,0)**2) then - prt%t=vector4_get_component(prt%momentum,0)**2 - end if - - if(prt%t .le. tmin) then - prt%t=particle_mass_squared(prt) - call particle_set_simulated(prt) - return - end if - -! simulate the branchings between prt%t and prt%t-tstep - tstep=max(tstepfactor*(prt%t-0.9_double*tmin), tstepmin) - cmax_t=cmax(prt) - c=-cmax_t ! take highest t -> minimal constraint - cstep=max(cstepfactor*(1._double-abs(c)), cstepmin) - ! get values at border of "previous" bin -> to be used in first bin - z(3)=0.5_double+0.5_double*get_beta(prt%t-0.5_double*tstep, vector4_get_component(prt%momentum,0))*c - if(particle_is_gluon(prt)) then - P(3)=P_ggg(z(3))+P_gqq(z(3))*number_of_flavors(prt%t) - else - P(3)=P_qqg(z(3)) - end if - a(3)=D_alpha_s(z(3)*(1._double-z(3))*prt%t)*P(3)/(prt%t-0.5_double*tstep) - - do while(ccmax_t) then - cstep=cmax_t-c - end if - if(cstep < 1D-10) then - ! reject too small bins - exit - end if - z(1)=z(3) - z(2)=0.5_double+0.5_double*get_beta(prt%t-0.5_double*tstep, vector4_get_component(prt%momentum,0))*(c+0.5_double*cstep) - z(3)=0.5_double+0.5_double*get_beta(prt%t-0.5_double*tstep, vector4_get_component(prt%momentum,0))*(c+cstep) - P(1)=P(3) - if(particle_is_gluon(prt)) then - P(2)=P_ggg(z(2))+P_gqq(z(2))*number_of_flavors(prt%t) - P(3)=P_ggg(z(3))+P_gqq(z(3))*number_of_flavors(prt%t) - else - P(2)=P_qqg(z(2)) - P(3)=P_qqg(z(3)) - end if - ! get values at borders of the intgral and in the middle - a(1)=a(3) - a(2)=D_alpha_s(z(2)*(1._double-z(2))*prt%t)*P(2)/(prt%t-0.5_double*tstep) - a(3)=D_alpha_s(z(3)*(1._double-z(3))*prt%t)*P(3)/(prt%t-0.5_double*tstep) - - ! fit x(1)+x(2)/(1+c)+x(3)/(1-c) to these values !! a little tricky - a11=(1._double+c+0.5_double*cstep)*(1._double-c-0.5_double*cstep)-(1._double-c)*(1._double+c+0.5_double*cstep) - a12=(1._double-c-0.5_double*cstep)-(1._double+c+0.5_double*cstep)*(1._double-c)/(1._double+c) - a13=a(2)*(1._double+c+0.5_double*cstep)*(1._double-c-0.5_double*cstep)-a(1)*(1._double-c)*(1._double+c+0.5_double*cstep) - a21=(1._double+c+cstep)*(1._double-c-cstep)-(1._double+c+cstep)*(1._double-c) - a22=(1._double-c-cstep)-(1._double+c+cstep)*(1._double-c)/(1._double+c) - a23=a(3)*(1._double+c+cstep)*(1._double-c-cstep)-a(1)*(1._double-c)*(1._double+c+cstep) - - x(2)=(a23-a21*a13/a11)/(a22-a12*a21/a11) - x(1)=(a13-a12*x(2))/a11 - x(3)=a(1)*(1._double-c)-x(1)*(1._double-c)-x(2)*(1._double-c)/(1._double+c) - - integral=integral+tstep*(x(1)*cstep+x(2)*log((1._double+c+cstep)/(1._double+c))-x(3)*log((1._double-c-cstep)/(1._double-c))) - - if(integral>zuintegral) then - oldt=prt%t - prt%t=prt%t-DoubleRand()*tstep - prt%costheta=c+(0.5_double-DoubleRand())*cstep - call particle_set_simulated(prt) - - if(prt%t < D_Min_t + particle_mass_squared(prt)) then - prt%t=particle_mass_squared(prt) - end if - if(prt%costheta.lt.-cmax_t .or. prt%costheta.gt.cmax_t) then - ! reject branching due to violation of costheta-limits - zufall=DoubleRand() - if(particle_is_quark(prt)) then - zuintegral = 3._double*pi*log(1._double/zufall) - else if(particle_is_gluon(prt)) then - zuintegral = 4._double*pi*log(1._double/zufall) - end if - integral=0._double - prt%t=oldt - call particle_set_simulated(prt, .false.) - end if - if(particle_is_gluon(prt)) then - ! decide between g->gg and g->qqbar - z(1)=0.5_double+0.5_double*prt%costheta - if(P_ggg(z(1)) > DoubleRand()*(P_ggg(z(1))+P_gqq(z(1))*number_of_flavors(prt%t))) then - gtoqq=0 - else - gtoqq=1+DoubleRand()*number_of_flavors(prt%t) - end if - end if - else - c=c+cstep - end if - cmax_t=cmax(prt) - end do - if(integral<=zuintegral) then - prt%t=prt%t-tstep - if(prt%t < D_Min_t + particle_mass_squared(prt)) then - prt%t=particle_mass_squared(prt) - call particle_set_simulated(prt) - end if - end if - end subroutine particle_simulate_stept - -!------------------------------------------------------------ -! ISR-algorithm -! all the ISR-stuff moved to shower_module.f90 -! only maxzz remains here -> needed in more than one procedure in shower_module - - function maxzz(shat, s) result(maxz) - real(kind=double), intent(in) :: shat,s - real(kind=double) :: maxz - - maxz=min(maxz_isr, 1._double-(2._double*minenergy_timelike*sqrt(shat))/s) - end function maxzz - -end module shower_particle_module Index: branches/attic/boschmann_standalone/src/lib/shower_basics.f90 =================================================================== --- branches/attic/boschmann_standalone/src/lib/shower_basics.f90 (revision 8608) +++ branches/attic/boschmann_standalone/src/lib/shower_basics.f90 (revision 8609) @@ -1,216 +0,0 @@ -!!! module: shower_basics_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2010 Sebastian Schmidt -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: Fri Mar 26 14:50:24 2010 Time zone: 3600 seconds -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module shower_basics_module - - use kinds, only: double - use constants, only : pi, twopi - use tao_random_numbers - - implicit none - - ! technical constants - logical, parameter :: D_print=.false. ! decides whether to print out additional information - - ! physical parameters - real(kind=double), parameter :: D_Min_t=1._double ! cut-off scale t_cut, given in GeV^2 - real(Kind=Double), parameter :: D_min_scale=0.5_double ! Cut-Off Scale For Pt^2 Ordered Shower, Given In Gev^2 - real(kind=double), parameter :: D_Lambda=0.29_double - real(kind=double), parameter :: D_pt2min=(max(0.25*D_Min_t, 1.1*D_Lambda))**2 - - ! settings - integer, parameter :: D_Nf=5 ! maximum number of flavours in gluon decay to quarks - logical, parameter :: D_running_alpha_s=.true. ! decides whether to use constant or running alpha_s -> see function D_alpha_s(t) - real(kind=double), parameter :: D_constalpha_s = 0.20_double - logical :: isr_pt_ordered = .true. ! should be a parameter?? - - ! varying parameters - real(kind=double), parameter :: primordial_kt_width=0._double ! was 1.5_double ! width of Gaussian primordial kt distribution - real(kind=double), parameter :: primordial_kt_cutoff=5._double ! cutoff for Gaussian primordial kt distribution - real(kind=double) :: maxz_isr=0.999_double ! should be a parameter - real(kind=double), parameter :: minenergy_timelike=1._double ! min energy of emitted timelike parton in isr - real(kind=double) :: tscalefactor_isr=1._double ! factor for first scale, default=1 ! should be a parameter - real(kind=double) :: first_integral_suppression_factor=1._double ! factor, by which the integral in the sudhakov-factor is suppressed for the respective first scale in isr ! should be a parameter - - ! auxiliary and temporaily paramters - real(kind=double) :: scalefactor1 = 0.02_double - real(kind=double) :: scalefactor2 = 0.02_double - -contains - - function DoubleRand() result(random) ! returns a random value in the range 0:1 - real(kind=double) :: random - - call tao_random_number(random) - end function DoubleRand - -!!$ function DoubleRand() result(random) ! returns a random value in the range 0:1 -!!$ COMMON/RANDHIST/hist(0:99) -!!$ SAVE /RANDHIST/ -!!$ -!!$ real(kind=double) :: random -!!$ integer :: hist -!!$ -!!$ call tao_random_number(random) -!!$ hist(floor(random*100)) = hist(floor(random*100))+1 -!!$ end function DoubleRand -!!$ -!!$ subroutine DoubleRand_print() -!!$ COMMON/RANDHIST/hist(0:99) -!!$ SAVE /RANDHIST/ -!!$ integer :: hist -!!$ integer :: i -!!$ -!!$ do i=0,99 -!!$ print *, "rand", 0.01_double*i, hist(i) -!!$ end do -!!$ end subroutine DoubleRand_print - - subroutine DoubleRand_randomseed(seed) - integer, intent(in), optional :: seed - integer :: clock - - if(present(seed)) then - clock = seed - else - CALL SYSTEM_CLOCK(COUNT=clock) - end if - call tao_random_seed(clock) - end subroutine DoubleRand_randomseed - - function D_alpha_s(tin) result(alpha_s) - real(kind=double), intent(in) :: tin - real(kind=double) :: b,t - real(kind=double) :: alpha_s - -! arbitrary lower cut off for scale -! t=MAX(max(1._double*D_Min_t, 1.1_double*D_Lambda**2), ABS(tin)) - t=max(max(0.1_double*D_Min_t, 1.1_double*D_Lambda**2), abs(tin)) - - if(D_running_alpha_s) then - b=(33._double-2._double*number_of_flavors(t))/(12._double*pi) - alpha_s=1._double/(b*log(t/(D_Lambda**2))) - else - alpha_s = D_constalpha_s - end if - end function D_alpha_s - - function mass_typ(typ) result(mass) ! mass in GeV - integer, intent(in) :: typ - real(kind=double) :: mass - -!!$ SELECT CASE(ABS(typ)) -!!$ ! It is assumed that quark masses are ordered mass(1)qq decay - real(kind=double), intent(in) :: t - integer :: nr - - integer :: i - - nr=0 - if(t < 0.25_double*D_Min_t) return ! arbitrary cut off ?WRONG? - do i=1,min(D_Nf,3) ! to do: take heavier quarks(-> cuts on allowed costheta in g->qq) into account - if( (4._double*mass_squared_typ(i)+D_Min_t) < t ) then - nr=i - else - exit - end if - end do - end function number_of_flavors - - function P_qqg(z) result(P) - real(kind=double), intent(in) :: z - real(kind=double) :: P - - P=(4._double/3._double)*(1._double+z**2)/(1._double-z) - end function P_qqg - - function P_gqq(z) result(P) - real(kind=double), intent(in) :: z - real(kind=double) :: P - - P=0.5_double*(z**2+(1._double-z)**2) -! P=(1._double-z)**2 ! anti-symmetrized version -> needs change of first and second daughter in 50% of branchings - end function P_gqq - - function P_ggg(z) result(P) - real(kind=double), intent(in) :: z - real(kind=double) :: P - - P=3._double*( (1._double-z)/z + z/(1._double-z) + z*(1._double-z) ) -! P=3._double*( 2._double*z/(1._double-z) + z*(1._double-z) ) ! anti-symmetrized version -> needs to by symmetrized in color connections - end function P_ggg - -end module shower_basics_module Index: branches/attic/boschmann_standalone/src/lib/constants.f90 =================================================================== --- branches/attic/boschmann_standalone/src/lib/constants.f90 (revision 8608) +++ branches/attic/boschmann_standalone/src/lib/constants.f90 (revision 8609) @@ -1,66 +0,0 @@ -! WHIZARD <> <> - -! (C) 1999-2009 by -! Wolfgang Kilian -! Thorsten Ohl -! Juergen Reuter -! with contributions by Sebastian Schmidt -! -! WHIZARD is free software; you can redistribute it and/or modify it -! under the terms of the GNU General Public License as published by -! the Free Software Foundation; either version 2, or (at your option) -! any later version. -! -! WHIZARD is distributed in the hope that it will be useful, but -! WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module constants - - use kinds, only: default !NODEP! - - implicit none - private - - complex(default), parameter, public :: & - ii = (0._default, 1._default) - - real(default), parameter, public :: & - one = 1.0_default, two = 2.0_default, three = 3.0_default, & - four = 4.0_default, five = 5.0_default - - real(default), parameter, public :: & - pi = 3.1415926535897932384626433832795028841972_default - - real(default), parameter, public :: & - twopi = 2*pi, & - twopi2 = twopi**2, twopi3 = twopi**3, twopi4 = twopi**4, & - twopi5 = twopi**5, twopi6 = twopi**6 - - real(default), parameter, public :: & - degree = pi/180 - - real(default), parameter, public :: & - conv = 0.38937966e12_default - - real(default), parameter, public :: & - pb_per_fb = 1.e-3_default - - real(default), parameter, public :: & - NC = three, CF = (NC**2 - one)/two/NC, CA = NC, & - TR = one/two - - character(*), parameter, public :: & - energy_unit = "GeV" - - character(*), parameter, public :: & - cross_section_unit = "fb" - -end module constants Index: branches/attic/boschmann_standalone/src/lib/shower_module.f90 =================================================================== --- branches/attic/boschmann_standalone/src/lib/shower_module.f90 (revision 8608) +++ branches/attic/boschmann_standalone/src/lib/shower_module.f90 (revision 8609) @@ -1,2531 +0,0 @@ -!!! module: shower_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2010 Hans-Werner Boschmann -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: 2010-10-01 10:04:08 CEST(+0200) -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!! module: shower_module -!!! This code is part of my Ph.D studies. -!!! -!!! Copyright (C) 2010 Sebastian Schmidt -!!! -!!! This program is free software; you can redistribute it and/or modify it -!!! under the terms of the GNU General Public License as published by the Free -!!! Software Foundation; either version 3 of the License, or (at your option) -!!! any later version. -!!! -!!! This program is distributed in the hope that it will be useful, but WITHOUT -!!! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!!! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -!!! more details. -!!! -!!! You should have received a copy of the GNU General Public License along -!!! with this program; if not, see . -!!! -!!! Latest Change: Fri Mar 26 14:50:58 2010 Time zone: 3600 seconds -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module shower_module - - use kinds, only: double - use constants, only: pi, twopi - use shower_basics_module - use shower_particle_module - use lorentz - - implicit none - - type :: interaction_t - type(particle_pointer_t) :: in1, in2 - type(particle_pointer_t) :: out1, out2 - - type(particle_pointer_t), dimension(:), allocatable :: particles - end type interaction_t - - type :: interaction_pointer_t - type(interaction_t), pointer :: i => null() - end type interaction_pointer_t - - type :: shower_t - type(interaction_pointer_t), dimension(:), allocatable :: interactions - type(particle_pointer_t), dimension(:), allocatable :: particles - integer :: next_free_nr - end type shower_t - - contains - - subroutine shower_add_interaction(shower, prtin1, prtin2, prtout1, prtout2) - type(shower_t), intent(inout) :: shower - type(particle_t), intent(inout), target :: prtin1, prtin2, prtout1, prtout2 - integer :: i - integer :: n_interactions, n_particles - - type(interaction_pointer_t), dimension(:), allocatable :: temp - type(particle_pointer_t), dimension(:), allocatable :: temp_particles - - ! ensure that belongstointeraction is set - prtin1%belongstointeraction=.true. - prtin2%belongstointeraction=.true. - prtout1%belongstointeraction=.true. - prtout2%belongstointeraction=.true. - ! ensure that belogstoFSR is set correctly - prtin1%belongstoFSR=.false. - prtin2%belongstoFSR=.false. - prtout1%belongstoFSR=.true. - prtout2%belongstoFSR=.true. - - if(allocated(shower%interactions)) then - n_interactions=size(shower%interactions)+1 - else - n_interactions=1 - end if - - allocate(temp(1:n_interactions)) - do i=1, n_interactions-1 - allocate(temp(i)%i) - temp(i)%i=shower%interactions(i)%i - end do - allocate(temp(n_interactions)%i) - temp(n_interactions)%i%in1%p=>prtin1 - temp(n_interactions)%i%in2%p=>prtin2 - temp(n_interactions)%i%out1%p=>prtout1 - temp(n_interactions)%i%out2%p=>prtout2 - allocate(temp(n_interactions)%i%particles(1:4)) - temp(n_interactions)%i%particles(1)%p=>prtin1 - temp(n_interactions)%i%particles(2)%p=>prtin2 - temp(n_interactions)%i%particles(3)%p=>prtout1 - temp(n_interactions)%i%particles(4)%p=>prtout2 - - n_particles=0 - if(allocated(shower%particles)) then - do i=1, size(shower%particles) - if(associated(shower%particles(i)%p)) n_particles=i - end do - else - n_particles=0 - end if - do i=1, n_particles - if(.not. associated(shower%particles(i)%p)) then - stop " BUG: non associated pointer before associated ones (1)" - end if - end do - - allocate(temp_particles(1:n_particles+4)) - do i=1, n_particles - temp_particles(i)%p=>shower%particles(i)%p - end do - temp_particles(n_particles+1)%p=>prtin1 - temp_particles(n_particles+2)%p=>prtin2 - temp_particles(n_particles+3)%p=>prtout1 - temp_particles(n_particles+4)%p=>prtout2 - - if(allocated(shower%interactions)) deallocate(shower%interactions) - if(allocated(shower%particles)) deallocate(shower%particles) - allocate(shower%interactions(1:n_interactions)) - do i=1, n_interactions - shower%interactions(i)%i=>temp(i)%i - end do - allocate(shower%particles(1:size(temp_particles))) - do i=1, size(shower%particles) - shower%particles(i)%p=>temp_particles(i)%p - end do - - ! if ISR is possible (-> initial particle set, lepton-hadron not implemented) - if(associated(prtin1%initial) .and. associated(prtin2%initial)) then - if(isr_pt_ordered) then - call shower_prepare_for_simulate_isr_pt(shower, shower%interactions(size(shower%interactions))%i) - else - call shower_prepare_for_simulate_isr_ana(shower, prtin1, prtin2) - end if - end if -! ! FSR is always possible -! call shower_prepare_for_simulate_fsr_ana(shower, prtout1, prtout2) ! moved to shower_interaction_generate_fsr - end subroutine shower_add_interaction - - subroutine shower_add_interaction2ton(shower, particles) - type(shower_t), intent(inout) :: shower - type(particle_pointer_t), intent(inout), dimension(:), allocatable :: particles - - integer :: n_particles_initial, n_particles, n_out, n_particles_shower - integer :: i,j, imin, jmin - real(kind=double) :: y, ymin ! the jet measure - real(kind=double) :: s ! s of the interaction - type(particle_pointer_t), dimension(:), allocatable :: new_particles - type(particle_t), pointer :: prt - integer :: n_interactions - type(interaction_pointer_t), dimension(:), allocatable :: temp - type(vector4_t) :: prtmomentum, childmomentum - - n_particles_initial = size(particles) - n_out = n_particles_initial-2 - if(n_out < 2) then - STOP "BUG: trying to add a 2-> (something<2) interaction" - end if - print *, " adding a 2-> ", n_out, " interaction" - - ! add the incoming and outgoing partons to the interaction - if(allocated(shower%interactions)) then - n_interactions=size(shower%interactions)+1 - else - n_interactions=1 - end if - allocate(temp(1:n_interactions)) - do i=1, n_interactions-1 - allocate(temp(i)%i) - temp(i)%i=shower%interactions(i)%i - end do - allocate(temp(n_interactions)%i) - allocate(temp(n_interactions)%i%particles(1:n_particles_initial)) - do i=1, n_particles_initial - temp(n_interactions)%i%particles(i)%p => particles(i)%p - end do - allocate(shower%interactions(1:n_interactions)) - do i=1, n_interactions - shower%interactions(i)%i=>temp(i)%i - end do - - ! add in1 and in2 - shower%interactions(n_interactions)%i%in1%p => particles(1)%p - shower%interactions(n_interactions)%i%in2%p => particles(2)%p - - ! generate pseudo PartonShower history and add all particles to shower%particles-array - s = ( particles(1)%p%momentum + particles(2)%p%momentum)**2 - do i=1, size(particles) - ! ensure that particles are marked as belonging to the hard interaction - particles(i)%p%belongstointeraction = .true. - ! ensure that incoming partons are marked as belonging to ISR - if(i.le.2) particles(i)%p%belongstoFSR = .false. - end do - - clustering: do - if(size(particles).eq.3) then - ! no more clustering possible - exit clustering - end if - - ! search for the partons to be clustered together - n_particles = size(particles) - n_out = n_particles-2 - ymin=1._double - outer: do i = 3, n_particles-1 - inner: do j = i+1, n_particles - ! calculate the jet measure - if(.not. shower_clustering_allowed(shower, particles, i,j)) cycle inner - ! Durham jet-measure - y = 2._double * min(vector4_get_component(particles(i)%p%momentum,0), vector4_get_component(particles(j)%p%momentum,0)) *(1._double -enclosed_angle_ct(particles(i)%p%momentum,particles(j)%p%momentum)) / s - if(yparticles(i)%p - j=j+1 - end do - print *, n_particles-1, j - allocate(new_particles(j)%p) - prt=>new_particles(j)%p - prt%nr = shower_get_next_free_nr(shower) - prt%typ = 94 ! something for internal use needed, 81-100 should be reserved for internal purposes - call particle_set_child(prt, particles(imin)%p, 1) - call particle_set_child(prt, particles(jmin)%p, 2) - call particle_set_parent(particles(imin)%p, prt) - call particle_set_parent(particles(jmin)%p, prt) - - prt%momentum = particles(imin)%p%momentum + particles(jmin)%p%momentum - prt%t = prt%momentum**2 - ! TODO -> calculate costheta and store it for later use in generate_ps - prtmomentum = prt%momentum - childmomentum = prt%child1%momentum - - print *, space_part_norm(prt%momentum) - - if(space_part_norm(prt%momentum) > 1D-10) then - - prtmomentum = boost(-particle_get_beta(prt)/sqrt(1._double-(particle_get_beta(prt))**2), space_part(prt%momentum)/space_part_norm(prt%momentum)) * prtmomentum - childmomentum = boost(-particle_get_beta(prt)/sqrt(1._double-(particle_get_beta(prt))**2), space_part(prt%momentum)/space_part_norm(prt%momentum)) * childmomentum - - print *, vector4_get_components(prt%momentum) - print *, vector4_get_components(prtmomentum) - print *, vector4_get_components(childmomentum) - - prt%costheta = enclosed_angle_ct(prt%momentum, childmomentum) - print *, enclosed_angle_ct(prt%momentum, childmomentum) - else - prt%costheta=-1._double - end if -! call particle_print(prt) - -! pause - - - prt%belongstointeraction = .true. - deallocate(particles) - allocate(particles(1:size(new_particles))) - do i=1, size(new_particles) - particles(i)%p => new_particles(i)%p - call particle_print(new_particles(i)%p) - end do - deallocate(new_particles) - end do clustering - - ! add all particles to the shower - print *, "adding" - if(allocated(shower%particles)) then - do i=1, size(shower%particles) - if(associated(shower%particles(i)%p)) n_particles_shower=i - end do - else - n_particles_shower=0 - end if - do i=1, n_particles_shower - if(.not. associated(shower%particles(i)%p)) then - stop " BUG: non associated pointer before associated ones (1)" - end if - end do - - allocate(new_particles(1:n_particles_shower+2*n_particles_initial-1)) - do i=1, n_particles_shower - new_particles(i)%p=>shower%particles(i)%p - end do -! print *, size(new_particles), size(shower%particles), n_particles_shower - i=n_particles_shower+1 - call transfer_pointers(new_particles, i , particles(1)%p) ! - call transfer_pointers(new_particles, i , particles(2)%p) ! the two initial ones - call transfer_pointers(new_particles, i , particles(3)%p) ! the imaginry mother of the FSR - - if(allocated(shower%particles)) deallocate(shower%particles) - allocate(shower%particles(1:size(new_particles))) - do i=1, size(shower%particles) - shower%particles(i)%p=>new_particles(i)%p - end do - - ! set the cut-off scale for all particles - call set_starting_scale(particles(3)%p, get_starting_scale(particles(3)%p)) - - do i=1, size(shower%particles) - if(.not. associated(shower%particles(i)%p)) cycle - call particle_print(shower%particles(i)%p) - end do - - contains - logical function shower_clustering_allowed(shower, particles, i, j) - type(shower_t), intent(inout) :: shower - type(particle_pointer_t), intent(in), dimension(:), allocatable :: particles - integer, intent(in) :: i, j - - ! TODO implement checking if clustering is allowed, e.g. in e+e- -> qqg don't cluster the quarks together first - shower_clustering_allowed = .true. - end function shower_clustering_allowed - - recursive subroutine transfer_pointers(destiny, start, prt) - type(particle_pointer_t), dimension(:), allocatable :: destiny - integer, intent(inout) :: start - type(particle_t), pointer :: prt - - destiny(start)%p => prt - start=start+1 - if(associated(prt%child1)) then - call transfer_pointers(destiny, start, prt%child1) - end if - if(associated(prt%child2)) then - call transfer_pointers(destiny, start, prt%child2) - end if - end subroutine transfer_pointers - - recursive function get_starting_scale(prt) result(scale) - type(particle_t), pointer :: prt - real(kind=double) :: scale - - scale = 1D6 - if(prt%t > 0._double) then - scale = prt%t - end if - if(associated(prt%child1)) then - scale = min(scale, get_starting_scale(prt%child1)) - end if - if(associated(prt%child2)) then - scale = min(scale, get_starting_scale(prt%child2)) - end if - end function get_starting_scale - - recursive subroutine set_starting_scale(prt, scale) - type(particle_t), pointer :: prt - real(kind=double) :: scale - - if(prt%typ .ne. 94) then - if(scale > D_Min_t + particle_mass_squared(prt)) then - prt%t = scale - else - prt%t = particle_mass_squared(prt) - call particle_set_simulated(prt) - end if - end if - if(associated(prt%child1)) then - call set_starting_scale(prt%child1, scale) - end if - if(associated(prt%child2)) then - call set_starting_scale(prt%child2, scale) - end if - end subroutine set_starting_scale - end subroutine shower_add_interaction2ton - - subroutine swap_pointers(prtp1, prtp2) - type(particle_pointer_t), intent(inout) :: prtp1, prtp2 - type(particle_pointer_t) :: prtptemp - - prtptemp%p=>prtp1%p - prtp1%p=>prtp2%p - prtp2%p=>prtptemp%p - - end subroutine swap_pointers - - subroutine shower_remove_particle_from_particles(shower, prt) - type(shower_t), intent(inout) :: shower - type(particle_t), pointer :: prt - integer :: i - - do i=1, size(shower%particles) - if(associated(shower%particles(i)%p, prt)) then - shower%particles(i)%p=>null() - exit - end if - if(i.eq.size(shower%particles)) then - stop "Bug: particle to be removed not found" - end if - end do -! deallocate(prt) - end subroutine shower_remove_particle_from_particles - - recursive subroutine shower_remove_particle_from_particles_recursive(shower, prt) - ! remove prt and all its children - type(shower_t), intent(inout) :: shower - type(particle_t), intent(in), pointer :: prt - - if(associated(prt%child1)) then - call shower_remove_particle_from_particles_recursive(shower, prt%child1) - end if - if(associated(prt%child2)) then - call shower_remove_particle_from_particles_recursive(shower, prt%child2) - end if - call shower_remove_particle_from_particles(shower, prt) - end subroutine shower_remove_particle_from_particles_recursive - - subroutine shower_sort_particles(shower) - type(shower_t), intent(inout) :: shower - integer i,j, maxsort, size_particles - logical :: changed - -!!$ print *, " shower_sort_particles" - - size_particles=size(shower%particles) - do i=1, size_particles - if(associated(shower%particles(i)%p)) maxsort=i - end do - - size_particles=size(shower%particles) - if(size_particles<=1) return - - do i=1, maxsort - if(.not. associated(shower%particles(i)%p)) cycle - if(isr_pt_ordered .eqv. .false.) then - ! set unsimulated ISR partons to be "typeless" to prevent influences from "wrong" masses - if( (shower%particles(i)%p%belongstoFSR.eqv. .false.) .and. (particle_is_simulated(shower%particles(i)%p).eqv. .false.) .and. (shower%particles(i)%p%belongstointeraction .eqv. .false.)) then - shower%particles(i)%p%typ=0 - end if - end if - end do - ! just a Bubblesort - ! different algorithms needed for t-ordered and pt^2-ordered shower - if(isr_pt_ordered) then ! pt-ordered - outerdo_pt: do i=1, maxsort-1 - changed=.false. - innerdo_pt: do j=1, maxsort-i - if(.not. associated(shower%particles(j+1)%p)) cycle - - if(.not. associated(shower%particles(j)%p)) then - ! change if j+1 ist assoaciated and j isn't - call swap_pointers(shower%particles(j), shower%particles(j+1)) - changed=.true. - else if(shower%particles(j)%p%scale < shower%particles(j+1)%p%scale) then - call swap_pointers(shower%particles(j), shower%particles(j+1)) - changed=.true. - else if(shower%particles(j)%p%scale .eq. shower%particles(j+1)%p%scale) then - if(shower%particles(j)%p%nr >shower%particles(j+1)%p%nr) then - call swap_pointers(shower%particles(j), shower%particles(j+1)) - changed=.true. - end if - end if - end do innerdo_pt - if(changed.eqv..false.) exit outerdo_pt - end do outerdo_pt - else ! |t|-ordered - outerdo_t: do i=1, maxsort-1 - changed=.false. - innerdo_t: do j=1, maxsort-i - if(.not. associated(shower%particles(j+1)%p)) cycle - - if(.not. associated(shower%particles(j)%p)) then - ! change if j+1 ist assoaciated and j isn't - call swap_pointers(shower%particles(j), shower%particles(j+1)) - changed=.true. - else if((shower%particles(j)%p%belongstointeraction.eqv..false.) .and. (shower%particles(j+1)%p%belongstointeraction.eqv..true.)) then - ! move particles belonging to the interaction to the front - call swap_pointers(shower%particles(j), shower%particles(j+1)) - changed=.true. - else if( (shower%particles(j)%p%belongstointeraction.eqv..false.) .and. (shower%particles(j+1)%p%belongstointeraction.eqv..false.) ) then - if(abs(shower%particles(j)%p%t)-particle_mass_squared(shower%particles(j)%p) < abs(shower%particles(j+1)%p%t)-particle_mass_squared(shower%particles(j+1)%p)) then - call swap_pointers(shower%particles(j), shower%particles(j+1)) - changed=.true. - else - if(abs(shower%particles(j)%p%t)-particle_mass_squared(shower%particles(j)%p) .eq. abs(shower%particles(j+1)%p%t)-particle_mass_squared(shower%particles(j+1)%p)) then - if(shower%particles(j)%p%nr >shower%particles(j+1)%p%nr) then - call swap_pointers(shower%particles(j), shower%particles(j+1)) - changed=.true. - end if - end if - end if - end if - end do innerdo_t - if(changed.eqv..false.) exit outerdo_t - end do outerdo_t - end if - -!!$ print *, " shower_sort_particles finished" - end subroutine shower_sort_particles - - !!! creation and finalization - - subroutine shower_create(shower) - type(shower_t), intent(inout) :: shower - - shower%next_free_nr=1 - if(allocated(shower%interactions)) then - STOP "Bug: creating new shower while old one still associated (interactions)" - end if - if(allocated(shower%particles)) then - STOP "Bug: creating new shower while old one still associated (particles)" - end if - end subroutine shower_create - - subroutine shower_final(shower) - type(shower_t), intent(inout) :: shower - integer :: i - - if(.not. allocated(shower%interactions)) then - return - end if - - ! deallocate hadrons - if(associated(shower%interactions(1)%i%in1%p%initial)) deallocate(shower%interactions(1)%i%in1%p%initial) - if(associated(shower%interactions(1)%i%in2%p%initial)) deallocate(shower%interactions(1)%i%in2%p%initial) - - ! deallocate interaction pointers - do i=1, size(shower%interactions) - if(allocated(shower%interactions(i)%i%particles)) deallocate (shower%interactions(i)%i%particles) - deallocate(shower%interactions(i)%i) - end do - - ! deallocate particles - do i=1, size(shower%particles) - if(associated(shower%particles(i)%p)) then - deallocate(shower%particles(i)%p) - end if - end do - deallocate(shower%interactions) - deallocate(shower%particles) - - end subroutine shower_final - - !!! bookkeeping - - function shower_get_next_free_nr(shower) result(next_number) - type(shower_t), intent(inout) :: shower - integer :: next_number - - next_number = shower%next_free_nr - shower%next_free_nr = shower%next_free_nr+1 - end function shower_get_next_free_nr - - subroutine shower_enlarge_particles_array(shower, length) - type(shower_t), intent(inout) :: shower - integer, intent(in) :: length - - integer :: i, oldlength - type(particle_pointer_t), dimension(:), allocatable :: new_particles - -! print *, "shower_enlarge_particles_array ", length - - if(length>0) then - oldlength=size(shower%particles) - allocate(new_particles(1:oldlength)) - do i=1, oldlength - new_particles(i)%p=>shower%particles(i)%p - end do - - deallocate(shower%particles) - allocate(shower%particles(1:oldlength+length)) - do i=1, oldlength - shower%particles(i)%p=>new_particles(i)%p - end do - do i=oldlength+1, oldlength+length - shower%particles(i)%p => null() - end do - else - stop "Bug: no particle_pointers added in shower%particles" - end if - -! print *, " shower_enlarge_particles_array finished" - end subroutine shower_enlarge_particles_array - - subroutine shower_add_child(shower, prt, child) - type(shower_t), intent(inout) :: shower - type(particle_t), intent(in), pointer :: prt -! type(particle_t), intent(inout), target :: prt - integer, intent(in) :: child - - integer :: i, lastfree - type(particle_pointer_t) :: newprt - -! print *, " shower_add_child for particle ", prt%nr - - if(child.ne.1 .and. child.ne.2) then - stop "BUG: Adding child in nonexisting place" - end if - - allocate(newprt%p) - newprt%p%nr=shower_get_next_free_nr(shower) - - ! add new particle as child - if(child .eq. 1) then - prt%child1=>newprt%p - else - prt%child2=>newprt%p - end if - newprt%p%parent=>prt - - ! add new particle to shower%particles list - if(associated(shower%particles(size(shower%particles))%p)) then - call shower_enlarge_particles_array(shower, 10) - end if - - ! find last free pointer and let it point to the new particle - lastfree=0 - do i=size(shower%particles), 1, -1 - if(.not. associated(shower%particles(i)%p)) then - lastfree=i - end if - end do - if(lastfree.eq.0) then - stop "BUG: no free pointers found" - end if - shower%particles(lastfree)%p => newprt%p - end subroutine shower_add_child - - subroutine shower_add_parent(shower, prt) - type(shower_t), intent(inout) :: shower - type(particle_t), intent(inout), target :: prt - - integer :: i, lastfree - type(particle_pointer_t) :: newprt - -! print *, " shower_add_parent for particle ", prt%nr - - allocate(newprt%p) - newprt%p%nr=shower_get_next_free_nr(shower) - - ! add new particle as parent - newprt%p%child1=>prt - prt%parent=>newprt%p - - ! add new particle to shower%particles list - if(associated(shower%particles(size(shower%particles))%p)) then - call shower_enlarge_particles_array(shower, 10) - end if - - ! find last free pointer and let it point to the new particle - lastfree=0 - do i=size(shower%particles), 1, -1 - if(.not. associated(shower%particles(i)%p)) then - lastfree=i - end if - end do - if(lastfree.eq.0) then - stop "BUG: no free pointers found" - end if - shower%particles(lastfree)%p => newprt%p -! print *, " shower_add_parent finished" - end subroutine shower_add_parent - - function shower_get_total_momentum(shower, c) result (mom) - type(shower_t), intent(in) :: shower - integer, intent(in) :: c - real(kind=double) :: mom - integer :: i - - mom=0._double - do i=1, size(shower%particles) - if(.not. associated(shower%particles(i)%p)) cycle - if(particle_is_final(shower%particles(i)%p)) then - select case (c) - case (0) - mom = mom + vector4_get_component(shower%particles(i)%p%momentum, 0) - case (1) - mom = mom + vector4_get_component(shower%particles(i)%p%momentum, 1) - case (2) - mom = mom + vector4_get_component(shower%particles(i)%p%momentum, 2) - case (3) - mom = mom + vector4_get_component(shower%particles(i)%p%momentum, 3) - case default - stop "Bug: wrong component of 4momentum" - end select - end if - end do - - end function shower_get_total_momentum - - function shower_get_nr_of_partons(shower, mine) result(nr) - type(shower_t), intent(in) :: shower - real(kind=double), intent(in), optional :: mine - integer :: nr - - integer :: i - type(particle_t), pointer :: prt - real(kind=double) :: minenergy - - nr = 0 - if(present(mine)) then - minenergy=mine - else - minenergy = 0._double - end if - - do i=1, size(shower%particles) - prt=>shower%particles(i)%p - if(.not. associated(prt)) cycle - if(.not. particle_is_final(prt)) cycle - if(vector4_get_component(prt%momentum, 0)>minenergy) then - nr = nr + 1 - end if - end do - - end function shower_get_nr_of_partons - - recursive function interaction_fsr_is_finished_for_particle(prt) result(finished) - type(particle_t), intent(in) :: prt - logical :: finished - - if(prt%belongstoFSR) then - ! FSR partons - if(associated(prt%child1)) then - finished = interaction_fsr_is_finished_for_particle(prt%child1) .and. interaction_fsr_is_finished_for_particle(prt%child2) - else - finished = (prt%t <= particle_mass_squared(prt)) - end if - else - ! search for emitted timelike partons in ISR shower - if(.not. associated(prt%initial)) then - ! no inital -> no ISR - finished = .true. - else if(.not. associated(prt%parent)) then - finished = .false. - else - if(.not. particle_is_hadron(prt%parent)) then - if(associated(prt%child2)) then - finished = interaction_fsr_is_finished_for_particle(prt%parent) .and. interaction_fsr_is_finished_for_particle(prt%child2) - else - finished = interaction_fsr_is_finished_for_particle(prt%parent) - end if - else - if(associated(prt%child2)) then - finished = interaction_fsr_is_finished_for_particle(prt%child2) - else - ! only second particles can come here -> if that happens fsr evolution is not existing - finished = .true. - end if - end if - end if - end if - end function interaction_fsr_is_finished_for_particle - - function interaction_fsr_is_finished(interaction) result(finished) - type(interaction_t), intent(in) :: interaction - logical :: finished - integer :: i - - finished=.true. - - do i=1, size(interaction%particles) - if(interaction_fsr_is_finished_for_particle(interaction%particles(i)%p) .eqv. .false.) then - finished = .false. - exit - end if - end do - end function interaction_fsr_is_finished - - function shower_fsr_is_finished(shower) result(finished) - type(shower_t), intent(in) :: shower - logical :: finished - integer :: i - - finished=.true. - do i=1, size(shower%interactions) - if(interaction_fsr_is_finished(shower%interactions(i)%i) .eqv. .false.) then - finished=.false. - exit - end if - end do - end function shower_fsr_is_finished - - function shower_isr_is_finished(shower) result(finished) - type(shower_t), intent(in) :: shower - logical :: finished - - integer :: i - type(particle_t), pointer :: prt - - finished=.true. - do i=1, size(shower%particles) - if(.not. associated(shower%particles(i)%p)) cycle - prt=>shower%particles(i)%p - if(isr_pt_ordered) then - if((prt%belongstoFSR.eqv..false.) .and. (particle_is_simulated(prt).eqv..false.) .and. (prt%scale>0._double)) then - finished=.false. - exit - end if - else - if((prt%belongstoFSR.eqv..false.) .and. (particle_is_simulated(prt).eqv..false.) .and. (prt%t<0._double)) then - finished=.false. - exit - end if - end if - end do - end function shower_isr_is_finished - - function shower_is_finished(shower) result(finished) - type(shower_t), intent(in) :: shower - logical :: finished - - finished=(shower_isr_is_finished(shower)) .and. (shower_fsr_is_finished(shower)) - end function shower_is_finished - - subroutine interaction_find_partons_nearest_to_hadron(interaction, prt1, prt2) - type(interaction_t), intent(inout) :: interaction - type(particle_t), pointer, intent(out) :: prt1, prt2 - - prt1=>null() - prt2=>null() - - prt1=>interaction%in1%p - do - if(associated(prt1%parent)) then - if(particle_is_hadron(prt1%parent)) then - exit - else if( ((isr_pt_ordered.eqv..false.).and.(particle_is_simulated(prt1%parent).eqv..false.)) .or. ((isr_pt_ordered).and.(particle_is_simulated(prt1).eqv..false.)) ) then - exit - else - prt1=>prt1%parent - end if - else - exit - end if - end do - prt2=>interaction%in2%p - do - if(associated(prt2%parent)) then - if(particle_is_hadron(prt2%parent)) then - exit - else if( ((isr_pt_ordered.eqv..false.).and.(particle_is_simulated(prt2%parent).eqv..false.)) .or. ((isr_pt_ordered).and.(particle_is_simulated(prt2).eqv..false.)) ) then - exit - else - prt2=>prt2%parent - end if - else - exit - end if - end do - end subroutine interaction_find_partons_nearest_to_hadron - - - subroutine shower_update_beamremnants(shower) - type(shower_t), intent(inout) :: shower - - type(particle_t), pointer :: hadron - - ! only proton in first interaction !!? - ! currently only first beam-remnant will be updated - - if(associated(shower%interactions(1)%i%in1%p%initial)) then - hadron=>shower%interactions(1)%i%in1%p%initial - if(associated(hadron%child2)) then - hadron%child2%momentum = hadron%momentum - hadron%child1%momentum - end if - end if - if(associated(shower%interactions(1)%i%in2%p%initial)) then - hadron=>shower%interactions(1)%i%in2%p%initial - if(associated(hadron%child2)) then - hadron%child2%momentum = hadron%momentum - hadron%child1%momentum - end if - end if - end subroutine shower_update_beamremnants - - subroutine interaction_apply_lorentztrafo(interaction, L) - type(interaction_t), intent(inout) :: interaction - type(lorentz_transformation_t), intent(in) :: L - - type(particle_t), pointer :: prt - integer :: i - - ! ISR part - do i=1,2 - if(i.eq.1) then - prt=>interaction%in1%p - else - prt=>interaction%in2%p - end if - ! loop over ancestors - mothers: do - ! boost particle - call particle_apply_lorentztrafo(prt, L) - if(associated(prt%child2)) then - ! boost emitted timelike particle (and daughters) - call particle_apply_lorentztrafo_recursiv(prt%child2, L) - end if - if(associated(prt%parent)) then - if(particle_is_hadron(prt%parent).eqv..false.) then - prt=>prt%parent - else - exit - end if - else - exit - end if - enddo mothers - end do - - ! FSR part - call particle_apply_lorentztrafo(interaction%out1%p, L) - call particle_apply_lorentztrafo(interaction%out2%p, L) - if(associated(interaction%out1%p%child1, interaction%out2%p%child1)) then - call particle_apply_lorentztrafo_recursiv(interaction%out1%p%child1, L) - else -! stop "BUG: in interaction_apply_lorentztrafo" - end if -! print *, " end interaction_apply_lorentztrafo" - end subroutine interaction_apply_lorentztrafo - - subroutine shower_apply_lorentztrafo(shower, L) - type(shower_t), intent(inout) :: shower - type(lorentz_transformation_t), intent(in) :: L - integer :: i - - do i=1, size(shower%interactions) - call interaction_apply_lorentztrafo(shower%interactions(i)%i, L) - end do - - end subroutine shower_apply_lorentztrafo - - subroutine interaction_boost_to_CMframe(interaction) - ! boosts particles belonging to the interaction to the center-of-mass-frame of its partons nearest to the hadron - type(interaction_t), intent(inout) :: interaction - type(vector4_t) :: beta - type(particle_t), pointer :: prt1, prt2 - - call interaction_find_partons_nearest_to_hadron(interaction, prt1, prt2) - - beta=prt1%momentum+prt2%momentum - beta=beta/vector4_get_component(beta,0) - - if(beta**2<0._double) then - print *, " BUG: beta > 1" - return - end if - if(space_part(beta)**2>0._double) then - call interaction_apply_lorentztrafo(interaction, boost(space_part(beta)**1 / sqrt(1._double-space_part(beta)**2), -direction(beta))) - end if - end subroutine interaction_boost_to_CMframe - - subroutine shower_boost_to_CMframe(shower) - ! boosts every interaction to the center-of-mass-frame of its partons nearest to the hadron - type(shower_t), intent(inout) :: shower - integer :: i - - do i=1, size(shower%interactions) - call interaction_boost_to_CMframe(shower%interactions(i)%i) - end do - call shower_update_beamremnants(shower) - end subroutine shower_boost_to_CMframe - - subroutine shower_boost_to_labframe(shower) - ! boost all partons so that initial partons have their assigned x-value - type(shower_t), intent(inout) :: shower - integer :: i - - do i=1, size(shower%interactions) - call interaction_boost_to_labframe(shower%interactions(i)%i) - end do - end subroutine shower_boost_to_labframe - - subroutine interaction_boost_to_labframe(interaction) - ! boost all partons so that initial partons have their assigned x-value - type(interaction_t), intent(inout) :: interaction - type(particle_t), pointer :: prt1, prt2 - type(vector3_t) :: beta - - call interaction_find_partons_nearest_to_hadron(interaction, prt1, prt2) - - ! transform partons to overall labframe. - beta=vector3_moving( (/ 0._double, 0._double, (prt1%x*vector4_get_component(prt2%momentum, 0)-prt2%x*vector4_get_component(prt1%momentum, 0))/(prt1%x*vector4_get_component(prt2%momentum, 3)-prt2%x*vector4_get_component(prt1%momentum, 3)) /) ) - call interaction_apply_lorentztrafo(interaction, boost(beta**1/sqrt(1._double-beta**2), -direction(beta) )) - end subroutine interaction_boost_to_labframe - - subroutine interaction_rotate_to_z(interaction) - type(interaction_t), intent(inout) :: interaction - type(particle_t), pointer :: prt1, prt2 - - call interaction_find_partons_nearest_to_hadron(interaction, prt1, prt2) - - ! only rotate to z if inital hadrons are given (and they are assumed to be aligned along the z-axis) - if(associated(prt1%initial)) then - call interaction_apply_lorentztrafo(interaction, rotation_to_2nd( space_part(prt1%momentum), vector3_moving( (/0._double, 0._double, sign(1._double, vector4_get_component(prt1%initial%momentum,3)) /) ) ) ) - end if - end subroutine interaction_rotate_to_z - - subroutine shower_rotate_to_z(shower) - !rotate initial partons to lie along +/- z axis - type(shower_t), intent(inout) :: shower - integer :: i - - do i=1, size(shower%interactions) - call interaction_rotate_to_z(shower%interactions(i)%i) - end do - call shower_update_beamremnants(shower) - end subroutine shower_rotate_to_z - - subroutine interaction_generate_primordial_kt(interaction) - type(interaction_t), intent(inout) :: interaction - type(particle_t), pointer :: had1, had2 - type(vector4_t) :: momenta(2) - type(vector3_t) :: beta - real(kind=double) :: pt (2), phi(2) - real(kind=double) :: shat - ! variables for boosting and rotating - real(kind=double) :: btheta, bphi - integer :: i - - if(primordial_kt_width .eq. 0._double) then - return - end if - - ! print *, "interaction_generate_primordial_kt" - - had1=>interaction%in1%p%initial - had2=>interaction%in2%p%initial - - ! copy momenta and energy - momenta(1)=had1%child1%momentum - momenta(2)=had2%child1%momentum - - generate_pt_phi: do i=1,2 - ! generate transverse momentum and phi - generate_pt: do - pt(i)=primordial_kt_width*sqrt(-log(DoubleRand())) - if(pt(i) 0) then -!!$ print *, " interactions: " -!!$ do i=1, size(shower%interactions) -!!$ print *, " interaction number ", i -!!$ if(.not. associated(shower%interactions(i)%i)) then -!!$ stop "Bug: missing interaction in shower" -!!$ end if -!!$ call interaction_print(shower%interactions(i)%i) -!!$ end do -!!$ else -!!$ print *, " no interactions in shower" -!!$ end if - - print * - - if(size(shower%particles) > 0) then - print *, " particles:" - do i=1, size(shower%particles) - ! print *, " i=", i - if(associated(shower%particles(i)%p)) then - call particle_print(shower%particles(i)%p) - if(i null() - - ! print *, " shower_replace_parent_by_hadron for particle ", prt%nr - - if(associated(prt%parent)) then - if(associated(prt%parent%child2)) then - prt%initial%child2=>prt%parent%child2 - else - call shower_add_child(shower, prt%initial, 2) - end if - - call shower_remove_particle_from_particles(shower, prt%parent) - deallocate(prt%parent) - else - call shower_add_child(shower, prt%initial, 2) - end if - - prt%parent=>prt%initial - prt%parent%child1=>prt - - ! make other child to be a beam-remnant - remnant=> prt%initial%child2 - remnant%typ= 9999 - remnant%momentum = prt%parent%momentum - prt%momentum - remnant%x = 1._double - prt%x - remnant%parent=>prt%initial - - remnant%t = 0._double ! ?? ! todo: mass of beamremnant ? t of beamremnant ? decomposition into quarks/diquarks... - - ! print *, " shower_replace_parent_by_hadron finished" - end subroutine shower_replace_parent_by_hadron - - subroutine shower_get_first_ISR_scale_for_particle(shower, prt, tmax) - type(shower_t), intent(inout) :: shower - type(particle_t), intent(inout), target :: prt - real(kind=double), intent(in), optional :: tmax - type(particle_t), pointer :: otherprt, otherprt1, otherprt2 - real(kind=double) :: t,tstep, zufall, integral, shat, s, temp1 - integer :: i - logical :: goon - - if(present(tmax)) then - t=max(-tscalefactor_isr*vector4_get_component(prt%momentum,0)**2, -abs(tmax)) - else - t=-tscalefactor_isr*vector4_get_component(prt%momentum,0)**2 - end if - zufall=DoubleRand() - zufall=-twopi*log(zufall) ! compare Integral and log(zufall) instead of zufall and exp(-Integral) - zufall=zufall/first_integral_suppression_factor - integral=0._double - - do_interactions: do i=1, size(shower%interactions) - otherprt1=>shower%interactions(i)%i%in1%p - otherprt2=>shower%interactions(i)%i%in2%p - do - goon=.false. - if(associated(otherprt1%parent)) then - if(abs(otherprt1%parent%typ)/=2212) then - otherprt1=>otherprt1%parent - goon=.true. - end if - end if - if(associated(otherprt2%parent)) then - if(abs(otherprt2%parent%typ)/=2212) then - otherprt2=>otherprt2%parent - goon=.true. - end if - end if - if(goon.eqv..false.) exit - end do - if(associated(otherprt1, prt).or. associated(otherprt2, prt)) then - exit do_interactions - end if - end do do_interactions - otherprt => null() - if(associated(otherprt1, prt)) then - otherprt=>otherprt2 - else if(associated(otherprt2, prt)) then - otherprt=>otherprt1 - else - call particle_print(prt) - stop "BUG: no otherparticle found" - end if - - shat=(otherprt%momentum + prt%child1%momentum)**2 - s=(otherprt%initial%momentum + prt%initial%momentum)**2 - - do - tstep=max(abs(0.01_double*t)*DoubleRand(), 0.1_double*D_Min_t) - if(t+0.5_double*tstep>-D_Min_t) then - prt%t=particle_mass_squared(prt) - call particle_set_simulated(prt) - exit - end if - prt%t=t+0.5_double*tstep - temp1=integral_over_z_simple(prt, shat, s, (zufall-integral)/tstep) - integral=integral+tstep*temp1 - if(integral>zufall) then - prt%t=t+0.5_double*tstep - exit - end if - t=t+tstep - end do - - if (prt%t>-D_Min_t) then - call shower_replace_parent_by_hadron(shower, prt) - end if - - call particle_set_simulated(prt) - - ! print *, " shower_get_first_ISR_scale_for_particle finished" - - contains - - function integral_over_z_simple(prt, shat, s, ende) result(integral) - type(particle_t), intent(inout) :: prt - real(kind=double), intent(in) :: shat,s,ende - real(kind=double) :: integral - - real(kind=double), parameter :: zstepfactor = 1._double - real(kind=double), parameter :: zstepmin = 0.0001_double - real(kind=double) :: z, zstep, minz, maxz - real(kind=double) :: pdfsum - integer :: quark - - integral=0._double - if(D_print) then - print *, "integral_over_z_simple for t=", prt%t - end if - - minz=prt%x - maxz=maxzz(shat, s) - z=minz - - if(particle_is_gluon(prt%child1)) then - ! gluon coming from g->gg - do - zstep=max(zstepmin, DoubleRand()*zstepfactor*z*(1._double-z)) - zstep=min(zstep, maxz-z) - integral=integral+zstep*(D_alpha_s((1._double-(z+0.5_double*zstep))*abs(prt%t))/(abs(prt%t)))*P_ggg(z+0.5_double*zstep)*get_pdf(prt%initial%typ, prt%x/(z+0.5_double*zstep), abs(prt%t), 21) - if(integral>ende) then - exit - end if - z=z+zstep - if(z>=maxz) then - exit - end if - enddo - - ! gluon coming from q->qg ! correctly implemented yet? - if(integralende) then - exit - end if - z=z+zstep - if(z>=maxz) then - exit - end if - enddo - end if - else if(particle_is_quark(prt%child1)) then - ! quark coming from q->qg - do - zstep=max(zstepmin, DoubleRand()*zstepfactor*z*(1._double-z)) - zstep=min(zstep, maxz-z) - integral=integral+zstep*(D_alpha_s((1._double-(z+0.5_double*zstep))*abs(prt%t))/(abs(prt%t)))*P_qqg(z+0.5_double*zstep)*get_pdf(prt%initial%typ, prt%x/(z+0.5_double*zstep), abs(prt%t), prt%typ) - if(integral>ende) then - exit - end if - z=z+zstep - if(z>=maxz) then - exit - end if - enddo - - ! quark coming from g->qqbar ! correctly implemented yet? - if(integralende) then - exit - end if - z=z+zstep - if(z>=maxz) then - exit - end if - enddo - end if - - end if - integral=integral/get_pdf(prt%initial%typ, prt%x, abs(prt%t),prt%typ) - end function integral_over_z_simple - end subroutine shower_get_first_ISR_scale_for_particle - - subroutine shower_prepare_for_simulate_isr_pt(shower, interaction) - type(shower_t), intent(inout) :: shower - type(interaction_t), intent(inout) :: interaction - real(kind=double) :: s - - ! print *, " shower_prepare_for_simulate_isr_pt" - - ! get sqrts of interaction - - s = (interaction%in1%p%momentum + interaction%in2%p%momentum)**2 - - interaction%in1%p%scale = tscalefactor_isr * 0.25_double * s - interaction%in2%p%scale = tscalefactor_isr * 0.25_double * s - -!!$ call shower_add_parent(shower, interaction%in1%p) -!!$ call shower_add_parent(shower, interaction%in2%p) -!!$ -!!$ interaction%in1%p%parent%scale = 0.5_double * sqrts -!!$ interaction%in1%p%parent%momentum = interaction%in1%p%momentum -!!$ interaction%in1%p%parent%belongstoFSR = .false. -!!$ interaction%in1%p%parent%initial => interaction%in1%p%initial -!!$ interaction%in2%p%parent%scale = 0.5_double * sqrts -!!$ interaction%in2%p%parent%momentum = interaction%in2%p%momentum -!!$ interaction%in2%p%parent%belongstoFSR = .false. -!!$ interaction%in2%p%parent%initial => interaction%in2%p%initial -!!$ -!!$ call shower_add_child(shower, interaction%in1%p%parent, 2) -!!$ call shower_add_child(shower, interaction%in2%p%parent, 2) - end subroutine shower_prepare_for_simulate_isr_pt - - subroutine shower_prepare_for_simulate_isr_ana(shower, prt1, prt2) - type(shower_t), intent(inout) :: shower - type(particle_t), intent(inout), target :: prt1, prt2 - type(particle_t), pointer :: prt, prta, prtb - real(kind=double) :: pini(0:3), scale, factor - integer :: i - - ! print *, " shower_prepare_for_simulate_isr_ana" - - if( (.not. associated(prt1%initial)) .or. (.not. associated(prt2%initial)) ) then - return - end if - - do i=0,3 - pini(i)=particle_get_momentum(prt1, i)+particle_get_momentum(prt2, i) - end do - scale = -( pini(0)**2 - pini(1)**2 - pini(2)**2 - pini(3)**2) - - call shower_add_parent(shower, prt1) - call shower_add_parent(shower, prt2) - - factor=sqrt(vector4_get_component(prt1%momentum, 0)**2-scale)/space_part_norm(prt1%momentum) - - prt1%parent%typ=prt1%typ - prt1%parent%z=1._double - prt1%parent%momentum = prt1%momentum - prt1%parent%t=scale - prt1%parent%x=prt1%x - prt1%parent%initial=>prt1%initial - prt1%parent%belongstoFSR=.false. - - prt2%parent%typ=prt2%typ - prt2%parent%z=1._double - prt2%parent%momentum = prt2%momentum - prt2%parent%t=scale - prt2%parent%x=prt2%x - prt2%parent%initial=>prt2%initial - prt2%parent%belongstoFSR=.false. - - call shower_get_first_ISR_scale_for_particle(shower, prt1%parent) - call shower_get_first_ISR_scale_for_particle(shower, prt2%parent) - - ! redistribute energy among first partons - prta=>prt1%parent - prtb=>prt2%parent - - do i=0,3 - pini(i)=particle_get_momentum(prt1, i)+particle_get_momentum(prt2, i) - end do - call particle_set_energy(prta, (pini(0)**2-prtb%t+prta%t)/(2._double*pini(0))) - call particle_set_energy(prtb, pini(0)-vector4_get_component(prta%momentum, 0)) - - ! rescale momenta - do i=1,2 - if(i.eq.1) then - prt=>prt1%parent - else - prt=>prt2%parent - end if - - factor= sqrt(vector4_get_component(prt%momentum,0)**2-prt%t)/space_part_norm(prt%momentum) - - prt%momentum = vector4_moving( vector4_get_component(prt%momentum, 0), factor*space_part(prt%momentum)) - end do - - if(prt1%parent%t<0._double) then - call shower_add_parent(shower, prt1%parent) - prt1%parent%parent%momentum = prt1%parent%momentum - prt1%parent%parent%t=prt1%parent%t - prt1%parent%parent%x=prt1%parent%x - prt1%parent%parent%initial => prt1%parent%initial - prt1%parent%parent%belongstoFSR=.false. - call shower_add_child(shower, prt1%parent%parent, 2) - end if - - if(prt2%parent%t<0._double) then - call shower_add_parent(shower, prt2%parent) - prt2%parent%parent%momentum=prt2%parent%momentum - prt2%parent%parent%t=prt2%parent%t - prt2%parent%parent%x=prt2%parent%x - prt2%parent%parent%initial => prt2%parent%initial - prt2%parent%parent%belongstoFSR=.false. - call shower_add_child(shower, prt2%parent%parent, 2) - end if - - ! print *, " shower_prepare_for_simulate_isr_ana finished" - end subroutine shower_prepare_for_simulate_isr_ana - - subroutine shower_prepare_for_simulate_fsr_ana(shower, prt1, prt2) - type(shower_t), intent(inout) :: shower - type(particle_t), intent(in), pointer :: prt1, prt2 - real(kind=double) :: pini(4) - integer i - - ! print *, "shower_prepare_for_simulate_fsr_ana" - - ! Define imagined single initiator of shower - call shower_add_child(shower, prt1, 1) - do i=1,4 - pini(i)=particle_get_momentum(prt1, i-1)+particle_get_momentum(prt2, i-1) - end do - call particle_set_simulated(prt1) - call particle_set_child(prt1, prt1%child1, 1) - call particle_set_child(prt1, prt1%child1, 2) - call particle_set_simulated(prt2) - call particle_set_child(prt2, prt1%child1, 1) - call particle_set_child(prt2, prt1%child1, 2) - - prt1%child1%typ=94 - prt1%child1%z=vector4_get_component(prt1%momentum, 0)/(vector4_get_component(prt1%momentum, 0)+vector4_get_component(prt2%momentum, 0)) - call particle_set_simulated(prt1%child1) - call particle_set_parent(prt1%child1, prt1) - call particle_set_momentum(prt1%child1, pini(1), pini(2), pini(3), pini(4)) - prt1%child1%t=particle_p4square(prt1%child1) - prt1%child1%costheta=-1._double - - call shower_add_child(shower, prt1%child1, 1) - call shower_add_child(shower, prt1%child1, 2) - - prt1%child1%child1%typ=prt1%typ - prt1%child1%child1%momentum=prt1%momentum - prt1%child1%child1%t=prt1%child1%t - if(associated(prt1%colorpartner)) then - if(associated(prt1%colorpartner, prt2)) then - prt1%child1%child1%colorpartner=>prt1%child1%child2 - else - prt1%child1%child1%colorpartner=>prt1%colorpartner - end if - end if - if(associated(prt1%anticolorpartner)) then - if(associated(prt1%anticolorpartner, prt2)) then - prt1%child1%child1%anticolorpartner=>prt1%child1%child2 - else - prt1%child1%child1%anticolorpartner=>prt1%anticolorpartner - end if - end if - call particle_set_parent(prt1%child1%child1, prt1%child1) - - prt1%child1%child2%typ=prt2%typ - prt1%child1%child2%momentum=prt2%momentum - prt1%child1%child2%t=prt2%child1%t - if(associated(prt2%colorpartner)) then - if(associated(prt2%colorpartner, prt1)) then - prt1%child1%child2%colorpartner=>prt1%child1%child1 - else - prt1%child1%child2%colorpartner=>prt2%colorpartner - end if - end if - if(associated(prt2%anticolorpartner)) then - if(associated(prt2%anticolorpartner, prt1)) then - prt1%child1%child2%anticolorpartner=>prt1%child1%child1 - else - prt1%child1%child2%anticolorpartner=>prt2%anticolorpartner - end if - end if - call particle_set_parent(prt1%child1%child2, prt1%child1) - - ! print *, " shower_prepare_for_simulate_fsr_ana finished" - end subroutine shower_prepare_for_simulate_fsr_ana - - subroutine shower_add_children_of_emitted_timelike_parton(shower, prt) - type(shower_t), intent(inout) :: shower - type(particle_t), intent(inout), pointer :: prt - - if(prt%t > particle_mass_squared(prt)+D_Min_t) then - if(particle_is_quark(prt)) then - ! q -> qg - call shower_add_child(shower, prt,1) - prt%child1%typ=prt%typ - call particle_set_energy(prt%child1, prt%z*vector4_get_component(prt%momentum, 0)) - prt%child1%t= prt%t - call shower_add_child(shower, prt,2) - prt%child2%typ=21 - call particle_set_energy(prt%child2, (1._double-prt%z)*vector4_get_component(prt%momentum, 0)) - prt%child2%t= prt%t - else - if(int(prt%x)>0) then - call shower_add_child(shower, prt,1) - prt%child1%typ=int(prt%x) - call particle_set_energy(prt%child1, prt%z*vector4_get_component(prt%momentum, 0)) - prt%child1%t= prt%t - call shower_add_child(shower, prt,2) - prt%child2%typ=-int(prt%x) - call particle_set_energy(prt%child2, (1._double-prt%z)*vector4_get_component(prt%momentum, 0)) - prt%child2%t= prt%t - else - call shower_add_child(shower, prt, 1) - prt%child1%typ=21 - call particle_set_energy(prt%child1, prt%z*vector4_get_component(prt%momentum, 0)) - prt%child1%t=prt%t - call shower_add_child(shower, prt, 2) - prt%child2%typ=21 - call particle_set_energy(prt%child2, (1._double-prt%z)*vector4_get_component(prt%momentum, 0)) - prt%child2%t= prt%t - end if - end if - end if - end subroutine shower_add_children_of_emitted_timelike_parton - - subroutine shower_simulate_children_ana(shower,prt) - type(shower_t), intent(inout) :: shower - type(particle_t), intent(inout) :: prt - real(kind=double), dimension(1:2) :: t, zufall, integral - integer, dimension(1:2) :: gtoqq - integer :: daughter - type(particle_t), pointer :: daughterprt - integer :: n_loop - - gtoqq(1)=0 - gtoqq(2)=0 - - if(D_print) print *, " simulate_children_ana for particle " , prt%nr - - if(.not. associated(prt%child1) .or. .not. associated(prt%child2)) then - print *, " error in simulate_children_ana: no children " - return - end if - - ! check if particles are "internal" -> fixed scale - if(prt%child1%typ .eq. 94) then - call particle_set_simulated(prt%child1) - end if - if(prt%child2%typ .eq. 94) then - call particle_set_simulated(prt%child2) - end if - - integral(1)=0._double - integral(2)=0._double - - ! impose constraints by angular ordering -> cf. (26) of Gaining analytic control - ! check if no branchings are possible - if(prt%child1%simulated .eqv. .false.) then - prt%child1%t = min(prt%child1%t, 0.5_double*vector4_get_component(prt%child1%momentum,0)**2*(1._double-particle_get_costheta(prt)) ) - if(min(prt%child1%t, vector4_get_component(prt%child1%momentum, 0)**2)10000) then - print *, " simulate_children_ana failed for particle ", prt%nr - STOP "BUG: too many loops in simulate_children_ana (?)" - end if - - t(1)=prt%child1%t - t(2)=prt%child2%t - - ! check if a branching in the range t(i) to t(i)-tstep(i) occurs - - ! check for child1 - if(particle_is_simulated(prt%child1).eqv..false.) then - call particle_simulate_stept(prt%child1, integral(1), zufall(1), gtoqq(1)) - end if - - ! check for child2 - if(particle_is_simulated(prt%child2).eqv..false.) then - call particle_simulate_stept(prt%child2, integral(2), zufall(2), gtoqq(2)) - end if - if( (particle_is_simulated(prt%child1).and.particle_is_simulated(prt%child2)) ) then - if(sqrt(prt%t) .le. sqrt(prt%child1%t) + sqrt(prt%child2%t)) then - ! repeat the simulation for the parton with the lower virtuality t-m**2 (assuming it's not fixed) - if((prt%child1%typ.eq.94).and.(prt%child2%typ.eq.94)) then - STOP "Bug: both particles fixed, but momentum not conserved" - else if(prt%child1%typ.eq.94) then - ! reset child2 - call particle_set_simulated(prt%child2, .false.) - prt%child2%t=min(prt%child1%t,(sqrt(prt%t) - sqrt(prt%child1%t))**2) - integral(2)=0._double - zufall(2)=DoubleRand() - else if(prt%child2%typ.eq.94) then - ! reset child1 - call particle_set_simulated(prt%child1, .false.) - prt%child1%t=min(prt%child2%t,(sqrt(prt%t) - sqrt(prt%child2%t))**2) - integral(1)=0._double - zufall(1)=DoubleRand() - elseif(prt%child1%t-particle_mass_squared(prt%child1)>prt%child2%t-particle_mass_squared(prt%child2)) then - ! reset child2 - call particle_set_simulated(prt%child2, .false.) - prt%child2%t=min(prt%child1%t,(sqrt(prt%t) - sqrt(prt%child1%t))**2) - integral(2)=0._double - zufall(2)=DoubleRand() - else - ! reset child1 - call particle_set_simulated(prt%child1, .false.) - prt%child1%t=min(prt%child2%t,(sqrt(prt%t) - sqrt(prt%child2%t))**2) - integral(1)=0._double - zufall(1)=DoubleRand() - end if - else - exit - end if - end if - enddo - - call particle_apply_costheta(prt) - - ! add children - do daughter=1,2 - if (daughter.eq.1) then - daughterprt=>prt%child1 - else - daughterprt=>prt%child2 - end if - if(daughterprt%t < particle_mass_squared(daughterprt)+D_Min_t) then - cycle - end if - if(daughterprt%typ .eq. 94) then - cycle - end if - if(particle_is_quark(daughterprt)) then - ! q -> qg - call shower_add_child(shower, daughterprt,1) - daughterprt%child1%typ=daughterprt%typ - call particle_set_energy(daughterprt%child1, daughterprt%z*vector4_get_component(daughterprt%momentum, 0)) - daughterprt%child1%t= daughterprt%t - call shower_add_child(shower, daughterprt,2) - daughterprt%child2%typ=21 - call particle_set_energy(daughterprt%child2, (1._double-daughterprt%z)*vector4_get_component(daughterprt%momentum, 0)) - daughterprt%child2%t= daughterprt%t - else - if(gtoqq(daughter)>0) then - call shower_add_child(shower, daughterprt,1) - daughterprt%child1%typ=gtoqq(daughter) - call particle_set_energy(daughterprt%child1, daughterprt%z*vector4_get_component(daughterprt%momentum, 0)) - daughterprt%child1%t= daughterprt%t - call shower_add_child(shower, daughterprt,2) - daughterprt%child2%typ=-gtoqq(daughter) - call particle_set_energy(daughterprt%child2, (1._double-daughterprt%z)*vector4_get_component(daughterprt%momentum, 0)) - daughterprt%child2%t= daughterprt%t - else - call shower_add_child(shower, daughterprt, 1) - daughterprt%child1%typ=21 - call particle_set_energy(daughterprt%child1, daughterprt%z*vector4_get_component(daughterprt%momentum, 0)) - daughterprt%child1%t=daughterprt%t - call shower_add_child(shower, daughterprt, 2) - daughterprt%child2%typ=21 - call particle_set_energy(daughterprt%child2, (1._double-daughterprt%z)*vector4_get_component(daughterprt%momentum, 0)) - daughterprt%child2%t= daughterprt%t - end if - end if - end do - end subroutine shower_simulate_children_ana - - subroutine shower_generate_next_fsr_branchings(shower) - type(shower_t), intent(inout) :: shower - integer i, index - type(particle_t), pointer :: prt - - ! find mother with highest t to be simulated - index=0 - do i=1,size(shower%particles) - prt=> shower%particles(i)%p - if(prt%belongstoFSR.eqv..false.) cycle - if(prt%belongstointeraction.eqv..true.) cycle - if(associated(prt%child1) .and. associated(prt%child2)) then - if(particle_is_simulated(prt%child1) .and. particle_is_simulated(prt%child2)) cycle - end if - if(particle_is_final(prt)) cycle - - index=i - exit - end do - - if(index.eq.0) then - print *, " no branchable particles found" - return - end if - - prt=> shower%particles(index)%p - call shower_simulate_children_ana(shower, prt) - - end subroutine shower_generate_next_fsr_branchings - - subroutine shower_isr_step_pt(shower, prt) - type(shower_t), intent(inout) :: shower - type(particle_t), target, intent(inout) :: prt - type(particle_t), pointer :: otherprt ! recoiler - - real(kind=double) :: scale, scalestep - real(kind=double) :: integral, zufall, factor - - otherprt => shower_find_recoiler(shower, prt) - - scale = prt%scale - scalestep=max(abs(scalefactor1*scale)*DoubleRand(), scalefactor2*DoubleRand()*D_Min_scale) - zufall = DoubleRand() - zufall=-twopi*log(zufall) ! compare Integral and log(zufall) instead of zufall and exp(-Integral) - integral=0._double - - if(scale - 0.5_double*scalestep < D_Min_scale) then ! close enough to cut-off scale -> ignore - prt%scale = 0._double - prt%t=particle_mass_squared(prt) - call particle_set_simulated(prt) - else - prt%scale=scale-0.5_double*scalestep - factor = scalestep * (D_alpha_s(prt%scale)/(prt%scale*get_pdf(prt%initial%typ, prt%x, prt%scale, prt%typ))) - integral=integral+ factor * integral_over_z_isr_pt(prt, otherprt,(zufall-integral)/factor) - if(integral>zufall) then - ! prt%scale set above and prt%z set in integral_over_z_isr_pt - call particle_set_simulated(prt) - prt%t = - prt%scale / (1._double - prt%z) - else - prt%scale=scale-scalestep - end if - end if - - contains - - function integral_over_z_isr_pt(prt, otherprt, ende) result(integral) - type(particle_t), intent(inout) :: prt, otherprt - real(kind=double), intent(in) :: ende - real(kind=double) :: integral - real(kind=double) :: mbr - real(kind=double) :: zmin, zmax, z, zstep - integer :: n_bin - integer, parameter :: n_total_bins = 100 - real(kind=double) :: quarkpdfsum - integer :: quark - - if(D_print) then - print *, "integral_over_z_isr_pt for scale=", prt%scale - end if - - integral = 0._double - mbr = (prt%momentum + otherprt%momentum)**1 - zmin = prt%x - zmax = min(1._double - (sqrt(prt%scale)/mbr) * ( sqrt(1._double + 0.25_double*prt%scale/mbr**2) - 0.25_double*sqrt(prt%scale)/mbr) , maxz_isr) - zstep = (zmax - zmin)/n_total_bins - - if(zmin>zmax) then - print *, " error in integral_over_z_isr_pt: zmin > zmax ", zmin, zmax, prt%scale, mbr - integral = 0._double - return - end if - - ! divide the range [zmin:zmax] in n_total_bins -> - bins: do n_bin = 1, n_total_bins - z = zmin + zstep * (n_bin -0.5_double) ! z-value in the middle of the bin - - if(particle_is_gluon(prt)) then - quarkpdfsum = 0._double - quarks: do quark = -D_Nf, D_Nf - if(quark .eq. 0) cycle - quarkpdfsum = quarkpdfsum + get_pdf(prt%initial%typ, prt%x/z, prt%scale, quark) - end do quarks - ! g -> gg or q -> gq - integral = integral + (zstep/z) * ( (P_ggg(z)+P_ggg(1._double-z))*get_pdf(prt%initial%typ, prt%x/z, prt%scale, 21) + P_qqg(1._double-z)*quarkpdfsum ) - else if(particle_is_quark(prt)) then - ! q -> qg or g -> qq - integral = integral + (zstep/z) * ( P_qqg(z)*get_pdf(prt%initial%typ, prt%x/z, prt%scale, prt%typ) + P_gqq(z)*get_pdf(prt%initial%typ, prt%x/z, prt%scale, 21) ) - else - STOP "Bug neither quark nor gluon in integral_over_z_isr_pt" - end if - if(integral > ende) then - prt%z = z - exit bins - end if - end do bins - end function integral_over_z_isr_pt - end subroutine shower_isr_step_pt - - function shower_find_recoiler(shower, prt) - type(shower_t), intent(inout) :: shower - type(particle_t), intent(in), target :: prt - type(particle_t), pointer :: shower_find_recoiler - - type(particle_t), pointer :: otherprt1, otherprt2 - integer :: n_int - logical :: goon - - do_interactions: do n_int=1, size(shower%interactions) - otherprt1=>shower%interactions(n_int)%i%in1%p - otherprt2=>shower%interactions(n_int)%i%in2%p - do - goon=.false. - if(associated(otherprt1%parent)) then - if(particle_is_hadron(otherprt1%parent).eqv. .false.) then - otherprt1=>otherprt1%parent - goon=.true. - end if - end if - if(associated(otherprt2%parent)) then - if(particle_is_hadron(otherprt2%parent).eqv. .false.) then - otherprt2=>otherprt2%parent - goon=.true. - end if - end if - if(goon.eqv..false.) exit - end do - if(associated(otherprt1, prt).or. associated(otherprt2, prt)) then - exit do_interactions - end if - end do do_interactions - - shower_find_recoiler => null() - if(associated(otherprt1, prt)) then - shower_find_recoiler=>otherprt2 - else if(associated(otherprt2, prt)) then - shower_find_recoiler=>otherprt1 - else - call particle_print(prt) - stop "BUG: no otherparticle found" - end if - - end function shower_find_recoiler - - subroutine shower_isr_step(shower, prt) - type(shower_t), intent(inout) :: shower - type(particle_t), target, intent(inout) :: prt - type(particle_t), pointer :: otherprt => null() - real(kind=double) :: t, tstep - real(kind=double) :: integral, zufall - -! print *, "shower_isr_step for particle ", prt%nr - - otherprt => shower_find_recoiler(shower, prt) - - if(.not. otherprt%child1%belongstointeraction) then - otherprt=>otherprt%child1 - end if - - t=prt%t - zufall=DoubleRand() - zufall=-twopi*log(zufall) ! compare Integral and log(zufall) instead of zufall and exp(-Integral) - integral=0._double - tstep=max(abs(0.02_double*t)*DoubleRand(), 0.02_double*DoubleRand()*D_Min_t) - if(t+0.5_double*tstep>-D_Min_t) then - prt%t=particle_mass_squared(prt) - call particle_set_simulated(prt) - else - prt%t=t+0.5_double*tstep - integral=integral+tstep*integral_over_z_isr(prt, otherprt,(zufall-integral)/tstep) - if(integral>zufall) then - prt%t=t+0.5_double*tstep - prt%x=prt%child1%x/prt%z - call particle_set_simulated(prt) - else - prt%t=t+tstep - end if - end if - -! PRINT *, " shower_isr_step finished" - - contains - function integral_over_z_isr(prt, otherprt, ende) result(integral) - type(particle_t), intent(inout) :: prt, otherprt - real(kind=double), intent(in) :: ende - real(kind=double) integral - - real(kind=double) :: minz, maxz, z, shat,s - integer :: quark - - if(D_print) then - print *, "integral_over_z_isr for t=", prt%t - end if - - ! calculate shat -> s of parton-parton system - shat=( otherprt%momentum + prt%child1%momentum)**2 - ! calculate s -> s of hadron-hadron system - s=(otherprt%initial%momentum + prt%initial%momentum)**2 - - integral=0._double - - minz=prt%child1%x - maxz=maxzz(shat, s) - - ! for gluon - if(particle_is_gluon(prt%child1)) then - ! 1: g->gg - prt%typ=21 - prt%child2%typ=21 - z=minz - prt%child2%t=abs(prt%t) - call integral_over_z_part_isr(prt,otherprt, shat, minz, maxz, integral, ende) - if(integral>ende) then - return - end if - ! 2: q->gq - do quark=-D_Nf, D_Nf - if (quark.eq.0) cycle - prt%typ=quark - prt%child2%typ=quark - z=minz - prt%child2%t=abs(prt%t) - call integral_over_z_part_isr(prt,otherprt, shat, minz, maxz, integral, ende) - if(integral>ende) then - return - end if - end do - else if(particle_is_quark(prt%child1)) then - ! 1: q->qg - prt%typ=prt%child1%typ - prt%child2%typ=21 - z=minz - prt%child2%t=abs(prt%t) - call integral_over_z_part_isr(prt,otherprt, shat, minz, maxz, integral, ende) - if(integral>ende) then - return - end if - ! 2: g->qqbar - prt%typ=21 - prt%child2%typ=-prt%child1%typ - z=minz - prt%child2%t=abs(prt%t) - call integral_over_z_part_isr(prt,otherprt, shat, minz, maxz, integral, ende) - if(integral>ende) then - return - end if - end if - end function integral_over_z_isr - - subroutine integral_over_z_part_isr(prt, otherprt, shat ,minz, maxz, retvalue, ende) - type(particle_t), intent(inout) :: prt, otherprt - real(kind=double), intent(in) :: shat, minz, maxz, ende - real(kind=double), intent(inout) :: retvalue - real(kind=double) :: z, zstep - real(kind=double) :: r1,r3,s1,s3 - real(kind=double) :: pdf_divisor - - real(kind=double), parameter :: zstepfactor = 1._double - real(kind=double), parameter :: zstepmin = 0.0001_double - - if(D_print) print *, "integral_over_z_part_isr" - - pdf_divisor=get_pdf(prt%initial%typ, prt%child1%x, prt%t, prt%child1%typ) - z=minz - s1=shat+abs(otherprt%t)+abs(prt%t) - r1=sqrt(s1**2-4._double*abs(otherprt%t*prt%t)) - do - if(z.ge.maxz) then - exit - end if - zstep=max(zstepmin, DoubleRand()*zstepfactor*z*(1._double-z)) - zstep=min(zstep, maxz-z) - prt%z=z+0.5_double*zstep - s3=shat/prt%z+abs(otherprt%t)+abs(prt%t) - r3=sqrt(s3**2-4._double*abs(otherprt%t*prt%t)) - prt%child2%t=min((s1*s3-r1*r3)/(2._double*abs(otherprt%t))-abs(prt%child1%t)-abs(prt%t),abs(prt%child1%t)) - do - call particle_set_energy(prt%child2, sqrt(abs(prt%child2%t))) - call particle_next_t_ana(prt%child2) - call particle_set_energy(prt, (shat/prt%z+abs(otherprt%t)-abs(prt%child1%t)-prt%child2%t)/(2._double*sqrt(shat)) ) - call particle_set_energy(prt%child2, vector4_get_component(prt%momentum,0)-vector4_get_component(prt%child1%momentum, 0)) - ! check if E and t of prt%child2 are consistent - if(vector4_get_component(prt%child2%momentum, 0)**2particle_mass_squared(prt%child2)) then - cycle - else - exit - end if - end do - - if(thetabar(prt) .and. pdf_divisor>0._double .and. vector4_get_component(prt%child2%momentum, 0)>0._double) then - retvalue=retvalue+zstep*(D_alpha_s((1._double-prt%z)*prt%t)*P_prt_to_child1(prt)*get_pdf(prt%initial%typ, prt%child1%x/prt%z, prt%t, prt%typ))/(abs(prt%t)*pdf_divisor) - end if - if (retvalue>ende) then - exit - else - z=z+zstep - end if - end do - end subroutine integral_over_z_part_isr - end subroutine shower_isr_step - - function shower_generate_next_isr_branching(shower) result(next_brancher) - ! returns a pointer to the parton with the next ISR branching / FSR branchings are ignored - type(shower_t), intent(inout) :: shower - type(particle_pointer_t) :: next_brancher - - integer i, index - type(particle_t), pointer :: prt - real(kind=double) :: maxscale - - next_brancher%p=> null() - - do - if(shower_isr_is_finished(shower)) exit - - ! find mother with highest |t| or pt to be simulated - index=0 - maxscale = 0._double - call shower_sort_particles(shower) - do i=1,size(shower%particles) - prt=> shower%particles(i)%p - if(.not. associated(prt)) cycle - if(.not. isr_pt_ordered) then - if(prt%belongstointeraction.eqv..true.) cycle - end if - if(prt%belongstoFSR) cycle - if(particle_is_final(prt)) cycle - if((prt%belongstoFSR.eqv..false.) .and. (particle_is_simulated(prt))) cycle - index=i - exit - end do - - if(index==0) then - print *, " no branchable particles found" - return - end if - - prt=> shower%particles(index)%p - - ! ISR simulation - if(isr_pt_ordered) then - call shower_isr_step_pt(shower, prt) - else - call shower_isr_step(shower, prt) - end if - if(particle_is_simulated(prt)) then - if(prt%t<0._double) then - next_brancher%p=>prt - if (isr_pt_ordered .eqv. .false.) call particle_generate_ps_ini(prt) - exit - else - if(isr_pt_ordered.eqv. .false.) then - call shower_replace_parent_by_hadron(shower, prt%child1) - else - call shower_replace_parent_by_hadron(shower, prt) - end if - end if - end if - end do - - ! some bookkeeping - call shower_sort_particles(shower) - call shower_boost_to_CMframe(shower) ! really necessary? - call shower_rotate_to_z(shower) ! really necessary? -! print *, "shower_generate_next_isr_branching finished" - end function shower_generate_next_isr_branching - - subroutine shower_generate_fsr_for_partons_emitted_in_ISR(shower) - type(shower_t), intent(inout) :: shower - integer :: n_int, i - type(particle_t), pointer :: prt - - ! search for all emitted and branched partons - - interactions_loop: do n_int=1, size(shower%interactions) - incoming_partons_loop: do i=1,2 - if(i .eq. 1) then - prt=>shower%interactions(n_int)%i%in1%p - else - prt=>shower%interactions(n_int)%i%in2%p - end if - - parent_partons_loop: do - if(associated(prt%parent)) then - if(.not. particle_is_hadron(prt%parent)) then - prt=>prt%parent - else - exit - end if - else - exit - end if - if(associated(prt%child2)) then - if(particle_is_branched(prt%child2)) then - call shower_particle_generate_fsr(shower, prt%child2) - end if - else - ! STOP "Bug: no child2 associated?" - end if - end do parent_partons_loop - end do incoming_partons_loop - end do interactions_loop - end subroutine shower_generate_fsr_for_partons_emitted_in_ISR - - subroutine shower_execute_next_isr_branching(shower, prtp) - ! executes the branching generated by shower_generate_next_isr_branching, that means it generates the flavours, momenta, etc... - type(shower_t), intent(inout) :: shower - type(particle_pointer_t), intent(inout) :: prtp - type(particle_t), pointer :: prt, otherprt - type(particle_t), pointer :: prta, prtb, prtc, prtr - real(kind=double) :: mar, mbr - real(kind=double) :: phirand - -! print *, "shower_execute_next_isr_branching" - if(.not. associated(prtp%p)) then - stop "Bug: prtp not associated" - end if - - prt=>prtp%p - - if( ((isr_pt_ordered.eqv..false.).and.(prt%t>-D_Min_t)) .or. ((isr_pt_ordered).and.(prt%scale shower_find_recoiler(shower, prt) - - if(.not. associated(prt%parent)) then - call shower_add_parent(shower, prt) - end if - prt%parent%belongstoFSR = .false. - if(.not. associated(prt%parent%child2)) then - call shower_add_child(shower, prt%parent, 2) - end if - - prta => prt%parent ! new parton a with branching a->bc - prtb => prt ! former parton - prtc => prt%parent%child2 ! emitted parton - prtr => otherprt ! recoiler - - mbr = (prtb%momentum + prtr%momentum)**1 - mar = mbr / sqrt(prt%z) - - ! 1. assume you are in the restframe - ! 2. rotate by random phi - phirand=twopi*DoubleRand() - call shower_apply_lorentztrafo(shower, rotation(cos(phirand), sin(phirand), vector3_moving( (/ 0._double, 0._double, 1._double /) ) ) ) - ! 3. Put the b off-shell - ! and - ! 4. construct the massless a - ! and the parton (eventually emitted by a) - - ! generate the flavour of the parent (for now only g->gg and q->qg considered WRONG!) - if(particle_is_quark(prtb)) then - prta%typ = prtb%typ ! quarks have same flavour - prtc%typ = 21 ! emitted gluon - else if(particle_is_gluon(prtb)) then - prta%typ = 21 - prtc%typ = 21 - else - STOP "Bug in shower_execute_nexT_branching: neither quark nor gluon" - end if - - prta%initial => prtb%initial - prta%belongstoFSR=.false. - prta%scale=prtb%scale - prta%x = prtb%x / prtb%z - - prtb%momentum = vector4_moving( (mbr**2+prtb%t)/(2._double*mbr), vector3_moving( (/ 0._double, 0._double, sign( (mbr**2-prtb%t)/(2._double*mbr) , vector4_get_component(prtb%momentum, 3)) /) ) ) - prtr%momentum = vector4_moving( (mbr**2-prtb%t)/(2._double*mbr), vector3_moving( (/ 0._double, 0._double, sign( (mbr**2-prtb%t)/(2._double*mbr) , vector4_get_component(prtr%momentum, 3)) /) ) ) - - prta%momentum = vector4_moving ( (0.5_double/mbr)*( (mbr**2/prtb%z) + prtb%t - particle_mass_squared(prtc) ), vector3_moving( (/ 0._double, 0._double, 0._double /) ) ) - prta%momentum = vector4_moving ( vector4_get_component(prta%momentum,0) , vector3_moving( (/ 0._double, 0._double, (0.5_double/vector4_get_component(prtb%momentum, 3))* ((mbr**2/prtb%z) - 2._double * vector4_get_component(prtr%momentum, 0)*vector4_get_component(prta%momentum, 0) ) /) ) ) - prta%momentum = vector4_moving ( vector4_get_component(prta%momentum,0) , vector3_moving( (/ sqrt(vector4_get_component(prta%momentum, 0)**2 - vector4_get_component(prta%momentum,3)**2 - particle_mass_squared(prtc)), 0._double, vector4_get_component(prta%momentum, 3) /) ) ) - - prtc%momentum = prta%momentum - prtb%momentum -! call particle_print(prtc) - - ! 5. rotate to have a along z-axis - call shower_boost_to_CMframe(shower) - call shower_rotate_to_z(shower) - ! 6. rotate back in phi - call shower_apply_lorentztrafo(shower, rotation(cos(-phirand), sin(-phirand), vector3_moving( (/ 0._double, 0._double, 1._double /) ) ) ) - else - if(prt%child2%t>particle_mass_squared(prt%child2)) then - call shower_add_children_of_emitted_timelike_parton(shower, prt%child2) - call particle_set_simulated(prt%child2) - end if - - call shower_add_parent(shower, prt) - call shower_add_child(shower, prt%parent, 2) - - prt%parent%momentum=prt%momentum - prt%parent%t=prt%t - prt%parent%x=prt%x - prt%parent%initial => prt%initial - prt%parent%belongstoFSR=.false. - end if -! call particle_generate_ps_ini(prt) - - call shower_sort_particles(shower) - call shower_boost_to_CMframe(shower) - call shower_rotate_to_z(shower) - -! print *, " shower_execute_next_isr_branching finished" - end subroutine shower_execute_next_isr_branching - - subroutine shower_remove_parents_and_stuff(shower, prt) - type(shower_t), intent(inout) :: shower - type(particle_t), intent(inout), target :: prt - type(particle_t), pointer :: actprt, nextprt - -! print *, " shower_remove_parents for particle ", prt%nr - - nextprt=>prt%parent - actprt=>null() - - ! remove children of emitted timelike particle - if(associated(prt%child2)) then - if(associated(prt%child2%child1)) then - call shower_remove_particle_from_particles_recursive(shower, prt%child2%child1) - end if - prt%child2%child1=>null() - if(associated(prt%child2%child2)) then - call shower_remove_particle_from_particles_recursive(shower, prt%child2%child2) - end if - prt%child2%child2=>null() - end if - - do - actprt=>nextprt - if(.not. associated(actprt)) then - exit - else if(particle_is_hadron(actprt)) then - ! remove beam-remnant - call shower_remove_particle_from_particles(shower, actprt%child2) - exit - end if - if(associated(actprt%parent)) then - nextprt=>actprt%parent - else - nextprt=>null() - end if - -! print *, " removing particle ", actprt%child2%nr - call shower_remove_particle_from_particles_recursive(shower, actprt%child2) -! print *, " removing particle ", actprt%nr - call shower_remove_particle_from_particles(shower, actprt) - - end do - prt%parent=>null() - -! print *, " shower_remove_parents for particle finished" - end subroutine shower_remove_parents_and_stuff - - subroutine shower_set_max_ISR_scale(shower, newscale) - type(shower_t), intent(inout) :: shower - real(kind=double), intent(in) :: newscale - real(kind=double) :: scale - type(particle_t), pointer :: prt - - integer :: i,j - -! print *, "shower_set_max_ISR_scale" - - if(isr_pt_ordered) then - ! scale = scale - else - scale = -abs(newscale) - end if - - - interactions: do i=1, size(shower%interactions) - particles: do j=1,2 - if(j==1) then - prt=>shower%interactions(i)%i%in1%p - else - prt=>shower%interactions(i)%i%in2%p - end if - do - if(isr_pt_ordered.eqv..false.) then - if(prt%belongstointeraction.eqv..true.) prt=>prt%parent - end if - if(prt%tprt%parent - else - exit ! unresolved prt found - end if - else - exit ! prt with scale above newscale found - end if - end do - if(isr_pt_ordered .eqv. .false.) then - if(prt%child1%belongstointeraction .or. particle_is_hadron(prt)) then - ! don't reset scales of "first" spacelike partons in virtuality ordered shower or hadrons - cycle - end if - else - if(particle_is_hadron(prt)) then - ! don't reset scales of hadrons - cycle - end if - end if - if(isr_pt_ordered) then - prt%scale = scale - else - prt%t=scale - end if - call particle_set_simulated(prt, .false.) - call shower_remove_parents_and_stuff(shower, prt) - end do particles - end do interactions - -! print *, "shower_set_max_ISR_scale finished" - end subroutine shower_set_max_ISR_scale - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!! new version -!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine shower_interaction_generate_fsr(shower, interaction) - type(shower_t), intent(inout) :: shower - type(interaction_t), intent(inout) :: interaction - type(particle_pointer_t), dimension(:), allocatable :: partons ! array of partons whose children are to be evolved - - ! arrange particles to be included in - ! for qqbar state: include imaginary mother + first branching - call shower_prepare_for_simulate_fsr_ana(shower, interaction%out1%p, interaction%out2%p) - - allocate(partons(1:1)) - partons(1)%p => interaction%out1%p%child1 - call shower_particle_pointer_array_generate_fsr(shower, partons) - call particle_update_color_connections(interaction%out1%p%child1%child1) - call particle_update_color_connections(interaction%out1%p%child1%child2) - end subroutine shower_interaction_generate_fsr - - subroutine shower_interaction_generate_fsr2ton(shower, interaction) - type(shower_t), intent(inout) :: shower - type(interaction_t), intent(inout) :: interaction - - type(particle_t), pointer :: prt - - prt=>interaction%particles(3)%p - do - if(.not. associated(prt%parent)) exit - prt=>prt%parent - end do - call shower_particle_generate_fsr(shower, prt) - call particle_update_color_connections(prt) - end subroutine shower_interaction_generate_fsr2ton - - subroutine shower_particle_generate_fsr(shower, prt) - ! perform the fsr for one particle, it is assumed, that the particle already branched -> its children are to be simulated - ! this procedure is intended for branched FSR-partons emitted in the ISR - type(shower_t), intent(inout) :: shower - type(particle_t), intent(inout), target :: prt - type(particle_pointer_t), dimension(:), allocatable :: partons - - if(particle_is_branched(prt) .eqv. .false.) then - print *, " error in shower_particle_generate_fsr: particle not branched" - return - end if - if(particle_is_simulated(prt%child1) .or. particle_is_simulated(prt%child2)) then - print *, " error in shower_particle_generate_fsr: children already simulated" - return - end if - - allocate(partons(1:1)) - partons(1)%p => prt - call shower_particle_pointer_array_generate_fsr(shower, partons) - - end subroutine shower_particle_generate_fsr - - recursive subroutine shower_particle_pointer_array_generate_fsr(shower, partons) - type(shower_t), intent(inout) :: shower - type(particle_pointer_t), dimension(:), allocatable, intent(inout) :: partons - type(particle_pointer_t), dimension(:), allocatable :: partons_new - - integer :: i, size_partons, size_partons_new - - size_partons=size(partons) - if(size_partons .eq. 0) return - - ! sort partons -> necessary ?? -> probably not - - ! simulate highest/first parton - call shower_simulate_children_ana(shower, partons(1)%p) - - ! check for new daughters to be included in new_partons - size_partons_new=size_partons-1 ! partons(1) not needed anymore - if(particle_is_branched(partons(1)%p%child1)) size_partons_new=size_partons_new+1 - if(particle_is_branched(partons(1)%p%child2)) size_partons_new=size_partons_new+1 - - allocate(partons_new(1:size_partons_new)) - - if(size_partons>1) then - do i=2, size_partons - partons_new(i-1)%p => partons(i)%p - end do - end if - if(particle_is_branched(partons(1)%p%child1)) partons_new(size_partons)%p=> partons(1)%p%child1 - if(particle_is_branched(partons(1)%p%child2)) then - ! check if child1 is already included - if(size_partons_new .eq. size_partons) then - partons_new(size_partons)%p=> partons(1)%p%child2 - else if(size_partons_new .eq. size_partons+1) then - partons_new(size_partons+1)%p=> partons(1)%p%child2 - else - STOP "BUG: wrong sizes in shower_particle_pointer_array_generate_fsr" - end if - end if - deallocate(partons) - -! print *, "end subroutine shower_particle_pointer_array_generate_fsr" - call shower_particle_pointer_array_generate_fsr(shower, partons_new) - - end subroutine shower_particle_pointer_array_generate_fsr - - -!!!!!!!!!!!!!!!!!!!!!!!!! -!!! PDF !!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!! - - function get_pdf(mother, x, Q2, daughter) result(pdf) - ! type(shower_t), intent(in), pointer :: shower - integer, intent(in) :: mother, daughter - real(kind=double), intent(in) :: x, Q2 - real(kind=double) :: pdf - - real, save :: f(-6:6) = 0.0 - real(kind=double), save :: lastx, lastQ2 =0._double - - if(abs(mother)/=2212) then - stop "Bug: pdf only implemented for (anti-)proton" - else - if(x>0._double .and. x<1._double) then - if(Q2 .ne. lastQ2 .or. x .ne. lastx) then - call evolvePDF(x,sqrt(abs(Q2)),f) - end if - if (abs(daughter)>=1 .and. abs(daughter)<=6) then - pdf=f(daughter*sign(1,mother)) - else if(daughter==21) then - pdf=f(0) - else - print *, "error in pdf" - pdf=0._double - end if - else - pdf=0._double - end if - end if - lastQ2 = Q2 - lastx = x -!!$ pdf=1._double ! WRONG - end function get_pdf - - end module shower_module Index: branches/attic/boschmann_standalone/src/lib/lorentz.f90 =================================================================== --- branches/attic/boschmann_standalone/src/lib/lorentz.f90 (revision 8608) +++ branches/attic/boschmann_standalone/src/lib/lorentz.f90 (revision 8609) @@ -1,1284 +0,0 @@ -! WHIZARD 2.0.0 Mon Aug 24 2009 -! -! (C) 1999-2009 by -! Wolfgang Kilian -! Thorsten Ohl -! Juergen Reuter -! with contributions by Sebastian Schmidt -! -! WHIZARD is free software; you can redistribute it and/or modify it -! under the terms of the GNU General Public License as published by -! the Free Software Foundation; either version 2, or (at your option) -! any later version. -! -! WHIZARD is distributed in the hope that it will be useful, but -! WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! This file has been stripped of most comments. For documentation, refer -! to the source 'whizard.nw' - -module lorentz - - use kinds, only: default !NODEP! - use constants, only: pi, twopi, degree - - implicit none - private - - public :: vector3_t -! public :: vector3_write - public :: vector3_null - public :: vector3_canonical - public :: vector3_moving - public :: vector3_get_component - public :: vector3_get_components - public :: vector4_t -! public :: vector4_write - public :: vector4_write_raw - public :: vector4_read_raw - public :: vector4_null - public :: vector4_canonical - public :: vector4_at_rest - public :: vector4_moving - public :: vector4_get_component - public :: vector4_get_components - public :: lorentz_transformation_t -! public :: lorentz_transformation_write - public :: lorentz_transformation_get_components - public :: identity - public :: space_reflection - - public :: operator(==), operator(/=) - public :: operator(+), operator(-) - public :: operator(*), operator(/) - public :: operator(**) - - public :: cross_product - public :: sum - public :: direction - public :: space_part - public :: array_from_vector4 - public :: azimuthal_angle - public :: azimuthal_angle_deg - public :: azimuthal_distance - public :: azimuthal_distance_deg - public :: polar_angle - public :: polar_angle_ct - public :: polar_angle_deg - public :: enclosed_angle - public :: enclosed_angle_ct - public :: enclosed_angle_deg - public :: enclosed_angle_rest_frame - public :: enclosed_angle_ct_rest_frame - public :: enclosed_angle_deg_rest_frame - public :: transverse_part - public :: longitudinal_part - public :: space_part_norm - public :: energy - public :: invariant_mass - public :: invariant_mass_squared - public :: transverse_mass - public :: rapidity - public :: pseudorapidity - public :: rapidity_distance - public :: pseudorapidity_distance - public :: eta_phi_distance - public :: inverse - public :: boost - public :: rotation - public :: rotation_to_2nd - public :: transformation - public :: LT_compose_r3_r2_b3 - public :: LT_compose_r2_r3_b3 - public :: axis_from_p_r3_r2_b3, axis_from_p_b3 - public :: lambda - - type :: vector3_t - private - real(default), dimension(3) :: p - end type vector3_t - - type :: vector4_t - private - real(default), dimension(0:3) :: p - end type vector4_t - type :: lorentz_transformation_t - private - real(default), dimension(0:3, 0:3) :: L - end type lorentz_transformation_t - - - type(vector3_t), parameter :: vector3_null = & - vector3_t ((/ 0._default, 0._default, 0._default /)) - - type(vector4_t), parameter :: vector4_null = & - vector4_t ((/ 0._default, 0._default, 0._default, 0._default /)) - - integer, dimension(3,3), parameter :: delta_three = & - & reshape( source = (/ 1,0,0, 0,1,0, 0,0,1 /), & - & shape = (/3,3/) ) - integer, dimension(3,3,3), parameter :: epsilon_three = & - & reshape( source = (/ 0, 0,0, 0,0,-1, 0,1,0,& - & 0, 0,1, 0,0, 0, -1,0,0,& - & 0,-1,0, 1,0, 0, 0,0,0 /),& - & shape = (/3,3,3/) ) - type(lorentz_transformation_t), parameter :: & - & identity = & - & lorentz_transformation_t ( & - & reshape( source = (/ 1._default, 0._default, 0._default, 0._default, & - & 0._default, 1._default, 0._default, 0._default, & - & 0._default, 0._default, 1._default, 0._default, & - & 0._default, 0._default, 0._default, 1._default /),& - & shape = (/ 4,4 /) ) ) - type(lorentz_transformation_t), parameter :: & - & space_reflection = & - & lorentz_transformation_t ( & - & reshape( source = (/ 1._default, 0._default, 0._default, 0._default, & - & 0._default,-1._default, 0._default, 0._default, & - & 0._default, 0._default,-1._default, 0._default, & - & 0._default, 0._default, 0._default,-1._default /),& - & shape = (/ 4,4 /) ) ) - - interface vector3_moving - module procedure vector3_moving_canonical - module procedure vector3_moving_generic - end interface - interface operator(==) - module procedure vector3_eq - end interface - interface operator(/=) - module procedure vector3_neq - end interface - interface operator(+) - module procedure add_vector3 - end interface - interface operator(-) - module procedure sub_vector3 - end interface - interface operator(*) - module procedure prod_integer_vector3, prod_vector3_integer - module procedure prod_real_vector3, prod_vector3_real - end interface - interface operator(/) - module procedure div_vector3_real, div_vector3_integer - end interface - interface operator(*) - module procedure prod_vector3 - end interface - interface cross_product - module procedure vector3_cross_product - end interface - interface operator(**) - module procedure power_vector3 - end interface - interface operator(-) - module procedure negate_vector3 - end interface - interface sum - module procedure sum_vector3 - end interface - interface direction - module procedure vector3_get_direction - end interface - interface vector4_moving - module procedure vector4_moving_canonical - module procedure vector4_moving_generic - end interface - interface operator(==) - module procedure vector4_eq - end interface - interface operator(/=) - module procedure vector4_neq - end interface - interface operator(+) - module procedure add_vector4 - end interface - interface operator(-) - module procedure sub_vector4 - end interface - interface operator(*) - module procedure prod_real_vector4, prod_vector4_real - module procedure prod_integer_vector4, prod_vector4_integer - end interface - interface operator(/) - module procedure div_vector4_real - module procedure div_vector4_integer - end interface - interface operator(*) - module procedure prod_vector4 - end interface - interface operator(**) - module procedure power_vector4 - end interface - interface operator(-) - module procedure negate_vector4 - end interface - interface sum - module procedure sum_vector4 - end interface - interface space_part - module procedure vector4_get_space_part - end interface - interface direction - module procedure vector4_get_direction - end interface - interface array_from_vector4 - module procedure array_from_vector4_1 - module procedure array_from_vector4_2 - end interface - interface azimuthal_angle - module procedure vector3_azimuthal_angle - module procedure vector4_azimuthal_angle - end interface - interface azimuthal_angle_deg - module procedure vector3_azimuthal_angle_deg - module procedure vector4_azimuthal_angle_deg - end interface - interface azimuthal_distance - module procedure vector3_azimuthal_distance - module procedure vector4_azimuthal_distance - end interface - interface azimuthal_distance_deg - module procedure vector3_azimuthal_distance_deg - module procedure vector4_azimuthal_distance_deg - end interface - interface polar_angle - module procedure polar_angle_vector3 - module procedure polar_angle_vector4 - end interface - interface polar_angle_ct - module procedure polar_angle_ct_vector3 - module procedure polar_angle_ct_vector4 - end interface - interface polar_angle_deg - module procedure polar_angle_deg_vector3 - module procedure polar_angle_deg_vector4 - end interface - interface enclosed_angle - module procedure enclosed_angle_vector3 - module procedure enclosed_angle_vector4 - end interface - interface enclosed_angle_ct - module procedure enclosed_angle_ct_vector3 - module procedure enclosed_angle_ct_vector4 - end interface - interface enclosed_angle_deg - module procedure enclosed_angle_deg_vector3 - module procedure enclosed_angle_deg_vector4 - end interface - interface enclosed_angle_rest_frame - module procedure enclosed_angle_rest_frame_vector4 - end interface - interface enclosed_angle_ct_rest_frame - module procedure enclosed_angle_ct_rest_frame_vector4 - end interface - interface enclosed_angle_deg_rest_frame - module procedure enclosed_angle_deg_rest_frame_vector4 - end interface - interface transverse_part - module procedure transverse_part_vector4 - end interface - interface longitudinal_part - module procedure longitudinal_part_vector4 - end interface - interface space_part_norm - module procedure space_part_norm_vector4 - end interface - interface energy - module procedure energy_vector4 - module procedure energy_vector3 - module procedure energy_real - end interface - interface invariant_mass - module procedure invariant_mass_vector4 - end interface - interface invariant_mass_squared - module procedure invariant_mass_squared_vector4 - end interface - interface transverse_mass - module procedure transverse_mass_vector4 - end interface - interface rapidity - module procedure rapidity_vector4 - end interface - interface pseudorapidity - module procedure pseudorapidity_vector4 - end interface - interface rapidity_distance - module procedure rapidity_distance_vector4 - end interface - interface pseudorapidity_distance - module procedure pseudorapidity_distance_vector4 - end interface - interface eta_phi_distance - module procedure eta_phi_distance_vector4 - end interface - interface inverse - module procedure lorentz_transformation_inverse - end interface - interface boost - module procedure boost_from_rest_frame - module procedure boost_from_rest_frame_vector3 - module procedure boost_generic - module procedure boost_canonical - end interface - interface rotation - module procedure rotation_generic - module procedure rotation_canonical - module procedure rotation_generic_cs - module procedure rotation_canonical_cs - end interface - interface rotation_to_2nd - module procedure rotation_to_2nd_generic - module procedure rotation_to_2nd_canonical - end interface - interface transformation - module procedure transformation_rec_generic - module procedure transformation_rec_canonical - end interface - interface operator(*) - module procedure prod_LT_vector4 - module procedure prod_LT_LT - module procedure prod_vector4_LT - end interface - -contains - -!!$ subroutine vector3_write (p, unit) -!!$ type(vector3_t), intent(in) :: p -!!$ integer, intent(in), optional :: unit -!!$ integer :: u -!!$ u = output_unit (unit) -!!$ write(u, *) 'P = ', p%p -!!$ end subroutine vector3_write - - elemental function vector3_canonical (k) result (p) - type(vector3_t) :: p - integer, intent(in) :: k - p = vector3_null - p%p(k) = 1 - end function vector3_canonical - - elemental function vector3_moving_canonical (p, k) result(q) - type(vector3_t) :: q - real(default), intent(in) :: p - integer, intent(in) :: k - q = vector3_null - q%p(k) = p - end function vector3_moving_canonical - pure function vector3_moving_generic (p) result(q) - real(default), dimension(3), intent(in) :: p - type(vector3_t) :: q - q%p = p - end function vector3_moving_generic - - elemental function vector3_eq (p, q) result (r) - logical :: r - type(vector3_t), intent(in) :: p,q - r = all (p%p == q%p) - end function vector3_eq - elemental function vector3_neq (p, q) result (r) - logical :: r - type(vector3_t), intent(in) :: p,q - r = any (p%p /= q%p) - end function vector3_neq - - elemental function add_vector3 (p, q) result (r) - type(vector3_t) :: r - type(vector3_t), intent(in) :: p,q - r%p = p%p + q%p - end function add_vector3 - elemental function sub_vector3 (p, q) result (r) - type(vector3_t) :: r - type(vector3_t), intent(in) :: p,q - r%p = p%p - q%p - end function sub_vector3 - - elemental function prod_real_vector3 (s, p) result (q) - type(vector3_t) :: q - real(default), intent(in) :: s - type(vector3_t), intent(in) :: p - q%p = s * p%p - end function prod_real_vector3 - elemental function prod_vector3_real (p, s) result (q) - type(vector3_t) :: q - real(default), intent(in) :: s - type(vector3_t), intent(in) :: p - q%p = s * p%p - end function prod_vector3_real - elemental function div_vector3_real (p, s) result (q) - type(vector3_t) :: q - real(default), intent(in) :: s - type(vector3_t), intent(in) :: p - q%p = p%p/s - end function div_vector3_real - elemental function prod_integer_vector3 (s, p) result (q) - type(vector3_t) :: q - integer, intent(in) :: s - type(vector3_t), intent(in) :: p - q%p = s * p%p - end function prod_integer_vector3 - elemental function prod_vector3_integer (p, s) result (q) - type(vector3_t) :: q - integer, intent(in) :: s - type(vector3_t), intent(in) :: p - q%p = s * p%p - end function prod_vector3_integer - elemental function div_vector3_integer (p, s) result (q) - type(vector3_t) :: q - integer, intent(in) :: s - type(vector3_t), intent(in) :: p - q%p = p%p/s - end function div_vector3_integer - - elemental function prod_vector3 (p, q) result (s) - real(default) :: s - type(vector3_t), intent(in) :: p,q - s = dot_product (p%p, q%p) - end function prod_vector3 - - elemental function vector3_cross_product (p, q) result (r) - type(vector3_t) :: r - type(vector3_t), intent(in) :: p,q - integer :: i - do i=1,3 - r%p(i) = dot_product (p%p, matmul(epsilon_three(i,:,:), q%p)) - end do - end function vector3_cross_product - - elemental function power_vector3 (p, e) result (s) - real(default) :: s - type(vector3_t), intent(in) :: p - integer, intent(in) :: e - s = dot_product (p%p, p%p) - if (e/=2) then - if (mod(e,2)==0) then - s = s**(e/2) - else - s = sqrt(s)**e - end if - end if - end function power_vector3 - - elemental function negate_vector3 (p) result (q) - type(vector3_t) :: q - type(vector3_t), intent(in) :: p - q%p = -p%p - end function negate_vector3 - - pure function sum_vector3 (p) result (q) - type(vector3_t) :: q - type(vector3_t), dimension(:), intent(in) :: p - integer :: i - do i=1, 3 - q%p(i) = sum (p%p(i)) - end do - end function sum_vector3 -! pure function sum_vector3_mask (p, mask) result (q) -! type(vector3_t) :: q -! type(vector3_t), dimension(:), intent(in) :: p -! logical, dimension(:), intent(in) :: mask -! integer :: i -! do i=1, 3 -! q%p(i) = sum (p%p(i), mask=mask) -! end do -! end function sum_vector3_mask - - elemental function vector3_get_component (p, k) result (c) - type(vector3_t), intent(in) :: p - integer, intent(in) :: k - real(default) :: c - c = p%p(k) - end function vector3_get_component - - pure function vector3_get_components (p) result (a) - type(vector3_t), intent(in) :: p - real(default), dimension(3) :: a - a = p%p - end function vector3_get_components - - elemental function vector3_get_direction (p) result (q) - type(vector3_t) :: q - type(vector3_t), intent(in) :: p - q = p / p**1 - end function vector3_get_direction - -!!$ subroutine vector4_write (p, unit, show_mass) -!!$ type(vector4_t), intent(in) :: p -!!$ integer, intent(in), optional :: unit -!!$ logical, intent(in), optional :: show_mass -!!$ integer :: u -!!$ u = output_unit (unit) -!!$ write(u, *) 'E = ', p%p(0) -!!$ write(u, *) 'P = ', p%p(1:) -!!$ if (present (show_mass)) then -!!$ if (show_mass) & -!!$ write (u, *) 'M = ', p**1 -!!$ end if -!!$ end subroutine vector4_write - - subroutine vector4_write_raw (p, u) - type(vector4_t), intent(in) :: p - integer, intent(in) :: u - write (u) p%p - end subroutine vector4_write_raw - - subroutine vector4_read_raw (p, u) - type(vector4_t), intent(out) :: p - integer, intent(in) :: u - read (u) p%p - end subroutine vector4_read_raw - - elemental function vector4_canonical (k) result (p) - type(vector4_t) :: p - integer, intent(in) :: k - p = vector4_null - p%p(k) = 1 - end function vector4_canonical - - elemental function vector4_at_rest (m) result (p) - type(vector4_t) :: p - real(default), intent(in) :: m - p = vector4_t ((/ m, 0._default, 0._default, 0._default /)) - end function vector4_at_rest - - elemental function vector4_moving_canonical (E, p, k) result (q) - type(vector4_t) :: q - real(default), intent(in) :: E, p - integer, intent(in) :: k - q = vector4_at_rest(E) - q%p(k) = p - end function vector4_moving_canonical - elemental function vector4_moving_generic (E, p) result (q) - type(vector4_t) :: q - real(default), intent(in) :: E - type(vector3_t), intent(in) :: p - q%p(0) = E - q%p(1:) = p%p - end function vector4_moving_generic - - elemental function vector4_eq (p, q) result (r) - logical :: r - type(vector4_t), intent(in) :: p,q - r = all (p%p == q%p) - end function vector4_eq - elemental function vector4_neq (p, q) result (r) - logical :: r - type(vector4_t), intent(in) :: p,q - r = any (p%p /= q%p) - end function vector4_neq - - elemental function add_vector4 (p,q) result (r) - type(vector4_t) :: r - type(vector4_t), intent(in) :: p,q - r%p = p%p + q%p - end function add_vector4 - elemental function sub_vector4 (p,q) result (r) - type(vector4_t) :: r - type(vector4_t), intent(in) :: p,q - r%p = p%p - q%p - end function sub_vector4 - - elemental function prod_real_vector4 (s, p) result (q) - type(vector4_t) :: q - real(default), intent(in) :: s - type(vector4_t), intent(in) :: p - q%p = s * p%p - end function prod_real_vector4 - elemental function prod_vector4_real (p, s) result (q) - type(vector4_t) :: q - real(default), intent(in) :: s - type(vector4_t), intent(in) :: p - q%p = s * p%p - end function prod_vector4_real - elemental function div_vector4_real (p, s) result (q) - type(vector4_t) :: q - real(default), intent(in) :: s - type(vector4_t), intent(in) :: p - q%p = p%p/s - end function div_vector4_real - elemental function prod_integer_vector4 (s, p) result (q) - type(vector4_t) :: q - integer, intent(in) :: s - type(vector4_t), intent(in) :: p - q%p = s * p%p - end function prod_integer_vector4 - elemental function prod_vector4_integer (p, s) result (q) - type(vector4_t) :: q - integer, intent(in) :: s - type(vector4_t), intent(in) :: p - q%p = s * p%p - end function prod_vector4_integer - elemental function div_vector4_integer (p, s) result (q) - type(vector4_t) :: q - integer, intent(in) :: s - type(vector4_t), intent(in) :: p - q%p = p%p/s - end function div_vector4_integer - - elemental function prod_vector4 (p, q) result (s) - real(default) :: s - type(vector4_t), intent(in) :: p,q - s = p%p(0)*q%p(0) - dot_product(p%p(1:), q%p(1:)) - end function prod_vector4 - - elemental function power_vector4 (p, e) result (s) - real(default) :: s - type(vector4_t), intent(in) :: p - integer, intent(in) :: e - s = p*p - if (e/=2) then - if (mod(e,2)==0) then - s = s**(e/2) - elseif (s>=0) then - s = sqrt(s)**e - else - s = -(sqrt(abs(s))**e) - end if - end if - end function power_vector4 - - elemental function negate_vector4 (p) result (q) - type(vector4_t) :: q - type(vector4_t), intent(in) :: p - q%p = -p%p - end function negate_vector4 - - pure function sum_vector4 (p) result (q) - type(vector4_t) :: q - type(vector4_t), dimension(:), intent(in) :: p - integer :: i - do i=0, 3 - q%p(i) = sum (p%p(i)) - end do - end function sum_vector4 -! pure function sum_vector4_mask (p, mask) result (q) -! type(vector4_t) :: q -! type(vector4_t), dimension(:), intent(in) :: p -! logical, dimension(:), intent(in) :: mask -! integer :: i -! do i=0, 3 -! q%p(i) = sum (p%p(i), mask=mask) -! end do -! end function sum_vector4_mask - - elemental function vector4_get_component (p, k) result (c) - real(default) :: c - type(vector4_t), intent(in) :: p - integer, intent(in) :: k - c = p%p(k) - end function vector4_get_component - - pure function vector4_get_components (p) result (a) - real(default), dimension(0:3) :: a - type(vector4_t), intent(in) :: p - a = p%p - end function vector4_get_components - - elemental function vector4_get_space_part (p) result (q) - type(vector3_t) :: q - type(vector4_t), intent(in) :: p - q%p = p%p(1:) - end function vector4_get_space_part - - elemental function vector4_get_direction (p) result (q) - type(vector3_t) :: q - type(vector4_t), intent(in) :: p - real(kind=default) :: abs - q%p = p%p(1:) -! q%p = q%p / q%p**1 - q = q / q**1 - end function vector4_get_direction - - pure function array_from_vector4_1 (p) result (a) - type(vector4_t), intent(in) :: p - real(default), dimension(0:3) :: a - a = p%p - end function array_from_vector4_1 - - pure function array_from_vector4_2 (p) result (a) - type(vector4_t), dimension(:), intent(in) :: p - real(default), dimension(0:3, size(p)) :: a - integer :: i - forall (i=1:size(p)) - a(0:3,i) = p(i)%p - end forall - end function array_from_vector4_2 - - elemental function vector3_azimuthal_angle (p) result (phi) - real(default) :: phi - type(vector3_t), intent(in) :: p - if (any(p%p(1:2)/=0)) then - phi = atan2(p%p(2), p%p(1)) - if (phi < 0) phi = phi + twopi - else - phi = 0 - end if - end function vector3_azimuthal_angle - elemental function vector4_azimuthal_angle (p) result (phi) - real(default) :: phi - type(vector4_t), intent(in) :: p - phi = vector3_azimuthal_angle (space_part (p)) - end function vector4_azimuthal_angle - - elemental function vector3_azimuthal_angle_deg (p) result (phi) - real(default) :: phi - type(vector3_t), intent(in) :: p - phi = vector3_azimuthal_angle (p) / degree - end function vector3_azimuthal_angle_deg - elemental function vector4_azimuthal_angle_deg (p) result (phi) - real(default) :: phi - type(vector4_t), intent(in) :: p - phi = vector4_azimuthal_angle (p) / degree - end function vector4_azimuthal_angle_deg - - elemental function vector3_azimuthal_distance (p, q) result (dphi) - real(default) :: dphi - type(vector3_t), intent(in) :: p,q - dphi = vector3_azimuthal_angle (q) - vector3_azimuthal_angle (p) - if (dphi <= -pi) then - dphi = dphi + twopi - else if (dphi > pi) then - dphi = dphi - twopi - end if - end function vector3_azimuthal_distance - elemental function vector4_azimuthal_distance (p, q) result (dphi) - real(default) :: dphi - type(vector4_t), intent(in) :: p,q - dphi = vector3_azimuthal_distance & - (space_part (p), space_part (q)) - end function vector4_azimuthal_distance - - elemental function vector3_azimuthal_distance_deg (p, q) result (dphi) - real(default) :: dphi - type(vector3_t), intent(in) :: p,q - dphi = vector3_azimuthal_distance (p, q) / degree - end function vector3_azimuthal_distance_deg - elemental function vector4_azimuthal_distance_deg (p, q) result (dphi) - real(default) :: dphi - type(vector4_t), intent(in) :: p,q - dphi = vector4_azimuthal_distance (p, q) / degree - end function vector4_azimuthal_distance_deg - - elemental function polar_angle_vector3 (p) result (theta) - real(default) :: theta - type(vector3_t), intent(in) :: p - if (any(p%p/=0)) then - theta = atan2 (sqrt(p%p(1)**2 + p%p(2)**2), p%p(3)) - else - theta = 0 - end if - end function polar_angle_vector3 - elemental function polar_angle_vector4 (p) result (theta) - real(default) :: theta - type(vector4_t), intent(in) :: p - theta = polar_angle (space_part (p)) - end function polar_angle_vector4 - - elemental function polar_angle_ct_vector3 (p) result (ct) - real(default) :: ct - type(vector3_t), intent(in) :: p - if (any(p%p/=0)) then - ct = p%p(3) / p**1 - else - ct = 1 - end if - end function polar_angle_ct_vector3 - elemental function polar_angle_ct_vector4 (p) result (ct) - real(default) :: ct - type(vector4_t), intent(in) :: p - ct = polar_angle_ct (space_part (p)) - end function polar_angle_ct_vector4 - - elemental function polar_angle_deg_vector3 (p) result (theta) - real(default) :: theta - type(vector3_t), intent(in) :: p - theta = polar_angle (p) / degree - end function polar_angle_deg_vector3 - elemental function polar_angle_deg_vector4 (p) result (theta) - real(default) :: theta - type(vector4_t), intent(in) :: p - theta = polar_angle (p) / degree - end function polar_angle_deg_vector4 - - elemental function enclosed_angle_vector3 (p, q) result (theta) - real(default) :: theta - type(vector3_t), intent(in) :: p, q - theta = acos (enclosed_angle_ct (p, q)) - end function enclosed_angle_vector3 - elemental function enclosed_angle_vector4 (p, q) result (theta) - real(default) :: theta - type(vector4_t), intent(in) :: p, q - theta = enclosed_angle (space_part (p), space_part (q)) - end function enclosed_angle_vector4 - - elemental function enclosed_angle_ct_vector3 (p, q) result (ct) - real(default) :: ct - type(vector3_t), intent(in) :: p, q - if (any(p%p/=0).and.any(q%p/=0)) then - ct = p*q / (p**1 * q**1) - if (ct>1) then - ct = 1 - else if (ct<-1) then - ct = -1 - end if - else - ct = 1 - end if - end function enclosed_angle_ct_vector3 - elemental function enclosed_angle_ct_vector4 (p, q) result (ct) - real(default) :: ct - type(vector4_t), intent(in) :: p, q - ct = enclosed_angle_ct (space_part (p), space_part (q)) - end function enclosed_angle_ct_vector4 - - elemental function enclosed_angle_deg_vector3 (p, q) result (theta) - real(default) :: theta - type(vector3_t), intent(in) :: p, q - theta = enclosed_angle (p, q) / degree - end function enclosed_angle_deg_vector3 - elemental function enclosed_angle_deg_vector4 (p, q) result (theta) - real(default) :: theta - type(vector4_t), intent(in) :: p, q - theta = enclosed_angle (p, q) / degree - end function enclosed_angle_deg_vector4 - - elemental function enclosed_angle_rest_frame_vector4 (p, q) result (theta) - type(vector4_t), intent(in) :: p, q - real(default) :: theta - theta = acos (enclosed_angle_ct_rest_frame (p, q)) - end function enclosed_angle_rest_frame_vector4 - elemental function enclosed_angle_ct_rest_frame_vector4 (p, q) result (ct) - type(vector4_t), intent(in) :: p, q - real(default) :: ct - if (invariant_mass(q) > 0) then - ct = enclosed_angle_ct ( & - space_part (boost(-q, invariant_mass (q)) * p), & - space_part (q)) - else - ct = 1 - end if - end function enclosed_angle_ct_rest_frame_vector4 - elemental function enclosed_angle_deg_rest_frame_vector4 (p, q) & - result (theta) - type(vector4_t), intent(in) :: p, q - real(default) :: theta - theta = enclosed_angle_rest_frame (p, q) / degree - end function enclosed_angle_deg_rest_frame_vector4 - - elemental function transverse_part_vector4 (p) result (pT) - real(default) :: pT - type(vector4_t), intent(in) :: p - pT = sqrt(p%p(1)**2 + p%p(2)**2) - end function transverse_part_vector4 - - elemental function longitudinal_part_vector4 (p) result (pL) - real(default) :: pL - type(vector4_t), intent(in) :: p - pL = p%p(3) - end function longitudinal_part_vector4 - - elemental function space_part_norm_vector4 (p) result (p3) - real(default) :: p3 - type(vector4_t), intent(in) :: p - p3 = sqrt (p%p(1)**2 + p%p(2)**2 + p%p(3)**2) - end function space_part_norm_vector4 - - elemental function energy_vector4 (p) result (E) - real(default) :: E - type(vector4_t), intent(in) :: p - E = p%p(0) - end function energy_vector4 - - elemental function energy_vector3 (p, mass) result (E) - real(default) :: E - type(vector3_t), intent(in) :: p - real(default), intent(in), optional :: mass - if (present (mass)) then - E = sqrt (p**2 + mass**2) - else - E = p**1 - end if - end function energy_vector3 - - elemental function energy_real (p, mass) result (E) - real(default) :: E - real(default), intent(in) :: p - real(default), intent(in), optional :: mass - if (present (mass)) then - E = sqrt (p**2 + mass**2) - else - E = abs (p) - end if - end function energy_real - - elemental function invariant_mass_vector4 (p) result (m) - real(default) :: m - type(vector4_t), intent(in) :: p - real(default) :: msq - msq = p*p - if (msq >= 0) then - m = sqrt (msq) - else - m = - sqrt (abs (msq)) - end if - end function invariant_mass_vector4 - elemental function invariant_mass_squared_vector4 (p) result (msq) - real(default) :: msq - type(vector4_t), intent(in) :: p - msq = p*p - end function invariant_mass_squared_vector4 - - elemental function transverse_mass_vector4 (p) result (m) - real(default) :: m - type(vector4_t), intent(in) :: p - real(default) :: msq - msq = p%p(0)**2 - p%p(1)**2 - p%p(2)**2 - if (msq >= 0) then - m = sqrt (msq) - else - m = - sqrt (abs (msq)) - end if - end function transverse_mass_vector4 - - elemental function rapidity_vector4 (p) result (y) - real(default) :: y - type(vector4_t), intent(in) :: p - y = .5 * log( (energy (p) + longitudinal_part (p)) & - & /(energy (p) - longitudinal_part (p))) - end function rapidity_vector4 - - elemental function pseudorapidity_vector4 (p) result (eta) - real(default) :: eta - type(vector4_t), intent(in) :: p - eta = -log( tan (.5 * polar_angle (p))) - end function pseudorapidity_vector4 - - elemental function rapidity_distance_vector4 (p, q) result (dy) - type(vector4_t), intent(in) :: p, q - real(default) :: dy - dy = rapidity (q) - rapidity (p) - end function rapidity_distance_vector4 - - elemental function pseudorapidity_distance_vector4 (p, q) result (deta) - real(default) :: deta - type(vector4_t), intent(in) :: p, q - deta = pseudorapidity (q) - pseudorapidity (p) - end function pseudorapidity_distance_vector4 - - elemental function eta_phi_distance_vector4 (p, q) result (dr) - type(vector4_t), intent(in) :: p, q - real(default) :: dr - dr = sqrt ( & - pseudorapidity_distance (p, q)**2 & - + azimuthal_distance (p, q)**2) - end function eta_phi_distance_vector4 - -!!$ subroutine lorentz_transformation_write (L, unit) -!!$ type(lorentz_transformation_t), intent(in) :: L -!!$ integer, intent(in), optional :: unit -!!$ integer :: u -!!$ integer :: i -!!$ u = output_unit (unit) -!!$ write (u, *) 'Lorentz transformation:' -!!$ write (u, *) 'L00:' -!!$ write (u, *) L%L(0,0) -!!$ write (u, *) 'L0j:', L%L(0,1:) -!!$ write (u, *) 'Li0, Lij:' -!!$ do i = 1, 3 -!!$ write (u, *) L%L(i,0) -!!$ write (u, *) ' ', L%L(i,1:) -!!$ end do -!!$ end subroutine lorentz_transformation_write - - pure function lorentz_transformation_get_components (L) result (a) - type(lorentz_transformation_t), intent(in) :: L - real(default), dimension(0:3,0:3) :: a - a = L%L - end function lorentz_transformation_get_components - - elemental function lorentz_transformation_inverse (L) result (IL) - type(lorentz_transformation_t) :: IL - type(lorentz_transformation_t), intent(in) :: L - IL%L(0,0) = L%L(0,0) - IL%L(0,1:) = -L%L(1:,0) - IL%L(1:,0) = -L%L(0,1:) - IL%L(1:,1:) = transpose(L%L(1:,1:)) - end function lorentz_transformation_inverse - - elemental function boost_from_rest_frame (p, m) result (L) - type(lorentz_transformation_t) :: L - type(vector4_t), intent(in) :: p - real(default), intent(in) :: m - L = boost_from_rest_frame_vector3 (space_part (p), m) - end function boost_from_rest_frame - elemental function boost_from_rest_frame_vector3 (p, m) result (L) - type(lorentz_transformation_t) :: L - type(vector3_t), intent(in) :: p - real(default), intent(in) :: m - type(vector3_t) :: beta_gamma - real(default) :: bg2, g, c - integer :: i,j - if (m /= 0) then - beta_gamma = p / m - bg2 = beta_gamma**2 - else - bg2 = 0 - end if - if (bg2 /= 0) then - g = sqrt(1 + bg2); c = (g-1)/bg2 - L%L(0,0) = g - L%L(0,1:) = beta_gamma%p - L%L(1:,0) = L%L(0,1:) - do i=1,3 - do j=1,3 - L%L(i,j) = delta_three(i,j) + c*beta_gamma%p(i)*beta_gamma%p(j) - end do - end do - else - L = identity - end if - end function boost_from_rest_frame_vector3 - elemental function boost_canonical (beta_gamma, k) result (L) - type(lorentz_transformation_t) :: L - real(default), intent(in) :: beta_gamma - integer, intent(in) :: k - real(default) :: g - g = sqrt(1 + beta_gamma**2) - L = identity - L%L(0,0) = g - L%L(0,k) = beta_gamma - L%L(k,0) = L%L(0,k) - L%L(k,k) = L%L(0,0) - end function boost_canonical - elemental function boost_generic (beta_gamma, axis) result (L) - type(lorentz_transformation_t) :: L - real(default), intent(in) :: beta_gamma - type(vector3_t), intent(in) :: axis - if (any(axis%p/=0)) then - L = boost_from_rest_frame_vector3 (beta_gamma * axis, axis**1) - else - L = identity - end if - end function boost_generic - - elemental function rotation_generic_cs (cp, sp, axis) result (R) - type(lorentz_transformation_t) :: R - real(default), intent(in) :: cp, sp - type(vector3_t), intent(in) :: axis - integer :: i,j - R = identity - do i=1,3 - do j=1,3 - R%L(i,j) = cp*delta_three(i,j) + (1-cp)*axis%p(i)*axis%p(j) & - & - sp*dot_product(epsilon_three(i,j,:), axis%p) - end do - end do - end function rotation_generic_cs - elemental function rotation_generic (axis) result (R) - type(lorentz_transformation_t) :: R - type(vector3_t), intent(in) :: axis - real(default) :: phi - if (any(axis%p/=0)) then - phi = abs(axis**1) - R = rotation_generic_cs (cos(phi), sin(phi), axis/phi) - else - R = identity - end if - end function rotation_generic - elemental function rotation_canonical_cs (cp, sp, k) result (R) - type(lorentz_transformation_t) :: R - real(default), intent(in) :: cp, sp - integer, intent(in) :: k - integer :: i,j - R = identity - do i=1,3 - do j=1,3 - R%L(i,j) = -sp*epsilon_three(i,j,k) - end do - R%L(i,i) = cp - end do - R%L(k,k) = 1 - end function rotation_canonical_cs - elemental function rotation_canonical (phi, k) result (R) - type(lorentz_transformation_t) :: R - real(default), intent(in) :: phi - integer, intent(in) :: k - R = rotation_canonical_cs(cos(phi), sin(phi), k) - end function rotation_canonical - elemental function rotation_to_2nd_generic (p, q) result (R) - type(lorentz_transformation_t) :: R - type(vector3_t), intent(in) :: p, q - type(vector3_t) :: a, b, ab - real(default) :: ct, st - if (any (p%p /= 0) .and. any (q%p /= 0)) then - a = direction (p) - b = direction (q) - ab = cross_product(a,b) - ct = a*b; st = ab**1 - if (st /= 0) then - R = rotation_generic_cs (ct, st, ab/st) - else if (ct < 0) then - R = space_reflection - else - R = identity - end if - else - R = identity - end if - end function rotation_to_2nd_generic - elemental function rotation_to_2nd_canonical (k, p) result (R) - type(lorentz_transformation_t) :: R - integer, intent(in) :: k - type(vector3_t), intent(in) :: p - type(vector3_t) :: b, ab - real(default) :: ct, st - integer :: i, j - if (any (p%p /= 0)) then - b = direction (p) - ab%p = 0 - do i = 1, 3 - do j = 1, 3 - ab%p(j) = ab%p(j) + b%p(i) * epsilon_three(i,j,k) - end do - end do - ct = b%p(k); st = ab**1 - if (st /= 0) then - R = rotation_generic_cs (ct, st, ab/st) - else if (ct < 0) then - R = space_reflection - else - R = identity - end if - else - R = identity - end if - end function rotation_to_2nd_canonical - - elemental function transformation_rec_generic (axis, p1, p2, m) result (L) - type(vector3_t), intent(in) :: axis - type(vector4_t), intent(in) :: p1, p2 - real(default), intent(in) :: m - type(lorentz_transformation_t) :: L - L = boost (p1 + p2, m) - L = L * rotation_to_2nd (axis, space_part (inverse (L) * p1)) - end function transformation_rec_generic - elemental function transformation_rec_canonical (k, p1, p2, m) result (L) - integer, intent(in) :: k - type(vector4_t), intent(in) :: p1, p2 - real(default), intent(in) :: m - type(lorentz_transformation_t) :: L - L = boost (p1 + p2, m) - L = L * rotation_to_2nd (k, space_part (inverse (L) * p1)) - end function transformation_rec_canonical - elemental function prod_LT_vector4 (L, p) result (np) - type(vector4_t) :: np - type(lorentz_transformation_t), intent(in) :: L - type(vector4_t), intent(in) :: p - np%p = matmul (L%L, p%p) - end function prod_LT_vector4 - elemental function prod_LT_LT (L1, L2) result (NL) - type(lorentz_transformation_t) :: NL - type(lorentz_transformation_t), intent(in) :: L1,L2 - NL%L = matmul (L1%L, L2%L) - end function prod_LT_LT - elemental function prod_vector4_LT (p, L) result (np) - type(vector4_t) :: np - type(vector4_t), intent(in) :: p - type(lorentz_transformation_t), intent(in) :: L - np%p = matmul (p%p, L%L) - end function prod_vector4_LT - - elemental function LT_compose_r3_r2_b3 & - (cp, sp, ct, st, beta_gamma) result (L) - type(lorentz_transformation_t) :: L - real(default), intent(in) :: cp, sp, ct, st, beta_gamma - real(default) :: gamma - if (beta_gamma==0) then - L%L(0,0) = 1 - L%L(1:,0) = 0 - L%L(0,1:) = 0 - L%L(1,1:) = (/ ct*cp, -ct*sp, st /) - L%L(2,1:) = (/ sp, cp, 0._default /) - L%L(3,1:) = (/ -st*cp, st*sp, ct /) - else - gamma = sqrt(1 + beta_gamma**2) - L%L(0,0) = gamma - L%L(1,0) = 0 - L%L(2,0) = 0 - L%L(3,0) = beta_gamma - L%L(0,1:) = beta_gamma * (/ -st*cp, st*sp, ct /) - L%L(1,1:) = (/ ct*cp, -ct*sp, st /) - L%L(2,1:) = (/ sp, cp, 0._default /) - L%L(3,1:) = gamma * (/ -st*cp, st*sp, ct /) - end if - end function LT_compose_r3_r2_b3 - - elemental function LT_compose_r2_r3_b3 & - (ct, st, cp, sp, beta_gamma) result (L) - type(lorentz_transformation_t) :: L - real(default), intent(in) :: ct, st, cp, sp, beta_gamma - real(default) :: gamma - if (beta_gamma==0) then - L%L(0,0) = 1 - L%L(1:,0) = 0 - L%L(0,1:) = 0 - L%L(1,1:) = (/ ct*cp, -sp, st*cp /) - L%L(2,1:) = (/ ct*sp, cp, st*sp /) - L%L(3,1:) = (/ -st , 0._default, ct /) - else - gamma = sqrt(1 + beta_gamma**2) - L%L(0,0) = gamma - L%L(1,0) = 0 - L%L(2,0) = 0 - L%L(3,0) = beta_gamma - L%L(0,1:) = beta_gamma * (/ -st , 0._default, ct /) - L%L(1,1:) = (/ ct*cp, -sp, st*cp /) - L%L(2,1:) = (/ ct*sp, cp, st*sp /) - L%L(3,1:) = gamma * (/ -st , 0._default, ct /) - end if - end function LT_compose_r2_r3_b3 - - elemental function axis_from_p_r3_r2_b3 & - (p, cp, sp, ct, st, beta_gamma) result (n) - type(vector3_t) :: n - type(vector4_t), intent(in) :: p - real(default), intent(in) :: cp, sp, ct, st, beta_gamma - real(default) :: gamma, px, py - px = cp * p%p(1) - sp * p%p(2) - py = sp * p%p(1) + cp * p%p(2) - n%p(1) = ct * px + st * p%p(3) - n%p(2) = py - n%p(3) = -st * px + ct * p%p(3) - if (beta_gamma/=0) then - gamma = sqrt(1 + beta_gamma**2) - n%p(3) = n%p(3) * gamma + p%p(0) * beta_gamma - end if - end function axis_from_p_r3_r2_b3 - - elemental function axis_from_p_b3 (p, beta_gamma) result (n) - type(vector3_t) :: n - type(vector4_t), intent(in) :: p - real(default), intent(in) :: beta_gamma - real(default) :: gamma - n%p = p%p(1:3) - if (beta_gamma/=0) then - gamma = sqrt(1 + beta_gamma**2) - n%p(3) = n%p(3) * gamma + p%p(0) * beta_gamma - end if - end function axis_from_p_b3 - - elemental function lambda (m1sq, m2sq, m3sq) - real(default) :: lambda - real(default), intent(in) :: m1sq, m2sq, m3sq - lambda = (m1sq - m2sq - m3sq)**2 - 4*m2sq*m3sq - end function lambda - -end module lorentz Index: branches/attic/boschmann_standalone/src/lib/tao_random_numbers.f90 =================================================================== --- branches/attic/boschmann_standalone/src/lib/tao_random_numbers.f90 (revision 8608) +++ branches/attic/boschmann_standalone/src/lib/tao_random_numbers.f90 (revision 8609) @@ -1,897 +0,0 @@ -! $Id: tao_random_numbers.f90 775 2009-06-11 17:59:14Z ohl $ -! -! Copyright (C) 1999-2009 by -! -! Wolfgang Kilian -! Thorsten Ohl -! Juergen Reuter -! -! WHIZARD is free software; you can redistribute it and/or modify it -! under the terms of the GNU General Public License as published by -! the Free Software Foundation; either version 2, or (at your option) -! any later version. -! -! WHIZARD is distributed in the hope that it will be useful, but -! WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! This version of the source code of vamp has no comments and -! can be hard to understand, modify, and improve. You should have -! received a copy of the literate noweb sources of vamp that -! contain the documentation in full detail. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -module tao_random_numbers - implicit none - private :: generate - private :: seed_static, seed_state, seed_raw_state - private :: seed_stateless - private :: create_state_from_seed, create_raw_state_from_seed, & - create_state_from_state, create_raw_state_from_state, & - create_state_from_raw_state, create_raw_state_from_raw_st - private :: destroy_state, destroy_raw_state - public :: assignment(=) - private :: copy_state, copy_raw_state, & - copy_raw_state_to_state, copy_state_to_raw_state - private :: write_state_unit, write_state_name - private :: write_raw_state_unit, write_raw_state_name - private :: read_state_unit, read_state_name - private :: read_raw_state_unit, read_raw_state_name - private :: find_free_unit - public :: tao_random_marshal - private :: marshal_state, marshal_raw_state - public :: tao_random_marshal_size - private :: marshal_state_size, marshal_raw_state_size - public :: tao_random_unmarshal - private :: unmarshal_state, unmarshal_raw_state - public :: tao_random_number - public :: tao_random_seed - public :: tao_random_create - public :: tao_random_destroy - public :: tao_random_copy - public :: tao_random_read - public :: tao_random_write - public :: tao_random_flush - public :: tao_random_luxury - public :: tao_random_test - private :: luxury_stateless - private :: luxury_static, luxury_state, & - luxury_static_integer, luxury_state_integer, & - luxury_static_real, luxury_state_real, & - luxury_static_double, luxury_state_double - private :: write_state_array - private :: read_state_array - private :: & - integer_stateless, integer_array_stateless, & - real_stateless, real_array_stateless, & - double_stateless, double_array_stateless - private :: integer_static, integer_state, & - integer_array_static, integer_array_state, & - real_static, real_state, real_array_static, real_array_state, & - double_static, double_state, double_array_static, double_array_state - interface tao_random_seed - module procedure seed_static, seed_state, seed_raw_state - end interface - interface tao_random_create - module procedure create_state_from_seed, create_raw_state_from_seed, & - create_state_from_state, create_raw_state_from_state, & - create_state_from_raw_state, create_raw_state_from_raw_st - end interface - interface tao_random_destroy - module procedure destroy_state, destroy_raw_state - end interface - interface tao_random_copy - module procedure copy_state, copy_raw_state, & - copy_raw_state_to_state, copy_state_to_raw_state - end interface - interface assignment(=) - module procedure copy_state, copy_raw_state, & - copy_raw_state_to_state, copy_state_to_raw_state - end interface - interface tao_random_write - module procedure & - write_state_unit, write_state_name, & - write_raw_state_unit, write_raw_state_name - end interface - interface tao_random_read - module procedure & - read_state_unit, read_state_name, & - read_raw_state_unit, read_raw_state_name - end interface - interface tao_random_marshal_size - module procedure marshal_state_size, marshal_raw_state_size - end interface - interface tao_random_marshal - module procedure marshal_state, marshal_raw_state - end interface - interface tao_random_unmarshal - module procedure unmarshal_state, unmarshal_raw_state - end interface - interface tao_random_luxury - module procedure luxury_static, luxury_state, & - luxury_static_integer, luxury_state_integer, & - luxury_static_real, luxury_state_real, & - luxury_static_double, luxury_state_double - end interface - interface tao_random_number - module procedure integer_static, integer_state, & - integer_array_static, integer_array_state, & - real_static, real_state, real_array_static, real_array_state, & - double_static, double_state, double_array_static, double_array_state - end interface - integer, parameter, private:: & - int32 = selected_int_kind (9), & - double = selected_real_kind (precision (1.0) + 1, range (1.0) + 1) - integer, parameter, private :: K = 100, L = 37 - integer, parameter, private :: DEFAULT_BUFFER_SIZE = 1009 - integer, parameter, private :: MIN_UNIT = 11, MAX_UNIT = 99 - integer(kind=int32), parameter, private :: M = 2**30 - integer(kind=int32), dimension(K), save, private :: s_state - logical, save, private :: s_virginal = .true. - integer(kind=int32), dimension(DEFAULT_BUFFER_SIZE), save, private :: s_buffer - integer, save, private :: s_buffer_end = size (s_buffer) - integer, save, private :: s_last = size (s_buffer) - type, public :: tao_random_raw_state - integer(kind=int32), dimension(K) :: x - end type tao_random_raw_state - type, public :: tao_random_state - type(tao_random_raw_state) :: state - integer(kind=int32), dimension(:), pointer :: buffer =>null() - integer :: buffer_end, last - end type tao_random_state - character(len=*), public, parameter :: TAO_RANDOM_NUMBERS_RCS_ID = & - "$Id: tao_random_numbers.f90 775 2009-06-11 17:59:14Z ohl $" -contains - subroutine seed_static (seed) - integer, optional, intent(in) :: seed - call seed_stateless (s_state, seed) - s_virginal = .false. - s_last = size (s_buffer) - end subroutine seed_static - elemental subroutine seed_raw_state (s, seed) - type(tao_random_raw_state), intent(inout) :: s - integer, optional, intent(in) :: seed - call seed_stateless (s%x, seed) - end subroutine seed_raw_state - elemental subroutine seed_state (s, seed) - type(tao_random_state), intent(inout) :: s - integer, optional, intent(in) :: seed - call seed_raw_state (s%state, seed) - s%last = size (s%buffer) - end subroutine seed_state - elemental subroutine create_state_from_seed (s, seed, buffer_size) - type(tao_random_state), intent(out) :: s - integer, intent(in) :: seed - integer, intent(in), optional :: buffer_size - call create_raw_state_from_seed (s%state, seed) - if (present (buffer_size)) then - s%buffer_end = max (buffer_size, K) - else - s%buffer_end = DEFAULT_BUFFER_SIZE - end if - allocate (s%buffer(s%buffer_end)) - call tao_random_flush (s) - end subroutine create_state_from_seed - elemental subroutine create_state_from_state (s, state) - type(tao_random_state), intent(out) :: s - type(tao_random_state), intent(in) :: state - call create_raw_state_from_raw_st (s%state, state%state) - allocate (s%buffer(size(state%buffer))) - call tao_random_copy (s, state) - end subroutine create_state_from_state - elemental subroutine create_state_from_raw_state & - (s, raw_state, buffer_size) - type(tao_random_state), intent(out) :: s - type(tao_random_raw_state), intent(in) :: raw_state - integer, intent(in), optional :: buffer_size - call create_raw_state_from_raw_st (s%state, raw_state) - if (present (buffer_size)) then - s%buffer_end = max (buffer_size, K) - else - s%buffer_end = DEFAULT_BUFFER_SIZE - end if - allocate (s%buffer(s%buffer_end)) - call tao_random_flush (s) - end subroutine create_state_from_raw_state - elemental subroutine create_raw_state_from_seed (s, seed) - type(tao_random_raw_state), intent(out) :: s - integer, intent(in) :: seed - call seed_raw_state (s, seed) - end subroutine create_raw_state_from_seed - elemental subroutine create_raw_state_from_state (s, state) - type(tao_random_raw_state), intent(out) :: s - type(tao_random_state), intent(in) :: state - call copy_state_to_raw_state (s, state) - end subroutine create_raw_state_from_state - elemental subroutine create_raw_state_from_raw_st (s, raw_state) - type(tao_random_raw_state), intent(out) :: s - type(tao_random_raw_state), intent(in) :: raw_state - call copy_raw_state (s, raw_state) - end subroutine create_raw_state_from_raw_st - elemental subroutine destroy_state (s) - type(tao_random_state), intent(inout) :: s - deallocate (s%buffer) - end subroutine destroy_state - elemental subroutine destroy_raw_state (s) - type(tao_random_raw_state), intent(inout) :: s - end subroutine destroy_raw_state - elemental subroutine copy_state (lhs, rhs) - type(tao_random_state), intent(inout) :: lhs - type(tao_random_state), intent(in) :: rhs - call copy_raw_state (lhs%state, rhs%state) - if (size (lhs%buffer) /= size (rhs%buffer)) then - deallocate (lhs%buffer) - allocate (lhs%buffer(size(rhs%buffer))) - end if - lhs%buffer = rhs%buffer - lhs%buffer_end = rhs%buffer_end - lhs%last = rhs%last - end subroutine copy_state - elemental subroutine copy_raw_state (lhs, rhs) - type(tao_random_raw_state), intent(out) :: lhs - type(tao_random_raw_state), intent(in) :: rhs - lhs%x = rhs%x - end subroutine copy_raw_state - elemental subroutine copy_raw_state_to_state (lhs, rhs) - type(tao_random_state), intent(inout) :: lhs - type(tao_random_raw_state), intent(in) :: rhs - call copy_raw_state (lhs%state, rhs) - call tao_random_flush (lhs) - end subroutine copy_raw_state_to_state - elemental subroutine copy_state_to_raw_state (lhs, rhs) - type(tao_random_raw_state), intent(out) :: lhs - type(tao_random_state), intent(in) :: rhs - call copy_raw_state (lhs, rhs%state) - end subroutine copy_state_to_raw_state - elemental subroutine tao_random_flush (s) - type(tao_random_state), intent(inout) :: s - s%last = size (s%buffer) - end subroutine tao_random_flush - subroutine write_state_unit (s, unit) - type(tao_random_state), intent(in) :: s - integer, intent(in) :: unit - write (unit = unit, fmt = *) "BEGIN TAO_RANDOM_STATE" - call write_raw_state_unit (s%state, unit) - write (unit = unit, fmt = "(2(1x,a16,1x,i10/),1x,a16,1x,i10)") & - "BUFFER_SIZE", size (s%buffer), & - "BUFFER_END", s%buffer_end, & - "LAST", s%last - write (unit = unit, fmt = *) "BEGIN BUFFER" - call write_state_array (s%buffer, unit) - write (unit = unit, fmt = *) "END BUFFER" - write (unit = unit, fmt = *) "END TAO_RANDOM_STATE" - end subroutine write_state_unit - subroutine read_state_unit (s, unit) - type(tao_random_state), intent(inout) :: s - integer, intent(in) :: unit - integer :: buffer_size - read (unit = unit, fmt = *) - call read_raw_state_unit (s%state, unit) - read (unit = unit, fmt = "(2(1x,16x,1x,i10/),1x,16x,1x,i10)") & - buffer_size, s%buffer_end, s%last - read (unit = unit, fmt = *) - if (buffer_size /= size (s%buffer)) then - deallocate (s%buffer) - allocate (s%buffer(buffer_size)) - end if - call read_state_array (s%buffer, unit) - read (unit = unit, fmt = *) - read (unit = unit, fmt = *) - end subroutine read_state_unit - subroutine write_raw_state_unit (s, unit) - type(tao_random_raw_state), intent(in) :: s - integer, intent(in) :: unit - write (unit = unit, fmt = *) "BEGIN TAO_RANDOM_RAW_STATE" - call write_state_array (s%x, unit) - write (unit = unit, fmt = *) "END TAO_RANDOM_RAW_STATE" - end subroutine write_raw_state_unit - subroutine read_raw_state_unit (s, unit) - type(tao_random_raw_state), intent(inout) :: s - integer, intent(in) :: unit - read (unit = unit, fmt = *) - call read_state_array (s%x, unit) - read (unit = unit, fmt = *) - end subroutine read_raw_state_unit - subroutine find_free_unit (u, iostat) - integer, intent(out) :: u - integer, intent(out), optional :: iostat - logical :: exists, is_open - integer :: i, status - do i = MIN_UNIT, MAX_UNIT - inquire (unit = i, exist = exists, opened = is_open, & - iostat = status) - if (status == 0) then - if (exists .and. .not. is_open) then - u = i - if (present (iostat)) then - iostat = 0 - end if - return - end if - end if - end do - if (present (iostat)) then - iostat = -1 - end if - u = -1 - end subroutine find_free_unit - subroutine write_state_name (s, name) - type(tao_random_state), intent(in) :: s - character(len=*), intent(in) :: name - integer :: unit - call find_free_unit (unit) - open (unit = unit, action = "write", status = "replace", file = name) - call write_state_unit (s, unit) - close (unit = unit) - end subroutine write_state_name - subroutine write_raw_state_name (s, name) - type(tao_random_raw_state), intent(in) :: s - character(len=*), intent(in) :: name - integer :: unit - call find_free_unit (unit) - open (unit = unit, action = "write", status = "replace", file = name) - call write_raw_state_unit (s, unit) - close (unit = unit) - end subroutine write_raw_state_name - subroutine read_state_name (s, name) - type(tao_random_state), intent(inout) :: s - character(len=*), intent(in) :: name - integer :: unit - call find_free_unit (unit) - open (unit = unit, action = "read", status = "old", file = name) - call read_state_unit (s, unit) - close (unit = unit) - end subroutine read_state_name - subroutine read_raw_state_name (s, name) - type(tao_random_raw_state), intent(inout) :: s - character(len=*), intent(in) :: name - integer :: unit - call find_free_unit (unit) - open (unit = unit, action = "read", status = "old", file = name) - call read_raw_state_unit (s, unit) - close (unit = unit) - end subroutine read_raw_state_name - elemental subroutine double_state (s, r) - type(tao_random_state), intent(inout) :: s - real(kind=double), intent(out) :: r - call double_stateless (s%state%x, s%buffer, s%buffer_end, s%last, r) - end subroutine double_state - pure subroutine double_array_state (s, v, num) - type(tao_random_state), intent(inout) :: s - real(kind=double), dimension(:), intent(out) :: v - integer, optional, intent(in) :: num - call double_array_stateless & - (s%state%x, s%buffer, s%buffer_end, s%last, v, num) - end subroutine double_array_state - subroutine double_static (r) - real(kind=double), intent(out) :: r - if (s_virginal) then - call tao_random_seed () - end if - call double_stateless (s_state, s_buffer, s_buffer_end, s_last, r) - end subroutine double_static - subroutine double_array_static (v, num) - real(kind=double), dimension(:), intent(out) :: v - integer, optional, intent(in) :: num - if (s_virginal) then - call tao_random_seed () - end if - call double_array_stateless & - (s_state, s_buffer, s_buffer_end, s_last, v, num) - end subroutine double_array_static - pure subroutine luxury_stateless & - (buffer_size, buffer_end, last, consumption) - integer, intent(in) :: buffer_size - integer, intent(inout) :: buffer_end - integer, intent(inout) :: last - integer, intent(in) :: consumption - if (consumption >= 1 .and. consumption <= buffer_size) then - buffer_end = consumption - last = min (last, buffer_end) - else -!!! print *, "tao_random_luxury: ", "invalid consumption ", & - !!! consumption, ", not in [ 1,", buffer_size, "]." - buffer_end = buffer_size - end if - end subroutine luxury_stateless - elemental subroutine luxury_state (s) - type(tao_random_state), intent(inout) :: s - call luxury_state_integer (s, size (s%buffer)) - end subroutine luxury_state - elemental subroutine luxury_state_integer (s, consumption) - type(tao_random_state), intent(inout) :: s - integer, intent(in) :: consumption - call luxury_stateless (size (s%buffer), s%buffer_end, s%last, consumption) - end subroutine luxury_state_integer - elemental subroutine luxury_state_real (s, consumption) - type(tao_random_state), intent(inout) :: s - real, intent(in) :: consumption - call luxury_state_integer (s, int (consumption * size (s%buffer))) - end subroutine luxury_state_real - elemental subroutine luxury_state_double (s, consumption) - type(tao_random_state), intent(inout) :: s - real(kind=double), intent(in) :: consumption - call luxury_state_integer (s, int (consumption * size (s%buffer))) - end subroutine luxury_state_double - subroutine luxury_static () - if (s_virginal) then - call tao_random_seed () - end if - call luxury_static_integer (size (s_buffer)) - end subroutine luxury_static - subroutine luxury_static_integer (consumption) - integer, intent(in) :: consumption - if (s_virginal) then - call tao_random_seed () - end if - call luxury_stateless (size (s_buffer), s_buffer_end, s_last, consumption) - end subroutine luxury_static_integer - subroutine luxury_static_real (consumption) - real, intent(in) :: consumption - if (s_virginal) then - call tao_random_seed () - end if - call luxury_static_integer (int (consumption * size (s_buffer))) - end subroutine luxury_static_real - subroutine luxury_static_double (consumption) - real(kind=double), intent(in) :: consumption - if (s_virginal) then - call tao_random_seed () - end if - call luxury_static_integer (int (consumption * size (s_buffer))) - end subroutine luxury_static_double - pure subroutine generate (a, state) - integer(kind=int32), dimension(:), intent(inout) :: a, state - integer :: j, n - n = size (a) - a(1:K) = state(1:K) - do j = K+1, n - a(j) = modulo (a(j-K) - a(j-L), M) - end do - state(1:L) = modulo (a(n+1-K:n+L-K) - a(n+1-L:n), M) - do j = L+1, K - state(j) = modulo (a(n+j-K) - state(j-L), M) - end do - end subroutine generate - pure subroutine seed_stateless (state, seed) - integer(kind=int32), dimension(:), intent(out) :: state - integer, optional, intent(in) :: seed - integer, parameter :: DEFAULT_SEED = 0 - integer, parameter :: MAX_SEED = 2**30 - 3 - integer, parameter :: TT = 70 - integer :: seed_value, j, s, t - integer(kind=int32), dimension(2*K-1) :: x - if (present (seed)) then - seed_value = seed - else - seed_value = DEFAULT_SEED - end if - if (seed_value < 0 .or. seed_value > MAX_SEED) then -!!! print *, "tao_random_seed: seed (", seed_value, & - !!! ") not in [ 0,", MAX_SEED, "]!" - seed_value = modulo (abs (seed_value), MAX_SEED + 1) -!!! print *, "tao_random_seed: seed set to ", seed_value, "!" - end if - s = seed_value - modulo (seed_value, 2) + 2 - do j = 1, K - x(j) = s - s = 2*s - if (s >= M) then - s = s - M + 2 - end if - end do - x(K+1:2*K-1) = 0 - x(2) = x(2) + 1 - s = seed_value - t = TT - 1 - do - x(3:2*K-1:2) = x(2:K) - x(2:K+L-1:2) = x(2*K-1:K-L+2:-2) - modulo (x(2*K-1:K-L+2:-2), 2) - do j= 2*K-1, K+1, -1 - if (modulo (x(j), 2) == 1) then - x(j-(K-L)) = modulo (x(j-(K-L)) - x(j), M) - x(j-K) = modulo (x(j-K) - x(j), M) - end if - end do - if (modulo (s, 2) == 1) then - x(2:K+1) = x(1:K) - x(1) = x(K+1) - if (modulo (x(K+1), 2) == 1) then - x(L+1) = modulo (x(L+1) - x(K+1), M) - end if - end if - if (s /= 0) then - s = s / 2 - else - t = t - 1 - end if - if (t <= 0) then - exit - end if - end do - state(K-L+1:K) = x(1:L) - state(1:K-L) = x(L+1:K) - end subroutine seed_stateless - subroutine write_state_array (a, unit) - integer(kind=int32), dimension(:), intent(in) :: a - integer, intent(in) :: unit - integer :: i - do i = 1, size (a) - write (unit = unit, fmt = "(1x,i10,1x,i10)") i, a(i) - end do - end subroutine write_state_array - subroutine read_state_array (a, unit) - integer(kind=int32), dimension(:), intent(inout) :: a - integer, intent(in) :: unit - integer :: i, idum - do i = 1, size (a) - read (unit = unit, fmt = *) idum, a(i) - end do - end subroutine read_state_array - pure subroutine marshal_state (s, ibuf, dbuf) - type(tao_random_state), intent(in) :: s - integer, dimension(:), intent(inout) :: ibuf - real(kind=double), dimension(:), intent(inout) :: dbuf - integer :: buf_size - buf_size = size (s%buffer) - ibuf(1) = s%buffer_end - ibuf(2) = s%last - ibuf(3) = buf_size - ibuf(4:3+buf_size) = s%buffer - call marshal_raw_state (s%state, ibuf(4+buf_size:), dbuf) - end subroutine marshal_state - pure subroutine marshal_state_size (s, iwords, dwords) - type(tao_random_state), intent(in) :: s - integer, intent(out) :: iwords, dwords - call marshal_raw_state_size (s%state, iwords, dwords) - iwords = iwords + 3 + size (s%buffer) - end subroutine marshal_state_size - pure subroutine unmarshal_state (s, ibuf, dbuf) - type(tao_random_state), intent(inout) :: s - integer, dimension(:), intent(in) :: ibuf - real(kind=double), dimension(:), intent(in) :: dbuf - integer :: buf_size - s%buffer_end = ibuf(1) - s%last = ibuf(2) - buf_size = ibuf(3) - s%buffer = ibuf(4:3+buf_size) - call unmarshal_raw_state (s%state, ibuf(4+buf_size:), dbuf) - end subroutine unmarshal_state - pure subroutine marshal_raw_state (s, ibuf, dbuf) - type(tao_random_raw_state), intent(in) :: s - integer, dimension(:), intent(inout) :: ibuf - real(kind=double), dimension(:), intent(inout) :: dbuf - ibuf(1) = size (s%x) - ibuf(2:1+size(s%x)) = s%x - end subroutine marshal_raw_state - pure subroutine marshal_raw_state_size (s, iwords, dwords) - type(tao_random_raw_state), intent(in) :: s - integer, intent(out) :: iwords, dwords - iwords = 1 + size (s%x) - dwords = 0 - end subroutine marshal_raw_state_size - pure subroutine unmarshal_raw_state (s, ibuf, dbuf) - type(tao_random_raw_state), intent(inout) :: s - integer, dimension(:), intent(in) :: ibuf - real(kind=double), dimension(:), intent(in) :: dbuf - integer :: buf_size - buf_size = ibuf(1) - s%x = ibuf(2:1+buf_size) - end subroutine unmarshal_raw_state - pure subroutine integer_stateless & - (state, buffer, buffer_end, last, r) - integer(kind=int32), dimension(:), intent(inout) :: state, buffer - integer, intent(in) :: buffer_end - integer, intent(inout) :: last - integer, intent(out) :: r - integer, parameter :: NORM = 1 - last = last + 1 - if (last > buffer_end) then - call generate (buffer, state) - last = 1 - end if - r = NORM * buffer(last) - end subroutine integer_stateless - pure subroutine real_stateless (state, buffer, buffer_end, last, r) - integer(kind=int32), dimension(:), intent(inout) :: state, buffer - integer, intent(in) :: buffer_end - integer, intent(inout) :: last - real, intent(out) :: r - real, parameter :: NORM = 1.0 / M - last = last + 1 - if (last > buffer_end) then - call generate (buffer, state) - last = 1 - end if - r = NORM * buffer(last) - end subroutine real_stateless - pure subroutine double_stateless (state, buffer, buffer_end, last, r) - integer(kind=int32), dimension(:), intent(inout) :: state, buffer - integer, intent(in) :: buffer_end - integer, intent(inout) :: last - real(kind=double), intent(out) :: r - real(kind=double), parameter :: NORM = 1.0_double / M - last = last + 1 - if (last > buffer_end) then - call generate (buffer, state) - last = 1 - end if - r = NORM * buffer(last) - end subroutine double_stateless - pure subroutine integer_array_stateless & - (state, buffer, buffer_end, last, v, num) - integer(kind=int32), dimension(:), intent(inout) :: state, buffer - integer, intent(in) :: buffer_end - integer, intent(inout) :: last - integer, dimension(:), intent(out) :: v - integer, optional, intent(in) :: num - integer, parameter :: NORM = 1 - integer :: nu, done, todo, chunk - if (present (num)) then - nu = num - else - nu = size (v) - end if - if (last >= buffer_end) then - call generate (buffer, state) - last = 0 - end if - done = 0 - todo = nu - chunk = min (todo, buffer_end - last) - v(1:chunk) = NORM * buffer(last+1:last+chunk) - do - last = last + chunk - done = done + chunk - todo = todo - chunk - chunk = min (todo, buffer_end) - if (chunk <= 0) then - exit - end if - call generate (buffer, state) - last = 0 - v(done+1:done+chunk) = NORM * buffer(1:chunk) - end do - end subroutine integer_array_stateless - pure subroutine real_array_stateless & - (state, buffer, buffer_end, last, v, num) - integer(kind=int32), dimension(:), intent(inout) :: state, buffer - integer, intent(in) :: buffer_end - integer, intent(inout) :: last - real, dimension(:), intent(out) :: v - integer, optional, intent(in) :: num - real, parameter :: NORM = 1.0 / M - integer :: nu, done, todo, chunk - if (present (num)) then - nu = num - else - nu = size (v) - end if - if (last >= buffer_end) then - call generate (buffer, state) - last = 0 - end if - done = 0 - todo = nu - chunk = min (todo, buffer_end - last) - v(1:chunk) = NORM * buffer(last+1:last+chunk) - do - last = last + chunk - done = done + chunk - todo = todo - chunk - chunk = min (todo, buffer_end) - if (chunk <= 0) then - exit - end if - call generate (buffer, state) - last = 0 - v(done+1:done+chunk) = NORM * buffer(1:chunk) - end do - end subroutine real_array_stateless - pure subroutine double_array_stateless & - (state, buffer, buffer_end, last, v, num) - integer(kind=int32), dimension(:), intent(inout) :: state, buffer - integer, intent(in) :: buffer_end - integer, intent(inout) :: last - real(kind=double), dimension(:), intent(out) :: v - integer, optional, intent(in) :: num - real(kind=double), parameter :: NORM = 1.0_double / M - integer :: nu, done, todo, chunk - if (present (num)) then - nu = num - else - nu = size (v) - end if - if (last >= buffer_end) then - call generate (buffer, state) - last = 0 - end if - done = 0 - todo = nu - chunk = min (todo, buffer_end - last) - v(1:chunk) = NORM * buffer(last+1:last+chunk) - do - last = last + chunk - done = done + chunk - todo = todo - chunk - chunk = min (todo, buffer_end) - if (chunk <= 0) then - exit - end if - call generate (buffer, state) - last = 0 - v(done+1:done+chunk) = NORM * buffer(1:chunk) - end do - end subroutine double_array_stateless - elemental subroutine integer_state (s, r) - type(tao_random_state), intent(inout) :: s - integer, intent(out) :: r - call integer_stateless (s%state%x, s%buffer, s%buffer_end, s%last, r) - end subroutine integer_state - elemental subroutine real_state (s, r) - type(tao_random_state), intent(inout) :: s - real, intent(out) :: r - call real_stateless (s%state%x, s%buffer, s%buffer_end, s%last, r) - end subroutine real_state - pure subroutine integer_array_state (s, v, num) - type(tao_random_state), intent(inout) :: s - integer, dimension(:), intent(out) :: v - integer, optional, intent(in) :: num - call integer_array_stateless & - (s%state%x, s%buffer, s%buffer_end, s%last, v, num) - end subroutine integer_array_state - pure subroutine real_array_state (s, v, num) - type(tao_random_state), intent(inout) :: s - real, dimension(:), intent(out) :: v - integer, optional, intent(in) :: num - call real_array_stateless & - (s%state%x, s%buffer, s%buffer_end, s%last, v, num) - end subroutine real_array_state - subroutine integer_static (r) - integer, intent(out) :: r - if (s_virginal) then - call tao_random_seed () - end if - call integer_stateless (s_state, s_buffer, s_buffer_end, s_last, r) - end subroutine integer_static - subroutine real_static (r) - real, intent(out) :: r - if (s_virginal) then - call tao_random_seed () - end if - call real_stateless (s_state, s_buffer, s_buffer_end, s_last, r) - end subroutine real_static - subroutine integer_array_static (v, num) - integer, dimension(:), intent(out) :: v - integer, optional, intent(in) :: num - if (s_virginal) then - call tao_random_seed () - end if - call integer_array_stateless & - (s_state, s_buffer, s_buffer_end, s_last, v, num) - end subroutine integer_array_static - subroutine real_array_static (v, num) - real, dimension(:), intent(out) :: v - integer, optional, intent(in) :: num - if (s_virginal) then - call tao_random_seed () - end if - call real_array_stateless & - (s_state, s_buffer, s_buffer_end, s_last, v, num) - end subroutine real_array_static - subroutine tao_random_test (name) - character(len=*), optional, intent(in) :: name - character (len = *), parameter :: & - OK = "(1x,i10,' is ok.')", & - NOT_OK = "(1x,i10,' is not ok, (expected ',i10,')!')" - integer, parameter :: & - SEED = 310952, & - N = 2009, M = 1009, & - N_SHORT = 1984 - integer, parameter :: & - A_2027082 = 461390032 - integer, dimension(N) :: a - type(tao_random_state) :: s, t - integer, dimension(:), allocatable :: ibuf - real(kind=double), dimension(:), allocatable :: dbuf - integer :: i, ibuf_size, dbuf_size - print *, TAO_RANDOM_NUMBERS_RCS_ID - print *, "testing the 30-bit tao_random_numbers ..." - call tao_random_luxury () - call tao_random_seed (SEED) - do i = 1, N+1 - call tao_random_number (a, M) - end do - if (a(1) == A_2027082) then - print OK, a(1) - else - print NOT_OK, a(1), A_2027082 - end if - call tao_random_seed (SEED) - do i = 1, M+1 - call tao_random_number (a) - end do - if (a(1) == A_2027082) then - print OK, a(1) - else - print NOT_OK, a(1), A_2027082 - end if - print *, "testing the stateless stuff ..." - call tao_random_create (s, SEED) - do i = 1, N_SHORT - call tao_random_number (s, a, M) - end do - call tao_random_create (t, s) - do i = 1, N+1 - N_SHORT - call tao_random_number (s, a, M) - end do - if (a(1) == A_2027082) then - print OK, a(1) - else - print NOT_OK, a(1), A_2027082 - end if - do i = 1, N+1 - N_SHORT - call tao_random_number (t, a, M) - end do - if (a(1) == A_2027082) then - print OK, a(1) - else - print NOT_OK, a(1), A_2027082 - end if - if (present (name)) then - print *, "testing I/O ..." - call tao_random_seed (s, SEED) - do i = 1, N_SHORT - call tao_random_number (s, a, M) - end do - call tao_random_write (s, name) - do i = 1, N+1 - N_SHORT - call tao_random_number (s, a, M) - end do - if (a(1) == A_2027082) then - print OK, a(1) - else - print NOT_OK, a(1), A_2027082 - end if - call tao_random_read (s, name) - do i = 1, N+1 - N_SHORT - call tao_random_number (s, a, M) - end do - if (a(1) == A_2027082) then - print OK, a(1) - else - print NOT_OK, a(1), A_2027082 - end if - end if - print *, "testing marshaling/unmarshaling ..." - call tao_random_seed (s, SEED) - do i = 1, N_SHORT - call tao_random_number (s, a, M) - end do - call tao_random_marshal_size (s, ibuf_size, dbuf_size) - allocate (ibuf(ibuf_size), dbuf(dbuf_size)) - call tao_random_marshal (s, ibuf, dbuf) - do i = 1, N+1 - N_SHORT - call tao_random_number (s, a, M) - end do - if (a(1) == A_2027082) then - print OK, a(1) - else - print NOT_OK, a(1), A_2027082 - end if - call tao_random_unmarshal (s, ibuf, dbuf) - do i = 1, N+1 - N_SHORT - call tao_random_number (s, a, M) - end do - if (a(1) == A_2027082) then - print OK, a(1) - else - print NOT_OK, a(1), A_2027082 - end if - end subroutine tao_random_test -end module tao_random_numbers Index: branches/attic/boschmann_standalone/nagfor_makefile =================================================================== --- branches/attic/boschmann_standalone/nagfor_makefile (revision 8608) +++ branches/attic/boschmann_standalone/nagfor_makefile (revision 8609) @@ -1,16 +0,0 @@ -SRC_BIN_DIR=src/bin -SRC_LIB_DIR=src/lib -FORTRAN_LIB_TARGETS= print_ieee_support.f03 -include common_makefile -FC=nagfor -FCS=nagfor gfortran -NFCS=gfortran -FC_COMMON_FLAGS= $< -maxcontin=1024 -f2003 -g90 -ieee=full -free -nan -w=x95 -w=x77 -mdir $(MOD_DIR) -I $(MOD_DIR) -I/usr/include -w -colour -C=all -FC_MODULE_FLAGS= -pic -M -FC_OBJECT_FLAGS= -pic -c -o $(LIB_DIR)/$@ -FC_STATIC_FLAGS= -c -o $(LIB_DIR)/$@ -FC_SHARED_FLAGS= -c -o $(LIB_DIR)/$@ -pic -shared - -$(SHARED_TARGETS): $$(basename $$@).o - cd $(LIB_DIR) && ld -fpic -shared -o $@ $(basename $@).o - Index: branches/attic/boschmann_standalone/trigger_svn =================================================================== --- branches/attic/boschmann_standalone/trigger_svn (revision 8608) +++ branches/attic/boschmann_standalone/trigger_svn (revision 8609) @@ -1 +0,0 @@ -xx