Index: trunk/omega/tests/tao_random_numbers.f90 =================================================================== --- trunk/omega/tests/tao_random_numbers.f90 (revision 8740) +++ trunk/omega/tests/tao_random_numbers.f90 (revision 8741) @@ -1,897 +1,894 @@ ! tao_random_numbers.f90 -- ! ! Copyright (C) 1999-2021 by ! Wolfgang Kilian ! Thorsten Ohl ! Juergen Reuter ! Christian Speckner ! ! 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 = & - "tao_random_numbers.f90 --" 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: trunk/circe1/share/doc/fit.mp4 =================================================================== --- trunk/circe1/share/doc/fit.mp4 (revision 8740) +++ trunk/circe1/share/doc/fit.mp4 (revision 8741) @@ -1,37 +1,36 @@ -% fit.mp -% $Id: fit.mp4,v 1.2 1996/07/26 10:52:25 ohl Exp $ +% fit.mp -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% include(`circemacs.mp4') include(`output/Slices.mp4') %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% string gpmode; gpmode = "slow"; % gpmode = "fast"; efit (11, "sband", gpmode, "ee", 10); efit (12, "tesla", gpmode, "ee", 10); efit (13, "nlc_a", gpmode, "ee", 10); efit (14, "sband1000", gpmode, "ee", 10); efit (15, "tesla1000", gpmode, "ee", 10); efit (16, "nlc1000_a", gpmode, "ee", 10); efit (17, "tesla350", gpmode, "ee", 10); efit (18, "tesla800", gpmode, "ee", 10); gfit (21, "sband", gpmode, "gg", 10); gfit (22, "tesla", gpmode, "gg", 10); gfit (23, "nlc_a", gpmode, "gg", 10); gfit (24, "sband1000", gpmode, "gg", 10); gfit (25, "tesla1000", gpmode, "gg", 10); gfit (26, "nlc1000_a", gpmode, "gg", 10); gfit (27, "tesla350", gpmode, "gg", 10); gfit (28, "tesla800", gpmode, "gg", 10); %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% postlude %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Local Variables: % mode:indented-text % End: Index: trunk/circe1/share/doc/circemacs.mp4 =================================================================== --- trunk/circe1/share/doc/circemacs.mp4 (revision 8740) +++ trunk/circe1/share/doc/circemacs.mp4 (revision 8741) @@ -1,304 +1,303 @@ -% circemacs.mp4 -% $Id: circemacs.mp4,v 1.11 1996/10/22 22:11:34 ohl Exp $ +% circemacs.mp4 -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % MetaPost's `input' doesn't blend well with verbatimtex. % Let's use m4(1) instead. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% verbatimtex \documentclass{article} \usepackage{amsmath} %%%\usepackage{euler,beton} \begin{document} etex; define(`postlude',` verbatimtex \end{document} etex; end.') %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% input graphx; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% vardef init_scriptsize_numbers = init_numbers (btex {\scriptsize$-$} etex, btex {\scriptsize$\text{1}$} etex, btex {\scriptsize$\cdot\text{10}$} etex, btex {\scriptsize${}^-$} etex, btex {\scriptsize${}^{\text{2}}$} etex); Fe_base := btex {\scriptsize$\text{10}$} etex; defaultfont := Fmfont_; defaultscale := Fmscale_; enddef; vardef init_normalsize_numbers = init_numbers (btex $-$ etex, btex $\text{1}$ etex, btex $\cdot\text{10}$ etex, btex ${}^-$ etex, btex ${}^{\text{2}}$ etex); Fe_base := btex $\text{10}$ etex; defaultfont := Fmfont_; defaultscale := Fmscale_; enddef; init_normalsize_numbers; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Hack around a bug in Mleq/Sleq which blows up when one operand % is negative. [Thanks to Wolfgang Kilian for the correct fix in % Mleq. My fix in Smin and Smax was stupid.] tertiarydef a Mleq b = (if a = Mabs a: if b = Mabs b: % a <= b % a > 0, b > 0 else: % false % a > 0, b < 0 fi % elseif b = Mabs b: % true % a < 0, b > 0 else: % b <= a % a < 0, b < 0 fi) enddef; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pwidth := 1.5pt; width := 38mm; height := 40mm; vardef energy expr e = if e = 350: btex $\sqrt s = 350$GeV etex elseif e = 500: btex $\sqrt s = 500$GeV etex elseif e = 800: btex $\sqrt s = 800$GeV etex elseif e = 1000: btex $\sqrt s = 1$TeV etex fi enddef; vardef gdist (expr n, prefix, postfix, e) = beginfig (n); Gmarks := 3; pickup pencircle scaled pwidth; draw begingraph (width, height); setcoords (log, log); gdraw (prefix & "-sband" & postfix); if e = 500: glabel.urt (btex S-Band etex, 30); elseif e = 1000: glabel.urt (btex S-Band etex, 10); fi gdraw (prefix & "-tesla" & postfix) dashed evenly; glabel.llft (btex Tesla etex, 40); gdraw (prefix & "-xband" & postfix) dashed withdots; if e = 500: glabel.llft (btex X-Band etex, 20); elseif e = 1000: glabel.urt (btex X-Band etex rotated -90, 45); fi glabel.lft (btex $d_{\gamma}(x)$ etex rotated 90, OUT); glabel.bot (btex $x_{\gamma}$ etex, OUT); glabel.top (energy e, OUT); endgraph; endfig; enddef; vardef tgdist (expr n) = beginfig (n); Gmarks := 3; pickup pencircle scaled pwidth; draw begingraph (width, height); setcoords (log, log); gdraw ("dg-tesla3.dat"); glabel.llft (btex 350 GeV etex, 30); gdraw ("dg-tesla.dat") dashed evenly; gdraw ("dg-tesla8.dat") dashed withdots; glabel.urt (btex 800 GeV etex rotated -90, 40); glabel.lft (btex $d_{\gamma}(x)$ etex rotated 90, OUT); glabel.bot (btex $x_{\gamma}$ etex, OUT); glabel.top (btex Tesla etex, OUT); endgraph; endfig; enddef; vardef e_gdraw (expr file) text w = save s, i; gdraw (gdata (file, s, if i > 1: -- fi ((4000 - (4000 * scantokens s1)) / 4000, scantokens s2))) w; enddef; vardef edist (expr n, prefix, postfix, e) = beginfig (n); Gmarks := 3; pickup pencircle scaled pwidth; draw begingraph (width, height); setcoords (-log, log); gdraw (prefix & "-sband" & postfix); if e = 500: glabel.ulft (btex S-Band etex, 30); elseif e = 1000: glabel.ulft (btex S-Band etex, 15); fi gdraw (prefix & "-tesla" & postfix) dashed evenly; glabel.lrt (btex Tesla etex, 40); gdraw (prefix & "-xband" & postfix) dashed withdots; glabel.ulft (btex X-Band etex rotated 90, 45); glabel.lft (btex $d_{e^\pm}(x)$ etex rotated 90, OUT); glabel.bot (btex $1 - x_{e^\pm}$ etex, OUT); glabel.top (energy e, OUT); endgraph; endfig; enddef; vardef tedist (expr n) = beginfig (n); Gmarks := 3; pickup pencircle scaled pwidth; draw begingraph (width, height); setcoords (-log, log); gdraw ("de-tesla3.dat"); glabel.lrt (btex 350 GeV etex, 30); gdraw ("de-tesla.dat") dashed evenly; gdraw ("de-tesla8.dat") dashed withdots; glabel.ulft (btex 800 GeV etex rotated 90, 40); glabel.lft (btex $d_{e^\pm}(x)$ etex rotated 90, OUT); glabel.bot (btex $1 - x_{e^\pm}$ etex, OUT); glabel.top (btex Tesla etex, OUT); endgraph; endfig; enddef; vardef gdist_ee (expr n, prefix, postfix, e) = beginfig (n); Gmarks := 3; pickup pencircle scaled pwidth; draw begingraph (width, height); setcoords (log, log); gdraw (prefix & postfix); glabel.urt (btex $e^+e^-$ etex, 20); gdraw (prefix & "-ee" & postfix) dashed evenly; glabel.llft (btex $e^-e^-$ etex, 20); glabel.lft (btex $d_{\gamma}(x)$ etex rotated 90, OUT); glabel.bot (btex $x_{\gamma}$ etex, OUT); glabel.top (energy e, OUT); endgraph; endfig; enddef; vardef edist_ee (expr n, prefix, postfix, e) = beginfig (n); Gmarks := 3; pickup pencircle scaled pwidth; draw begingraph (width, height); setcoords (-log, log); gdraw (prefix & postfix); glabel.lrt (btex $e^+e^-$ etex, 30); gdraw (prefix & "-ee" & postfix) dashed evenly; glabel.ulft (btex $e^-e^-$ etex, 30); glabel.lft (btex $d_{e^\pm}(x)$ etex rotated 90, OUT); glabel.bot (btex $1 - x_{e^\pm}$ etex, OUT); glabel.top (energy e, OUT); endgraph; endfig; enddef; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% picture eslice[], gslice[]; vardef twodigs (expr n) = if (n >= 0) and (n <= 9): "0" & decimal n elseif (n >= 10) and (n <= 99): decimal n else: "**" fi enddef; vardef fod_name (expr acc, mode, tag, sli) = "output" & "/" & acc & "_" & mode & "/lumidiff-" & tag & "x" & twodigs (sli) enddef; vardef fit_name (expr acc, mode, tag, sli) = fod_name (acc, mode, tag, sli) & ".fit" enddef; vardef dat_name (expr acc, mode, tag, sli) = fod_name (acc, mode, tag, sli) & ".dat" enddef; vardef acc_name expr acc = if acc = "sband": btex S-Band, $\sqrt s = 500$GeV etex elseif acc = "sband1000": btex S-Band, $\sqrt s = 1$TeV etex elseif acc = "tesla350": btex Tesla, $\sqrt s = 350$GeV etex elseif acc = "tesla": btex Tesla, $\sqrt s = 500$GeV etex elseif acc = "tesla500": btex Tesla, $\sqrt s = 500$GeV etex elseif acc = "tesla800": btex Tesla, $\sqrt s = 800$GeV etex elseif acc = "tesla1000": btex Tesla, $\sqrt s = 1$TeV etex elseif substring (0,4) of acc = "nlc_": btex X-Band, $\sqrt s = 500$GeV etex elseif substring (0,8) of acc = "nlc1000_": btex X-Band, $\sqrt s = 1$TeV etex fi enddef; vardef gfit (expr n, acc, mode, tag, sli) = beginfig (n); pickup pencircle scaled 1pt; draw begingraph (width, height); setcoords (log, linear); message ("gfit: " & fod_name (acc, mode, tag, sli)); gdraw (fit_name (acc, mode, tag, sli)); gdraw_err (dat_name (acc, mode, tag, sli), circle, false, 0); glabel.lft (gslice[sli] rotated 90, OUT); glabel.bot (btex $x_\gamma$ etex, OUT); glabel.ulft (btex etex, OUT); glabel.top (acc_name acc, OUT); endgraph; endfig; enddef; vardef efit (expr n, acc, mode, tag, sli) = beginfig (n); pickup pencircle scaled 1pt; draw begingraph (width, height); save s; setcoords (-log, linear); message ("efit: " & fod_name (acc, mode, tag, sli)); gdraw (fit_name (acc, mode, tag, sli)); gdraw_err (dat_name (acc, mode, tag, sli), circle, false, 0); glabel.lft (eslice[sli] rotated 90, OUT); glabel.bot (btex $1-x_{e^\pm}$ etex, OUT); glabel.top (acc_name acc, OUT); endgraph; endfig; enddef; warningcheck := 0; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Local Variables: % mode:indented-text % End: Index: trunk/circe1/share/doc/tex-comments.sh =================================================================== --- trunk/circe1/share/doc/tex-comments.sh (revision 8740) +++ trunk/circe1/share/doc/tex-comments.sh (revision 8741) @@ -1,23 +1,23 @@ #! /usr/bin/awk -f -# $Id: tex-comments.sh 314 2010-04-17 20:32:33Z ohl $ +# tex-comments.sh -- /^@begin docs / { code = 0 } /^@begin code / { code = 1 } code && /^@text .*![:$]/ { if (match($0, /!:.*$/)) { printf("%s\n", substr($0, 1, RSTART-1)) printf("@literal ! {\\setupmodname %s}\n", substr($0, RSTART+2)) next } if (match($0, /!\$.*$/)) { printf("%s\n", substr($0, 1, RSTART-1)) printf("@literal ! {\\setupmodname$ %s $}\n", substr($0, RSTART+2)) next } } # Hide a trick for Poor Man's Elemental Procedures code { gsub(/`'_/, "_") } { print } Index: trunk/circe1/share/doc/dist.mp4 =================================================================== --- trunk/circe1/share/doc/dist.mp4 (revision 8740) +++ trunk/circe1/share/doc/dist.mp4 (revision 8741) @@ -1,30 +1,29 @@ % dist-v0-r0.mp4 -- -% $Id: dist.mp4,v 1.2 1996/08/08 10:37:58 ohl Exp $ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% include(`circemacs.mp4') %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% edist_ee (11, "de-tesla", ".dat", 500); gdist_ee (12, "dg-tesla", ".dat", 500); edist_ee (13, "de-teslat", ".dat", 500); gdist_ee (14, "dg-teslat", ".dat", 500); edist (1, "de", ".dat", 500); gdist (2, "dg", ".dat", 500); edist (3, "de", "t.dat", 1000); gdist (4, "dg", "t.dat", 1000); tedist (5); tgdist (6); %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% postlude %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Local Variables: % mode:indented-text % End: Index: trunk/circe1/share/doc/graphx.mp =================================================================== --- trunk/circe1/share/doc/graphx.mp (revision 8740) +++ trunk/circe1/share/doc/graphx.mp (revision 8741) @@ -1,283 +1,282 @@ % graphx.mp -- % Copyright (C) 1995-2011 by ohl@physik.uni-wuerzburg.de -% $Id: graphx.nw,v 1.13 1995/08/29 22:16:59 ohl Exp $ % % Graphx 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. % % Graphx 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. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% input graph; input sarith; numeric symbol_width, error_width; symbol_width = 2mm; error_width = 3mm; def gMdraw = Gaddto_ doublepath GMdraw_ enddef; def gMfill = Gaddto_ contour GMfill_ enddef; def GMdraw_ expr p = if path p or pair p: GMcvi_ (true) p else: Gerr_ (p, "gMdraw argument should be a pair or a path") origin fi withpen currentpen Gwithlist_ _op_ enddef; def GMfill_ expr p = if cycle p: GMcvi_ (true) p else: Gerr_ (p, "gMfill argument should be a cyclic path") origin .. cycle fi Gwithlist_ _op_ enddef; vardef glabel_err (expr p, f) (suffix s) text w = if path p or picture p: glabel_err_symbol (p, f, s) w; elseif string p or numeric p: glabel_err_area (p, f, s); else: Gerr_ (p, "glabel_err's first argument must be a path or numeric") fi enddef; vardef glabel_err_symbol (expr p, f) (suffix s) text w = interim warningcheck := 0; save i, Mx, My, Mep, Mem, Mpep, Mpem, Sep, Sem; string Sep, Sem; glabel (if picture p: p else: image (if f: fill else: draw fi p) fi, s1, s2) w; (Mx, My) = (Mlog_Str s1, Mlog_Str s2); Sep := "0"; Sem := "0"; (Mpep, Mpem) = (Mzero, Mzero); i := 3; forever: exitunless iserror s[i]; if (strip s[i]) Sneq 0: if (substring (0,1) of s[i]) = "+": Sep := Sep Sadd s[i]; Mep := Mlog_Str Sep; glabel (image (draw bar), s1, s2 Sadd Sep) w; gMdraw (Mx, My Madd Mpep) -- (Mx, My Madd Mep) w; Mpep := Mep; elseif (substring (0,1) of s[i]) = "-": Sem := Sem Sadd (Sabs s[i]); Mem := Mlog_Str Sem; glabel (image (draw bar), s1, s2 Ssub Sem) w; gMdraw (Mx, My Msub Mpem) -- (Mx, My Msub Mem) w; Mpem := Mem; elseif isnumeric (substring (0,1) of s[i]): Sem := Sem Sadd (Sabs s[i]); Mem := Mlog_Str Sem; glabel (image (draw bar), s1, s2 Ssub Sem) w; gMdraw (Mx, My Msub Mpem) -- (Mx, My Msub Mem) w; Mpem := Mem; Sep := Sep Sadd s[i]; Mep := Mlog_Str Sep; glabel (image (draw bar), s1, s2 Sadd Sep) w; gMdraw (Mx, My Madd Mpep) -- (Mx, My Madd Mep) w; Mpep := Mep; elseif (substring (0,1) of s[i]) = "^": Sep := Sep Sadd (substring (1,infinity) of s[i]); Mep := Mlog_Str Sep; glabel (image (fill uparr), s1, s2 Sadd Sep) w; gMdraw (Mx, My Madd Mpep) -- (Mx, My Madd Mep) w; Mpep := Mep; elseif (substring (0,1) of s[i]) = "_": Sem := Sem Sadd (Sabs (substring (1,infinity) of s[i])); Mem := Mlog_Str Sem; glabel (image (fill downarr), s1, s2 Ssub Sem) w; gMdraw (Mx, My Msub Mpem) -- (Mx, My Msub Mem) w; Mpem := Mem; fi fi i := i + 1; endfor enddef; vardef issymbolic expr s = (s = "+") or (s = "-") or (s = "^") or (s = "_") enddef; vardef strip expr s = if issymbolic (substring (0,1) of s): substring (1,infinity) of s else: s fi enddef; vardef isnumeric expr s = if known s: (isdigit (substring (0,1) of s)) or (substring (0,1) of s = ".") else: false fi enddef; vardef iserror expr s = if known s: (isnumeric (substring (0,1) of s)) or (issymbolic (substring (0,1) of s)) else: false fi enddef; vardef glabel_err_area (expr w, col) (suffix s) = interim warningcheck := 0; save n, i, Mw, Mx, My, Mep, Mem, Mpep, Mpem, Mxp, Mxm; Mw := Mlog_Str w; (Mx, My) = (Mlog_Str s1, Mlog_Str s2); (Mxm, Mxp) = (Mx Msub Mw, Mx Madd Mw); n := 1; forever: exitunless iserror s[n]; n := n + 1; endfor n := n - 1; (Mpep, Mpem) = (Mzero, Mzero); for i = 3 upto n: if s[i] Sneq 0: if (substring (0,1) of s[i]) = "+": Mep := Mpep Madd Mlog_Str s[i]; rectangle (Mxm, Mxp, My Madd Mpep, My Madd Mep, col, (i-3)/(n-2)); Mpep := Mep; elseif (substring (0,1) of s[i]) = "-": Mem := Mpem Madd (Mabs Mlog_Str s[i]); rectangle (Mxm, Mxp, My Msub Mpem, My Msub Mem, col, (i-3)/(n-2)); Mpem := Mem; elseif isnumeric (substring (0,1) of s[i]): Mep := Mpep Madd Mlog_Str s[i]; rectangle (Mxm, Mxp, My Madd Mpep, My Madd Mep, col, (i-3)/(n-2)); Mpep := Mep; Mem := Mpem Madd (Mabs Mlog_Str s[i]); rectangle (Mxm, Mxp, My Msub Mpem, My Msub Mem, col, (i-3)/(n-2)); Mpem := Mem; fi fi endfor enddef; vardef rectangle (expr xm, xp, ym, yp, col, f) = gMfill (xm, ym) -- (xm, yp) -- (xp, yp) -- (xp, ym) -- cycle withcolor f[if color col: col elseif numeric col: col*white else: .5white fi, white] enddef; vardef gdraw_err_scaled (expr file, scale, p, f, off) text w = gdata (file, s, gscale (s, off, scale); glabel_err (p, f, s) w;) enddef; vardef gscale (suffix s) (expr off, scale) = save i, pfx; string pfx; if known off and known s1: s[1] := s[1] Sadd off; fi if known scale: i := 2; forever: exitunless iserror s[i]; pfx := substring (0,1) of s[i]; if issymbolic pfx: s[i] := (substring (1,infinity) of s[i]) Smul scale; s[i] := pfx & s[i]; else: s[i] := s[i] Smul scale; fi i := i + 1; endfor fi enddef; vardef gdraw_err (expr file, p, f, off) text w = gdraw_err_scaled (file, 1, p, f, off) w enddef; vardef bar = (-error_width/2,0) -- (error_width/2,0) enddef; vardef uparr = (-error_width/2,-error_width/2) -- origin -- (error_width/2,-error_width/2) -- (0,-error_width/4) -- cycle enddef; vardef downarr = (-error_width/2,error_width/2) -- origin -- (error_width/2,error_width/2) -- (0,error_width/4) -- cycle enddef; vardef square = unitsquare shifted (-.5,-.5) scaled symbol_width enddef; vardef circle = fullcircle scaled symbol_width enddef; vardef diamond = unitsquare shifted (-.5,-.5) rotated 45 scaled symbol_width enddef; vardef polygon expr n = if n > 2: (for i = 1 upto n: (.5up rotated (360i/n)) -- endfor cycle) else: fullcircle fi scaled symbol_width enddef; vardef polygram expr n = if n > 2: (for i = 1 upto n: (.5up rotated (360i/n)) -- (.2up rotated (360(i+.5)/n)) -- endfor cycle) else: fullcircle fi scaled symbol_width enddef; vardef polycross expr n = save i; (for i = 1 upto n: origin -- .5 dir (360(i-.5)/n) -- endfor cycle) scaled symbol_width enddef; secondarydef a Madd b = if a = Mzero: b elseif b = Mzero: a elseif a >= b: (Mlog(1579 + Mexp(b Mmul (1885.32404-a))) + a-1885.32404) else: b Madd a fi enddef; vardef Garwhd_ (expr p) (text w) = addto Gcur_ also image (fill arrowhead p w; Gsetb_ point infinity of p..cycle); enddef; endinput; % The End. Index: trunk/circe1/share/misc/gg.f90 =================================================================== --- trunk/circe1/share/misc/gg.f90 (revision 8740) +++ trunk/circe1/share/misc/gg.f90 (revision 8741) @@ -1,1576 +1,1574 @@ -! $Id:$ +! gg.f90 -- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module kinds implicit none integer, parameter, public :: & double = selected_real_kind (precision (1.0) + 1, range (1.0) + 1) end module kinds !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module histograms use kinds implicit none integer, parameter :: DEFAULT_UNIT = 42 public :: create_histogram public :: fill_histogram public :: delete_histogram public :: write_histogram private :: create_histogram1, create_histogram2 private :: fill_histogram1, fill_histogram2s, fill_histogram2v private :: delete_histogram1, delete_histogram2 private :: write_histogram1, write_histogram2 private :: midpoint private :: midpoint1, midpoint2 interface create_histogram module procedure create_histogram1, create_histogram2 end interface interface fill_histogram module procedure fill_histogram1, fill_histogram2s, fill_histogram2v end interface interface delete_histogram module procedure delete_histogram1, delete_histogram2 end interface interface write_histogram module procedure write_histogram1, write_histogram2 end interface interface midpoint module procedure midpoint1, midpoint2 end interface integer, parameter, private :: N_BINS_DEFAULT = 10 type, public :: histogram integer :: n_bins real(kind=double) :: x_min, x_max real(kind=double), dimension(:), pointer :: bins, bins2 end type histogram type, public :: histogram2 integer, dimension(2) :: n_bins real(kind=double), dimension(2) :: x_min, x_max real(kind=double), dimension(:,:), pointer :: bins, bins2 end type histogram2 - character(len=*), public, parameter :: HISTOGRAMS_RCS_ID = & - "$Id: triangle90.f90,v 1.8 1998/09/09 11:10:14 ohl Exp $" contains elemental subroutine create_histogram1 (h, x_min, x_max, nb) type(histogram), intent(out) :: h real(kind=double), intent(in) :: x_min, x_max integer, intent(in), optional :: nb if (present (nb)) then h%n_bins = nb else h%n_bins = N_BINS_DEFAULT end if h%x_min = x_min h%x_max = x_max allocate (h%bins(0:h%n_bins+1), h%bins2(0:h%n_bins+1)) h%bins = 0 h%bins2 = 0 end subroutine create_histogram1 pure subroutine create_histogram2 (h, x_min, x_max, nb) type(histogram2), intent(out) :: h real(kind=double), dimension(:), intent(in) :: x_min, x_max integer, intent(in), dimension(:), optional :: nb if (present (nb)) then h%n_bins = nb else h%n_bins = N_BINS_DEFAULT end if h%x_min = x_min h%x_max = x_max allocate (h%bins(0:h%n_bins(1)+1,0:h%n_bins(1)+1), & h%bins2(0:h%n_bins(2)+1,0:h%n_bins(2)+1)) h%bins = 0 h%bins2 = 0 end subroutine create_histogram2 elemental subroutine fill_histogram1 (h, x, weight) type(histogram), intent(inout) :: h real(kind=double), intent(in) :: x real(kind=double), intent(in), optional :: weight integer :: i i = 1 + h%n_bins * (x - h%x_min) / (h%x_max - h%x_min) i = min (max (i, 0), h%n_bins + 1) if (present (weight)) then h%bins(i) = h%bins(i) + weight h%bins2(i) = h%bins2(i) + weight*weight else h%bins(i) = h%bins(i) + 1 h%bins2(i) = h%bins2(i) + 1 end if end subroutine fill_histogram1 elemental subroutine fill_histogram2s (h, x1, x2, weight) type(histogram2), intent(inout) :: h real(kind=double), intent(in) :: x1, x2 real(kind=double), intent(in), optional :: weight call fill_histogram2v (h, (/ x1, x2 /), weight) end subroutine fill_histogram2s pure subroutine fill_histogram2v (h, x, weight) type(histogram2), intent(inout) :: h real(kind=double), dimension(:), intent(in) :: x real(kind=double), intent(in), optional :: weight integer, dimension(2) :: i i = 1 + h%n_bins * (x - h%x_min) / (h%x_max - h%x_min) i = min (max (i, 0), h%n_bins + 1) if (present (weight)) then h%bins(i(1),i(2)) = h%bins(i(1),i(2)) + weight h%bins2(i(1),i(2)) = h%bins2(i(1),i(2)) + weight*weight else h%bins(i(1),i(2)) = h%bins(i(1),i(2)) + 1 h%bins2(i(1),i(2)) = h%bins2(i(1),i(2)) + 1 end if end subroutine fill_histogram2v elemental subroutine delete_histogram1 (h) type(histogram), intent(inout) :: h deallocate (h%bins, h%bins2) end subroutine delete_histogram1 elemental subroutine delete_histogram2 (h) type(histogram2), intent(inout) :: h deallocate (h%bins, h%bins2) end subroutine delete_histogram2 subroutine write_histogram1 (h, name, over) type(histogram), intent(in) :: h character(len=*), intent(in), optional :: name logical, intent(in), optional :: over integer :: i if (present (name)) then if (DEFAULT_UNIT > 0) then open (unit = DEFAULT_UNIT, action = "write", status = "replace", & file = name) if (present (over)) then if (over) then write (unit = DEFAULT_UNIT, fmt = *) & "underflow", h%bins(0), sqrt (h%bins2(0)) end if end if do i = 1, h%n_bins write (unit = DEFAULT_UNIT, fmt = *) & midpoint (h, i), h%bins(i), sqrt (h%bins2(i)) end do if (present (over)) then if (over) then write (unit = DEFAULT_UNIT, fmt = *) & "overflow", h%bins(h%n_bins+1), & sqrt (h%bins2(h%n_bins+1)) end if end if close (unit = DEFAULT_UNIT) else print *, "write_histogram: Can't find a free unit!" end if else if (present (over)) then if (over) then print *, "underflow", h%bins(0), sqrt (h%bins2(0)) end if end if do i = 1, h%n_bins print *, midpoint (h, i), h%bins(i), sqrt (h%bins2(i)) end do if (present (over)) then if (over) then print *, "overflow", h%bins(h%n_bins+1), & sqrt (h%bins2(h%n_bins+1)) end if end if end if end subroutine write_histogram1 elemental function midpoint1 (h, bin) result (x) type(histogram), intent(in) :: h integer, intent(in) :: bin real(kind=double) :: x x = h%x_min + (h%x_max - h%x_min) * (bin - 0.5) / h%n_bins end function midpoint1 elemental function midpoint2 (h, bin, d) result (x) type(histogram2), intent(in) :: h integer, intent(in) :: bin, d real(kind=double) :: x x = h%x_min(d) + (h%x_max(d) - h%x_min(d)) * (bin - 0.5) / h%n_bins(d) end function midpoint2 subroutine write_histogram2 (h, name, over) type(histogram2), intent(in) :: h character(len=*), intent(in), optional :: name logical, intent(in), optional :: over integer :: i1, i2 if (present (name)) then if (DEFAULT_UNIT > 0) then open (unit = DEFAULT_UNIT, action = "write", status = "replace", & file = name) if (present (over)) then if (over) then write (unit = DEFAULT_UNIT, fmt = *) & "double underflow", h%bins(0,0), sqrt (h%bins2(0,0)) do i2 = 1, h%n_bins(2) write (unit = DEFAULT_UNIT, fmt = *) & "x1 underflow", midpoint (h, i2, 2), & h%bins(0,i2), sqrt (h%bins2(0,i2)) end do do i1 = 1, h%n_bins(1) write (unit = DEFAULT_UNIT, fmt = *) & "x2 underflow", midpoint (h, i1, 1), & h%bins(i1,0), sqrt (h%bins2(i1,0)) end do end if end if do i1 = 1, h%n_bins(1) do i2 = 1, h%n_bins(2) write (unit = DEFAULT_UNIT, fmt = *) & midpoint (h, i1, 1), midpoint (h, i2, 2), & h%bins(i1,i2), sqrt (h%bins2(i1,i2)) end do end do if (present (over)) then if (over) then do i2 = 1, h%n_bins(2) write (unit = DEFAULT_UNIT, fmt = *) & "x1 overflow", midpoint (h, i2, 2), & h%bins(h%n_bins(1)+1,i2), & sqrt (h%bins2(h%n_bins(1)+1,i2)) end do do i1 = 1, h%n_bins(1) write (unit = DEFAULT_UNIT, fmt = *) & "x2 overflow", midpoint (h, i1, 1), & h%bins(i1,h%n_bins(2)+1), & sqrt (h%bins2(i1,h%n_bins(2)+1)) end do write (unit = DEFAULT_UNIT, fmt = *) "double overflow", & h%bins(h%n_bins(1)+1,h%n_bins(2)+1), & sqrt (h%bins2(h%n_bins(1)+1,h%n_bins(2)+1)) end if end if close (unit = DEFAULT_UNIT) else print *, "write_histogram: Can't find a free unit!" end if else if (present (over)) then if (over) then print *, "double underflow", h%bins(0,0), sqrt (h%bins2(0,0)) do i2 = 1, h%n_bins(2) print *, "x1 underflow", midpoint (h, i2, 2), & h%bins(0,i2), sqrt (h%bins2(0,i2)) end do do i1 = 1, h%n_bins(1) print *, "x2 underflow", midpoint (h, i1, 1), & h%bins(i1,0), sqrt (h%bins2(i1,0)) end do end if end if do i1 = 1, h%n_bins(1) do i2 = 1, h%n_bins(2) print *, midpoint (h, i1, 1), midpoint (h, i2, 2), & h%bins(i1,i2), sqrt (h%bins2(i1,i2)) end do end do if (present (over)) then if (over) then do i2 = 1, h%n_bins(2) print *, "x1 overflow", midpoint (h, i2, 2), & h%bins(h%n_bins(1)+1,i2), & sqrt (h%bins2(h%n_bins(1)+1,i2)) end do do i1 = 1, h%n_bins(1) print *, "x2 overflow", midpoint (h, i1, 1), & h%bins(i1,h%n_bins(2)+1), & sqrt (h%bins2(i1,h%n_bins(2)+1)) end do print *, "double overflow", & h%bins(h%n_bins(1)+1,h%n_bins(2)+1), & sqrt (h%bins2(h%n_bins(1)+1,h%n_bins(2)+1)) end if end if end if end subroutine write_histogram2 end module histograms !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!! module specfun77 !!! use kinds !!! implicit none !!! contains !!! function besi0(x) !!! implicit double precision (a-h,o-z) !!! implicit integer (i-n) !!! logical lex !!! dimension ci(0:24,0:1),ck(0:16,0:1) !!! parameter (eps=1d-15) !!! parameter (z1 = 1, hf = z1/2) !!! parameter (pi = 3.14159265358979324d0) !!! parameter (ce = 0.57721566490153286d0) !!! parameter (pih = pi/2, rpih = 2/pi, rpi2 = 1/(2*pi)) !!! !!! data ci( 0,0) /+1.008279205458740032d0/ !!! data ci( 1,0) /+0.008445122624920943d0/ !!! data ci( 2,0) /+0.000172700630777567d0/ !!! data ci( 3,0) /+0.000007247591099959d0/ !!! data ci( 4,0) /+0.000000513587726878d0/ !!! data ci( 5,0) /+0.000000056816965808d0/ !!! data ci( 6,0) /+0.000000008513091223d0/ !!! data ci( 7,0) /+0.000000001238425364d0/ !!! data ci( 8,0) /+0.000000000029801672d0/ !!! data ci( 9,0) /-0.000000000078956698d0/ !!! data ci(10,0) /-0.000000000033127128d0/ !!! data ci(11,0) /-0.000000000004497339d0/ !!! data ci(12,0) /+0.000000000001799790d0/ !!! data ci(13,0) /+0.000000000000965748d0/ !!! data ci(14,0) /+0.000000000000038604d0/ !!! data ci(15,0) /-0.000000000000104039d0/ !!! data ci(16,0) /-0.000000000000023950d0/ !!! data ci(17,0) /+0.000000000000009554d0/ !!! data ci(18,0) /+0.000000000000004443d0/ !!! data ci(19,0) /-0.000000000000000859d0/ !!! data ci(20,0) /-0.000000000000000709d0/ !!! data ci(21,0) /+0.000000000000000087d0/ !!! data ci(22,0) /+0.000000000000000112d0/ !!! data ci(23,0) /-0.000000000000000012d0/ !!! data ci(24,0) /-0.000000000000000018d0/ !!! !!! data ci( 0,1) /+0.975800602326285926d0/ !!! data ci( 1,1) /-0.024467442963276385d0/ !!! data ci( 2,1) /-0.000277205360763829d0/ !!! data ci( 3,1) /-0.000009732146728020d0/ !!! data ci( 4,1) /-0.000000629724238640d0/ !!! data ci( 5,1) /-0.000000065961142154d0/ !!! data ci( 6,1) /-0.000000009613872919d0/ !!! data ci( 7,1) /-0.000000001401140901d0/ !!! data ci( 8,1) /-0.000000000047563167d0/ !!! data ci( 9,1) /+0.000000000081530681d0/ !!! data ci(10,1) /+0.000000000035408148d0/ !!! data ci(11,1) /+0.000000000005102564d0/ !!! data ci(12,1) /-0.000000000001804409d0/ !!! data ci(13,1) /-0.000000000001023594d0/ !!! data ci(14,1) /-0.000000000000052678d0/ !!! data ci(15,1) /+0.000000000000107094d0/ !!! data ci(16,1) /+0.000000000000026120d0/ !!! data ci(17,1) /-0.000000000000009561d0/ !!! data ci(18,1) /-0.000000000000004713d0/ !!! data ci(19,1) /+0.000000000000000829d0/ !!! data ci(20,1) /+0.000000000000000743d0/ !!! data ci(21,1) /-0.000000000000000080d0/ !!! data ci(22,1) /-0.000000000000000117d0/ !!! data ci(23,1) /+0.000000000000000011d0/ !!! data ci(24,1) /+0.000000000000000019d0/ !!! !!! data ck( 0,0) /+0.988408174230825800d0/ !!! data ck( 1,0) /-0.011310504646928281d0/ !!! data ck( 2,0) /+0.000269532612762724d0/ !!! data ck( 3,0) /-0.000011106685196665d0/ !!! data ck( 4,0) /+0.000000632575108500d0/ !!! data ck( 5,0) /-0.000000045047337641d0/ !!! data ck( 6,0) /+0.000000003792996456d0/ !!! data ck( 7,0) /-0.000000000364547179d0/ !!! data ck( 8,0) /+0.000000000039043756d0/ !!! data ck( 9,0) /-0.000000000004579936d0/ !!! data ck(10,0) /+0.000000000000580811d0/ !!! data ck(11,0) /-0.000000000000078832d0/ !!! data ck(12,0) /+0.000000000000011360d0/ !!! data ck(13,0) /-0.000000000000001727d0/ !!! data ck(14,0) /+0.000000000000000275d0/ !!! data ck(15,0) /-0.000000000000000046d0/ !!! data ck(16,0) /+0.000000000000000008d0/ !!! !!! data ck( 0,1) /+1.035950858772358331d0/ !!! data ck( 1,1) /+0.035465291243331114d0/ !!! data ck( 2,1) /-0.000468475028166889d0/ !!! data ck( 3,1) /+0.000016185063810053d0/ !!! data ck( 4,1) /-0.000000845172048124d0/ !!! data ck( 5,1) /+0.000000057132218103d0/ !!! data ck( 6,1) /-0.000000004645554607d0/ !!! data ck( 7,1) /+0.000000000435417339d0/ !!! data ck( 8,1) /-0.000000000045757297d0/ !!! data ck( 9,1) /+0.000000000005288133d0/ !!! data ck(10,1) /-0.000000000000662613d0/ !!! data ck(11,1) /+0.000000000000089048d0/ !!! data ck(12,1) /-0.000000000000012726d0/ !!! data ck(13,1) /+0.000000000000001921d0/ !!! data ck(14,1) /-0.000000000000000305d0/ !!! data ck(15,1) /+0.000000000000000050d0/ !!! data ck(16,1) /-0.000000000000000009d0/ !!! !!! nu=0 !!! lex=.false. !!! go to 6 !!! !!! entry ebesi0(x) !!! nu=0 !!! lex=.true. !!! go to 6 !!! !!! entry besi1(x) !!! nu=1 !!! lex=.false. !!! go to 6 !!! !!! entry ebesi1(x) !!! nu=1 !!! lex=.true. !!! !!! 6 continue !!! v=abs(x) !!! if(v .lt. 8) then !!! y=(hf*v)**2 !!! xl=nu+2 !!! a0=1 !!! a1=1+2*y/((xl+1)*(xl-1)) !!! a2=1+y*(4+3*y/((xl+2)*xl))/((xl+3)*(xl-1)) !!! b0=1 !!! b1=1-y/(xl+1) !!! b2=1-y*(1-y/(2*(xl+2)))/(xl+3) !!! w1=3+xl !!! v1=3-xl !!! v3=xl-1 !!! v2=v3+v3 !!! c=0 !!! do n = 3,30 !!! c0=c !!! fn=n !!! w1=w1+2 !!! w2=w1-1 !!! w3=w2-1 !!! w4=w3-1 !!! w5=w4-1 !!! w6=w5-1 !!! v1=v1+1 !!! v2=v2+1 !!! v3=v3+1 !!! u1=fn*w4 !!! e=v3/(u1*w3) !!! u2=e*y !!! f1=1+y*v1/(u1*w1) !!! f2=(1+y*v2/(v3*w2*w5))*u2 !!! f3=-y*y*u2/(w4*w5*w5*w6) !!! a=f1*a2+f2*a1+f3*a0 !!! b=f1*b2+f2*b1+f3*b0 !!! c=a/b !!! if(abs(c0-c) .lt. eps*abs(c)) go to 4 !!! a0=a1 !!! a1=a2 !!! a2=a !!! b0=b1 !!! b1=b2 !!! b2=b !!! end do !!! 4 continue !!! h=c !!! if(nu .eq. 1) h=hf*x*h !!! if(lex) h=exp(-v)*h !!! else !!! r=1/v !!! h=16*r-1 !!! alfa=h+h !!! b1=0 !!! b2=0 !!! do i = 24,0,-1 !!! b0=ci(i,nu)+alfa*b1-b2 !!! b2=b1 !!! b1=b0 !!! end do !!! h=sqrt(rpi2*r)*(b0-h*b2) !!! if(nu*x .lt. 0) h=-h !!! if(.not.lex) h=exp(v)*h !!! end if !!! go to 9 !!! !!! entry besk0(x) !!! nu=0 !!! lex=.false. !!! go to 8 !!! !!! entry ebesk0(x) !!! nu=0 !!! lex=.true. !!! go to 8 !!! !!! entry besk1(x) !!! nu=1 !!! lex=.false. !!! go to 8 !!! !!! entry ebesk1(x) !!! nu=1 !!! lex=.true. !!! !!! 8 continue !!! if(x .le. 0) then !!! h = - huge (h) !!! return !!! elseif(x .lt. 1) then !!! b=hf*x !!! bk=-(log(b)+ce) !!! f=bk !!! p=hf !!! q=hf !!! c=1 !!! d=b**2 !!! bk1=p !!! do n = 1,15 !!! fn=n !!! rfn=1/fn !!! p=p*rfn !!! q=q*rfn !!! f=(f+p+q)*rfn !!! c=c*d*rfn !!! g=c*(p-fn*f) !!! h=c*f !!! bk=bk+h !!! bk1=bk1+g !!! if(bk1*h+abs(g)*bk .le. eps*bk*bk1) go to 12 !!! end do !!! 12 continue !!! h=bk !!! if(nu .eq. 1) h=bk1/b !!! if(lex) h=exp(x)*h !!! elseif(x .le. 5) then !!! xn=4*nu**2 !!! a=9-xn !!! b=25-xn !!! c=768*x**2 !!! c0=48*x !!! a0=1 !!! a1=(16*x+7+xn)/a !!! a2=(c+c0*(xn+23)+xn*(xn+62)+129)/(a*b) !!! b0=1 !!! b1=(16*x+9-xn)/a !!! b2=(c+c0*b)/(a*b)+1 !!! c=0 !!! do n = 3,30 !!! c0=c !!! fn=n !!! fn2=fn+fn !!! fn1=fn2-1 !!! fn3=fn1/(fn2-3) !!! fn4=12*fn**2-(1-xn) !!! fn5=16*fn1*x !!! ran=1/((fn2+1)**2-xn) !!! f1=fn3*(fn4-20*fn)+fn5 !!! f2=28*fn-fn4-8+fn5 !!! f3=fn3*((fn2-5)**2-xn) !!! a=(f1*a2+f2*a1+f3*a0)*ran !!! b=(f1*b2+f2*b1+f3*b0)*ran !!! c=a/b !!! if(abs(c0-c) .lt. eps*abs(c)) go to 25 !!! a0=a1 !!! a1=a2 !!! a2=a !!! b0=b1 !!! b1=b2 !!! b2=b !!! end do !!! 25 continue !!! h=c/sqrt(rpih*x) !!! if(.not.lex) h=exp(-x)*h !!! else !!! r=1/x !!! h=10*r-1 !!! alfa=h+h !!! b1=0 !!! b2=0 !!! do i = 16,0,-1 !!! b0=ck(i,nu)+alfa*b1-b2 !!! b2=b1 !!! b1=b0 !!! end do !!! h=sqrt(pih*r)*(b0-h*b2) !!! if(.not.lex) h=exp(-x)*h !!! end if !!! 9 continue !!! besi0=h !!! return !!! end function besi0 !!! end module specfun77 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module specfun use kinds implicit none real(kind=double), private, parameter :: PI = 3.14159265358979324d0 real(kind=double), private, parameter :: CE = 0.57721566490153286d0 real(kind=double), private, parameter :: PIH = PI/2 real(kind=double), private, parameter :: RPIH = 2/PI real(kind=double), private, parameter :: RPI2 = 1/(2*PI) contains elemental function bessel_i0 (x) result (i0) real(kind=double), intent(in) :: x real(kind=double) :: i0 i0 = bessel_i (x, 0, .false.) end function bessel_i0 elemental function bessel_i1 (x) result (i1) real(kind=double), intent(in) :: x real(kind=double) :: i1 i1 = bessel_i (x, 1, .false.) end function bessel_i1 elemental function bessel_i0_exp (x) result (i0) real(kind=double), intent(in) :: x real(kind=double) :: i0 i0 = bessel_i (x, 0, .true.) end function bessel_i0_exp elemental function bessel_i1_exp (x) result (i1) real(kind=double), intent(in) :: x real(kind=double) :: i1 i1 = bessel_i (x, 1, .true.) end function bessel_i1_exp elemental function bessel_k0 (x) result (i0) real(kind=double), intent(in) :: x real(kind=double) :: i0 i0 = bessel_k (x, 0, .false.) end function bessel_k0 elemental function bessel_k1 (x) result (i1) real(kind=double), intent(in) :: x real(kind=double) :: i1 i1 = bessel_k (x, 1, .false.) end function bessel_k1 elemental function bessel_k0_exp (x) result (i0) real(kind=double), intent(in) :: x real(kind=double) :: i0 i0 = bessel_k (x, 0, .true.) end function bessel_k0_exp elemental function bessel_k1_exp (x) result (i1) real(kind=double), intent(in) :: x real(kind=double) :: i1 i1 = bessel_k (x, 1, .true.) end function bessel_k1_exp elemental function bessel_i (x, nu, lex) ! implicit double precision (a-h,o-z) real(kind=double), intent(in) :: x integer, intent(in) :: nu logical, intent(in) :: lex real(kind=double) :: bessel_i real(kind=double), parameter :: EPS = 1.0e-15_double integer :: i, n real(kind=double) :: alfa, xl, y, e, h, r real(kind=double) :: w1, w2, w3, w4, w5, w6 real(kind=double) :: fn, f1, f2, f3, u1, u2, v, v1, v2, v3 real(kind=double) :: a, a0, a1, a2, b, b0, b1, b2, c, c0 real(kind=double), parameter :: CI_00_0 = +1.008279205458740032_double real(kind=double), parameter :: CI_01_0 = +0.008445122624920943_double real(kind=double), parameter :: CI_02_0 = +0.000172700630777567_double real(kind=double), parameter :: CI_03_0 = +0.000007247591099959_double real(kind=double), parameter :: CI_04_0 = +0.000000513587726878_double real(kind=double), parameter :: CI_05_0 = +0.000000056816965808_double real(kind=double), parameter :: CI_06_0 = +0.000000008513091223_double real(kind=double), parameter :: CI_07_0 = +0.000000001238425364_double real(kind=double), parameter :: CI_08_0 = +0.000000000029801672_double real(kind=double), parameter :: CI_09_0 = -0.000000000078956698_double real(kind=double), parameter :: CI_10_0 = -0.000000000033127128_double real(kind=double), parameter :: CI_11_0 = -0.000000000004497339_double real(kind=double), parameter :: CI_12_0 = +0.000000000001799790_double real(kind=double), parameter :: CI_13_0 = +0.000000000000965748_double real(kind=double), parameter :: CI_14_0 = +0.000000000000038604_double real(kind=double), parameter :: CI_15_0 = -0.000000000000104039_double real(kind=double), parameter :: CI_16_0 = -0.000000000000023950_double real(kind=double), parameter :: CI_17_0 = +0.000000000000009554_double real(kind=double), parameter :: CI_18_0 = +0.000000000000004443_double real(kind=double), parameter :: CI_19_0 = -0.000000000000000859_double real(kind=double), parameter :: CI_20_0 = -0.000000000000000709_double real(kind=double), parameter :: CI_21_0 = +0.000000000000000087_double real(kind=double), parameter :: CI_22_0 = +0.000000000000000112_double real(kind=double), parameter :: CI_23_0 = -0.000000000000000012_double real(kind=double), parameter :: CI_24_0 = -0.000000000000000018_double real(kind=double), parameter :: CI_00_1 = +0.975800602326285926_double real(kind=double), parameter :: CI_01_1 = -0.024467442963276385_double real(kind=double), parameter :: CI_02_1 = -0.000277205360763829_double real(kind=double), parameter :: CI_03_1 = -0.000009732146728020_double real(kind=double), parameter :: CI_04_1 = -0.000000629724238640_double real(kind=double), parameter :: CI_05_1 = -0.000000065961142154_double real(kind=double), parameter :: CI_06_1 = -0.000000009613872919_double real(kind=double), parameter :: CI_07_1 = -0.000000001401140901_double real(kind=double), parameter :: CI_08_1 = -0.000000000047563167_double real(kind=double), parameter :: CI_09_1 = +0.000000000081530681_double real(kind=double), parameter :: CI_10_1 = +0.000000000035408148_double real(kind=double), parameter :: CI_11_1 = +0.000000000005102564_double real(kind=double), parameter :: CI_12_1 = -0.000000000001804409_double real(kind=double), parameter :: CI_13_1 = -0.000000000001023594_double real(kind=double), parameter :: CI_14_1 = -0.000000000000052678_double real(kind=double), parameter :: CI_15_1 = +0.000000000000107094_double real(kind=double), parameter :: CI_16_1 = +0.000000000000026120_double real(kind=double), parameter :: CI_17_1 = -0.000000000000009561_double real(kind=double), parameter :: CI_18_1 = -0.000000000000004713_double real(kind=double), parameter :: CI_19_1 = +0.000000000000000829_double real(kind=double), parameter :: CI_20_1 = +0.000000000000000743_double real(kind=double), parameter :: CI_21_1 = -0.000000000000000080_double real(kind=double), parameter :: CI_22_1 = -0.000000000000000117_double real(kind=double), parameter :: CI_23_1 = +0.000000000000000011_double real(kind=double), parameter :: CI_24_1 = +0.000000000000000019_double real(kind=double), dimension(0:24,0:1), parameter :: & CI = reshape ( (/ & CI_00_0, CI_01_0, CI_02_0, CI_03_0, CI_04_0, CI_05_0, & CI_06_0, CI_07_0, CI_08_0, CI_09_0, CI_10_0, CI_11_0, & CI_12_0, CI_13_0, CI_14_0, CI_15_0, CI_16_0, CI_17_0, & CI_18_0, CI_19_0, CI_20_0, CI_21_0, CI_22_0, CI_23_0, CI_24_0, & CI_00_1, CI_01_1, CI_02_1, CI_03_1, CI_04_1, CI_05_1, & CI_06_1, CI_07_1, CI_08_1, CI_09_1, CI_10_1, CI_11_1, & CI_12_1, CI_13_1, CI_14_1, CI_15_1, CI_16_1, CI_17_1, & CI_18_1, CI_19_1, CI_20_1, CI_21_1, CI_22_1, CI_23_1, CI_24_1 /), & (/ 25, 2 /) ) v = abs(x) if (v < 8) then y = (0.5_double*v)**2 xl = nu+2 a0 = 1 a1 = 1+2*y/((xl+1)*(xl-1)) a2 = 1+y*(4+3*y/((xl+2)*xl))/((xl+3)*(xl-1)) b0 = 1 b1 = 1-y/(xl+1) b2 = 1-y*(1-y/(2*(xl+2)))/(xl+3) w1 = 3+xl v1 = 3-xl v3 = xl-1 v2 = v3+v3 c = 0 cheby: do n = 3,30 c0 = c fn = n w1 = w1+2 w2 = w1-1 w3 = w2-1 w4 = w3-1 w5 = w4-1 w6 = w5-1 v1 = v1+1 v2 = v2+1 v3 = v3+1 u1 = fn*w4 e = v3/(u1*w3) u2 = e*y f1 = 1+y*v1/(u1*w1) f2 = (1+y*v2/(v3*w2*w5))*u2 f3 = -y*y*u2/(w4*w5*w5*w6) a = f1*a2+f2*a1+f3*a0 b = f1*b2+f2*b1+f3*b0 c = a/b if (abs(c0-c) < eps*abs(c)) then exit cheby end if a0 = a1 a1 = a2 a2 = a b0 = b1 b1 = b2 b2 = b end do cheby h = c if (nu == 1) then h = 0.5_double*x*h end if if (lex) then h = exp(-v)*h end if else r = 1/v h = 16*r-1 alfa = h+h b1 = 0 b2 = 0 do i = 24, 0, -1 b0 = ci(i,nu)+alfa*b1-b2 b2 = b1 b1 = b0 end do h = sqrt(rpi2*r)*(b0-h*b2) if (nu*x < 0) then h = -h end if if (.not.lex) then h = exp(v)*h end if end if bessel_i = h end function bessel_i elemental function bessel_k (x, nu, lex) real(kind=double), intent(in) :: x integer, intent(in) :: nu logical, intent(in) :: lex real(kind=double) :: bessel_k real(kind=double), parameter :: EPS = 1.0e-15_double integer :: i, n real(kind=double) :: alfa, xn, h, r, p, q, ran real(kind=double) :: f, f1, f2, f3, rfn, fn, fn1, fn2, fn3, fn4, fn5, g real(kind=double) :: a, a0, a1, a2, b, b0, b1, b2, bk, bk1, c, c0, d real(kind=double), parameter :: CK_00_0 = +0.988408174230825800_double real(kind=double), parameter :: CK_01_0 = -0.011310504646928281_double real(kind=double), parameter :: CK_02_0 = +0.000269532612762724_double real(kind=double), parameter :: CK_03_0 = -0.000011106685196665_double real(kind=double), parameter :: CK_04_0 = +0.000000632575108500_double real(kind=double), parameter :: CK_05_0 = -0.000000045047337641_double real(kind=double), parameter :: CK_06_0 = +0.000000003792996456_double real(kind=double), parameter :: CK_07_0 = -0.000000000364547179_double real(kind=double), parameter :: CK_08_0 = +0.000000000039043756_double real(kind=double), parameter :: CK_09_0 = -0.000000000004579936_double real(kind=double), parameter :: CK_10_0 = +0.000000000000580811_double real(kind=double), parameter :: CK_11_0 = -0.000000000000078832_double real(kind=double), parameter :: CK_12_0 = +0.000000000000011360_double real(kind=double), parameter :: CK_13_0 = -0.000000000000001727_double real(kind=double), parameter :: CK_14_0 = +0.000000000000000275_double real(kind=double), parameter :: CK_15_0 = -0.000000000000000046_double real(kind=double), parameter :: CK_16_0 = +0.000000000000000008_double real(kind=double), parameter :: CK_00_1 = +1.035950858772358331_double real(kind=double), parameter :: CK_01_1 = +0.035465291243331114_double real(kind=double), parameter :: CK_02_1 = -0.000468475028166889_double real(kind=double), parameter :: CK_03_1 = +0.000016185063810053_double real(kind=double), parameter :: CK_04_1 = -0.000000845172048124_double real(kind=double), parameter :: CK_05_1 = +0.000000057132218103_double real(kind=double), parameter :: CK_06_1 = -0.000000004645554607_double real(kind=double), parameter :: CK_07_1 = +0.000000000435417339_double real(kind=double), parameter :: CK_08_1 = -0.000000000045757297_double real(kind=double), parameter :: CK_09_1 = +0.000000000005288133_double real(kind=double), parameter :: CK_10_1 = -0.000000000000662613_double real(kind=double), parameter :: CK_11_1 = +0.000000000000089048_double real(kind=double), parameter :: CK_12_1 = -0.000000000000012726_double real(kind=double), parameter :: CK_13_1 = +0.000000000000001921_double real(kind=double), parameter :: CK_14_1 = -0.000000000000000305_double real(kind=double), parameter :: CK_15_1 = +0.000000000000000050_double real(kind=double), parameter :: CK_16_1 = -0.000000000000000009_double real(kind=double), dimension(0:16,0:1), parameter :: & CK = reshape ( (/ & CK_00_0, CK_01_0, CK_02_0, CK_03_0, CK_04_0, CK_05_0, & CK_06_0, CK_07_0, CK_08_0, CK_09_0, CK_10_0, CK_11_0, & CK_12_0, CK_13_0, CK_14_0, CK_15_0, CK_16_0, & CK_00_1, CK_01_1, CK_02_1, CK_03_1, CK_04_1, CK_05_1, & CK_06_1, CK_07_1, CK_08_1, CK_09_1, CK_10_1, CK_11_1, & CK_12_1, CK_13_1, CK_14_1, CK_15_1, CK_16_1 /), & (/ 17, 2 /) ) if (x <= 0) then h = - huge (h) return elseif (x < 1) then b = 0.5_double*x bk = -(log(b)+ce) f = bk p = 0.5_double q = 0.5_double c = 1 d = b**2 bk1 = p cheby1: do n = 1, 15 fn = n rfn = 1/fn p = p*rfn q = q*rfn f = (f+p+q)*rfn c = c*d*rfn g = c*(p-fn*f) h = c*f bk = bk+h bk1 = bk1+g if(bk1*h+abs(g)*bk <= eps*bk*bk1) then exit cheby1 end if end do cheby1 h = bk if(nu == 1) h = bk1/b if(lex) h = exp(x)*h elseif(x <= 5) then xn = 4*nu**2 a = 9-xn b = 25-xn c = 768*x**2 c0 = 48*x a0 = 1 a1 = (16*x+7+xn)/a a2 = (c+c0*(xn+23)+xn*(xn+62)+129)/(a*b) b0 = 1 b1 = (16*x+9-xn)/a b2 = (c+c0*b)/(a*b)+1 c = 0 cheby2: do n = 3, 30 c0 = c fn = n fn2 = fn+fn fn1 = fn2-1 fn3 = fn1/(fn2-3) fn4 = 12*fn**2-(1-xn) fn5 = 16*fn1*x ran = 1/((fn2+1)**2-xn) f1 = fn3*(fn4-20*fn)+fn5 f2 = 28*fn-fn4-8+fn5 f3 = fn3*((fn2-5)**2-xn) a = (f1*a2+f2*a1+f3*a0)*ran b = (f1*b2+f2*b1+f3*b0)*ran c = a/b if (abs(c0-c) < eps*abs(c)) then exit cheby2 end if a0 = a1 a1 = a2 a2 = a b0 = b1 b1 = b2 b2 = b end do cheby2 h = c/sqrt(rpih*x) if (.not.lex) then h = exp(-x)*h end if else r = 1/x h = 10*r-1 alfa = h+h b1 = 0 b2 = 0 do i = 16, 0, -1 b0 = ck(i,nu)+alfa*b1-b2 b2 = b1 b1 = b0 end do h = sqrt(pih*r)*(b0-h*b2) if (.not.lex) then h = exp(-x)*h end if end if bessel_k = h end function bessel_k end module specfun !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module util use kinds implicit none real(kind=double), private, parameter :: PI = 3.14159265358979324_double contains function gauss (f, a, b, eps) result (integral) real(kind=double), intent(in) :: a, b, eps real(kind=double) :: integral interface elemental function f (x) result (f_val) use kinds real(kind=double), intent(in) :: x real(kind=double) :: f_val end function f end interface real(kind=double) :: aa, bb, sum8, sum16 real(kind=double) :: midpoint, half_width, min_half_width real(kind=double), dimension(4) :: u8 real(kind=double), dimension(4), parameter :: X8 = & (/ 9.6028985649753623e-1_double, & 7.9666647741362674e-1_double, & 5.2553240991632899e-1_double, & 1.8343464249564980e-1_double /) real(kind=double), dimension(4), parameter :: W8 = & (/ 1.0122853629037626e-1_double, & 2.2238103445337447e-1_double, & 3.1370664587788729e-1_double, & 3.6268378337836198e-1_double /) real(kind=double), dimension(8) :: u16 real(kind=double), dimension(8), parameter :: X16 = & (/ 9.8940093499164993e-1_double, & 9.4457502307323258e-1_double, & 8.6563120238783174e-1_double, & 7.5540440835500303e-1_double, & 6.1787624440264375e-1_double, & 4.5801677765722739e-1_double, & 2.8160355077925891e-1_double, & 9.5012509837637440e-2_double /) real(kind=double), dimension(8), parameter :: W16 = & (/ 2.7152459411754095e-2_double, & 6.2253523938647893e-2_double, & 9.5158511682492785e-2_double, & 1.2462897125553387e-1_double, & 1.4959598881657673e-1_double, & 1.6915651939500254e-1_double, & 1.8260341504492359e-1_double, & 1.8945061045506850e-1_double /) integral = 0 if (b == a) then return end if min_half_width = (1 + 200 * abs (b - a)) * epsilon (min_half_width) aa = a bb = b do midpoint = (bb + aa) / 2 half_width = (bb - aa) / 2 u8 = half_width * X8 sum8 = half_width * sum (W8 * (f (midpoint + u8) + f (midpoint - u8))) u16 = half_width * X16 sum16 = half_width * sum (W16 * (f (midpoint + u16) + f (midpoint - u16))) if (abs (sum16 - sum8) > eps * (1 + abs (sum16))) then ! not accurate enough, try to subdivide if (abs (half_width) < min_half_width) then ! too high accuracy required, bail out integral = - huge (integral) return end if bb = midpoint else ! accuracy reached, accept the partial integral integral = integral + sum16 if (bb == b) then ! endpoint reached, accept the integral return end if aa = bb bb = b end if end do end function gauss pure subroutine solve_quadratic (z, a) complex(kind=double), dimension(2), intent(out) :: z real(kind=double), dimension(0:2), intent(in) :: a real(kind=double) :: d complex(kind=double) :: q d = a(1)**2 - 4*a(0)*a(2) if (d >= 0) then q = - (a(1) + sign (sqrt (d), a(1))) / 2 else q = - cmplx (a(1), sign (sqrt (-d), a(1))) / 2 end if z(1) = q / a(2) z(2) = a(0) / q end subroutine solve_quadratic pure subroutine solve_cubic (z, a0) complex(kind=double), dimension(3), intent(out) :: z real(kind=double), dimension(0:3), intent(in) :: a0 real(kind=double), dimension(0:3) :: a real(kind=double) :: q, sqrt_q, r, r2q3, theta, s1, s2 a = a0 / a0(3) q = (a(2)**2 - 3*a(1)) / 9 r = (2*a(2)**3 - 9*a(1)*a(2) + 27*a(0)) / 54 r2q3 = r**2 - q**3 if (r2q3 < 0) then sqrt_q = sqrt (q) theta = acos (r / sqrt_q**3) z(1) = - 2 * sqrt_q * cos (theta / 3) - a(2) / 3 z(2) = - 2 * sqrt_q * cos ((theta + 2*PI) / 3) - a(2) / 3 z(3) = - 2 * sqrt_q * cos ((theta - 2*PI) / 3) - a(2) / 3 else s1 = - sign ((abs (r) + sqrt (r2q3)) ** (1.0_double / 3), r) if (s1 == 0) then s2 = 0 else s2 = q / s1 endif z(1) = s1 + s2 - a(2) / 3 z(2) = - (s1 + s2) / 2 - a(2) / 3 & + (s1 - s2) * cmplx (0, sqrt (3.0_double) / 2) z(3) = - (s1 + s2) / 2 - a(2) / 3 & - (s1 - s2) * cmplx (0, sqrt (3.0_double) / 2) end if end subroutine solve_cubic end module util !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module gg use kinds use util use specfun implicit none real(kind=double), parameter :: m_e = 511.0e-6_double real(kind=double), private, parameter :: PI = 3.14159265358979324_double type, private :: lumi_closure real(kind=double) :: x, z, y_max, rho, pol1, pol2 end type lumi_closure type(lumi_closure), private :: cl contains elemental function x_of_kinematics (e_gamma, e_e, alpha) result (x) real(kind=double), intent(in) :: e_gamma, e_e, alpha real(kind=double) :: x x = 4 * e_gamma * e_e * cos(alpha/2)**2 / m_e**2 end function x_of_kinematics elemental function theta0_of_kinematics (e_gamma, e_e, alpha) result (theta0) real(kind=double), intent(in) :: e_gamma, e_e, alpha real(kind=double) :: theta0 real(kind=double) :: x x = x_of_kinematics (e_gamma, e_e, alpha) theta0 = m_e / e_e * sqrt (1 + x) end function theta0_of_kinematics elemental function y_of_theta (theta, theta0, y_max) result (y) real(kind=double), intent(in) :: theta, theta0, y_max real(kind=double) :: y y = y_max / (1 + (theta/theta0)**2) end function y_of_theta elemental function sigma (x, pol) result (s) real(kind=double), intent(in) :: x, pol real(kind=double) :: s real(kind=double) :: s0, s1 s0 = (2 / x) * ((1 - 4/x - 8/x**2) * log (x + 1) & + 0.5_double + 8/x - 0.5_double / (x + 1)**2) s1 = (2 / x) * ((1 + 2/x) * log (x + 1) & - 2.5_double + 1/(x+1) - 0.5_double / (x + 1)**2) s = s0 + pol*s1 end function sigma elemental function dsigma_dy (y, x, pol) result (s) real(kind=double), intent(in) :: y, x, pol real(kind=double) :: s real(kind=double) :: y_max, r y_max = x / (1 + x) if ((y > y_max) .or. (y < 0)) then s = 0 else r = y / (x * (1 - y)) s = (2 / x) * (1 / (1-y) + (1-y) - 4*r*(1-r) + pol*r*x*(1-2*r)*(2-y)) !!! s = s + (2 / x) * y**(-0.9_double) end if end function dsigma_dy elemental function polarization (y, x, pol_gamma, pol_e) result (p) real(kind=double), intent(in) :: y, x, pol_gamma, pol_e real(kind=double) :: p real(kind=double) :: y_max, r y_max = x / (1 + x) if ((y > y_max) .or. (y < 0)) then p = 0 else r = y / (x * (1 - y)) p = (pol_e * x * r * (1 + (1-y) * (1-2*r)**2) & + pol_gamma * (1-2*r) * (1/(1-y) + (1-y))) & / (1 / (1-y) + (1-y) - 4*r*(1-r) & + pol_gamma*pol_e*r*x*(1-2*r)*(2-y)) end if end function polarization elemental function dsigma_dy_pol (y, x, pol, pol_gamma, pol_e) result (s) real(kind=double), intent(in) :: y, x integer, intent(in) :: pol real(kind=double), intent(in) :: pol_gamma, pol_e real(kind=double) :: s real(kind=double) :: y_max, s_unpol y_max = x / (1 + x) if ((y > y_max) .or. (y < 0)) then s = 0 else s_unpol = dsigma_dy (y, x, pol_gamma*pol_e) select case (pol) case (1) s = (1 + polarization (y, x, pol_gamma, pol_e)) / 2 * s_unpol case (0) s = s_unpol case (-1) s = (1 - polarization (y, x, pol_gamma, pol_e)) / 2 * s_unpol case default s = 0 end select end if end function dsigma_dy_pol subroutine generate_dsigma_dy (y, x, pol) real(kind=double), intent(out) :: y real(kind=double), intent(in), optional :: pol, x real(kind=double), save :: x_saved = -1, pol_saved = -1, & y_max = -1, p_plus = -1, w_plus = -1, & w0 = -1, w2 = -1, w2_int = -1 real(kind=double) :: r0, w, s0, s1, c0, c1, int_plus, int_minus real(kind=double), dimension(2) :: r real(kind=double), dimension(0:2) :: a2 complex(kind=double), dimension(2) :: z2 real(kind=double), dimension(0:3) :: a3 complex(kind=double), dimension(3) :: z3 if (present (x) .and. present (pol)) then x_saved = x pol_saved = pol y_max = x / (x + 1) !!! find maximum for pol = +1 a3(0) = 4 * x * (2 - x) ! a3(0) = 4 * x * (2 - x * pol) a3(1) = 4 * ((x + 2) * x - 4) ! a3(1) = 4 * ((2 * pol - 1) * (x + 2) * x - 4) a3(2) = - 12 * x ! a3(2) = - 6 * x * ((x + 2) * pol - x) a3(3) = 4 * x ! a3(3) = 2 * x * ((x + 2) * pol - x) call solve_cubic (z3, a3) w_plus = dsigma_dy (real (z3(1), kind=double), x, 1.0_double) !!! find simple envelope for pol = -1 s0 = dsigma_dy (0.0_double, x, -1.0_double) s1 = dsigma_dy (y_max - 2 * epsilon (y_max), x, -1.0_double) c1 = (s1 - s0) / (1 / (1 - y_max)**2 - 1) c0 = s0 - c1 w0 = c0 w2 = c1 / w0 w2_int = y_max * (1 + w2 / (1 - y_max)) !!! find fraction of pol = +1 events int_plus = sigma (x, 1.0_double) int_minus = sigma (x, -1.0_double) p_plus = (1 + pol) * int_plus & / ((1 + pol) * int_plus + (1 - pol) * int_minus) end if call random_number (r0) if (r0 <= p_plus) then rejection_plus: do call random_number (r) y = r(1) w = dsigma_dy (y, x_saved, 1.0_double) / w_plus if (r(2) < w) then return end if end do rejection_plus else rejection_minus: do call random_number (r) a2(0) = w2_int * r(1) a2(1) = - (1 + w2 + w2_int * r(1)) a2(2) = 1 call solve_quadratic (z2, a2) y = real (z2(2)) if ((y > y_max) .or. (y < 0)) then y = - huge (y) return end if w = dsigma_dy (y, x_saved, -1.0_double) / w0 / (1 + w2 / (1 - y)**2) if (w > 1) then print *, y, w end if if (r(2) < w) then return end if end do rejection_minus end if end subroutine generate_dsigma_dy subroutine generate_d2lumi_dy1dy2 (y1, y2, rho, x, pol1, pol2) real(kind=double), intent(out) :: y1, y2 real(kind=double), intent(in) :: rho real(kind=double), intent(in), optional :: x, pol1, pol2 real(kind=double) :: r, w, y_max real(kind=double), save :: x_saved = -1, pol1_saved, pol2_saved real(kind=double), save :: w_max = -1, w_sum = 0 integer, save :: w_count = 0 if (present (x) .and. present (pol1) .and. present (pol2)) then x_saved = x y_max = x / (x + 1) pol1_saved = pol1 pol2_saved = pol2 w_max = d2bessel_dy1dy2 (y_max, y_max, x, rho) call generate_dsigma_dy (y1, x, pol1) call generate_dsigma_dy (y2, x, pol2) if (w_count > 0) then print *, "eff = ", w_sum / w_count, w_count end if end if rejection: do call generate_dsigma_dy (y1) call generate_dsigma_dy (y2) w = d2bessel_dy1dy2 (y1, y2, x_saved, rho) / w_max if (w > 1) then print *, "w>1: ", real(y1), real(y2), real(w) return end if if (w /= w) then print *, "NAN: ", real(y1), real(y2), real(w) return end if w_count = w_count + 1 w_sum = w_sum + w ! print *, real(y1), real(y2), real(w), real(w_sum), w_count call random_number (r) if (r < w) then return end if end do rejection end subroutine generate_d2lumi_dy1dy2 elemental function dsigma_dy_a (y, x, pol) result (s) real(kind=double), intent(in) :: y, x, pol real(kind=double) :: s real(kind=double) :: y_max, s0, s1, c0, c1 y_max = x / (1 + x) if ((y > y_max) .or. (y < 0)) then s = 0 else s0 = dsigma_dy (0.0_double, x, pol) s1 = dsigma_dy (y_max - 2 * epsilon (y_max), x, pol) c1 = (s1 - s0) / (1 / (1 - y_max)**2 - 1) c0 = s0 - c1 s = c0 + c1 / (1 - y)**2 end if end function dsigma_dy_a elemental function dsigma_dy_b (y, x, pol) result (s) real(kind=double), intent(in) :: y, x, pol real(kind=double) :: s real(kind=double) :: y_max, y_extreme complex(kind=double), dimension(3) :: z real(kind=double), dimension(0:3) :: a y_max = x / (1 + x) if ((y > y_max) .or. (y < 0)) then s = 0 else a(0) = 4 * x * (2 - x * pol) a(1) = 4 * ((2 * pol - 1) * (x + 2) * x - 4) a(2) = - 6 * x * ((x + 2) * pol - x) a(3) = 2 * x * ((x + 2) * pol - x) call solve_cubic (z, a) y_extreme = real (z(1), kind=double) s = dsigma_dy (y_extreme, x, pol) end if end function dsigma_dy_b elemental function dsigma_dtheta (theta, theta0, x, pol) result (s) real(kind=double), intent(in) :: theta, theta0, x, pol real(kind=double) :: s real(kind=double) :: y, y_max y_max = x / (1 + x) y = y_of_theta (theta, theta0, y_max) if ((y > y_max) .or. (y < 0)) then s = 0 else s = y_max * dsigma_dy (y, x, pol) & / (PI * theta0**2 * (1 + (theta/theta0)**2)**2) end if end function dsigma_dtheta !!! gfortran does not allow this function to be elemental (?) function d2lumi_dzdy (y) result (l) !!! elemental function d2lumi_dzdy (y) result (l) real(kind=double), intent(in) :: y real(kind=double) :: l real(kind=double) :: rho2, xi1, xi2 rho2 = cl%rho**2 * (cl%x + 1) xi1 = cl%y_max / y - 1 xi2 = cl%y_max * y / cl%z**2 - 1 l = dsigma_dy (y, cl%x, cl%pol1) * dsigma_dy (cl%z**2/y, cl%x, cl%pol2) & * bessel_i0 (rho2 * sqrt (xi1 * xi2)) & * exp (- rho2/2 * (xi1 + xi2)) / y end function d2lumi_dzdy elemental function d2lumi_dy1dy2 (y1, y2, rho, x, pol1, pol2) result (l) real(kind=double), intent(in) :: y1, y2, rho, x, pol1, pol2 real(kind=double) :: l real(kind=double) :: y_max, rho2, xi1, xi2 y_max = x / (1 + x) rho2 = rho**2 * (x + 1) xi1 = y_max / y1 - 1 xi2 = y_max / y2 - 1 l = dsigma_dy (y1, x, pol1) * dsigma_dy (y2, x, pol2) & * d2bessel_dy1dy2 (y1, y2, x, rho) end function d2lumi_dy1dy2 elemental function d2bessel_dy1dy2 (y1, y2, x, rho) result (l) real(kind=double), intent(in) :: y1, y2, x, rho real(kind=double) :: l real(kind=double) :: y_max, rho2, xi1, xi2 y_max = x / (1 + x) if ((y1 > y_max) .or. (y2 > y_max)) then l = 0 else rho2 = rho**2 * (x + 1) xi1 = y_max / y1 - 1 xi2 = y_max / y2 - 1 l = bessel_i0_exp (rho2 * sqrt (xi1 * xi2)) & * exp (rho2 * (sqrt (xi1 * xi2) - (xi1 + xi2) / 2)) end if end function d2bessel_dy1dy2 elemental function d2bessel_dy1dy2_broken (y1, y2, x, rho) result (l) real(kind=double), intent(in) :: y1, y2, x, rho real(kind=double) :: l real(kind=double) :: y_max, rho2, xi1, xi2 y_max = x / (1 + x) if ((y1 > y_max) .or. (y2 > y_max)) then l = 0 else rho2 = rho**2 * (x + 1) xi1 = y_max / y1 - 1 xi2 = y_max / y2 - 1 l = bessel_i0 (rho2 * sqrt (xi1 * xi2)) * exp (- rho2/2 * (xi1 + xi2)) end if end function d2bessel_dy1dy2_broken function dlumi_dz (z, x, rho, pol) result (l) real(kind=double), intent(in) :: z, x, rho, pol real(kind=double) :: l cl%z = z cl%x = x cl%rho = rho cl%pol1 = pol cl%pol2 = pol cl%y_max = x / (1 + x) l = z * gauss (d2lumi_dzdy, z**2 / cl%y_max, cl%y_max, 1e-8_double) end function dlumi_dz end module gg !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! program test use kinds use gg use histograms implicit none real(kind=double) :: z, y, y1, y2, x, x1, x2 integer :: i, i1, i2, irho, ipol, ipol1, ipol2 real(kind=double) :: e_gamma, e_e, rho, pol, pol1, pol2 character(len=*), dimension(-1:1), parameter :: & tag_pol = (/ "minus", "unpol", "plus " /) character(len=1) :: tag_rho character(len=2) :: cmd type(histogram) :: h_unweighted(-1:1), h_reweighted(-1:1) type(histogram2) :: h_unweighted2, h_reweighted2 e_gamma = 1.25e-9_double e_e = 250.0_double ! e_e = 1000.0_double ! e_e = 100.0_double x = x_of_kinematics (e_gamma, e_e, 0.0_double) print *, x read (*, fmt="(A)") cmd select case (cmd) case ("po") do ipol1 = -1, 1 do ipol2 = -1, 1 open (10, file = trim (tag_pol(ipol1)) // "_" // trim (tag_pol(ipol2))) do i = 0, 1000 y = real (i, kind=double) / 1000 write (10, *) y, polarization (y, x, & real (ipol1, kind=double), & real (ipol2, kind=double)) end do close (10) end do end do case ("co") do ipol = -1, 1 open (10, file = trim (tag_pol(ipol))) do i = 0, 1000 y = real (i, kind=double) / 1000 write (10, *) y, dsigma_dy (y, x, real (ipol, kind=double)) end do close (10) end do case ("lu") do irho = 0, 9 rho = irho * 0.2_double write (tag_rho, "(i1)") irho do ipol = -1, 1 open (10, file = trim (tag_pol(ipol)) // tag_rho) do i = 0, 1000 z = real (i, kind=double) / 10000 write (10, *) z, dlumi_dz (z, x, rho, real (ipol, kind=double)) end do do i = 100, 1000 z = real (i, kind=double) / 1000 write (10, *) z, dlumi_dz (z, x, rho, real (ipol, kind=double)) end do close (10) end do end do case ("2d") do irho = 0, 9 rho = irho write (tag_rho, "(i1)") irho do ipol = -1, 1 open (10, file = trim (tag_pol(ipol)) // tag_rho) do i1 = 0, 100 y1 = real (i1, kind=double) / 100 do i2 = 0, 100 y2 = real (i2, kind=double) / 100 write (10, *) y1, y2, & d2lumi_dy1dy2 (y1, y2, rho, x, & real (ipol, kind=double), & real (ipol, kind=double)) end do end do close (10) end do end do case ("2b") do irho = 0, 9 rho = irho write (tag_rho, "(i1)") irho open (10, file = "bessel" // tag_rho) do i1 = 0, 100 y1 = real (i1, kind=double) / 100 do i2 = 0, 100 y2 = real (i2, kind=double) / 100 write (10, *) y1, y2, d2bessel_dy1dy2 (y1, y2, x, rho) end do end do close (10) end do case ("xx") do ipol = -1, 1 open (10, file = trim (tag_pol(ipol))) open (11, file = trim (tag_pol(ipol)) // "a") open (12, file = trim (tag_pol(ipol)) // "b") ! open (13, file = trim (tag_pol(ipol)) // "c") do i = 0, 1000 y = real (i, kind=double) / 1000 write (10, *) y, dsigma_dy (y, x, real (ipol, kind=double)) write (11, *) y, dsigma_dy_a (y, x, real (ipol, kind=double)) z = dsigma_dy_b (y, x, real (ipol, kind=double)) write (12, *) y, z ! write (13, *) y, dsigma_dy_c (y, x, real (ipol, kind=double)) end do close (10) close (11) close (12) ! close (13) end do case ("mc") call create_histogram (h_unweighted, 0.0_double, 1.0_double, 100) call create_histogram (h_reweighted, 0.0_double, 1.0_double, 100) call generate_dsigma_dy (y, x, pol) do i = 0, 10000000 call generate_dsigma_dy (y) call fill_histogram (h_unweighted(int(pol)), y) call fill_histogram (h_reweighted(int(pol)), y, 1 / dsigma_dy (y, x, pol)) call fill_histogram (h_unweighted(0), y) call fill_histogram (h_reweighted(0), y, 1 / dsigma_dy (y, x, 0.0_double)) end do do ipol = -1, 1 call write_histogram (h_unweighted(ipol), trim (tag_pol(ipol))) call write_histogram (h_reweighted(ipol), trim (tag_pol(ipol)) // "x") end do case ("m2") rho = 1.5 read *, rho call create_histogram (h_unweighted(0), 0.0_double, 1.0_double, 50) call create_histogram (h_reweighted(0), 0.0_double, 1.0_double, 50) call create_histogram (h_unweighted2, & (/ 0.0_double, 0.0_double /), (/ 1.0_double, 1.0_double /), & (/ 20, 20 /) ) call create_histogram (h_reweighted2, & (/ 0.0_double, 0.0_double /), (/ 1.0_double, 1.0_double /), & (/ 20, 20 /) ) call generate_d2lumi_dy1dy2 (y1, y2, rho, x, pol1, pol2) do i = 0, 100000! 00 call generate_d2lumi_dy1dy2 (y1, y2, rho) call fill_histogram (h_unweighted(0), sqrt (y1*y2)) call fill_histogram (h_reweighted(0), sqrt (y1*y2), & 1 / dlumi_dz (sqrt (y1*y2), x, rho, 0.0_double)) call fill_histogram (h_unweighted2, y1, y2) call fill_histogram (h_reweighted2, y1, y2, & 1 / d2lumi_dy1dy2 (y1, y2, rho, x, 0.0_double, 0.0_double)) end do call write_histogram (h_unweighted(0), "lumi") call write_histogram (h_reweighted(0), "lumix") call write_histogram (h_unweighted2, "lumi2") call write_histogram (h_reweighted2, "lumi2x") call generate_d2lumi_dy1dy2 (y1, y2, rho, x, pol1, pol2) end select end program test !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Index: trunk/circe1/src/prelude.nw =================================================================== --- trunk/circe1/src/prelude.nw (revision 8740) +++ trunk/circe1/src/prelude.nw (revision 8741) @@ -1,1601 +1,1599 @@ -% $Id$ +% prelude.nw -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \iffalse %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% To: hep-ph@xxx.lanl.gov Subject: put \\ Title: CIRCE1: Beam Spectra for Linear Collider Physics Author: Thorsten Ohl (TH Darmstadt) Comments: 26 pages, LaTeX (using amsmath.sty), PostScript figures included, paper saving version formatted for A4 available from ftp://crunch.ikp.physik.th-darmstadt.de/pub/preprints/IKDA-96-13.ps.gz Report-no: IKDA 96/13 \\ I describe parameterizations of realistic $e^\pm$- and $\gamma$-beam spectra at future linear $e^+e^-$-colliders. Emphasis is put on simplicity and reproducibility of the parameterizations, supporting reproducible physics simulations. The parameterizations are implemented in a library of distribution functions and event generators. \\ \fi %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \def\Kirke/{\texttt{Circe1}} \def\Circe/{\texttt{circe1}} \def\Hydra/{\texttt{Hydra}} \def\Version/{2.2} \def\Date/{March 2014} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \NeedsTeXFormat{LaTeX2e} \NeedsTeXFormat{LaTeX2e} \RequirePackage{ifpdf} \ifpdf \documentclass[a4paper]{article} \usepackage{type1cm} \usepackage[pdftex,colorlinks]{hyperref} \usepackage[pdftex]{graphicx} \DeclareGraphicsRule{*}{mps}{*}{} \else \documentclass[a4paper]{article} \usepackage[T1]{fontenc} \usepackage{graphicx} \fi \usepackage{amsmath} \allowdisplaybreaks %%% \usepackage{mcite} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \usepackage{noweb} \setlength{\unitlength}{1mm} \setlength{\nwmarginglue}{1em} %%% Saving paper: \def\nwendcode{\endtrivlist\endgroup} \nwcodepenalty=0 \let\nwdocspar\relax %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Some decorations depend on local stuff. Make it optional. \usepackage{thohacks} \usepackage[english]{babel}% \IfFileExists{mflogo.sty}% {\usepackage{mflogo}}% {\def\MF{\textsf{META}\-\textsf{FONT}}}% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \newenvironment{params}% {\begin{list}{}% {\setlength{\leftmargin}{2em}% \setlength{\rightmargin}{2em}% \setlength{\itemindent}{-1em}% \setlength{\listparindent}{0pt}% \renewcommand{\makelabel}{\hfil}}}% {\end{list}} \makeatletter \def\preprintno#1{\gdef\thepreprintno{#1}} \def\thepreprintno{} \let\orig@maketitle\maketitle \makeatother %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% LOTS of floats: \setcounter{topnumber}{3} % 2 \setcounter{bottomnumber}{3} % 2 \setcounter{totalnumber}{5} % 3 \renewcommand{\topfraction}{0.95} % 0.7 \renewcommand{\bottomfraction}{0.95} % 0.3 \renewcommand{\textfraction}{0.05} % 0.2 \renewcommand{\floatpagefraction}{0.5} % 0.5 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \makeindex \begin{document} \bibliographystyle{prsty}%%%{unsrt}%%%{physics} \title{% \Kirke/ (internal Version \Version/):\\ Beam Spectra for Simulating Linear Collider Physics% \thanks{% Supported by Bundesministerium f\"ur Bildung, Wissenschaft, Forschung und Technologie, Germany.}} \author{% Thorsten Ohl% \thanks{e-mail: \texttt{ohl@physik.uni-wuerzburg.de}}\\ \hfil\\ University of W\"urzburg \\ Emil-Hilb-Weg 22 \\ D-97089 W\"urzburg\\ Germany} \preprintno{\hfil} \date{% IKDA 96/13-rev\\ hep-ph/9607454-rev\\ July 1996 (expanded \Date/)} \maketitle \begin{abstract} I describe parameterizations of realistic $e^\pm$- and $\gamma$-beam spectra at future linear $e^+e^-$-colliders. Emphasis is put on simplicity and reproducibility of the parameterizations, supporting reproducible physics simulations. The parameterizations are implemented in a library of distribution functions and event generators. \end{abstract} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \tableofcontents %!MANUAL% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%!MANUAL% \newpage \section*{Program Summary:} \begin{itemize} \item \textbf{Title of program:} \Kirke/ (\Date/) %CPC% \item \textbf{Catalogue number:} %CPC% ???? \item \textbf{Program obtainable} %CPC% from CPC Program Library, Queen's University of Belfast, %CPC% N.~Ireland (see application form in this issue) or by anonymous \verb|ftp| from the host \hfil\allowbreak\verb|crunch.ikp.physik.th-darmstadt.de| in the directory \allowbreak\verb|pub/ohl/circe|. \item \textbf{Licensing provisions:} Free software under the GNU General Public License. \item \textbf{Programming language used:} Fortran77 originally, transferred to Fortran90 \item \textbf{Number of program lines in distributed program, including test data, etc.:} $\approx$ 1100 (excluding comments) \item \textbf{Computer/Operating System:} Any with a Fortran90 programming environment. \item \textbf{Memory required to execute with typical data:} Negligible on the scale of typical applications calling the library. \item \textbf{Typical running time:} A small fraction (typically a few percent) of the running time of applications calling the library. \item \textbf{Purpose of program:} Provide simple and reproducible, yet realistic, parameterizations of the $e^\pm$- and $\gamma$-beam spectra for linear colliders. \item \textbf{Nature of physical problem:} The intricate beam dynamics in the interaction region of a high luminosity linear collider at $\sqrt s = 500$GeV result in non-trivial energy spectra of the scattering electrons, positrons and photons. Physics simulations require simple and reproducible, yet realistic, parameterizations of these spectra. \item \textbf{Method of solution:} Parameterization, curve fitting, Monte Carlo event generation. \item \textbf{Keywords:} Event generation, beamstrahlung, linear colliders. \end{itemize} \newpage @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Introduction} Despite the enormous quantitative success of the electro-weak standard model up to energies of $200\text{GeV}$, neither the nature of electro-weak symmetry breaking~(EWSB) nor the origin of mass are understood.\par {}From theoretical considerations, we know that clues to the answer of these open questions are hidden in the energy range below~$\Lambda_{\text{EWSB}} = 4\pi v \approx 3.1\text{TeV}$. Either we will discover a Higgs particle in this energy range or signatures for a strongly interacting EWSB sector will be found. Experiments at CERN's Large Hadron Collider~(LHC) will shed a first light on this regime in the next decade. In the past is has been very fruitful to complement experiments at high energy hadron colliders with experiments at $e^+e^-$-colliders. The simpler initial state allows more precise measurements with smaller theoretical errors. Lucid expositions of the physics opportunities of high energy $e^+e^-$ colliders with references to the literature can be found in~\cite{Murayama/Peskin:1996:LC_review}.\par However, the power emitted by circular storage rings in form of synchrotron radiation scales like~$(E/m)^4/R^2$ with the energy and mass of the particle and the radius of the ring. This cost becomes prohibitive after LEP2 and a Linear Collider~(LC) has to be built instead.\par Unfortunately, the ``interesting'' hard cross sections scale like~$1/s$ with the square of the center of mass energy and a LC will have to operate at extremely high luminosities in excess of~$10^{33}\text{cm}^{-2}\text{s}^{-1}$. To achieve such luminosities, the bunches of electrons and positrons have to be very dense. Under these conditions, the electrons undergo acceleration from strong electromagnetic forces from the positron bunch (and vice versa). The resulting synchrotron radiation is called \emph{beamstrahlung}~\cite{Chen/Noble:1986:Beamstrahlung} and has a strong effect on the energy spectrum~$D(x_1,x_2)$ of the colliding particles. This changes the observable $e^+e^-$~cross sections \begin{subequations} \begin{align} \frac{d\sigma^{e^+e^-}_0}{d\Omega}(s) \to \frac{d\sigma^{e^+e^-}}{d\Omega}(s) &= \int_0^1 \!dx_1dx_2\, D_{e^+e^-} (x_1,x_2;\sqrt s) J(\Omega',\Omega) \frac{d\sigma^{e^+e^-}_0}{d\Omega'}(x_1x_2s)\\ \intertext{% and produces luminosity for $e^\pm\gamma$ and $\gamma\gamma$~collisions:} \frac{d\sigma^{e^\pm\gamma}}{d\Omega}(s) &= \int_0^1 \!dx_1dx_2\, D_{e^\pm\gamma} (x_1,x_2;\sqrt s) J(\Omega',\Omega) \frac{d\sigma^{e^\pm\gamma}_0}{d\Omega'}(x_1x_2s)\\ \frac{d\sigma^{\gamma\gamma}}{d\Omega}(s) &= \int_0^1 \!dx_1dx_2\, D_{\gamma\gamma} (x_1,x_2;\sqrt s) J(\Omega',\Omega) \frac{d\sigma^{\gamma\gamma}_0}{d\Omega'}(x_1x_2s) \end{align} \end{subequations} Therefore, simulations of the physics expected at a LC need to know the spectra of the~$e^\pm$ and~$\gamma$ beams precisely.\par Microscopic simulations of the beam dynamics are available (e.g.~\texttt{ABEL}\cite{Yokoya:1985:ABEL}, \texttt{CAIN}\cite{Chen/etal:1995:CAIN} and~\texttt{Guinea-Pig}\cite{Schulte:1996:Thesis}) and their predictions are compatible with each other. But they require too much computer time and memory for direct use in physics programs. \Kirke/ provides a fast and simple parameterization of the results from these simulations. Furthermore, even if the computational cost of the simulations would be negligible, the input parameters for microscopic simulations are not convenient for particle physics applications. Due to the highly non-linear beam dynamics, the optimization of LC designs is a subtle art~\cite{Palmer:1990:LC_review}, that is best practiced by the experts. Furthermore, particle physics applications need benchmarking and \text{easily reproducible} parameterizations are required for this purpose.\par The parameterizations in \Kirke/ are not based on approximate solutions~(cf.~\cite{Chen:1992:Beamstrahlung}) of the beamstrahlung dynamics. Instead, they provide a ``phenomenological'' description of the results from full simulations. The parameterizations are as simple as possible while remaining consistent with basic physical principles: \begin{enumerate} \item \emph{positivity:} the distribution functions~$D(x_1,x_2)$ \emph{must not} be negative in the physical region~$[0,1]\times[0,1]$. \item \emph{integrability:} the definite integral of the distribution functions over the physical region~$[0,1]\times[0,1]$ \emph{must} exist, even though the distributions can have singularities. \end{enumerate} This paper is organized as follows: I start in section~\ref{sec:parameters} with a discussion of the input for the microscopic simulations. In section~\ref{sec:usage} I describe the usage of the \Kirke/ library and in section~\ref{sec:technical} I discuss some technical details of the implementation. After discussing the parameterizations available (in internal version \Version/) in section~\ref{sec:parameterizations}, I conclude in section~\ref{sec:conclusions}. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Parameters} \label{sec:parameters} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|c||c|c|c|c|c|c|}\hline & \texttt{SBAND} & \texttt{TESLA} & \texttt{XBAND} & \texttt{SBAND} & \texttt{TESLA} & \texttt{XBAND} \\\hline\hline $E/\text{GeV}$ & 250 & 250 & 250 & 500 & 500 & 500 \\\hline $N_{\text{particles}}/10^{10}$ & 1.1 & 3.63 & 0.65 & 2.9 & 1.8 & 0.95 \\\hline $\epsilon_x/10^{-6}\text{mrad}$ & 5 & 14 & 5 & 10 & 14 & 5 \\\hline $\epsilon_y/10^{-6}\text{mrad}$ & 0.25 & 0.25 & 0.08 & 0.1 & 0.06 & 0.1 \\\hline $\beta^*_x/\text{mm}$ & 10.98 & 24.95 & 8.00 & 32 & 25 & 10.00 \\\hline $\beta^*_y/\text{mm}$ & 0.45 & 0.70 & 0.13 & 0.8 & 0.7 & 0.12 \\\hline $\sigma_x/\text{nm}$ & 335 & 845 & 286 & 571.87 & 598.08 & 226 \\\hline $\sigma_y/\text{nm}$ & 15.1 & 18.9 & 4.52 & 9.04 & 6.55 & 3.57 \\\hline $\sigma_z/\mu\text{m}$ & 300 & 700 & 100 & 500 & 500 & 125 \\\hline $f_{\text{rep}}$ & 50 & 5 & 180 & 50 & 5 & 180 \\\hline $n_{\text{bunch}}$ & 333 & 1135 & 90 & 125 & 2270 & 90 \\\hline \end{tabular} \end{center} \caption{\label{tab:acc_param}% Accelerator parameters for three typical designs at~$\protect\sqrt s = 500\text{GeV}$ and~$\protect\sqrt s = 1\text{TeV}$. The resulting distributions are shown in figure~\ref{fig:dist}. The design efforts are currently concentrated on a $350\text{GeV}$-$800\text{GeV}$ LC. Therefore the Tesla parameters for~$1\text{TeV}$ are slightly out of date.} \end{table} \begin{figure}[tp] \begin{center} \includegraphics{dist.1}\quad\includegraphics{dist.2} \\ \includegraphics{dist.3}\quad\includegraphics{dist.4} %% \includegraphics{dist1}\quad\includegraphics{dist2} \\ %% \includegraphics{dist3}\quad\includegraphics{dist4} \end{center} \caption{\label{fig:dist}% Version 1, revision 1996 09 02 of the factorized $e^\pm$- and $\gamma$-distributions at~$\protect\sqrt s = 500\text{GeV}$ and~$\protect\sqrt s = 1\text{TeV}$ in a doubly logarithmic plot. The accelerator parameters are taken from table~\ref{tab:acc_param}.} \end{figure} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|c||c|c|c|}\hline & \texttt{TESLA} & \texttt{TESLA} & \texttt{TESLA} \\\hline\hline $E/\text{GeV}$ & 175 & 250 & 400 \\\hline $N_{\text{particles}}/10^{10}$ & 3.63 & 3.63 & 3.63 \\\hline $\epsilon_x/10^{-6}\text{mrad}$ & 14 & 14 & 14 \\\hline $\epsilon_y/10^{-6}\text{mrad}$ & 0.25 & 0.25 & 0.1 \\\hline $\beta^*_x/\text{mm}$ & 25.00 & 24.95 & 15.00 \\\hline $\beta^*_y/\text{mm}$ & 0.70 & 0.70 & 0.70 \\\hline $\sigma_x/\text{nm}$ & 1010.94 & 845 & 668.67 \\\hline $\sigma_y/\text{nm}$ & 22.6 & 18.9 & 9.46 \\\hline $\sigma_z/\mu\text{m}$ & 700 & 700 & 700 \\\hline $f_{\text{rep}}$ & 5 & 5 & 5 \\\hline $n_{\text{bunch}}$ & 1135 & 1135 & 1135 \\\hline \end{tabular} \end{center} \caption{\label{tab:acc_param/Tesla}% Accelerator parameters for the Tesla design at three planned~\protect\cite{Tesla:1996:CDR} energies. The resulting distributions are shown in figure~\ref{fig:dist/Tesla}.} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|c||c|c|c|}\hline & High-$\mathcal{L}$ & Low-$\mathcal{L}$ & Low-$\epsilon_y$ \\\hline\hline $E/\text{GeV}$ & 400 & 400 & 400 \\\hline $N_{\text{particles}}/10^{10}$ & 3.63 & 3.63 & 1.800 \\\hline $\epsilon_x/10^{-6}\text{mrad}$ & 14 & 14 & 12 \\\hline $\epsilon_y/10^{-6}\text{mrad}$ & 0.1 & 0.25 & 0.025 \\\hline $\beta^*_x/\text{mm}$ & 15.00 & 25.00 & 25.00 \\\hline $\beta^*_y/\text{mm}$ & 0.70 & 0.70 & 0.50 \\\hline $\sigma_x/\text{nm}$ & 668.67 & 700.00 & \\\hline $\sigma_y/\text{nm}$ & 9.46 & & \\\hline $\sigma_z/\mu\text{m}$ & 700 & 700 & 500 \\\hline $f_{\text{rep}}$ & 5 & 5 & 3 \\\hline $n_{\text{bunch}}$ & 1135 & 1135 & 2260 \\\hline \end{tabular} \end{center} \caption{\label{tab:acc_param/Tesla/x}% Variant accelerator parameters for the Tesla design at 800 Gev.} \end{table} \begin{figure}[tp] \begin{center} \includegraphics{dist.5}\quad\includegraphics{dist.6} %% \includegraphics{dist5}\quad\includegraphics{dist6} \end{center} \caption{\label{fig:dist/Tesla}% Version 1, revision 1996 09 02 of the factorized $e^\pm$- and $\gamma$-distributions for Tesla in a doubly logarithmic plot. The accelerator parameters are taken from table~\ref{tab:acc_param/Tesla}.} \end{figure} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|c||c|c|c|}\hline & \texttt{TESLA} & \texttt{TESLA} \\\hline\hline $E/\text{GeV}$ & 250 & 400 \\\hline $N_{\text{particles}}/10^{10}$ & 2 & 1.40 \\\hline $\epsilon_x/10^{-6}\text{m rad}$ & 10 & 8 \\\hline $\epsilon_y/10^{-6}\text{m rad}$ & 0.03 & 0.01 \\\hline $\beta^*_x/\text{mm}$ & 15.00 & 15.00 \\\hline $\beta^*_y/\text{mm}$ & 0.40 & 0.30 \\\hline $\sigma_x/\text{nm}$ & 553 & 391 \\\hline $\sigma_y/\text{nm}$ & 5 & 2 \\\hline $\sigma_z/\mu\text{m}$ & 400 & 300 \\\hline $f_{\text{rep}}$ & 5 & 3 \\\hline $n_{\text{bunch}}$ & 2820 & 4500 \\\hline \end{tabular} \end{center} \caption{\label{tab:acc_param/Tesla/hi}% Accelerator parameters for a high luminosity Tesla design at two planned~\protect\cite{Tesla:1996:CDR} energies. The resulting distributions are shown in figure~\ref{fig:dist/Tesla/hi}.} \end{table} \begin{figure}[tp] \begin{center} \includegraphics[width=.9\textwidth]{dist78} \end{center} \caption{\label{fig:dist/Tesla/hi}% Version 5, revision 1998 05 05 of the factorized $e^\pm$- and $\gamma$-distributions for a high luminosity Tesla in a doubly logarithmic plot. The accelerator parameters are taken from table~\ref{tab:acc_param/Tesla/hi}.} \end{figure} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{figure}[tp] \begin{center} \includegraphics{dist.11}\quad\includegraphics{dist.12} \\ \includegraphics{dist.13}\quad\includegraphics{dist.14} \\ \end{center} \caption{\label{fig:dist/Tesla/ee}% \emph{Experimental:} Version 1, revision 0 of the factorized $e^-$- and $\gamma$-distributions for Tesla-$e^-e^-$ in a doubly logarithmic plot. The accelerator parameters are taken from table~\ref{tab:acc_param/Tesla} and have \emph{not} been endorsed for use in an $e^-e^-$-machine yet!.} \end{figure} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% The microscopic simulation program \texttt{Guinea-Pig}~\cite{Schulte:1996:Thesis} used for the current version of the parameterizations in \Kirke/ simulates the passage of electrons through a bunch of electrons (and vice versa). It takes the following accelerator parameters as input: \begin{description} \item[$E$]: the energy of the particles before the beam-beam interaction. \item[$N_{\text{particles}}$]: the number of particles per bunch. \item[$\epsilon_{x,y}$]: the normalized horizontal and vertical emittances. \item[$\beta^*_{x,y}$]: the horizontal and vertical beta functions. \item[$\sigma_{x,y,z}$]: the horizontal, vertical and longitudinal beam size. A Gaussian shape is used for the charge distribution in the bunches. \item[$f_{\text{rep}}$]: the repetition rate. \item[$n_{\text{bunch}}$]: the number of bunches per train. \end{description} The transversal beam sizes, beta functions and normalized emittances for relativistic particles are related by \begin{equation} \beta^*_{x,y} = \frac{\sigma_{x,y}^2}{\epsilon_{x,y}} \frac{E}{m_e} \end{equation} The parameters used in the most recent revision of the parameterizations are collected in tables~\ref{tab:acc_param} and~\ref{tab:acc_param/Tesla}. The resulting factorized electron/positron and photon distributions in version 1 of the parameterizations are depicted in figures~\ref{fig:dist} and~\ref{fig:dist/Tesla}.\par The most important purpose of \Kirke/ is to map the manifold of possible beam spectra for the NLC to a \emph{finite} number of \emph{reproducible} parameterizations. The distributions \begin{equation} \label{eq:dist} D^{\alpha\nu\rho}_{p_1p_2} (x_1, x_2; \sqrt s) \end{equation} provided by \Kirke/ are indexed by three integers \begin{description} \item[$\alpha$]: the \emph{accelerator design class:} currently there are three options: S-band~\cite{S-Band:1996:CDR}, Tesla~\cite{Tesla:1996:CDR}, X-band~\cite{JLC:1992:CDR,NLC:1996:ZDR}. More variety will be added later, in particular the~$e^-e^-$ mode and the $e^-\gamma$ and~$\gamma\gamma$ laser backscattering modes of these designs. \item[$\nu$]: the \emph{version of the parameterization:} over the years, the form of the parameterizations can change, either because better approximations are found or because new simulation programs become available. All versions will remain available in order to be able to reproduce calculations. \item[$\rho$]: the \emph{revision date for the parameterization:} a particular parameterization can contain bugs, which will be fixed in subsequent revisions. While only the most recent revision should be used for new calculations, old revisions will remain available in order to be able to reproduce calculations. \end{description} The continuous parameter~$\sqrt s$ in~(\ref{eq:dist}) is misleading, because accelerator parameters have been optimized for discrete values of the energy. Therefore the distributions are not available for all values of~$\sqrt s$.\par The usage of the distributions in application programs is discussed in section~\ref{sec:dist-usage}. \Kirke/ provides for each of the distributions a non-uniform random variate generator, that generates energy fractions according to the distributions. The usage of these generators is discussed in section~\ref{sec:mc-usage}. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Usage} \label{sec:usage} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Distributions} \label{sec:dist-usage} A generic interface to all distributions~$D_{p_1p_2}(x_1,x_2)$ is given by the \texttt{circe} function <>= function circe, d, x1, x2 real(kind=double) :: circe integer :: p1, p2 d = circe (x1, x2, p1, p2) @ where the energy fractions are specified by~$x_{1,2}$ and the particles~$p_{1,2}$ are identified by their standard Monte Carlo codes (we use [[C1]] as a prefix to avoid name clashes when using [[CIRCE1]] inside [[WHIZARD]]):\cite{PDG:1994} <>= integer, parameter, public :: C1_ELECTRON = 11 integer, parameter, public :: C1_POSITRON = -11 integer, parameter, public :: C1_PHOTON = 22 @ %def C1_ELECTRON C1_POSITRON C1_PHOTON @ The distributions can have integrable singularities at the end points, therefore the calling functions \emph{must not} evaluate them at the endpoints~$0$ and~$1$. This is usually not a problem, since standard mapping techniques~(cf.~(\ref{eq:mapping}) below) will have to be used to take care of the singularity anyway. Nevertheless, all applications should favor open quadrature formulae (i.e.~formulae not involving the endpoints) over closed formulae. @ The distributions are guaranteed to vanish unless~$0>= real(kind=dobule) :: lumi call circel (lumi) @ A particular parameterization is selected by the [[circes]] function: <>= real(kind=double) :: x1m, x2m, roots integer :: acc, ver, rev, chat call circes (x1m, x2m, roots, acc, ver, rev, chat) @ The parameter [[roots]] corresponds to the nominal center of mass energy~$\sqrt s/\text{GeV}$ of the collider. Currently $\sqrt s = 350\text{GeV}, 500\text{GeV}, 800\text{GeV}, 1\text{TeV}$ (i.e.~[[350D0]], [[500D0]], [[800D0]] and~[[1000D0]]) are supported. Application programs can \emph{not} assume that energy values are interpolated. For convenience, e.g.~in top threshold scans around~$350\text{GeV}$, a small interval around the supported values will be accepted as synonymous with the central value, but a warning will be printed. Section~\ref{sec:parameterizations} should be consulted for the discrete values supported by a particular version of the parameterizations. Negative values of [[roots]] will keep the currently active value for~$\sqrt s$.\par The parameters [[x1m]] and [[x2m]] will set thresholds~$x_{1,\text{min}}$ and~$x_{2,\text{min}}$ for the event generation in the routines described in section~\ref{sec:mc-usage}.\par The parameter [[acc]] selects the accelerator design. Currently the following accelerator codes are recognized: <>= integer, parameter :: SBAND = 1 integer, parameter :: TESLA = 2 integer, parameter :: XBAND = 3 integer, parameter :: JLCNLC = 3 integer, parameter :: SBNDEE = 4 integer, parameter :: TESLEE = 5 integer, parameter :: XBNDEE = 6 integer, parameter :: NLCH = 7 integer, parameter :: ILC = 8 integer, parameter :: CLIC = 9 @ %def SBAND TESLA XBAND @ %def JLCNLC SBNDEE TESLEE XBNDEE @ %def ILC CLIC @ The total number of accelerator codes <>= integer, parameter :: NACC = 9 @ %def NACC @ The [[ver]] parameter is used to determine the version as follows: \begin{description} \item[$\text{[[ver]]}>0$]: a frozen version which is documented in section~\ref{sec:parameterizations}. For example, version 1 is a family of factorized Beta distributions: $D(x_1,x_2) \propto x_1^{a_1}(1-x_1)^{b_1} x_2^{a_2}(1-x_2)^{b_2}$. \item[$\text{[[ver]]}=0$]: the latest experimental version, which is usually not documented and can change at any time without announcement. \item[$\text{[[ver]]}<0$]: keep the currently active version. \end{description} @ The [[rev]] parameter is used to determine the revision of a version as follows: \begin{description} \item[$\text{[[rev]]}>0$]: a frozen revision which is documented in section~\ref{sec:parameterizations}. The integer [[rev]] is constructed from the date as follows: $\text{[[rev]]} = 10^4\cdot\text{year} + 10^2\cdot\text{month} + \text{day}$, where the year is greater than 1995. Since Fortran77 ignored whitespace, it could be written like \verb+1996 07 11+ for readability. In Fortran90 the white space have been erased. If there is no exact match, the most recent revision before the specified date is chosen. \item[$\text{[[rev]]}=0$]: the most recent revision. \item[$\text{[[rev]]}<0$]: keep the currently active revision. \end{description} @ Finally, the parameter [[chat]] controls the ``chattiness'' of [[circe]]. If it is~$0$, only error messages are printed. If it is~$1$, the parameters in use are printed whenever they change. Higher values of [[chat]] can produce even more diagnostics.\par In addition to the generic interface [[circe]], there are specialized functions for particular particle distributions. Obviously \begin{equation} D_{e^\pm\gamma}^{\alpha\nu\rho} (x_1, x_2, s) = D_{\gamma e^\pm}^{\alpha\nu\rho} (x_2, x_1, s) \end{equation} and there are three independent functions~$D_{e^-e^+}$, $D_{e^-\gamma}$ and~$D_{\gamma\gamma}$ for the~$e^+e^-$ colliders with reasonable mnemonics: <>= real(kind=double) :: circee, circeg, circgg d = circee (x1, x2) d = circeg (x1, x2) d = circgg (x1, x2) @ Calling the latter three functions is marginally faster in the current implementation, but this can change in the future. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Example} \label{sec:sample-int} For clarification, let me give a simple example. Imagine we want to calculate the integrated production cross section \begin{equation} \sigma_X(s) = \int\!dx_1dx_2\, \sigma_{e^+e^-\to X}(x_1x_2s) D_{e^+e^-}(x_1,x_2,s) \end{equation} Since the distributions are singular in the~$x_{1,2}\to1$ limit, we have to map away this singularity with \begin{subequations} \label{eq:mapping} \begin{align} x &\to t = (1-x)^{1/\eta}\\ \intertext{Therefore} \int_0^1\!dx\,f(x) &= \int_0^1\!dt\, \eta t^{\eta-1} f(1-t^\eta) \end{align} \end{subequations} with~$\eta$ sufficiently large to give the integrand a finite limit at~$x\to1$. If~$f$ diverges like a power~$f(x) \propto 1/(1-x)^\beta$, this means~$\eta>1/(1-\beta)$.\par As a specific example, let us ``measure'' a one particle $s$-channel exchange cross section \begin{equation} \sigma(s) \propto \frac{1}{s} \end{equation} <<[[circe1_sample.f90: public]]>>= public :: sigma <<[[circe1_sample.f90: subroutines]]>>= function sigma (s) real(kind=double) :: s, sigma sigma = 1d0 / s end function sigma @ %def sigma @ I will present the example code in a bottom-up fashion, which should be intuitive and is described in some more detail in appendix~\ref{sec:litprog}. Assuming the existence of a one- and a two-dimensional Gaussian integration function [[gauss1]] and [[gauss2]],\footnote{% They are provided in the example program [[circe1_sample.f90]].} we can perform the integral as follows: <>= s = sigma (1d0) * circee (1d0, 1d0) & + gauss1 (d1, 0d0, 1d0, EPS) & + gauss1 (d2, 0d0, 1d0, EPS) & + gauss2 (d12, 0d0, 1d0, 0d0, 1d0, EPS) write (*, 1000) 'delta(sigma) (Gauss) =', (s-1d0)*100d0 1000 format (1X, A22, 1X, F6.2, '%') @ Note how the four combinations of continuum and $\delta$-peak are integrated separately, where you have to use three auxiliary functions~[[d1]], [[d2]] and~[[d12]]. The continuum contribution, including the Jacobian: <<[[circe1_sample.f90: public]]>>= public :: d12 <<[[circe1_sample.f90: subroutines]]>>= function d12 (t1, t2) real(kind=double) :: d12, t1, t2, x1, x2 <<[[EPS]] \&\ [[PWR]]>> x1 = 1d0 - t1**PWR x2 = 1d0 - t2**PWR d12 = PWR*PWR * (t1*t2)**(PWR-1d0) & * sigma (x1*x2) * circee (x1, x2) end function d12 @ %def d12 @ the first product of continuum and $\delta$-peak: <<[[circe1_sample.f90: public]]>>= public :: d1 <<[[circe1_sample.f90: subroutines]]>>= function d1 (t1) real(kind=double) :: t1, x1, d1 <<[[EPS]] \&\ [[PWR]]>> x1 = 1d0 - t1**PWR d1 = PWR * t1**(PWR-1d0) * sigma (x1) * circee (x1, 1d0) end function d1 @ %def d1 @ and the second one: <<[[circe1_sample.f90: public]]>>= public :: d2 <<[[circe1_sample.f90: subroutines]]>>= function d2 (t2) real(kind=double) :: t2, x2, d2 <<[[EPS]] \&\ [[PWR]]>> x2 = 1d0 - t2**PWR d2 = PWR * t2**(PWR-1d0) * sigma (x2) * circee (1d0, x2) end function d2 @ %def d2 @ Below you will see that the power of the singularity of the $e^+e^-$~distributions at~$x\to1$ is~$\approx-2/3$. To be on the safe side, we choose the power~$\eta$ in~(\ref{eq:mapping}) as~$5$. It is kept in the parameter~[[PWR]], while~[[EPS]] is the desired accuracy of the Gaussian integration: <<[[EPS]] \&\ [[PWR]]>>= real(kind=double), parameter :: EPS = 1d-6, PWR = 5d0 @ The Gauss integration of the non-singular version converges to the cotrrect value only if the final bin is integrated separately: <>= s = gauss2 (d12a, 0d0, 1d0-KIREPS, 0d0, 1d0-KIREPS, EPS) & + gauss2 (d12a, 0d0, 1d0-KIREPS, 1d0-KIREPS, 1d0, EPS) & + gauss2 (d12a, 1d0-KIREPS, 1d0, 0d0, 1d0-KIREPS, EPS) & + gauss2 (d12a, 1d0-KIREPS, 1d0, 1d0-KIREPS, 1d0, EPS) write (*, 1000) 'delta(sigma) (Gauss) =', (s-1d0)*100d0 @ <<[[EPS]] \&\ [[PWR]]>>= real(kind=double), parameter :: KIREPS = 1D-6 @ <<[[circe1_sample.f90: public]]>>= public :: d12a <<[[circe1_sample.f90: subroutines]]>>= function d12a (x1, x2) real(kind=double) :: x1, x2, d12a d12a = sigma (x1*x2) * kirkee (x1, x2) end function d12a @ %def d12a @ These code fragments can now be used in a main program that loops over energies and accelerator designs <<[[circe1_sample.f90]]>>= ! circe1_sample.f90 -- canonical beam spectra for linear collider physics -! $Id$ <> module sample_routines use kinds use circe1 !NODEP! implicit none private <<[[circe1_sample.f90: public]]>> contains <<[[circe1_sample.f90: subroutines]]>> end module sample_routines program circe1_sample use kinds use sample_routines use circe1 implicit none <> <<[[EPS]] \&\ [[PWR]]>> <> integer :: acc, ver, i real(kind=double), dimension(9) :: roots(9) = & (/ 90D0, 170D0, 250D0, 350D0, 500D0, & 800D0, 1000D0, 1200D0, 1500D0 /) do acc = 1, NACC ! do acc = JLCNLC, NLCH, NLCH-JLCNLC do ver = 9, 9 do i = 1, 9 call circes (0d0, 0d0, roots(i), acc, ver, 20020328, 1) <> <> <> end do end do end do end program circe1_sample @ with the following result <>= circe1:message: starting up ... - circe1:message: $Id$ circe1:message: updating `roots' to 90.0 circe1:message: updating `ver' to 7 circe1:message: updating `rev' to 20000501 delta(sigma) (Gauss) = 0.11% delta(sigma) (MC) = 0.11% +/- 0.00% circe1:message: updating `roots' to 170.0 circe1:message: updating `ver' to 7 delta(sigma) (Gauss) = 0.38% delta(sigma) (MC) = 0.38% +/- 0.01% circe1:message: updating `roots' to 350.0 circe1:message: updating `ver' to 7 delta(sigma) (Gauss) = 1.67% delta(sigma) (MC) = 1.66% +/- 0.03% circe1:message: updating `roots' to 500.0 circe1:message: updating `ver' to 7 delta(sigma) (Gauss) = 3.66% delta(sigma) (MC) = 3.58% +/- 0.07% circe1:message: updating `roots' to 800.0 circe1:message: updating `ver' to 7 delta(sigma) (Gauss) = 5.21% delta(sigma) (MC) = 5.19% +/- 0.11% circe1:message: updating `roots' to 1000.0 circe1:message: updating `ver' to 7 circe1:message: energy 1000.0GeV too high, using spectrum for 800.0GeV delta(sigma) (Gauss) = 5.21% delta(sigma) (MC) = 5.19% +/- 0.11% circe1:message: updating `roots' to 90.0 circe1:message: updating `acc' to JLCNLC circe1:message: updating `ver' to 7 circe1:message: energy 90.0GeV too low, using spectrum for 500.0GeV delta(sigma) (Gauss) = 4.74% delta(sigma) (MC) = 4.75% +/- 0.11% circe1:message: updating `roots' to 170.0 circe1:message: updating `ver' to 7 circe1:message: energy 170.0GeV too low, using spectrum for 500.0GeV delta(sigma) (Gauss) = 4.74% delta(sigma) (MC) = 4.68% +/- 0.11% circe1:message: updating `roots' to 350.0 circe1:message: updating `ver' to 7 circe1:message: energy 350.0GeV too low, using spectrum for 500.0GeV delta(sigma) (Gauss) = 4.74% delta(sigma) (MC) = 4.75% +/- 0.11% circe1:message: updating `roots' to 500.0 circe1:message: updating `ver' to 7 delta(sigma) (Gauss) = 4.74% delta(sigma) (MC) = 4.75% +/- 0.11% circe1:message: updating `roots' to 800.0 circe1:message: updating `ver' to 7 circe1:message: energy 800.0GeV interpolated between 500.0 and 1000.0GeV delta(sigma) (Gauss) = 8.37% delta(sigma) (MC) = 8.39% +/- 0.21% circe1:message: updating `roots' to 1000.0 circe1:message: updating `ver' to 7 delta(sigma) (Gauss) = 15.39% delta(sigma) (MC) = 14.68% +/- 0.33% @ We almost forgot to declare the variables in the main program <>= real(kind=double) :: s @ This concludes the integration example. It should have made it obvious how to proceed in a realistic application.\par In section~\ref{sec:sample-MC} below, I will describe a Monte Carlo method for calculating such integrals efficiently. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Generators} \label{sec:mc-usage} The function [[circe]] and its companions are opaque to the user. Since they will in general contain singularities, applications will \emph{not} be able to generate corresponding samples of random numbers efficiently. To fill this gap, four random number generators are provided. The subroutine [[girce]] will generate particle types~$p_{1,2}$ and energy fractions~$x_{1,2}$ in one step, according to the selected distribution.\footnote{\index{inefficiencies}% The implementation of the flavor selection with non-vanishing thresholds~$x_{1,\text{min}}$ and~$x_{2,\text{min}}$ is moderately inefficient at the moment. It can be improved by a factor of two.} Particle~$p_1$ will be either a positron or a photon and~$p_2$ will be either an electron or a photon. The energy fractions are guaranteed to be above the currently active thresholds: $x_i \ge x_{i,\text{min}}$. This can be used to cut on soft events---the photon distributions are rather soft---which might not be interesting in most simulations. <>= call girce (x1, x2, p1, p2, rng) @ The output parameters of [[girce]] are identical to the input parameters of [[circe]], with the exception of [[rng]]. The latter is a subroutine with a single double precision argument, which will be assigned a uniform deviate from the interval $[0,1]$ after each call: <>= subroutine rng (r) real(kind=double) :: r r = <> end subroutine rng @ Typically, it will be just a wrapper around the standard random number generator of the application program. @ For studies with a definite initial state, three generator functions are available. <>= call gircee (x1, x2, rng) call girceg (x1, x2, rng) call gircgg (x1, x2, rng) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Example} \label{sec:sample-MC} Returning to the example from section~\ref{sec:sample-MC}, I present a concise Monte Carlo algorithm for calculating the same integral: <>= s = 0d0 s2 = 0d0 do n = 1, NEVENT call gircee (x1, x2, random) w = sigma (x1*x2) s = s + w s2 = s2 + w*w end do s = s / dble(NEVENT) s2 = s2 / dble(NEVENT) write (*, 1000) 'delta(sigma) (MC) =', (s-1d0)*100d0 write (*, 1000) ' +/-', sqrt((s2-s*s)/dble(NEVENT))*100d0 @ <>= real(kind=double) :: w, s2, x1, x2 integer, parameter :: NEVENT = 10000 integer :: n @ Here is a simple linear congruential random number generator for the sample program. Real applications will use their more sophisticated generators instead. <<[[circe1_sample.f90: public]]>>= public :: random <<[[circe1_sample.f90: subroutines]]>>= subroutine random (r) real(kind=double), intent(out) :: r integer :: m = 259200, a = 7141, c = 54773 integer, save :: n = 0 ! data n /0/ n = mod(n*a+c,m) r = real (n, kind=double) / real (m, kind=double) end subroutine random @ %def random @ If the cross section is slowly varying on the range where the~$x_{1,2}$ distributions are non-zero, this algorithm is very efficient.\par However, if this condition is not met, the explicit form of the parameterizations in section~\ref{sec:parameterizations} should be consulted and appropriate mapping techniques should be applied. The typical example for this problem is a narrow resonance just below the nominal beam energy. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Event Generators} \label{sec:MC} For Monte Carlo event generators that use the standard [[/hepevt/]] common block~\cite{Altarelli/etal:1989:LEP1}, the addition of the \Kirke/ library is trivial. During the initialization of the event generator, the [[circes]] subroutine is called to set up \Kirke/'s internal state. For example: <>= call circes (0d0, 0d0, roots, acc, ver, 1996 07 11, 1) @ During event generation, before setting up the~$e^+e^-$ initial state, the [[gircee]] subroutine is called with the event generator's random number generator: <>= call gircee (x1, x2, random) @ The resulting energy fractions~$x_1$ and~$x_2$ are now available for defining the initial state electron <>= isthep(1) = 101 idhep(1) = C1_ELECTRON phep(1,1) = 0d0 phep(2,1) = 0d0 phep(3,1) = x1 * ebeam phep(4,1) = x1 * ebeam phep(5,1) = 0d0 @ and positron. <>= isthep(2) = 102 idhep(2) = C1_POSITRON phep(1,2) = 0d0 phep(2,2) = 0d0 phep(3,2) = - x2 * ebeam phep(4,2) = x2 * ebeam phep(5,2) = 0d0 @ Using \Kirke/ with other event generators should be straightforward as well. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Technical Notes} \label{sec:technical} \begin{figure}[tp] \begin{center} \includegraphics{figures1} \end{center} \caption{\label{fig:architecture}% Architecture of \Kirke/: \texttt{circes()} selects energy and accelerator and loads the parameterization. The function \texttt{circe()} calculates the values of the selected distribution function at the given energy fractions. The subroutine \texttt{girce()} generates energy fractions using a specified random number generator in accordance with the selected distribution.} \end{figure} The structure of \Kirke/ is extremely simple~(cf.~figure~\ref{fig:architecture}) and is mainly a bookkeeping excercise. All that needs to be done is to maintain a database of available parameterizations and to evaluate the corresponding functions. The only non trivial algorithms are used for the efficient generation of random deviates.\par I have avoided the use of initialized \texttt{common} blocks (i.e.~\texttt{block data} subroutines), because the Fortran77 standard does not provide a \emph{portable} way of ensuring that \texttt{block data} subroutines are actually executed at loading time \footnote{In Fortran90 the common blocks have been replaced by saved module variables.}. Instead, the \texttt{/circom/} common block is tagged by a ``magic number'' to check for initialization and its members are filled by the \texttt{circes} subroutine when necessary.\par A more flexible method would be to replace the \texttt{data} statements by reading external files. This option causes portability problems, however, because I would have to make sure that the names of the external files are valid in all files systems of the target operating systems. More significantly, splitting the implementation into several parts forces the user to keep all files up to date. This can be a problem, because Fortran source files and data input files will typically be kept in different parts of the file system.\par The option of implementing \Kirke/ statelessly, i.e.~with pure function calls and without \texttt{common} blocks, has been dismissed. While it would have been more straightforward on the side of the library, it would have placed the burdon of maintaining state (accelerator, energy, etc.) on the application program, thereby complicating them considerably. Keeping an explicit state in \Kirke/ has the additional benefit of allowing to precompute certain internal variables, resulting in a more efficient implementation. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Parameterizations} \label{sec:parameterizations} The internal Version \Version/ of \Kirke/1 supports just one version of the parameterizations. Future versions will provide additional parameterizations. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Version 1} \label{sec:factorized-beta} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|c||c|c|c|c|}\hline & \texttt{SBAND} & \texttt{TESLA} & \texttt{TESLA'} & \texttt{XBAND} \\\hline\hline $\mathcal{L}/\text{fb}^{-1}\upsilon^{-1}$ & $ 31.38_{-0.22}^{+0.22}$ & $ 106.25_{-0.71}^{+0.71}$ & $ 95.24_{-0.73}^{+0.73}$ & $ 36.39_{-0.29}^{+0.29}$ \\\hline $\int d_{e^\pm}$ & $ 0.4812_{-0.0041}^{+0.0041}$ & $ 0.5723_{-0.0045}^{+0.0046}$ & $ 0.3512_{-0.0048}^{+0.0048}$ & $ 0.3487_{-0.0040}^{+0.0040}$ \\\hline $x_{e^\pm}^\alpha$ & $11.1534_{-0.0761}^{+0.0770}$ & $15.2837_{-0.0914}^{+0.0923}$ & $27.1032_{-0.3019}^{+0.3071}$ & $ 6.9853_{-0.0718}^{+0.0733}$ \\\hline $(1-x_{e^\pm})^\alpha$ & $-0.6302_{-0.0012}^{+0.0013}$ & $-0.6166_{-0.0011}^{+0.0011}$ & $-0.6453_{-0.0017}^{+0.0017}$ & $-0.6444_{-0.0017}^{+0.0017}$ \\\hline $\int d_\gamma$ & $ 0.6237_{-0.0033}^{+0.0033}$ & $ 0.7381_{-0.0036}^{+0.0036}$ & $ 0.3502_{-0.0034}^{+0.0034}$ & $ 0.4149_{-0.0031}^{+0.0031}$ \\\hline $x_\gamma^\alpha$ & $-0.6911_{-0.0006}^{+0.0006}$ & $-0.6921_{-0.0006}^{+0.0006}$ & $-0.6947_{-0.0011}^{+0.0011}$ & $-0.6876_{-0.0010}^{+0.0010}$ \\\hline $(1-x_\gamma)^\alpha$ & $14.9355_{-0.0754}^{+0.0761}$ & $24.1647_{-0.1116}^{+0.1124}$ & $33.6576_{-0.2983}^{+0.3021}$ & $ 8.3227_{-0.0649}^{+0.0659}$ \\\hline \end{tabular} \end{center} \caption{\label{tab:param}% Version 1, revision 1997 04 16 of the beam spectra at 500 GeV. The rows correspond to the luminosity per effective year, the integral over the continuum and the powers in the factorized Beta distributions~(\ref{eq:beta}).} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|c||c|c|c|c|}\hline & \texttt{SBAND} & \texttt{TESLA} & \texttt{TESLA'} & \texttt{XBAND} \\\hline\hline $\mathcal{L}/\text{fb}^{-1}\upsilon^{-1}$ & $ 119.00_{-0.83}^{+0.83}$ & $ 214.33_{-0***}^{+0***}$ & $ 212.22_{-0***}^{+0***}$ & $ 118.99_{-0.91}^{+0.91}$ \\\hline $\int d_{e^\pm}$ & $ 0.5604_{-0.0039}^{+0.0040}$ & $ 0.6686_{-0.0040}^{+0.0040}$ & $ 0.4448_{-0.0043}^{+0.0043}$ & $ 0.5001_{-0.0038}^{+0.0038}$ \\\hline $x_{e^\pm}^\alpha$ & $ 4.2170_{-0.0255}^{+0.0258}$ & $ 5.5438_{-0.0239}^{+0.0241}$ & $ 9.6341_{-0.0803}^{+0.0814}$ & $ 2.6184_{-0.0190}^{+0.0192}$ \\\hline $(1-x_{e^\pm})^\alpha$ & $-0.6118_{-0.0013}^{+0.0013}$ & $-0.5847_{-0.0011}^{+0.0011}$ & $-0.6359_{-0.0014}^{+0.0014}$ & $-0.6158_{-0.0015}^{+0.0015}$ \\\hline $\int d_\gamma$ & $ 0.7455_{-0.0032}^{+0.0032}$ & $ 1.0112_{-0.0033}^{+0.0033}$ & $ 0.4771_{-0.0031}^{+0.0031}$ & $ 0.6741_{-0.0031}^{+0.0031}$ \\\hline $x_\gamma^\alpha$ & $-0.6870_{-0.0006}^{+0.0006}$ & $-0.6908_{-0.0004}^{+0.0004}$ & $-0.6936_{-0.0008}^{+0.0008}$ & $-0.6834_{-0.0007}^{+0.0007}$ \\\hline $(1-x_\gamma)^\alpha$ & $ 6.7145_{-0.0308}^{+0.0310}$ & $ 9.9992_{-0.0340}^{+0.0342}$ & $13.1607_{-0.0886}^{+0.0896}$ & $ 3.8589_{-0.0213}^{+0.0215}$ \\\hline \end{tabular} \end{center} \caption{\label{tab:param/TeV}% Version 1, revision 1997 04 17 of the beam spectra at 1 TeV.} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|c||c|c|c|c|}\hline & 350 GeV & 500 GeV & 800 GeV & 1600 GeV \\\hline\hline $\mathcal{L}/\text{fb}^{-1}\upsilon^{-1}$ & $ 97.45_{-0.67}^{+0.67}$ & $ 106.25_{-0.71}^{+0.71}$ & $ 170.86_{-0***}^{+0***}$ & $ 340.86_{-0***}^{+0***}$ \\\hline $\int d_{e^\pm}$ & $ 0.6093_{-0.0049}^{+0.0049}$ & $ 0.5723_{-0.0045}^{+0.0046}$ & $ 0.6398_{-0.0041}^{+0.0042}$ & $ 0.5094_{-0.0040}^{+0.0040}$ \\\hline $x_{e^\pm}^\alpha$ & $17.6137_{-0.1055}^{+0.1065}$ & $15.2837_{-0.0914}^{+0.0923}$ & $ 7.6221_{-0.0361}^{+0.0365}$ & $ 5.0550_{-0.0349}^{+0.0353}$ \\\hline $(1-x_{e^\pm})^\alpha$ & $-0.6061_{-0.0011}^{+0.0011}$ & $-0.6166_{-0.0011}^{+0.0011}$ & $-0.5944_{-0.0011}^{+0.0011}$ & $-0.6187_{-0.0013}^{+0.0013}$ \\\hline $\int d_\gamma$ & $ 0.7729_{-0.0039}^{+0.0039}$ & $ 0.7381_{-0.0036}^{+0.0036}$ & $ 0.9178_{-0.0034}^{+0.0034}$ & $ 0.5875_{-0.0031}^{+0.0031}$ \\\hline $x_\gamma^\alpha$ & $-0.6949_{-0.0006}^{+0.0006}$ & $-0.6921_{-0.0006}^{+0.0006}$ & $-0.6908_{-0.0005}^{+0.0005}$ & $-0.6892_{-0.0007}^{+0.0007}$ \\\hline $(1-x_\gamma)^\alpha$ & $28.9399_{-0.1361}^{+0.1370}$ & $24.1647_{-0.1116}^{+0.1124}$ & $13.1167_{-0.0495}^{+0.0497}$ & $ 7.5514_{-0.0424}^{+0.0428}$ \\\hline \end{tabular} \end{center} \caption{\label{tab:param/Tesla}% Version 1, revision 1997 04 17 of the beam spectra for TESLA.} \end{table} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|c||c|c|c|c|}\hline & 500 GeV & 800 GeV \\\hline\hline $\mathcal{L}/\text{fb}^{-1}\upsilon^{-1}$ & $ 339.80_{-0.83}^{+0.83}$ & $ 359.36_{-0.93}^{+0.93}$ \\\hline $\int d_{e^\pm}$ & $ 0.5019_{-0.0016}^{+0.0016}$ & $ 0.4125_{-0.0016}^{+0.0016}$ \\\hline $x_{e^\pm}^\alpha$ & $12.2867_{-0.0316}^{+0.0318}$ & $13.3242_{-0.0440}^{+0.0442}$ \\\hline $(1-x_{e^\pm})^\alpha$ & $-0.6276_{-0.0005}^{+0.0005}$ & $-0.6401_{-0.0005}^{+0.0005}$ \\\hline $\int d_\gamma$ & $ 0.5114_{-0.0012}^{+0.0012}$ & $ 0.3708_{-0.0011}^{+0.0011}$ \\\hline $x_\gamma^\alpha$ & $-0.6912_{-0.0003}^{+0.0003}$ & $-0.6924_{-0.0004}^{+0.0004}$ \\\hline $(1-x_\gamma)^\alpha$ & $17.0673_{-0.0375}^{+0.0375}$ & $16.8145_{-0.0480}^{+0.0482}$ \\\hline \end{tabular} \end{center} \caption{\label{tab:param/Tesla/hi}% Version 5, revision 1998 05 05 of the beam spectra for high luminosity TESLA.} \end{table} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{figure}[tp] \begin{center} \includegraphics{fit11}\quad\includegraphics{fit21} \end{center} \caption{\label{fig:fit/S-Band/500GeV}% Fit of the $e^\pm$- and $\gamma$-distributions for the S-Band design at $\protect\sqrt s = 500\text{GeV}$. The open circles with error bars are the result of the \texttt{Guinea-Pig} similation. The full line is the fit.} \end{figure} \begin{figure}[tp] \begin{center} \includegraphics{fit12}\quad\includegraphics{fit22} \end{center} \caption{\label{fig:fit/Tesla/500GeV}% Fit of the $e^\pm$- and $\gamma$-distributions for the Tesla design at $\protect\sqrt s = 500\text{GeV}$.} \end{figure} \begin{figure}[tp] \begin{center} \includegraphics{fit13}\quad\includegraphics{fit23} \end{center} \caption{\label{fig:fit/X-Band/500GeV}% Fit of the $e^\pm$- and $\gamma$-distributions for the X-Band design at $\protect\sqrt s = 500\text{GeV}$.} \end{figure} \begin{figure}[tp] \begin{center} \includegraphics{fit15}\quad\includegraphics{fit25} \end{center} \caption{\label{fig:fit/Tesla/1TeV}% Fit of the $e^\pm$- and $\gamma$-distributions for the Tesla design at $\protect\sqrt s = 1\text{TeV}$.} \end{figure} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% The first version of the parameterization uses a simple factorized \textit{ansatz} \begin{subequations} \label{eq:beta} \begin{align} D_{p_1p_2}^{\alpha1\rho} (x_1,x_2,s) &= d_{p_1}^{\alpha1\rho} (x_1) d_{p_2}^{\alpha1\rho} (x_2)\\ \intertext{where the distributions are simple Beta distributions:} d_{e^\pm}^{\alpha1\rho} (x) &= a_0^{\alpha\rho} \delta(1-x) + a_1^{\alpha\rho} x^{a_2^{\alpha\rho}} (1-x)^{a_3^{\alpha\rho}} \\ d_\gamma^{\alpha1\rho} (x) &= a_4^{\alpha\rho} x^{a_5^{\alpha\rho}} (1-x)^{a_6^{\alpha\rho}} \end{align} \end{subequations} This form of the distributions is motivated by the observation~\cite{Chen/Noble:1986:Beamstrahlung} that the $e^\pm$~distributions diverge like a power for $x\to1$ and vanish at $x\to0$. The behavior of the $\gamma$~distributions is similar with the borders exchanged. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|c||c|c|c|}\hline & \texttt{SBNDEE} & \texttt{TESLEE} & \texttt{XBNDEE} \\\hline\hline $\mathcal{L}/\text{fb}^{-1}\upsilon^{-1}$ & $ 9.29_{-0.06}^{+0.06}$ & $ 21.62_{-0.17}^{+0.17}$ & $ 13.97_{-0.10}^{+0.10}$ \\\hline $\int d_{e^\pm}$ & $ .6513_{-0.0059}^{+0.0059}$ & $ .7282_{-0.0082}^{+0.0083}$ & $ .5270_{-0.0049}^{+0.0049}$ \\\hline $x_{e^\pm}^\alpha$ & $10.3040_{-0.0593}^{+0.0601}$ & $14.8578_{-0.1034}^{+0.1047}$ & $ 5.8897_{-0.0448}^{+0.0455}$ \\\hline $(1-x_{e^\pm})^\alpha$ & $ -.5946_{-0.0015}^{+0.0015}$ & $ -.5842_{-0.0018}^{+0.0018}$ & $ -.6169_{-0.0015}^{+0.0016}$ \\\hline $\int d_\gamma$ & $ .4727_{-0.0035}^{+0.0035}$ & $ .5300_{-0.0046}^{+0.0046}$ & $ .3746_{-0.0029}^{+0.0029}$ \\\hline $x_\gamma^\alpha$ & $ -.6974_{-0.0009}^{+0.0009}$ & $ -.7039_{-0.0009}^{+0.0009}$ & $ -.6892_{-0.0010}^{+0.0010}$ \\\hline $(1-x_\gamma)^\alpha$ & $20.6447_{-0.1497}^{+0.1513}$ & $36.1286_{-0.2991}^{+0.3027}$ & $10.0872_{-0.0815}^{+0.0822}$ \\\hline \end{tabular} \end{center} \caption{\label{tab:param/ee}% \emph{Experimental} Version 1, revision 0 of the beam spectra at 500 GeV. The rows correspond to the luminosity per effective year, the integral over the continuum and the powers in the factorized Beta distributions~(\ref{eq:beta}).} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|c||c|c|c|}\hline & \texttt{SBNDEE} & \texttt{TESLEE} & \texttt{XBNDEE} \\\hline\hline $\mathcal{L}/\text{fb}^{-1}\upsilon^{-1}$ & $ 45.59_{-0.34}^{+0.34}$ & $ 25.47_{-0.20}^{+0.20}$ & $ 41.06_{-0.28}^{+0.28}$ \\\hline $\int d_{e^\pm}$ & $ .7892_{-0.0074}^{+0.0075}$ & $ .6271_{-0.0065}^{+0.0066}$ & $ .7203_{-0.0058}^{+0.0058}$ \\\hline $x_{e^\pm}^\alpha$ & $ 5.4407_{-0.0281}^{+0.0285}$ & $ 8.7504_{-0.0658}^{+0.0669}$ & $ 2.7415_{-0.0119}^{+0.0121}$ \\\hline $(1-x_{e^\pm})^\alpha$ & $ -.5285_{-0.0020}^{+0.0020}$ & $ -.6058_{-0.0017}^{+0.0017}$ & $ -.5049_{-0.0020}^{+0.0020}$ \\\hline $\int d_\gamma$ & $ .6403_{-0.0040}^{+0.0040}$ & $ .4278_{-0.0038}^{+0.0038}$ & $ .6222_{-0.0032}^{+0.0032}$ \\\hline $x_\gamma^\alpha$ & $ -.6960_{-0.0008}^{+0.0008}$ & $ -.6982_{-0.0010}^{+0.0010}$ & $ -.6795_{-0.0008}^{+0.0008}$ \\\hline $(1-x_\gamma)^\alpha$ & $12.4803_{-0.0831}^{+0.0839}$ & $18.5260_{-0.1655}^{+0.1674}$ & $ 4.7506_{-0.0260}^{+0.0262}$ \\\hline \end{tabular} \end{center} \caption{\label{tab:param/TeV/ee}% \emph{Experimental} Version 1, revision 0 of the beam spectra at 1 TeV.} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|c||c|c|c|}\hline & 350 GeV & 500 GeV & 800 GeV \\\hline\hline $\mathcal{L}/\text{fb}^{-1}\upsilon^{-1}$ & $ 15.18_{-0.13}^{+0.13}$ & $ 21.62_{-0.17}^{+0.17}$ & $ 43.98_{-0.38}^{+0.38}$ \\\hline $\int d_{e^\pm}$ & $ .6691_{-0.0083}^{+0.0083}$ & $ .7282_{-0.0082}^{+0.0083}$ & $ .7701_{-0.0089}^{+0.0090}$ \\\hline $x_{e^\pm}^\alpha$ & $25.2753_{-0.2007}^{+0.2040}$ & $14.8578_{-0.1034}^{+0.1047}$ & $ 8.1905_{-0.0535}^{+0.0543}$ \\\hline $(1-x_{e^\pm})^\alpha$ & $ -.5994_{-0.0017}^{+0.0017}$ & $ -.5842_{-0.0018}^{+0.0018}$ & $ -.5575_{-0.0021}^{+0.0021}$ \\\hline $\int d_\gamma$ & $ .4464_{-0.0047}^{+0.0047}$ & $ .5300_{-0.0046}^{+0.0046}$ & $ .5839_{-0.0047}^{+0.0047}$ \\\hline $x_\gamma^\alpha$ & $ -.7040_{-0.0011}^{+0.0011}$ & $ -.7039_{-0.0009}^{+0.0009}$ & $ -.7046_{-0.0009}^{+0.0009}$ \\\hline $(1-x_\gamma)^\alpha$ & $60.1882_{-0.5797}^{+0.5882}$ & $36.1286_{-0.2991}^{+0.3027}$ & $19.3944_{-0.1660}^{+0.1681}$ \\\hline \end{tabular} \end{center} \caption{\label{tab:param/Tesla/ee}% \emph{Experimental} Version 1, revision 0 of the beam spectra for \texttt{TESLEE}.} \end{table} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Fitting} The parameters~$a_i$ in~(\ref{eq:beta}) have been obtained by a least-square fit of~(\ref{eq:beta}) to histograms of simulation results from \texttt{Guinea-Pig}. Some care has to taken when fitting singular distributions to histogrammed data. Obviously equidistant bins are not a good idea, because most bins will be almost empty (cf.~figures~\ref{fig:dist} and~\ref{fig:dist/Tesla}) and consequently a lot of information will be wasted. One solution to this problem is the use of logarithmic bins. This, however, maps the compact region~$[0,1]\times[0,1]$ to~$[-\infty,0]\times[-\infty,0]$, which is inconvenient because of the missing lower bounds.\par The more appropriate solution is to use two maps \begin{equation} \begin{aligned} \phi : [0,1] &\to [0,1] \\ x &\mapsto y = x^{1/\eta} \end{aligned} \end{equation} where~$x=x_\gamma$ or~$x=1-x_{e^\pm}$, and to bin the result equidistantly. If~$\eta$ is chosen properly (cf.~(\ref{eq:mapping})), the bin contents will then fall off at the singularity. The fits in tables~\ref{tab:param}, \ref{tab:param/TeV}, and~\ref{tab:param/Tesla} have been performed with~$\eta=5$ and the resulting bin contents can be read off from figures~\ref{fig:fit/S-Band/500GeV}--\ref{fig:fit/Tesla/1TeV}.\par Using this procedure for binning the results of the simulations, the popular fitting package \texttt{MINUIT}~\cite{James/Roos:1989:Minuit} converges quickly in all cases considered. The resulting parameters are given in tables~\ref{tab:param}, \ref{tab:param/TeV}, and~\ref{tab:param/Tesla}. Plots of the corresponding distributions have been shown in figures~\ref{fig:dist} and~\ref{fig:dist/Tesla}. It is obvious that an \textit{ansatz} like~(\ref{eq:beta}) is able to distinguish among the accelerator designs. Thus it can provide a solid basis for physics studies.\par In figures~\ref{fig:fit/S-Band/500GeV}--\ref{fig:fit/Tesla/1TeV} I give a graphical impression of the quality of the fit, which appears to be as good as one could reasonably expect for a simple \textit{ansatz} like~(\ref{eq:beta}). Note that the histograms have non-equidistant bins and that the resulting Jacobians have not been removed. Therefore the bin contents falls off at the singularities, as discussed above.\par The errors used for the least-square fit had to be taken from a Monte Carlo~(MC) study. \texttt{Guinea-Pig} only provides the~$\sqrt n$ from Poissonian statistics for each bin, but the error accumulation during tracking the particles through phase space is not available. The MC studies shows that the latter error dominates the former, but appears to be reasonably Gaussian. A complete MC study of all parameter sets is computationally expensive (more than a week of processor time on a fast SGI). From an exemplary MC study of a few parameter sets, it appears that the errors can be described reasonably well by rescaling the Poissonian error in each bin with appropriate factors for electrons/positrons and photons and for continuum and delta. This procedure has been adopted.\par The~$\chi^2/\text{d.o.f.}$'s of the fits are less than~$\mathcal{O}(10)$. The simple \emph{ansatz}~(\ref{eq:beta}) is therefore very satisfactory. In fact, trying to improve the ad-hoc factorized Beta distributions by the better motivated approximations from~\cite{Chen:1992:Beamstrahlung} or~\cite{Anlauf:1996:Beamstrahlung}, it turns out~\cite{Anlauf:1996:Chen_no_good} that~(\ref{eq:beta}) provides a significantly better fit of the results of the simulations. The price to pay is that the parameters in~(\ref{eq:beta}) have no direct physical interpretation. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Generators} For this version of the parameterizations we need a fast generator of Beta distributions: \begin{equation} \beta^{a,b}(x) \propto x^{a-1}(1-x)^{b-1} \end{equation} This problem has been studied extensively and we can use a published algorithm~\cite{Atkinson/Whittaker:1979:beta_distribution} that is guaranteed to be very fast for all~$a$, $b$ such that~$0>= ! circe1.f90 -- canonical beam spectra for linear collider physics -! $Id$ <> <
> @ <>= ! ! Copyright (C) 1999-2021 by ! Wolfgang Kilian ! Thorsten Ohl ! Juergen Reuter ! with contributions from ! Christian Speckner ! ! 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 'circe1.nw' @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Now we can move on to the implementation. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Symbolic Constants} The file \texttt{circe.h} contains symbolic names for various magic constants used by \Kirke/: <<[[circe.h]]>>= c circe.h -- canonical beam spectra for linear collider physics -c $Id$ <
>= module circe1 use kinds implicit none private <> <> <> <> <> integer, parameter, public :: MAGIC0 = 19040616 real(kind=double), parameter :: KIREPS = 1D-6 <> type(circe1_params_t), public, save :: circe1_params <> <> contains <> end module circe1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Distributions} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Version 1} We start with a convenience function which dispatches over the valid particle types. The hardest part is of course to avoid typos in such trivial functions ... <>= public :: circe <>= function circe (x1, x2, p1, p2) real(kind=double) :: x1, x2 integer :: p1, p2 real(kind=double) :: circe <> circe = -1.0 if (abs(p1) .eq. C1_ELECTRON) then if (abs(p2) .eq. C1_ELECTRON) then circe = circee (x1, x2) else if (p2 .eq. C1_PHOTON) then circe = circeg (x1, x2) end if else if (p1 .eq. C1_PHOTON) then if (abs(p2) .eq. C1_ELECTRON) then circe = circeg (x2, x1) else if (p2 .eq. C1_PHOTON) then circe = circgg (x1, x2) end if end if end function circe @ %def circe @ <>= public :: circes <>= subroutine circes (xx1m, xx2m, xroots, xacc, xver, xrev, xchat) real(kind=double) :: xx1m, xx2m, xroots integer :: xacc, xver, xrev, xchat <> <> if (circe1_params%magic .ne. 19040616) then circe1_params%magic = 19040616 <> end if <> <<[[format]]s for [[circes]]>> end subroutine circes @ %def circes @ <>= public :: circe1_params_t <>= type :: circe1_params_t <<8-byte aligned part of circe1 parameters>> <<4-byte aligned part of circe1 parameters>> end type circe1_params_t @ <<8-byte aligned part of circe1 parameters>>= real(kind=double) :: x1m = 0d0 real(kind=double) :: x2m = 0d0 real(kind=double) :: roots = 500D0 @ <<4-byte aligned part of circe1 parameters>>= integer :: acc = TESLA integer :: ver = 0 integer :: rev = 0 integer :: chat = 1 @ Instead of using fragile [[block data]] subroutines, we use a magic number to tag [[circe1_params]] as initialized: <<4-byte aligned part of circe1 parameters>>= integer :: magic @ Since negative values are no updated, we can call [[circes]] with all negative variables to ensure initialization: <>= if (circe1_params%magic .ne. MAGIC0) then call circes (-1d0, -1d0, -1d0, -1, -1, -1, -1) endif @ <>= circe1_params%x1m = 0d0 circe1_params%x2m = 0d0 circe1_params%roots = 500D0 circe1_params%acc = TESLA circe1_params%ver = 0 circe1_params%rev = 0 circe1_params%chat = 1 if (xchat .ne. 0) then call circem ('MESSAGE', 'starting up ...') - call circem ('MESSAGE', & - '$Id$') endif @ <>= if ((xchat .ge. 0) .and. (xchat .ne. circe1_params%chat)) then circe1_params%chat = xchat if (circe1_params%chat .ge. 1) then write (msgbuf, 1000) 'chat', circe1_params%chat 1000 format ('updating `', A, ''' to ', I2) call circem ('MESSAGE', msgbuf) endif else if (circe1_params%chat .ge. 2) then write (msgbuf, 1100) 'chat', circe1_params%chat 1100 format ('keeping `', A, ''' at ', I2) call circem ('MESSAGE', msgbuf) endif endif @ <>= character(len=60) :: msgbuf @ <>= if ((xx1m .ge. 0d0) .and. (xx1m .ne. circe1_params%x1m)) then circe1_params%x1m = xx1m if (circe1_params%chat .ge. 1) then write (msgbuf, 1001) 'x1min', circe1_params%x1m 1001 format ('updating `', A, ''' to ', E12.4) call circem ('MESSAGE', msgbuf) endif else if (circe1_params%chat .ge. 2) then write (msgbuf, 1101) 'x1min', circe1_params%x1m 1101 format ('keeping `', A, ''' at ', E12.4) call circem ('MESSAGE', msgbuf) endif endif @ <>= if ((xx2m .ge. 0d0) .and. (xx2m .ne. circe1_params%x2m)) then circe1_params%x2m = xx2m if (circe1_params%chat .ge. 1) then write (msgbuf, 1001) 'x2min', circe1_params%x2m call circem ('MESSAGE', msgbuf) endif else if (circe1_params%chat .ge. 2) then write (msgbuf, 1101) 'x2min', circe1_params%x2m call circem ('MESSAGE', msgbuf) endif endif @ <>= if ((xroots .ge. 0d0) .and.(xroots .ne. circe1_params%roots)) then circe1_params%roots = xroots if (circe1_params%chat .ge. 1) then write (msgbuf, 1002) 'roots', circe1_params%roots 1002 format ('updating `', A, ''' to ', F6.1) call circem ('MESSAGE', msgbuf) endif else if (circe1_params%chat .ge. 2) then write (msgbuf, 1102) 'roots', circe1_params%roots 1102 format ('keeping `', A, ''' at ', F6.1) call circem ('MESSAGE', msgbuf) endif endif @ <>= if ((xacc .ge. 0) .and.(xacc .ne. circe1_params%acc)) then if ((xacc .ge. 1) .and. (xacc .le. NACC)) then circe1_params%acc = xacc if (circe1_params%chat .ge. 1) then write (msgbuf, 1003) 'acc', accnam(circe1_params%acc) 1003 format ('updating `', A, ''' to ', A) call circem ('MESSAGE', msgbuf) endif else write (msgbuf, 1203) xacc 1203 format ('invalid `acc'': ', I8) call circem ('ERROR', msgbuf) write (msgbuf, 1103) 'acc', accnam(circe1_params%acc) 1103 format ('keeping `', A, ''' at ', A) call circem ('MESSAGE', msgbuf) endif else if (circe1_params%chat .ge. 2) then write (msgbuf, 1003) 'acc', accnam(circe1_params%acc) call circem ('MESSAGE', msgbuf) endif endif if ((circe1_params%acc .eq. SBNDEE) .or. (circe1_params%acc .eq. TESLEE) & .or. (circe1_params%acc .eq. XBNDEE)) then <> endif @ <>= <> @ <>= <> @ <>= character(len=6), dimension(NACC) :: accnam @ <>= data accnam(SBAND) /'SBAND'/ data accnam(TESLA) /'TESLA'/ data accnam(JLCNLC) /'JLCNLC'/ data accnam(SBNDEE) /'SBNDEE'/ data accnam(TESLEE) /'TESLEE'/ data accnam(XBNDEE) /'XBNDEE'/ data accnam(NLCH) /'NLC H'/ data accnam(ILC) /'ILC'/ data accnam(CLIC) /'CLIC'/ @ <>= public :: circex <>= subroutine circex (xx1m, xx2m, xroots, cacc, xver, xrev, xchat) real(kind=double) :: xx1m, xx2m, xroots character(*) :: cacc integer :: xver, xrev, xchat integer :: xacc, i <> <> <> xacc = -1 do i = 1, NACC if (trim (accnam(i)) == trim (cacc)) then xacc = i end if end do call circes (xx1m, xx2m, xroots, xacc, xver, xrev, xchat) end subroutine circex @ %def circex @ <>= call circem ('WARNING', '***********************************') call circem ('WARNING', '* The accelerator parameters have *') call circem ('WARNING', '* not been endorsed for use in *') call circem ('WARNING', '* an e-e- collider yet!!! *') call circem ('WARNING', '***********************************') @ <>= if (xver .ge. 0) then circe1_params%ver = xver if (circe1_params%chat .ge. 1) then write (msgbuf, 1000) 'ver', circe1_params%ver call circem ('MESSAGE', msgbuf) endif else if (circe1_params%chat .ge. 2) then write (msgbuf, 1100) 'ver', circe1_params%ver call circem ('MESSAGE', msgbuf) endif endif @ <>= if ((xrev .ge. 0) .and.(xrev .ne. circe1_params%rev)) then circe1_params%rev = xrev if (circe1_params%chat .ge. 1) then write (msgbuf, 1004) 'rev', circe1_params%rev 1004 format ('updating `', A, ''' to ', I8) call circem ('MESSAGE', msgbuf) endif else if (circe1_params%chat .ge. 2) then write (msgbuf, 1104) 'rev', circe1_params%rev 1104 format ('keeping `', A, ''' at ', I8) call circem ('MESSAGE', msgbuf) endif endif @ Versions 3 and 4 are identical to version 1, except for TESLA at 800~GeV. <>= ver34 = 0 if ((circe1_params%ver .eq. 1) .or. (circe1_params%ver .eq. 0)) then <> else if ((circe1_params%ver .eq. 3) .or. (circe1_params%ver .eq. 4)) then ver34 = circe1_params%ver circe1_params%ver = 1 <> else if (circe1_params%ver .eq. 5) then circe1_params%ver = 1 <> else if (circe1_params%ver .eq. 6) then circe1_params%ver = 1 <> else if (circe1_params%ver .eq. 7) then circe1_params%ver = 1 <> else if (circe1_params%ver .eq. 8) then circe1_params%ver = 1 <> else if (circe1_params%ver .eq. 9) then circe1_params%ver = 1 <> else if (circe1_params%ver .eq. 10) then circe1_params%ver = 1 <> <<[[else]] handle invalid versions>> @ <>= integer :: ver34 @ <<[[else]] handle invalid versions>>= else if (circe1_params%ver .eq. 2) then <> else if (circe1_params%ver .gt. 10) then call circem ('PANIC', 'versions >10 not available yet') return else call circem ('PANIC', 'version must be positive') return end if @ <>= integer :: e, r, ehi, elo @ <>= if (circe1_params%rev .eq. 0) then r = 0 elseif (circe1_params%rev .ge. 19970417) then r = 5 elseif (circe1_params%rev .ge. 19960902) then r = 4 elseif (circe1_params%rev .ge. 19960729) then r = 3 elseif (circe1_params%rev .ge. 19960711) then r = 2 elseif (circe1_params%rev .ge. 19960401) then r = 1 elseif (circe1_params%rev .lt. 19960401) then call circem ('ERROR', & 'no revision of version 1 before 96/04/01 available') call circem ('MESSAGE', 'falling back to default') r = 1 endif if (circe1_params%chat .ge. 2) then write (msgbuf, 2000) circe1_params%rev, r 2000 format ('mapping date ', I8, ' to revision index ', I2) call circem ('MESSAGE', msgbuf) endif @ <>= if (circe1_params%chat .ge. 2) then write (msgbuf, 2000) circe1_params%rev, r call circem ('MESSAGE', msgbuf) endif @ <>= <> @ <>= if (circe1_params%roots .eq. 350d0) then e = GEV350 else if ((circe1_params%roots .ge. 340d0) .and. (circe1_params%roots .le. 370d0)) then write (msgbuf, 2001) circe1_params%roots, 350d0 call circem ('MESSAGE', msgbuf) e = GEV350 @ <<[[format]]s for [[circes]]>>= 2001 format ('treating energy ', F6.1, 'GeV as ', F6.1, 'GeV') @ <>= else if (circe1_params%roots .eq. 500d0) then e = GEV500 else if ((circe1_params%roots .ge. 480d0) .and. (circe1_params%roots .le. 520d0)) then write (msgbuf, 2001) circe1_params%roots, 500d0 call circem ('MESSAGE', msgbuf) e = GEV500 else if (circe1_params%roots .eq. 800d0) then e = GEV800 else if ((circe1_params%roots .ge. 750d0) .and. (circe1_params%roots .le. 850d0)) then write (msgbuf, 2001) circe1_params%roots, 800d0 call circem ('MESSAGE', msgbuf) e = GEV800 else if (circe1_params%roots .eq. 1000d0) then e = TEV1 else if ((circe1_params%roots .ge. 900d0) .and. (circe1_params%roots .le. 1100d0)) then write (msgbuf, 2001) circe1_params%roots, 1000d0 call circem ('MESSAGE', msgbuf) e = TEV1 else if (circe1_params%roots .eq. 1600d0) then e = TEV16 else if ((circe1_params%roots .ge. 1500d0) .and. (circe1_params%roots .le. 1700d0)) then write (msgbuf, 2001) circe1_params%roots, 1600d0 call circem ('MESSAGE', msgbuf) e = TEV16 @ <>= else call circem ('ERROR', & 'only ROOTS = 350, 500, 800, 1000 and 1600GeV available') call circem ('MESSAGE', 'falling back to 500GeV') e = GEV500 endif @ <>= if (xa1lum(e,circe1_params%acc,r) .lt. 0d0) then write (msgbuf, 2002) circe1_params%roots, accnam(circe1_params%acc), r call circem ('ERROR', msgbuf) call circem ('MESSAGE', 'falling back to 500GeV') e = GEV500 end if <> @ <<[[format]]s for [[circes]]>>= 2002 format ('energy ', F6.1, ' not available for ', A6,' in revison ', I2) @ <>= if (circe1_params%chat .ge. 2) then if (e .ge. GEV090) then write (msgbuf, 2003) circe1_params%roots, e call circem ('MESSAGE', msgbuf) else if (elo .ge. GEV090 .and. ehi .ge. GEV090) then write (msgbuf, 2013) circe1_params%roots, elo, ehi call circem ('MESSAGE', msgbuf) end if endif @ <<[[format]]s for [[circes]]>>= 2003 format ('mapping energy ', F6.1, ' to energy index ', I2) 2013 format ('mapping energy ', F6.1, ' to energy indices ', I2, ' and ', I2) @ The energies 250\,GeV, 1.2\,TeV and 1.5\,TeV were entered late into the game by the SLAC people. And, of course, 200\,GeV and 230\,GeV only appeared even much later <>= integer, parameter :: EINVAL = -2 integer, parameter :: GEV090 = -1 integer, parameter :: GEV170 = 0 integer, parameter :: GEV350 = 1 integer, parameter :: GEV500 = 2 integer, parameter :: GEV800 = 3 integer, parameter :: TEV1 = 4 integer, parameter :: TEV16 = 5 integer, parameter :: GEV250 = 6 integer, parameter :: TEV12 = 7 integer, parameter :: TEV15 = 8 integer, parameter :: GEV200 = 9 integer, parameter :: GEV230 = 10 integer, parameter :: A1NEGY = 5 integer, parameter :: A1NREV = 5 integer :: i @ <<8-byte aligned part of circe1 parameters>>= real(kind=double) :: lumi real(kind=double) :: a1(0:7) @ <>= circe1_params%lumi = xa1lum (e,circe1_params%acc,r) do i = 0, 7 circe1_params%a1(i) = xa1(i,e,circe1_params%acc,r) end do @ <>= real(kind=double), dimension(A1NEGY,NACC,0:A1NREV), save :: xa1lum = 0 real(kind=double), dimension(0:7,A1NEGY,NACC,0:A1NREV), save :: xa1 = 0 @ \textbf{Revision 1}. The mother of all revisions. <>= xa1lum(GEV500,SBAND,1) = 5.212299E+01 xa1(0:7,GEV500,SBAND,1) = (/ & .39192E+00, .66026E+00, .11828E+02,-.62543E+00, & .52292E+00,-.69245E+00, .14983E+02, .65421E+00 /) xa1lum(GEV500,TESLA,1) = 6.066178E+01 xa1(0:7,GEV500,TESLA,1) = (/ & .30196E+00, .12249E+01, .21423E+02,-.57848E+00, & .68766E+00,-.69788E+00, .23121E+02, .78399E+00 /) xa1lum(GEV500,XBAND,1) = 5.884699E+01 xa1(0:7,GEV500,XBAND,1) = (/ & .48594E+00, .52435E+00, .83585E+01,-.61347E+00, & .30703E+00,-.68804E+00, .84109E+01, .44312E+00 /) @ <>= xa1lum(TEV1,SBAND,1) = 1.534650E+02 xa1(0:7,TEV1,SBAND,1) = (/ & .24399E+00, .87464E+00, .66751E+01,-.56808E+00, & .59295E+00,-.68921E+00, .94232E+01, .83351E+00 /) xa1lum(TEV1,TESLA,1) = 1.253381E+03 xa1(0:7,TEV1,TESLA,1) = (/ & .39843E+00, .70097E+00, .11602E+02,-.61061E+00, & .40737E+00,-.69319E+00, .14800E+02, .51382E+00 /) xa1lum(TEV1,XBAND,1) = 1.901783E+02 xa1(0:7,TEV1,XBAND,1) = (/ & .32211E+00, .61798E+00, .28298E+01, -.54644E+00, & .45674E+00, -.67301E+00, .41703E+01, .74536E+00 /) @ Unavailable <>= xa1lum(GEV350,1:NACC,1) = NACC * (-1d0) xa1lum(GEV800,1:NACC,1) = NACC * (-1d0) @ Unavailable as well <>= xa1lum(GEV500,SBNDEE:NACC,1) = 4 * (-1d0) xa1lum(TEV1,SBNDEE:NACC,1) = 4 * (-1d0) @ No 1.6TeV parameters in this revision <>= xa1lum(TEV16,1:NACC,1) = 7 * (-1d0) @ <>= public :: circel <>= subroutine circel (l) real(kind=double), intent(out) :: l l = circe1_params%lumi end subroutine circel @ %def circel @ <>= public :: circee <>= function circee (x1, x2) real(kind=double) :: x1, x2 real(kind=double) :: circee real(kind=double) :: d1, d2 <> circee = -1.0 if ((circe1_params%ver .eq. 1) .or. (circe1_params%ver .eq. 0)) then <> <<[[else]] handle invalid versions>> end function circee @ %def circee @ The first version of the parametrization is factorized \begin{equation} D_{p_1p_2}^{\alpha1\rho} (x_1,x_2,s) = d_{p_1}^{\alpha1\rho} (x_1) d_{p_2}^{\alpha1\rho} (x_2) \end{equation} where the distributions are \begin{eqnarray} d_{e^\pm}^{\alpha1\rho} (x) & = & a_0^{\alpha\rho} \delta(1-x) + a_1^{\alpha\rho} x^{a_2^{\alpha\rho}} (1-x)^{a_3^{\alpha\rho}} \\ d_\gamma(x) & = & a_4^{\alpha\rho} x^{a_5^{\alpha\rho}} (1-x)^{a_6^{\alpha\rho}} \end{eqnarray} @ <>= if (x1 .eq. 1d0) then d1 = circe1_params%a1(0) elseif (x1 .lt. 1d0 .and. x1 .gt. 0d0) then d1 = circe1_params%a1(1) * x1**circe1_params%a1(2) * (1d0 - x1)**circe1_params%a1(3) elseif (x1 .eq. -1d0) then d1 = 1d0 - circe1_params%a1(0) else d1 = 0d0 endif if (x2 .eq. 1d0) then d2 = circe1_params%a1(0) elseif (x2 .lt. 1d0 .and. x2 .gt. 0d0) then d2 = circe1_params%a1(1) * x2**circe1_params%a1(2) * (1d0 - x2)**circe1_params%a1(3) elseif (x2 .eq. -1d0) then d2 = 1d0 - circe1_params%a1(0) else d2 = 0d0 endif circee = d1 * d2 @ <>= public :: circeg <>= function circeg (x1, x2) real(kind=double) :: x1, x2 real(kind=double) :: circeg real(kind=double) :: d1, d2 <> circeg = -1.0 if ((circe1_params%ver .eq. 1) .or. (circe1_params%ver .eq. 0)) then <> <<[[else]] handle invalid versions>> end function circeg @ %def circeg @ <>= if (x1 .eq. 1d0) then d1 = circe1_params%a1(0) else if (x1 .lt. 1d0 .and. x1 .gt. 0d0) then d1 = circe1_params%a1(1) * x1**circe1_params%a1(2) * (1d0 - x1)**circe1_params%a1(3) else if (x1 .eq. -1d0) then d1 = 1d0 - circe1_params%a1(0) else d1 = 0d0 end if if (x2 .lt. 1d0 .and. x2 .gt. 0d0) then d2 = circe1_params%a1(4) * x2**circe1_params%a1(5) * (1d0 - x2)**circe1_params%a1(6) else if (x2 .eq. -1d0) then d2 = circe1_params%a1(7) else d2 = 0d0 end if circeg = d1 * d2 @ <>= public :: circgg <>= function circgg (x1, x2) real(kind=double) :: x1, x2 real(kind=double) :: circgg real(kind=double) :: d1, d2 <> circgg = -1.0 if ((circe1_params%ver .eq. 1) .or. (circe1_params%ver .eq. 0)) then <> <<[[else]] handle invalid versions>> end function circgg @ %def circgg @ <>= if (x1 .lt. 1d0 .and. x1 .gt. 0d0) then d1 = circe1_params%a1(4) * x1**circe1_params%a1(5) * (1d0 - x1)**circe1_params%a1(6) elseif (x1 .eq. -1d0) then d1 = circe1_params%a1(7) else d1 = 0d0 endif if (x2 .lt. 1d0 .and. x2 .gt. 0d0) then d2 = circe1_params%a1(4) * x2**circe1_params%a1(5) * (1d0 - x2)**circe1_params%a1(6) elseif (x2 .eq. -1d0) then d2 = circe1_params%a1(7) else d2 = 0d0 endif circgg = d1 * d2 @ \textbf{Revision 2}. New Tesla parameters, including 350 GeV and 800 GeV. <>= xa1lum(GEV500,SBAND,2) = .31057E+02 xa1(0:7,GEV500,SBAND,2) = (/ & .38504E+00, .79723E+00, .14191E+02,-.60456E+00, & .53411E+00,-.68873E+00, .15105E+02, .65151E+00 /) xa1lum(TEV1,SBAND,2) = .24297E+03 xa1(0:7,TEV1,SBAND,2) = (/ & .24374E+00, .89466E+00, .70242E+01,-.56754E+00, & .60910E+00,-.68682E+00, .96083E+01, .83985E+00 /) xa1lum(GEV350,TESLA,2) = .73369E+02 xa1(0:7,GEV350,TESLA,2) = (/ & .36083E+00, .12819E+01, .37880E+02,-.59492E+00, & .69109E+00,-.69379E+00, .40061E+02, .65036E+00 /) xa1lum(GEV500,TESLA,2) = .10493E+03 xa1(0:7,GEV500,TESLA,2) = (/ & .29569E+00, .11854E+01, .21282E+02,-.58553E+00, & .71341E+00,-.69279E+00, .24061E+02, .77709E+00 /) xa1lum(GEV800,TESLA,2) = .28010E+03 xa1(0:7,GEV800,TESLA,2) = (/ & .22745E+00, .11265E+01, .10483E+02,-.55711E+00, & .69579E+00,-.69068E+00, .13093E+02, .89605E+00 /) xa1lum(TEV1,TESLA,2) = .10992E+03 xa1(0:7,TEV1,TESLA,2) = (/ & .40969E+00, .66105E+00, .11972E+02,-.62041E+00, & .40463E+00,-.69354E+00, .14669E+02, .51281E+00 /) xa1lum(GEV500,XBAND,2) = .35689E+02 xa1(0:7,GEV500,XBAND,2) = (/ & .48960E+00, .46815E+00, .75249E+01,-.62769E+00, & .30341E+00,-.68754E+00, .85545E+01, .43453E+00 /) xa1lum(TEV1,XBAND,2) = .11724E+03 xa1(0:7,TEV1,XBAND,2) = (/ & .31939E+00, .62415E+00, .30763E+01,-.55314E+00, & .45634E+00,-.67089E+00, .41529E+01, .73807E+00 /) @ Unavailable <>= xa1lum(GEV350,SBAND,2) = -1d0 xa1lum(GEV350,XBAND,2) = -1d0 xa1lum(GEV800,SBAND,2) = -1d0 xa1lum(GEV800,XBAND,2) = -1d0 @ Unavailable as well <>= xa1lum(GEV350,SBNDEE:NACC,2) = 4 * (-1d0) xa1lum(GEV500,SBNDEE:NACC,2) = 4 * (-1d0) xa1lum(GEV800,SBNDEE:NACC,2) = 4 * (-1d0) xa1lum(TEV1,SBNDEE:NACC,2) = 4 * (-1d0) @ No 1.6TeV parameters in this revision <>= xa1lum(TEV16,1:NACC,2) = 7 * (-1d0) @ \textbf{Revision 3}. Features: \begin{itemize} \item improved error estimates. \item cleaner fitting procedure, including delta function pieces. \end{itemize} <>= xa1lum(GEV500,SBAND,3) = .31469E+02 xa1(0:7,GEV500,SBAND,3) = (/ & .38299E+00, .72035E+00, .12618E+02,-.61611E+00, & .51971E+00,-.68960E+00, .15066E+02, .63784E+00 /) xa1lum(TEV1,SBAND,3) = .24566E+03 xa1(0:7,TEV1,SBAND,3) = (/ & .24013E+00, .95763E+00, .69085E+01,-.55151E+00, & .59497E+00,-.68622E+00, .94494E+01, .82158E+00 /) xa1lum(GEV350,TESLA,3) = .74700E+02 xa1(0:7,GEV350,TESLA,3) = (/ & .34689E+00, .12484E+01, .33720E+02,-.59523E+00, & .66266E+00,-.69524E+00, .38488E+02, .63775E+00 /) xa1lum(GEV500,TESLA,3) = .10608E+03 xa1(0:7,GEV500,TESLA,3) = (/ & .28282E+00, .11700E+01, .19258E+02,-.58390E+00, & .68777E+00,-.69402E+00, .23638E+02, .75929E+00 /) xa1lum(GEV800,TESLA,3) = .28911E+03 xa1(0:7,GEV800,TESLA,3) = (/ & .21018E+00, .12039E+01, .96763E+01,-.54024E+00, & .67220E+00,-.69083E+00, .12733E+02, .87355E+00 /) xa1lum(TEV1,TESLA,3) = .10936E+03 xa1(0:7,TEV1,TESLA,3) = (/ & .41040E+00, .68099E+00, .11610E+02,-.61237E+00, & .40155E+00,-.69073E+00, .14698E+02, .49989E+00 /) xa1lum(GEV500,XBAND,3) = .36145E+02 xa1(0:7,GEV500,XBAND,3) = (/ & .51285E+00, .45812E+00, .75135E+01,-.62247E+00, & .30444E+00,-.68530E+00, .85519E+01, .43062E+00 /) xa1lum(TEV1,XBAND,3) = .11799E+03 xa1(0:7,TEV1,XBAND,3) = (/ & .31241E+00, .61241E+00, .29938E+01,-.55848E+00, & .44801E+00,-.67116E+00, .41119E+01, .72753E+00 /) @ Still unavailable <>= xa1lum(GEV350,SBAND,3) = -1d0 xa1lum(GEV350,XBAND,3) = -1d0 xa1lum(GEV800,SBAND,3) = -1d0 xa1lum(GEV800,XBAND,3) = -1d0 @ Unavailable as well <>= xa1lum(GEV350,SBNDEE:NACC,3) = 4 * (-1d0) xa1lum(GEV500,SBNDEE:NACC,3) = 4 * (-1d0) xa1lum(GEV800,SBNDEE:NACC,3) = 4 * (-1d0) xa1lum(TEV1,SBNDEE:NACC,3) = 4 * (-1d0) @ No 1.6TeV parameters in this revision <>= xa1lum(TEV16,1:NACC,3) = 7 * (-1d0) @ \textbf{Revision 4}. Features: \begin{itemize} \item a bug in \texttt{Guinea-Pig}'s synchrotron radiation spectrum has been fixed. \end{itemize} <>= xa1lum(GEV500,SBAND,4) = .31528E+02 xa1(0:7,GEV500,SBAND,4) = (/ & .38169E+00, .73949E+00, .12543E+02,-.61112E+00, & .51256E+00,-.69009E+00, .14892E+02, .63314E+00 /) xa1lum(TEV1,SBAND,4) = .24613E+03 xa1(0:7,TEV1,SBAND,4) = (/ & .24256E+00, .94117E+00, .66775E+01,-.55160E+00, & .57484E+00,-.68891E+00, .92271E+01, .81162E+00 /) xa1lum(GEV350,TESLA,4) = .74549E+02 xa1(0:7,GEV350,TESLA,4) = (/ & .34120E+00, .12230E+01, .32932E+02,-.59850E+00, & .65947E+00,-.69574E+00, .38116E+02, .63879E+00 /) xa1lum(GEV500,TESLA,4) = .10668E+03 xa1(0:7,GEV500,TESLA,4) = (/ & .28082E+00, .11074E+01, .18399E+02,-.59118E+00, & .68880E+00,-.69375E+00, .23463E+02, .76073E+00 /) xa1lum(GEV800,TESLA,4) = .29006E+03 xa1(0:7,GEV800,TESLA,4) = (/ & .21272E+00, .11443E+01, .92564E+01,-.54657E+00, & .66799E+00,-.69137E+00, .12498E+02, .87571E+00 /) xa1lum(TEV1,TESLA,4) = .11009E+03 xa1(0:7,TEV1,TESLA,4) = (/ & .41058E+00, .64745E+00, .11271E+02,-.61996E+00, & .39801E+00,-.69150E+00, .14560E+02, .49924E+00 /) xa1lum(GEV500,XBAND,4) = .36179E+02 xa1(0:7,GEV500,XBAND,4) = (/ & .51155E+00, .43313E+00, .70446E+01,-.63003E+00, & .29449E+00,-.68747E+00, .83489E+01, .42458E+00 /) xa1lum(TEV1,XBAND,4) = .11748E+03 xa1(0:7,TEV1,XBAND,4) = (/ & .32917E+00, .54322E+00, .28493E+01,-.57959E+00, & .39266E+00,-.68217E+00, .38475E+01, .68478E+00 /) @ Still unavailable <>= xa1lum(GEV350,SBAND,4) = -1d0 xa1lum(GEV350,XBAND,4) = -1d0 xa1lum(GEV800,SBAND,4) = -1d0 xa1lum(GEV800,XBAND,4) = -1d0 @ Unavailable as well <>= xa1lum(GEV350,SBNDEE:NACC,4) = 4 * (-1d0) xa1lum(GEV500,SBNDEE:NACC,4) = 4 * (-1d0) xa1lum(GEV800,SBNDEE:NACC,4) = 4 * (-1d0) xa1lum(TEV1,SBNDEE:NACC,4) = 4 * (-1d0) @ No 1.6TeV parameters in this revision <>= xa1lum(TEV16,1:NACC,4) = 7 * (-1d0) @ \textbf{Revision 5}. Features: \begin{itemize} \item a bug in \texttt{Guinea-Pig} has been fixed. \item updated parameter sets \end{itemize} <>= xa1lum(GEV350,SBAND,5) = 0.21897E+02 xa1(0:7,GEV350,SBAND,5) = (/ & 0.57183E+00, 0.53877E+00, 0.19422E+02,-0.63064E+00, & 0.49112E+00,-0.69109E+00, 0.24331E+02, 0.52718E+00 /) xa1lum(GEV500,SBAND,5) = 0.31383E+02 xa1(0:7,GEV500,SBAND,5) = (/ & 0.51882E+00, 0.49915E+00, 0.11153E+02,-0.63017E+00, & 0.50217E+00,-0.69113E+00, 0.14935E+02, 0.62373E+00 /) xa1lum(GEV800,SBAND,5) = 0.95091E+02 xa1(0:7,GEV800,SBAND,5) = (/ & 0.47137E+00, 0.46150E+00, 0.56562E+01,-0.61758E+00, & 0.46863E+00,-0.68897E+00, 0.85876E+01, 0.67577E+00 /) xa1lum(TEV1,SBAND,5) = 0.11900E+03 xa1(0:7,TEV1,SBAND,5) = (/ & 0.43956E+00, 0.45471E+00, 0.42170E+01,-0.61180E+00, & 0.48711E+00,-0.68696E+00, 0.67145E+01, 0.74551E+00 /) xa1lum(TEV16,SBAND,5) = 0.11900E+03 xa1(0:7,TEV16,SBAND,5) = (/ & 0.43956E+00, 0.45471E+00, 0.42170E+01,-0.61180E+00, & 0.48711E+00,-0.68696E+00, 0.67145E+01, 0.74551E+00 /) xa1lum(GEV350,TESLA,5) = 0.97452E+02 xa1(0:7,GEV350,TESLA,5) = (/ & 0.39071E+00, 0.84996E+00, 0.17614E+02,-0.60609E+00, & 0.73920E+00,-0.69490E+00, 0.28940E+02, 0.77286E+00 /) xa1lum(GEV500,TESLA,5) = 0.10625E+03 xa1(0:7,GEV500,TESLA,5) = (/ & 0.42770E+00, 0.71457E+00, 0.15284E+02,-0.61664E+00, & 0.68166E+00,-0.69208E+00, 0.24165E+02, 0.73806E+00 /) xa1lum(GEV800,TESLA,5) = 0.17086E+03 xa1(0:7,GEV800,TESLA,5) = (/ & 0.36025E+00, 0.69118E+00, 0.76221E+01,-0.59440E+00, & 0.71269E+00,-0.69077E+00, 0.13117E+02, 0.91780E+00 /) xa1lum(TEV1,TESLA,5) = 0.21433E+03 xa1(0:7,TEV1,TESLA,5) = (/ & 0.33145E+00, 0.67075E+00, 0.55438E+01,-0.58468E+00, & 0.72503E+00,-0.69084E+00, 0.99992E+01, 0.10112E+01 /) xa1lum(TEV16,TESLA,5) = 0.34086E+03 xa1(0:7,TEV16,TESLA,5) = (/ & 0.49058E+00, 0.42609E+00, 0.50550E+01,-0.61867E+00, & 0.39225E+00,-0.68916E+00, 0.75514E+01, 0.58754E+00 /) xa1lum(GEV350,XBAND,5) = 0.31901E+02 xa1(0:7,GEV350,XBAND,5) = (/ & 0.65349E+00, 0.31752E+00, 0.94342E+01,-0.64291E+00, & 0.30364E+00,-0.68989E+00, 0.11446E+02, 0.40486E+00 /) xa1lum(GEV500,XBAND,5) = 0.36386E+02 xa1(0:7,GEV500,XBAND,5) = (/ & 0.65132E+00, 0.28728E+00, 0.69853E+01,-0.64440E+00, & 0.28736E+00,-0.68758E+00, 0.83227E+01, 0.41492E+00 /) xa1lum(GEV800,XBAND,5) = 0.10854E+03 xa1(0:7,GEV800,XBAND,5) = (/ & 0.49478E+00, 0.36221E+00, 0.30116E+01,-0.61548E+00, & 0.39890E+00,-0.68418E+00, 0.45183E+01, 0.67243E+00 /) xa1lum(TEV1,XBAND,5) = 0.11899E+03 xa1(0:7,TEV1,XBAND,5) = (/ & 0.49992E+00, 0.34299E+00, 0.26184E+01,-0.61584E+00, & 0.38450E+00,-0.68342E+00, 0.38589E+01, 0.67408E+00 /) xa1lum(TEV16,XBAND,5) = 0.13675E+03 xa1(0:7,TEV16,XBAND,5) = (/ & 0.50580E+00, 0.30760E+00, 0.18339E+01,-0.61421E+00, & 0.35233E+00,-0.68315E+00, 0.26708E+01, 0.67918E+00 /) @ \textbf{Revision 0}. Features: \begin{itemize} \item $e^-e^-$ mode \end{itemize} <>= xa1lum(GEV500,SBNDEE,0) = .92914E+01 xa1(0:7,GEV500,SBNDEE,0) = (/ & .34866E+00, .78710E+00, .10304E+02,-.59464E+00, & .40234E+00,-.69741E+00, .20645E+02, .47274E+00 /) xa1lum(TEV1,SBNDEE,0) = .45586E+02 xa1(0:7,TEV1,SBNDEE,0) = (/ & .21084E+00, .99168E+00, .54407E+01,-.52851E+00, & .47493E+00,-.69595E+00, .12480E+02, .64027E+00 /) xa1lum(GEV350,TESLEE,0) = .15175E+02 xa1(0:7,GEV350,TESLEE,0) = (/ & .33093E+00, .11137E+01, .25275E+02,-.59942E+00, & .49623E+00,-.70403E+00, .60188E+02, .44637E+00 /) xa1lum(GEV500,TESLEE,0) = .21622E+02 xa1(0:7,GEV500,TESLEE,0) = (/ & .27175E+00, .10697E+01, .14858E+02,-.58418E+00, & .50824E+00,-.70387E+00, .36129E+02, .53002E+00 /) xa1lum(GEV800,TESLEE,0) = .43979E+02 xa1(0:7,GEV800,TESLEE,0) = (/ & .22994E+00, .10129E+01, .81905E+01,-.55751E+00, & .46551E+00,-.70461E+00, .19394E+02, .58387E+00 /) xa1lum(TEV1,TESLEE,0) = .25465E+02 xa1(0:7,TEV1,TESLEE,0) = (/ & .37294E+00, .67522E+00, .87504E+01,-.60576E+00, & .35095E+00,-.69821E+00, .18526E+02, .42784E+00 /) xa1lum(GEV500,XBNDEE,0) = .13970E+02 xa1(0:7,GEV500,XBNDEE,0) = (/ & .47296E+00, .46800E+00, .58897E+01,-.61689E+00, & .27181E+00,-.68923E+00, .10087E+02, .37462E+00 /) xa1lum(TEV1,XBNDEE,0) = .41056E+02 xa1(0:7,TEV1,XBNDEE,0) = (/ & .27965E+00, .74816E+00, .27415E+01,-.50491E+00, & .38320E+00,-.67945E+00, .47506E+01, .62218E+00 /) @ Still unavailable <>= xa1lum(GEV350,SBNDEE,0) = -1d0 xa1lum(GEV350,XBNDEE,0) = -1d0 xa1lum(GEV800,SBNDEE,0) = -1d0 xa1lum(GEV800,XBNDEE,0) = -1d0 @ <>= xa1lum(GEV500,SBAND,0) = .31528E+02 xa1(0:7,GEV500,SBAND,0) = (/ & .38169E+00, .73949E+00, .12543E+02,-.61112E+00, & .51256E+00,-.69009E+00, .14892E+02, .63314E+00 /) xa1lum(TEV1,SBAND,0) = .24613E+03 xa1(0:7,TEV1,SBAND,0) = (/ & .24256E+00, .94117E+00, .66775E+01,-.55160E+00, & .57484E+00,-.68891E+00, .92271E+01, .81162E+00 /) xa1lum(GEV350,TESLA,0) = .74549E+02 xa1(0:7,GEV350,TESLA,0) = (/ & .34120E+00, .12230E+01, .32932E+02,-.59850E+00, & .65947E+00,-.69574E+00, .38116E+02, .63879E+00 /) xa1lum(GEV500,TESLA,0) = .10668E+03 xa1(0:7,GEV500,TESLA,0) = (/ & .28082E+00, .11074E+01, .18399E+02,-.59118E+00, & .68880E+00,-.69375E+00, .23463E+02, .76073E+00 /) xa1lum(GEV800,TESLA,0) = .29006E+03 xa1(0:7,GEV800,TESLA,0) = (/ & .21272E+00, .11443E+01, .92564E+01,-.54657E+00, & .66799E+00,-.69137E+00, .12498E+02, .87571E+00 /) xa1lum(TEV1,TESLA,0) = .11009E+03 xa1(0:7,TEV1,TESLA,0) = (/ & .41058E+00, .64745E+00, .11271E+02,-.61996E+00, & .39801E+00,-.69150E+00, .14560E+02, .49924E+00 /) xa1lum(GEV500,XBAND,0) = .36179E+02 xa1(0:7,GEV500,XBAND,0) = (/ & .51155E+00, .43313E+00, .70446E+01,-.63003E+00, & .29449E+00,-.68747E+00, .83489E+01, .42458E+00 /) xa1lum(TEV1,XBAND,0) = .11748E+03 xa1(0:7,TEV1,XBAND,0) = (/ & .32917E+00, .54322E+00, .28493E+01,-.57959E+00, & .39266E+00,-.68217E+00, .38475E+01, .68478E+00 /) @ Still unavailable <>= xa1lum(GEV350,SBAND,0) = -1d0 xa1lum(GEV350,XBAND,0) = -1d0 xa1lum(GEV800,SBAND,0) = -1d0 xa1lum(GEV800,XBAND,0) = -1d0 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Version 2} <>= call circem ('PANIC', '*********************************') call circem ('PANIC', '* version 2 has been retired, *') call circem ('PANIC', '* please use version 1 instead! *') call circem ('PANIC', '*********************************') return @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Versions 3 and 4} <>= if (circe1_params%rev .eq. 0) then r = 0 elseif (circe1_params%rev .ge. 19970417) then r = 5 if (ver34 .eq. 3) then call circem ('WARNING', 'version 3 retired after 97/04/17') call circem ('MESSAGE', 'falling back to version 4') end if else if (circe1_params%rev .ge. 19961022) then r = ver34 if ((circe1_params%roots .ne. 800d0) .or. (circe1_params%acc .ne. TESLA)) then call circem ('ERROR', 'versions 3 and 4 before 97/04/17') call circem ('ERROR', 'apply to TESLA at 800 GeV only') call circem ('MESSAGE', 'falling back to TESLA at 800GeV') circe1_params%acc = TESLA e = GEV800 end if else if (circe1_params%rev .lt. 19961022) then call circem ('ERROR', & 'no revision of versions 3 and 4 available before 96/10/22') call circem ('MESSAGE', 'falling back to default') r = 5 end if <> @ <>= <> if (xa3lum(e,circe1_params%acc,r) .lt. 0d0) then write (msgbuf, 2002) circe1_params%roots, accnam(circe1_params%acc), r call circem ('ERROR', msgbuf) call circem ('MESSAGE', 'falling back to 500GeV') e = GEV500 endif <> @ <>= integer, parameter :: A3NEGY = 5, A3NREV = 5 @ <>= circe1_params%lumi = xa3lum (e,circe1_params%acc,r) do i = 0, 7 circe1_params%a1(i) = xa3(i,e,circe1_params%acc,r) end do @ <>= real, dimension(A3NEGY,NACC,0:A3NREV), save :: xa3lum = -1 real, dimension(0:7,A3NEGY,NACC,0:A3NREV), save :: xa3 = 0 @ \textbf{Revisions 3 \&\ 4}. The mother of all revisions. <>= xa3lum(GEV800,TESLA,3) = .17196E+03 xa3(0:7,GEV800,TESLA,3) = (/ & .21633E+00, .11333E+01, .95928E+01,-.55095E+00, & .73044E+00,-.69101E+00, .12868E+02, .94737E+00 /) xa3lum(GEV800,TESLA, 4) = .16408E+03 xa3(0:7,GEV800,TESLA, 4) = (/ & .41828E+00, .72418E+00, .14137E+02,-.61189E+00, & .36697E+00,-.69205E+00, .17713E+02, .43583E+00 /) @ \textbf{Revision 5}. <>= xa3lum(GEV350,TESLA,5) = 0.66447E+02 xa3(0:7,GEV350,TESLA,5) = (/ & 0.69418E+00, 0.50553E+00, 0.48430E+02,-0.63911E+00, & 0.34074E+00,-0.69533E+00, 0.55502E+02, 0.29397E+00 /) xa3lum(GEV500,TESLA,5) = 0.95241E+02 xa3(0:7,GEV500,TESLA,5) = (/ & 0.64882E+00, 0.45462E+00, 0.27103E+02,-0.64535E+00, & 0.35101E+00,-0.69467E+00, 0.33658E+02, 0.35024E+00 /) xa3lum(GEV800,TESLA,5) = 0.16974E+03 xa3(0:7,GEV800,TESLA,5) = (/ & 0.58706E+00, 0.43771E+00, 0.13422E+02,-0.63804E+00, & 0.35541E+00,-0.69467E+00, 0.17528E+02, 0.43051E+00 /) xa3lum(TEV1,TESLA,5) = 0.21222E+03 xa3(0:7,TEV1,TESLA,5) = (/ & 0.55525E+00, 0.42577E+00, 0.96341E+01,-0.63587E+00, & 0.36448E+00,-0.69365E+00, 0.13161E+02, 0.47715E+00 /) xa3lum(TEV16,TESLA,5) = 0.34086E+03 xa3(0:7,TEV16,TESLA,5) = (/ & 0.49058E+00, 0.42609E+00, 0.50550E+01,-0.61867E+00, & 0.39225E+00,-0.68916E+00, 0.75514E+01, 0.58754E+00 /) @ \textbf{Revision 0}. Currently identical to revision 5. <>= xa3lum(GEV350,TESLA,0) = 0.66447E+02 xa3(0:7,GEV350,TESLA,0) = (/ & 0.69418E+00, 0.50553E+00, 0.48430E+02,-0.63911E+00, & 0.34074E+00,-0.69533E+00, 0.55502E+02, 0.29397E+00 /) xa3lum(GEV500,TESLA,0) = 0.95241E+02 xa3(0:7,GEV500,TESLA,0) = (/ & 0.64882E+00, 0.45462E+00, 0.27103E+02,-0.64535E+00, & 0.35101E+00,-0.69467E+00, 0.33658E+02, 0.35024E+00 /) xa3lum(GEV800,TESLA,0) = 0.16974E+03 xa3(0:7,GEV800,TESLA,0) = (/ & 0.58706E+00, 0.43771E+00, 0.13422E+02,-0.63804E+00, & 0.35541E+00,-0.69467E+00, 0.17528E+02, 0.43051E+00 /) xa3lum(TEV1,TESLA,0) = 0.21222E+03 xa3(0:7,TEV1,TESLA,0) = (/ & 0.55525E+00, 0.42577E+00, 0.96341E+01,-0.63587E+00, & 0.36448E+00,-0.69365E+00, 0.13161E+02, 0.47715E+00 /) xa3lum(TEV16,TESLA,0) = 0.34086E+03 xa3(0:7,TEV16,TESLA,0) = (/ & 0.49058E+00, 0.42609E+00, 0.50550E+01,-0.61867E+00, & 0.39225E+00,-0.68916E+00, 0.75514E+01, 0.58754E+00 /) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Version 5} <>= if (circe1_params%rev .eq. 0) then r = 0 elseif (circe1_params%rev .ge. 19980505) then r = 1 elseif (circe1_params%rev .lt. 19980505) then call circem ('ERROR', & 'no revision of version 5 available before 98/05/05') call circem ('MESSAGE', 'falling back to default') r = 1 endif <> @ <>= if (circe1_params%acc .ne. TESLA) then call circem ('ERROR', 'versions 5 applies to TESLA only') circe1_params%acc = TESLA end if <> if (xa5lum(e,circe1_params%acc,r) .lt. 0d0) then write (msgbuf, 2002) circe1_params%roots, accnam(circe1_params%acc), r call circem ('ERROR', msgbuf) call circem ('MESSAGE', 'falling back to 500GeV') e = GEV500 endif <> @ <>= integer, parameter :: A5NEGY = 5, A5NREV = 1 @ <>= circe1_params%lumi = xa5lum (e,circe1_params%acc,r) do i = 0, 7 circe1_params%a1(i) = xa5(i,e,circe1_params%acc,r) end do @ <>= real, dimension(A5NEGY,NACC,0:A5NREV), save :: xa5lum real, dimension(0:7,A5NEGY,NACC,0:A5NREV), save :: xa5 @ \textbf{Revision 1}. The mother of all revisions. Note that $3.3980\cdot10^{34}\mathop{\textrm{cm}^{-2}}\mathop{\textrm{s}^{-1}} = 2.4099\cdot10^{34}\mathop{\textrm{m}^{-2}}\cdot 2820\cdot5\mathop{\textrm{s}^{-1}}$ and $3.5936\cdot10^{34}\mathop{\textrm{cm}^{-2}}\mathop{\textrm{s}^{-1}} = 2.6619\cdot10^{34}\mathop{\textrm{m}^{-2}}\cdot 4500\cdot3\mathop{\textrm{s}^{-1}}$. This unit conversion is missing in \emph{all} earlier versions, unfortunately. <>= xa5lum(GEV350,TESLA,1) = -1.0 xa5lum(GEV500,TESLA,1) = 0.33980E+03 xa5(0:7,GEV500,TESLA,1) = (/ & 0.49808E+00, 0.54613E+00, 0.12287E+02,-0.62756E+00, & 0.42817E+00,-0.69120E+00, 0.17067E+02, 0.51143E+00 /) xa5lum(GEV800,TESLA,1) = 0.35936E+03 xa5(0:7,GEV800,TESLA,1) = (/ & 0.58751E+00, 0.43128E+00, 0.13324E+02,-0.64006E+00, & 0.30682E+00,-0.69235E+00, 0.16815E+02, 0.37078E+00 /) xa5lum(TEV1, TESLA,1) = -1.0 xa5lum(TEV16,TESLA,1) = -1.0 @ \textbf{Revision 0}. Currently identical to revision 1. <>= xa5lum(GEV350,TESLA,0) = -1.0 xa5lum(GEV500,TESLA,0) = 0.33980E+03 xa5(0:7,GEV500,TESLA,0) = (/ & 0.49808E+00, 0.54613E+00, 0.12287E+02,-0.62756E+00, & 0.42817E+00,-0.69120E+00, 0.17067E+02, 0.51143E+00 /) xa5lum(GEV800,TESLA,0) = 0.35936E+03 xa5(0:7,GEV800,TESLA,0) = (/ & 0.58751E+00, 0.43128E+00, 0.13324E+02,-0.64006E+00, & 0.30682E+00,-0.69235E+00, 0.16815E+02, 0.37078E+00 /) xa5lum(TEV1, TESLA,0) = -1.0 xa5lum(TEV16,TESLA,0) = -1.0 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Version 6} <>= if (circe1_params%rev .eq. 0) then r = 0 else if (circe1_params%rev .ge. 19990415) then r = 1 else if (circe1_params%rev .lt. 19990415) then call circem ('ERROR', & 'no revision of version 6 available before 1999/04/15') call circem ('MESSAGE', 'falling back to default') r = 1 end if <> @ <>= if (circe1_params%acc .ne. TESLA) then call circem ('ERROR', 'versions 6 applies to TESLA only') circe1_params%acc = TESLA end if <> if (xa6lum(e,circe1_params%acc,r) .lt. 0d0) then write (msgbuf, 2002) circe1_params%roots, accnam(circe1_params%acc), r call circem ('ERROR', msgbuf) call circem ('MESSAGE', 'falling back to 500GeV') e = GEV500 endif <> @ <>= if (circe1_params%roots .eq. 90d0) then e = GEV090 elseif ((circe1_params%roots .ge. 85d0) .and. (circe1_params%roots .le. 95d0)) then write (msgbuf, 2001) circe1_params%roots, 90d0 call circem ('MESSAGE', msgbuf) e = GEV090 elseif (circe1_params%roots .eq. 170d0) then e = GEV170 elseif ((circe1_params%roots .ge. 160d0) .and. (circe1_params%roots .le. 180d0)) then write (msgbuf, 2001) circe1_params%roots, 170d0 call circem ('MESSAGE', msgbuf) e = GEV170 elseif (circe1_params%roots .eq. 350d0) then e = GEV350 elseif ((circe1_params%roots .ge. 340d0) .and. (circe1_params%roots .le. 370d0)) then write (msgbuf, 2001) circe1_params%roots, 350d0 call circem ('MESSAGE', msgbuf) e = GEV350 elseif (circe1_params%roots .eq. 500d0) then e = GEV500 elseif ((circe1_params%roots .ge. 480d0) .and. (circe1_params%roots .le. 520d0)) then write (msgbuf, 2001) circe1_params%roots, 500d0 call circem ('MESSAGE', msgbuf) e = GEV500 else call circem ('ERROR', & 'only ROOTS = 90, 170, 350, and 500GeV available') call circem ('MESSAGE', 'falling back to 500GeV') e = GEV500 endif @ <>= integer, parameter :: A6NEGY = 2, A6NREV = 1 @ <>= circe1_params%lumi = xa6lum (e,circe1_params%acc,r) do i = 0, 7 circe1_params%a1(i) = xa6(i,e,circe1_params%acc,r) end do @ <>= real, dimension(GEV090:A6NEGY,NACC,0:A6NREV), save :: xa6lum real, dimension(0:7,GEV090:A6NEGY,NACC,0:A6NREV), save :: xa6 @ \textbf{Revision 1}. The mother of all revisions. <>= xa6lum(GEV090,TESLA,1) = 0.62408E+02 xa6(0:7,GEV090,TESLA,1) = (/ & 0.72637E+00, 0.75534E+00, 0.18180E+03,-0.63426E+00, & 0.36829E+00,-0.69653E+00, 0.18908E+03, 0.22157E+00 /) xa6lum(GEV170,TESLA,1) = 0.11532E+02 xa6(0:7,GEV170,TESLA,1) = (/ & 0.65232E+00, 0.67249E+00, 0.66862E+02,-0.63315E+00, & 0.38470E+00,-0.69477E+00, 0.75120E+02, 0.30162E+00 /) xa6lum(GEV350,TESLA,1) = 0.24641E+03 xa6(0:7,GEV350,TESLA,1) = (/ & 0.54610E+00, 0.59105E+00, 0.20297E+02,-0.62747E+00, & 0.41588E+00,-0.69188E+00, 0.26345E+02, 0.43818E+00 /) xa6lum(GEV500,TESLA,1) = 0.30340E+03 xa6(0:7,GEV500,TESLA,1) = (/ & 0.52744E+00, 0.52573E+00, 0.13895E+02,-0.63145E+00, & 0.40824E+00,-0.69150E+00, 0.18645E+02, 0.47585E+00 /) @ \textbf{Revision 0}. Currently identical to revision 1. <>= xa6lum(GEV090,TESLA,0) = 0.62408E+02 xa6(0:7,GEV090,TESLA,0) = (/ & 0.72637E+00, 0.75534E+00, 0.18180E+03,-0.63426E+00, & 0.36829E+00,-0.69653E+00, 0.18908E+03, 0.22157E+00 /) xa6lum(GEV170,TESLA,0) = 0.11532E+02 xa6(0:7,GEV170,TESLA,0) = (/ & 0.65232E+00, 0.67249E+00, 0.66862E+02,-0.63315E+00, & 0.38470E+00,-0.69477E+00, 0.75120E+02, 0.30162E+00 /) xa6lum(GEV350,TESLA,0) = 0.24641E+03 xa6(0:7,GEV350,TESLA,0) = (/ & 0.54610E+00, 0.59105E+00, 0.20297E+02,-0.62747E+00, & 0.41588E+00,-0.69188E+00, 0.26345E+02, 0.43818E+00 /) xa6lum(GEV500,TESLA,0) = 0.30340E+03 xa6(0:7,GEV500,TESLA,0) = (/ & 0.52744E+00, 0.52573E+00, 0.13895E+02,-0.63145E+00, & 0.40824E+00,-0.69150E+00, 0.18645E+02, 0.47585E+00 /) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Version 7} <>= if (circe1_params%rev .eq. 0) then r = 0 elseif (circe1_params%rev .ge. 20000426) then r = 1 elseif (circe1_params%rev .lt. 20000426) then call circem ('ERROR', & 'no revision of version 7 available before 2000/04/26') call circem ('MESSAGE', 'falling back to default') r = 1 endif <> @ <>= if (circe1_params%acc .ne. TESLA .and. circe1_params%acc .ne. JLCNLC) then call circem ('ERROR', & 'version 7 applies to TESLA and JLCNLC only') call circem ('ERROR', 'falling back to TESLA') circe1_params%acc = TESLA end if <> <> @ <<[[format]]s for [[circes]]>>= 2004 format ('energy ', F6.1, 'GeV too low, using spectrum for ', F6.1, 'GeV') 2005 format ('energy ', F6.1, 'GeV too high, using spectrum for ', F6.1, 'GeV') 2006 format ('energy ', F6.1, 'GeV interpolated between ', F6.1, ' and ', F6.1, 'GeV') @ <>= real(kind=double) :: eloval, ehival real(kind=double), parameter :: DELTAE = 0.5d0 @ The rules are as follows: \texttt{XBAND} has 500\,GeV and 1\,TeV, \texttt{TESLA} has 500\,GeV and 800\,TeV. Low energy \texttt{TESLA} will be added. <>= e = GEV090 - 1 elo = e ehi = e if (circe1_params%acc .eq. TESLA) then if (circe1_params%roots .lt. 90d0 - DELTAE) then write (msgbuf, 2004) circe1_params%roots, 90d0 call circem ('MESSAGE', msgbuf) e = GEV090 elseif (abs (circe1_params%roots-090d0) .le. DELTAE) then e = GEV090 elseif (circe1_params%roots .lt. 170d0 - DELTAE) then write (msgbuf, 2005) circe1_params%roots, 170d0 call circem ('MESSAGE', msgbuf) e = GEV170 elseif (abs (circe1_params%roots-170d0) .le. DELTAE) then e = GEV170 elseif (circe1_params%roots .lt. 350d0-DELTAE) then write (msgbuf, 2006) circe1_params%roots, 170d0, 350d0 call circem ('MESSAGE', msgbuf) elo = GEV170 ehi = GEV350 eloval = 170d0 ehival = 350d0 elseif (abs (circe1_params%roots-350d0) .le. DELTAE) then e = GEV350 elseif (circe1_params%roots .lt. 500d0 - DELTAE) then write (msgbuf, 2006) circe1_params%roots, 350d0, 500d0 call circem ('MESSAGE', msgbuf) elo = GEV350 ehi = GEV500 eloval = 350d0 ehival = 500d0 elseif (abs (circe1_params%roots-500d0) .le. DELTAE) then e = GEV500 elseif (circe1_params%roots .lt. 800d0 - DELTAE) then write (msgbuf, 2006) circe1_params%roots, 500d0, 800d0 call circem ('MESSAGE', msgbuf) elo = GEV500 ehi = GEV800 eloval = 500d0 ehival = 800d0 elseif (abs (circe1_params%roots-800d0) .le. DELTAE) then e = GEV800 else write (msgbuf, 2005) circe1_params%roots, 800d0 call circem ('MESSAGE', msgbuf) e = GEV800 endif elseif (circe1_params%acc .eq. XBAND) then if (circe1_params%roots .lt. 500d0 - DELTAE) then write (msgbuf, 2004) circe1_params%roots, 500d0 call circem ('MESSAGE', msgbuf) e = GEV500 elseif (abs (circe1_params%roots-500d0) .le. DELTAE) then e = GEV500 elseif (circe1_params%roots .lt. 1000d0 - DELTAE) then write (msgbuf, 2006) circe1_params%roots, 500d0, 1000d0 call circem ('MESSAGE', msgbuf) elo = GEV500 ehi = TEV1 eloval = 500d0 ehival = 1000d0 elseif (abs (circe1_params%roots-1000d0) .le. DELTAE) then e = TEV1 else write (msgbuf, 2005) circe1_params%roots, 1000d0 call circem ('MESSAGE', msgbuf) e = TEV1 endif endif @ <>= integer, parameter :: A7NEGY = TEV1, A7NREV = 1 @ Note that ew \emph{must not} interpolate \texttt{a1(0)} and \texttt{a1(7)} because they depend non-linearly on the other parameters! <>= if (e .ge. GEV090) then circe1_params%lumi = xa7lum(e,circe1_params%acc,r) do i = 0, 7 circe1_params%a1(i) = xa7(i,e,circe1_params%acc,r) end do else if (elo .ge. GEV090 .and. ehi .ge. GEV090) then circe1_params%lumi = ((circe1_params%roots-eloval)*xa7lum(ehi,circe1_params%acc,r) & + (ehival-circe1_params%roots)*xa7lum(elo,circe1_params%acc,r)) / (ehival - eloval) do i = 1, 6 circe1_params%a1(i) = ((circe1_params%roots-eloval)*xa7(i,ehi,circe1_params%acc,r) & + (ehival-circe1_params%roots)*xa7(i,elo,circe1_params%acc,r)) / (ehival - eloval) end do circe1_params%a1(0) = 1d0 - circe1_params%a1(1) * beta(circe1_params%a1(2)+1d0,circe1_params%a1(3)+1d0) circe1_params%a1(7) = circe1_params%a1(4) * beta(circe1_params%a1(5)+1d0,circe1_params%a1(6)+1d0) endif @ <>= real, dimension(GEV090:A7NEGY,NACC,0:A7NREV), save :: xa7lum real, dimension(0:7,GEV090:A7NEGY,NACC,0:A7NREV), save :: xa7 @ \textbf{Revision 1}. The mother of all revisions. <>= xa7lum(GEV090,TESLA,1) = 0.62408E+02 xa7(0:7,GEV090,TESLA,1) = (/ & 0.72637E+00, 0.75534E+00, 0.18180E+03,-0.63426E+00, & 0.36829E+00,-0.69653E+00, 0.18908E+03, 0.22157E+00 /) xa7lum(GEV170,TESLA,1) = 0.11532E+02 xa7(0:7,GEV170,TESLA,1) = (/ & 0.65232E+00, 0.67249E+00, 0.66862E+02,-0.63315E+00, & 0.38470E+00,-0.69477E+00, 0.75120E+02, 0.30162E+00 /) xa7lum(GEV350,TESLA,1) = 0.24641E+03 xa7(0:7,GEV350,TESLA,1) = (/ & 0.54610E+00, 0.59105E+00, 0.20297E+02,-0.62747E+00, & 0.41588E+00,-0.69188E+00, 0.26345E+02, 0.43818E+00 /) xa7lum(GEV500,TESLA,1) = 0.34704E+03 xa7(0:7,GEV500,TESLA,1) = (/ & 0.51288E+00, 0.49025E+00, 0.99716E+01,-0.62850E+00, & 0.41048E+00,-0.69065E+00, 0.13922E+02, 0.51902E+00 /) xa7lum(GEV800,TESLA,1) = 0.57719E+03 xa7(0:7,GEV800,TESLA,1) = (/ & 0.52490E+00, 0.42573E+00, 0.69069E+01,-0.62649E+00, & 0.32380E+00,-0.68958E+00, 0.93819E+01, 0.45671E+00 /) xa7lum(TEV1,TESLA,1) = -1.0 @ <>= xa7lum(GEV090,JLCNLC,1) = -1.0 xa7lum(GEV170,JLCNLC,1) = -1.0 xa7lum(GEV350,JLCNLC,1) = -1.0 xa7lum(GEV500,JLCNLC,1) = 0.63039E+02 xa7(0:7,GEV500,JLCNLC,1) = (/ & 0.58967E+00, 0.34035E+00, 0.63631E+01,-0.63683E+00, & 0.33383E+00,-0.68803E+00, 0.81005E+01, 0.48702E+00 /) xa7lum(TEV1,JLCNLC,1) = 0.12812E+03 xa7(0:7,TEV1,JLCNLC,1) = (/ & 0.50222E+00, 0.33773E+00, 0.25681E+01,-0.61711E+00, & 0.36826E+00,-0.68335E+00, 0.36746E+01, 0.65393E+00 /) @ \textbf{Revision 0}. <>= xa7lum(GEV090,TESLA,0) = 0.62408E+02 xa7(0:7,GEV090,TESLA,0) = (/ & 0.72637E+00, 0.75534E+00, 0.18180E+03,-0.63426E+00, & 0.36829E+00,-0.69653E+00, 0.18908E+03, 0.22157E+00 /) xa7lum(GEV170,TESLA,0) = 0.11532E+02 xa7(0:7,GEV170,TESLA,0) = (/ & 0.65232E+00, 0.67249E+00, 0.66862E+02,-0.63315E+00, & 0.38470E+00,-0.69477E+00, 0.75120E+02, 0.30162E+00 /) xa7lum(GEV350,TESLA,0) = 0.24641E+03 xa7(0:7,GEV350,TESLA,0) = (/ & 0.54610E+00, 0.59105E+00, 0.20297E+02,-0.62747E+00, & 0.41588E+00,-0.69188E+00, 0.26345E+02, 0.43818E+00 /) xa7lum(GEV500,TESLA,0) = 0.34704E+03 xa7(0:7,GEV500,TESLA,0) = (/ & 0.51288E+00, 0.49025E+00, 0.99716E+01,-0.62850E+00, & 0.41048E+00,-0.69065E+00, 0.13922E+02, 0.51902E+00 /) xa7lum(GEV800,TESLA,0) = 0.57719E+03 xa7(0:7,GEV800,TESLA,0) = (/ & 0.52490E+00, 0.42573E+00, 0.69069E+01,-0.62649E+00, & 0.32380E+00,-0.68958E+00, 0.93819E+01, 0.45671E+00 /) xa7lum(TEV1,TESLA,0) = -1.0 @ <>= xa7lum(GEV090,JLCNLC,0) = -1.0 xa7lum(GEV170,JLCNLC,0) = -1.0 xa7lum(GEV350,JLCNLC,0) = -1.0 xa7lum(GEV500,JLCNLC,0) = 0.63039E+02 xa7(0:7,GEV500,JLCNLC,0) = (/ & 0.58967E+00, 0.34035E+00, 0.63631E+01,-0.63683E+00, & 0.33383E+00,-0.68803E+00, 0.81005E+01, 0.48702E+00 /) xa7lum(TEV1,JLCNLC,0) = 0.12812E+03 xa7(0:7,TEV1,JLCNLC,0) = (/ & 0.50222E+00, 0.33773E+00, 0.25681E+01,-0.61711E+00, & 0.36826E+00,-0.68335E+00, 0.36746E+01, 0.65393E+00 /) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Version 8} <>= if (circe1_params%rev .eq. 0) then r = 0 elseif (circe1_params%rev .ge. 20010617) then r = 1 elseif (circe1_params%rev .lt. 20010617) then call circem ('ERROR', & 'no revision of version 8 available before 2001/06/17') call circem ('MESSAGE', 'falling back to default') r = 1 endif <> @ <>= if (circe1_params%acc .eq. NLCH) then circe1_params%acc = JLCNLC end if if (circe1_params%acc .ne. JLCNLC) then call circem ('ERROR', & 'version 8 applies to JLCNLC (NLC H) only') call circem ('ERROR', 'falling back to JLCNLC') circe1_params%acc = JLCNLC end if <> <> @ <>= integer, parameter :: A8NEGY = TEV1, A8NREV = 1 @ Note that ew \emph{must not} interpolate \texttt{a1(0)} and \texttt{a1(7)} because they depend non-linearly on the other parameters! <>= if (e .ge. GEV090) then circe1_params%lumi = xa8lum(e,circe1_params%acc,r) do i = 0, 7 circe1_params%a1(i) = xa8(i,e,circe1_params%acc,r) end do elseif (elo .ge. GEV090 .and. ehi .ge. GEV090) then circe1_params%lumi = ((circe1_params%roots-eloval)*xa8lum(ehi,circe1_params%acc,r) & + (ehival-circe1_params%roots)*xa8lum(elo,circe1_params%acc,r)) / (ehival - eloval) do i = 1, 6 circe1_params%a1(i) = ((circe1_params%roots-eloval)*xa8(i,ehi,circe1_params%acc,r) & + (ehival-circe1_params%roots)*xa8(i,elo,circe1_params%acc,r)) / (ehival - eloval) end do circe1_params%a1(0) = 1d0 - circe1_params%a1(1) * beta(circe1_params%a1(2)+1d0,circe1_params%a1(3)+1d0) circe1_params%a1(7) = circe1_params%a1(4) * beta(circe1_params%a1(5)+1d0,circe1_params%a1(6)+1d0) endif @ <>= real, dimension(GEV090:A8NEGY,NACC,0:A8NREV), save :: xa8lum real, dimension(0:7,GEV090:A8NEGY,NACC,0:A8NREV), save :: xa8 @ \textbf{Revision 1}. The mother of all revisions. <>= xa8lum(GEV090,TESLA,1) = -1.0 xa8lum(GEV170,TESLA,1) = -1.0 xa8lum(GEV350,TESLA,1) = -1.0 xa8lum(GEV500,TESLA,1) = -1.0 xa8lum(GEV800,TESLA,1) = -1.0 xa8lum(TEV1, TESLA,1) = -1.0 @ <>= xa8lum(GEV090,JLCNLC,1) = -1.0 xa8lum(GEV170,JLCNLC,1) = -1.0 xa8lum(GEV350,JLCNLC,1) = -1.0 xa8lum(GEV500,JLCNLC,1) = 0.239924E+03 xa8(0:7,GEV500,JLCNLC,1) = (/ & 0.57025E+00, 0.34004E+00, 0.52864E+01,-0.63405E+00, & 0.31627E+00,-0.68722E+00, 0.69629E+01, 0.47973E+00 /) xa8lum(TEV1,JLCNLC,1) = 0.40858E+03 xa8(0:7,TEV1,JLCNLC,1) = (/ & 0.52344E+00, 0.31536E+00, 0.25244E+01,-0.62215E+00, & 0.31935E+00,-0.68424E+00, 0.35877E+01, 0.57315E+00 /) @ \textbf{Revision 0}. <>= xa8lum(GEV090,TESLA,0) = -1.0 xa8lum(GEV170,TESLA,0) = -1.0 xa8lum(GEV350,TESLA,0) = -1.0 xa8lum(GEV500,TESLA,0) = -1.0 xa8lum(GEV800,TESLA,0) = -1.0 xa8lum(TEV1, TESLA,0) = -1.0 @ <>= xa8lum(GEV090,JLCNLC,0) = -1.0 xa8lum(GEV170,JLCNLC,0) = -1.0 xa8lum(GEV350,JLCNLC,0) = -1.0 xa8lum(GEV500,JLCNLC,0) = 0.239924E+03 xa8(0:7,GEV500,JLCNLC,0) = (/ & 0.57025E+00, 0.34004E+00, 0.52864E+01,-0.63405E+00, & 0.31627E+00,-0.68722E+00, 0.69629E+01, 0.47973E+00 /) xa8lum(TEV1,JLCNLC,0) = 0.40858E+03 xa8(0:7,TEV1,JLCNLC,0) = (/ & 0.52344E+00, 0.31536E+00, 0.25244E+01,-0.62215E+00, & 0.31935E+00,-0.68424E+00, 0.35877E+01, 0.57315E+00 /) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Version 9} <>= if (circe1_params%rev .eq. 0) then r = 0 elseif (circe1_params%rev .ge. 20020328) then r = 1 elseif (circe1_params%rev .lt. 20020328) then call circem ('ERROR', & 'no revision of version 9 available before 2002/03/28') call circem ('MESSAGE', 'falling back to default') r = 1 endif <> @ <>= if (circe1_params%acc .ne. JLCNLC .and. circe1_params%acc .ne. NLCH) then call circem ('ERROR', & 'version 9 applies to JLCNLC and NLCH only') call circem ('ERROR', 'falling back to JLCNLC') circe1_params%acc = JLCNLC end if if (circe1_params%acc .eq. JLCNLC) then <> else if (circe1_params%acc .eq. NLCH) then <> end if <> @ <>= e = GEV090 - 1 elo = e ehi = e if (circe1_params%roots .lt. 250d0 - DELTAE) then write (msgbuf, 2004) circe1_params%roots, 250d0 call circem ('MESSAGE', msgbuf) e = GEV250 elseif (abs (circe1_params%roots-250d0) .le. DELTAE) then e = GEV250 elseif (circe1_params%roots .lt. 500d0 - DELTAE) then write (msgbuf, 2006) circe1_params%roots, 250d0, 500d0 call circem ('MESSAGE', msgbuf) elo = GEV250 ehi = GEV500 eloval = 250d0 ehival = 500d0 elseif (abs (circe1_params%roots-500d0) .le. DELTAE) then e = GEV500 elseif (circe1_params%roots .lt. 800d0 - DELTAE) then write (msgbuf, 2006) circe1_params%roots, 500d0, 800d0 call circem ('MESSAGE', msgbuf) elo = GEV500 ehi = GEV800 eloval = 500d0 ehival = 800d0 elseif (abs (circe1_params%roots-800d0) .le. DELTAE) then e = GEV800 elseif (circe1_params%roots .lt. 1000d0 - DELTAE) then write (msgbuf, 2006) circe1_params%roots, 800d0, 1000d0 call circem ('MESSAGE', msgbuf) elo = GEV800 ehi = TEV1 eloval = 800d0 ehival = 1000d0 elseif (abs (circe1_params%roots-1000d0) .le. DELTAE) then e = TEV1 elseif (circe1_params%roots .lt. 1200d0 - DELTAE) then write (msgbuf, 2006) circe1_params%roots, 1000d0, 1200d0 call circem ('MESSAGE', msgbuf) elo = TEV1 ehi = TEV12 eloval = 1000d0 ehival = 1200d0 elseif (abs (circe1_params%roots-1200d0) .le. DELTAE) then e = TEV12 elseif (circe1_params%roots .lt. 1500d0 - DELTAE) then write (msgbuf, 2006) circe1_params%roots, 1200d0, 1500d0 call circem ('MESSAGE', msgbuf) elo = TEV12 ehi = TEV15 eloval = 1200d0 ehival = 1500d0 elseif (abs (circe1_params%roots-1500d0) .le. DELTAE) then e = TEV15 else write (msgbuf, 2005) circe1_params%roots, 1500d0 call circem ('MESSAGE', msgbuf) e = TEV15 endif @ <>= e = GEV090 - 1 elo = e ehi = e if (circe1_params%roots .lt. 500d0 - DELTAE) then write (msgbuf, 2004) circe1_params%roots, 500d0 call circem ('MESSAGE', msgbuf) e = GEV500 elseif (abs (circe1_params%roots-500d0) .le. DELTAE) then e = GEV500 elseif (circe1_params%roots .lt. 1000d0 - DELTAE) then write (msgbuf, 2006) circe1_params%roots, 500d0, 1000d0 call circem ('MESSAGE', msgbuf) elo = GEV500 ehi = TEV1 eloval = 500d0 ehival = 1000d0 elseif (abs (circe1_params%roots-1000d0) .le. DELTAE) then e = TEV1 elseif (circe1_params%roots .lt. 1500d0 - DELTAE) then write (msgbuf, 2006) circe1_params%roots, 1000d0, 1500d0 call circem ('MESSAGE', msgbuf) elo = TEV1 ehi = TEV15 eloval = 1000d0 ehival = 1500d0 elseif (abs (circe1_params%roots-1500d0) .le. DELTAE) then e = TEV15 else write (msgbuf, 2005) circe1_params%roots, 1500d0 call circem ('MESSAGE', msgbuf) e = TEV15 endif @ <>= integer, parameter :: A9NEGY = TEV15, A9NREV = 1 @ Note that ew \emph{must not} interpolate \texttt{a1(0)} and \texttt{a1(7)} because they depend non-linearly on the other parameters! <>= if (e .ge. GEV090) then circe1_params%lumi = xa9lum(e,circe1_params%acc,r) do i = 0, 7 circe1_params%a1(i) = xa9(i,e,circe1_params%acc,r) end do else if (elo .ge. GEV090 .and. ehi .ge. GEV090) then circe1_params%lumi = ((circe1_params%roots-eloval)*xa9lum(ehi,circe1_params%acc,r) & + (ehival-circe1_params%roots)*xa9lum(elo,circe1_params%acc,r)) / (ehival - eloval) do i = 1, 6 circe1_params%a1(i) = ((circe1_params%roots-eloval)*xa9(i,ehi,circe1_params%acc,r) & + (ehival-circe1_params%roots)*xa9(i,elo,circe1_params%acc,r)) / (ehival - eloval) end do circe1_params%a1(0) = 1d0 - circe1_params%a1(1) * beta(circe1_params%a1(2)+1d0,circe1_params%a1(3)+1d0) circe1_params%a1(7) = circe1_params%a1(4) * beta(circe1_params%a1(5)+1d0,circe1_params%a1(6)+1d0) end if @ <>= real, dimension(GEV090:A9NEGY,NACC,0:A9NREV) :: xa9lum real, dimension(0:7,GEV090:A9NEGY,NACC,0:A9NREV) :: xa9 @ \textbf{Revision 1}. The mother of all revisions. <>= xa9lum(GEV090,TESLA,1) = -1.0 xa9lum(GEV170,TESLA,1) = -1.0 xa9lum(GEV350,TESLA,1) = -1.0 xa9lum(GEV500,TESLA,1) = -1.0 xa9lum(GEV800,TESLA,1) = -1.0 xa9lum(TEV1, TESLA,1) = -1.0 xa9lum(TEV12, TESLA,1) = -1.0 xa9lum(TEV15, TESLA,1) = -1.0 xa9lum(TEV16, TESLA,1) = -1.0 @ <>= xa9lum(GEV090,JLCNLC,1) = -1.0 xa9lum(GEV170,JLCNLC,1) = -1.0 xa9lum(GEV250,JLCNLC,1) = 109.886976 xa9(0:7,GEV250,JLCNLC,1) = (/ & 0.65598E+00, 0.34993E+00, 0.13766E+02,-0.64698E+00, & 0.29984E+00,-0.69053E+00, 0.16444E+02, 0.36060E+00 /) xa9lum(GEV350,JLCNLC,1) = -1.0 xa9lum(GEV500,JLCNLC,1) = 220.806144 xa9(0:7,GEV500,JLCNLC,1) = (/ & 0.57022E+00, 0.33782E+00, 0.52811E+01,-0.63540E+00, & 0.32035E+00,-0.68776E+00, 0.69552E+01, 0.48751E+00 /) xa9lum(GEV800,JLCNLC,1) = 304.63488 xa9(0:7,GEV800,JLCNLC,1) = (/ & 0.54839E+00, 0.31823E+00, 0.33071E+01,-0.62671E+00, & 0.31655E+00,-0.68468E+00, 0.45325E+01, 0.53449E+00 /) xa9lum(TEV1, JLCNLC,1) = 319.95648 xa9(0:7,TEV1, JLCNLC,1) = (/ & 0.56047E+00, 0.29479E+00, 0.28820E+01,-0.62856E+00, & 0.29827E+00,-0.68423E+00, 0.39138E+01, 0.52297E+00 /) xa9lum(TEV12,JLCNLC,1) = 349.90848 xa9(0:7,TEV12,JLCNLC,1) = (/ & 0.56102E+00, 0.28503E+00, 0.24804E+01,-0.62563E+00, & 0.29002E+00,-0.68376E+00, 0.33854E+01, 0.52736E+00 /) xa9lum(TEV15,JLCNLC,1) = 363.15648 xa9(0:7,TEV15,JLCNLC,1) = (/ & 0.57644E+00, 0.26570E+00, 0.22007E+01,-0.62566E+00, & 0.27102E+00,-0.68283E+00, 0.29719E+01, 0.50764E+00 /) xa9lum(TEV16,JLCNLC,1) = -1.0 @ <>= xa9lum(GEV090,NLCH,1) = -1.0 xa9lum(GEV170,NLCH,1) = -1.0 xa9lum(GEV250,NLCH,1) = -1.0 xa9lum(GEV350,NLCH,1) = -1.0 xa9lum(GEV500,NLCH,1) = 371.4624 xa9(0:7,GEV500,NLCH,1)= (/ & 0.33933E+00, 0.55165E+00, 0.29138E+01,-0.57341E+00, & 0.54323E+00,-0.68590E+00, 0.51786E+01, 0.88956E+00 /) xa9lum(GEV800,NLCH,1) = -1.0 xa9lum(TEV1,NLCH,1) = 516.41856 xa9(0:7,TEV1,NLCH,1)= (/ & 0.35478E+00, 0.46474E+00, 0.17666E+01,-0.56949E+00, & 0.49269E+00,-0.68384E+00, 0.31781E+01, 0.91121E+00 /) xa9lum(TEV12,NLCH,1) = -1.0 xa9lum(TEV15,NLCH,1) = 575.06688 xa9(0:7,TEV15,NLCH,1)= (/ & 0.38183E+00, 0.40310E+00, 0.13704E+01,-0.57742E+00, & 0.44548E+00,-0.68341E+00, 0.24956E+01, 0.87448E+00 /) xa9lum(TEV16,NLCH, 1) = -1.0 @ \textbf{Revision 0}. <>= xa9lum(GEV090,TESLA,0) = -1.0 xa9lum(GEV170,TESLA,0) = -1.0 xa9lum(GEV350,TESLA,0) = -1.0 xa9lum(GEV500,TESLA,0) = -1.0 xa9lum(GEV800,TESLA,0) = -1.0 xa9lum(TEV1, TESLA,0) = -1.0 xa9lum(TEV12, TESLA,0) = -1.0 xa9lum(TEV15, TESLA,0) = -1.0 xa9lum(TEV16, TESLA,0) = -1.0 @ <>= xa9lum(GEV090,JLCNLC,0) = -1.0 xa9lum(GEV170,JLCNLC,0) = -1.0 xa9lum(GEV250,JLCNLC,0) = 109.886976 xa9(0:7,GEV250,JLCNLC,0) = (/ & 0.65598E+00, 0.34993E+00, 0.13766E+02,-0.64698E+00, & 0.29984E+00,-0.69053E+00, 0.16444E+02, 0.36060E+00 /) xa9lum(GEV350,JLCNLC,0) = -1.0 xa9lum(GEV500,JLCNLC,0) = 220.806144 xa9(0:7,GEV500,JLCNLC,0) = (/ & 0.57022E+00, 0.33782E+00, 0.52811E+01,-0.63540E+00, & 0.32035E+00,-0.68776E+00, 0.69552E+01, 0.48751E+00 /) xa9lum(GEV800,JLCNLC,0) = 304.63488 xa9(0:7,GEV800,JLCNLC,0) = (/ & 0.54839E+00, 0.31823E+00, 0.33071E+01,-0.62671E+00, & 0.31655E+00,-0.68468E+00, 0.45325E+01, 0.53449E+00 /) xa9lum(TEV1, JLCNLC,0) = 319.95648 xa9(0:7,TEV1, JLCNLC,0) = (/ & 0.56047E+00, 0.29479E+00, 0.28820E+01,-0.62856E+00, & 0.29827E+00,-0.68423E+00, 0.39138E+01, 0.52297E+00 /) xa9lum(TEV12,JLCNLC,0) = 349.90848 xa9(0:7,TEV12,JLCNLC,0) = (/ & 0.56102E+00, 0.28503E+00, 0.24804E+01,-0.62563E+00, & 0.29002E+00,-0.68376E+00, 0.33854E+01, 0.52736E+00 /) xa9lum(TEV15,JLCNLC,0) = 363.15648 xa9(0:7,TEV15,JLCNLC,0) = (/ & 0.57644E+00, 0.26570E+00, 0.22007E+01,-0.62566E+00, & 0.27102E+00,-0.68283E+00, 0.29719E+01, 0.50764E+00 /) xa9lum(TEV16,JLCNLC,0) = -1.0 @ <>= xa9lum(GEV090,NLCH,0) = -1.0 xa9lum(GEV170,NLCH,0) = -1.0 xa9lum(GEV250,NLCH,0) = -1.0 xa9lum(GEV350,NLCH,0) = -1.0 xa9lum(GEV500,NLCH,0) = 371.4624 xa9(0:7,GEV500,NLCH,0) = (/ & 0.33933E+00, 0.55165E+00, 0.29138E+01,-0.57341E+00, & 0.54323E+00,-0.68590E+00, 0.51786E+01, 0.88956E+00 /) xa9lum(GEV800,NLCH,0) = -1.0 xa9lum(TEV1,NLCH,0) = 516.41856 xa9(0:7,TEV1,NLCH,0) = (/ & 0.35478E+00, 0.46474E+00, 0.17666E+01,-0.56949E+00, & 0.49269E+00,-0.68384E+00, 0.31781E+01, 0.91121E+00 /) xa9lum(TEV12,NLCH,0) = -1.0 xa9lum(TEV15,NLCH,0) = 575.06688 xa9(0:7,TEV15,NLCH,0) = (/ & 0.38183E+00, 0.40310E+00, 0.13704E+01,-0.57742E+00, & 0.44548E+00,-0.68341E+00, 0.24956E+01, 0.87448E+00 /) xa9lum(TEV16,NLCH,0) = -1.0 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Version 10} <>= if (circe1_params%rev .eq. 0) then r = 0 elseif (circe1_params%rev .ge. 20140305) then r = 1 elseif (circe1_params%rev .lt. 20140305) then call circem ('ERROR', & 'no revision of version 10 available before 2014/03/05') call circem ('MESSAGE', 'falling back to default') r = 1 endif <> @ <>= if (circe1_params%acc .ne. ILC) then call circem ('ERROR', 'version 10 applies to ILC only') call circem ('ERROR', 'falling back to ILC') circe1_params%acc = ILC end if if (circe1_params%acc .eq. ILC) then <> end if <> @ <>= e = -EINVAL elo = -EINVAL ehi = -EINVAL if (circe1_params%roots .lt. 200d0 - DELTAE) then write (msgbuf, 2004) circe1_params%roots, 200d0 call circem ('MESSAGE', msgbuf) e = GEV200 elseif (abs (circe1_params%roots-200d0) .le. DELTAE) then e = GEV200 elseif (circe1_params%roots .lt. 230d0 - DELTAE) then write (msgbuf, 2006) circe1_params%roots, 200d0, 230d0 call circem ('MESSAGE', msgbuf) elo = GEV200 ehi = GEV230 eloval = 200d0 ehival = 230d0 elseif (abs (circe1_params%roots-230d0) .le. DELTAE) then e = GEV230 elseif (circe1_params%roots .lt. 250d0 - DELTAE) then write (msgbuf, 2006) circe1_params%roots, 230d0, 250d0 call circem ('MESSAGE', msgbuf) elo = GEV230 ehi = GEV250 eloval = 230d0 ehival = 250d0 elseif (abs (circe1_params%roots-250d0) .le. DELTAE) then e = GEV250 elseif (circe1_params%roots .lt. 350d0 - DELTAE) then write (msgbuf, 2006) circe1_params%roots, 250d0, 350d0 call circem ('MESSAGE', msgbuf) elo = GEV250 ehi = GEV350 eloval = 250d0 ehival = 350d0 elseif (abs (circe1_params%roots-350d0) .le. DELTAE) then e = GEV350 elseif (circe1_params%roots .lt. 500d0 - DELTAE) then write (msgbuf, 2006) circe1_params%roots, 350d0, 500d0 call circem ('MESSAGE', msgbuf) elo = GEV350 ehi = GEV500 eloval = 350d0 ehival = 500d0 elseif (abs (circe1_params%roots-500d0) .le. DELTAE) then e = GEV500 else write (msgbuf, 2005) circe1_params%roots, 500d0 call circem ('MESSAGE', msgbuf) e = GEV500 endif @ <>= integer, parameter :: A10NEGY = GEV230, A10NREV = 1 @ Note that ew \emph{must not} interpolate \texttt{a1(0)} and \texttt{a1(7)} because they depend non-linearly on the other parameters! <>= if (e .ne. EINVAL) then circe1_params%lumi = xa10lum(e,circe1_params%acc,r) do i = 0, 7 circe1_params%a1(i) = xa10(i,e,circe1_params%acc,r) end do else if (elo .ne. EINVAL .and. ehi .ne. EINVAL) then circe1_params%lumi = ((circe1_params%roots-eloval)*xa10lum(ehi,circe1_params%acc,r) & + (ehival-circe1_params%roots)*xa10lum(elo,circe1_params%acc,r)) / (ehival - eloval) do i = 1, 6 circe1_params%a1(i) = ((circe1_params%roots-eloval)*xa10(i,ehi,circe1_params%acc,r) & + (ehival-circe1_params%roots)*xa10(i,elo,circe1_params%acc,r)) / (ehival - eloval) end do circe1_params%a1(0) = 1d0 - circe1_params%a1(1) * beta(circe1_params%a1(2)+1d0,circe1_params%a1(3)+1d0) circe1_params%a1(7) = circe1_params%a1(4) * beta(circe1_params%a1(5)+1d0,circe1_params%a1(6)+1d0) end if @ <>= real, dimension(GEV090:A10NEGY,ILC:ILC,0:A10NREV) :: xa10lum real, dimension(0:7,GEV090:A10NEGY,ILC:ILC,0:A10NREV) :: xa10 @ \textbf{Revision 1}. The mother of all revisions. <>= xa10lum = -1 xa10 = -1 @ <>= xa10lum(GEV200,ILC,1) = 56 xa10(:,GEV200,ILC,1) = (/ & 0.66253E+00, 0.51646E+00, 0.43632E+02, -0.64508E+00, & 0.35915E+00, -0.69716E+00, 0.51645E+02, 0.32097E+00 /) xa10lum(GEV230,ILC,1) = 83 xa10(:,GEV230,ILC,1) = (/ & 0.62360E+00, 0.52780E+00, 0.31915E+02, -0.64171E+00, & 0.38375E+00, -0.69529E+00, 0.39717E+02, 0.36597E+00 /) xa10lum(GEV250,ILC,1) = 97 xa10(:,GEV250,ILC,1) = (/ & 0.59996E+00, 0.52141E+00, 0.26647E+02, -0.64331E+00, & 0.39186E+00, -0.69687E+00, 0.33764E+02, 0.39669E+00 /) xa10lum(GEV350,ILC,1) = 100 xa10(:,GEV350,ILC,1) = (/ & 0.58875E+00, 0.50027E+00, 0.18594E+02, -0.63380E+00, & 0.38659E+00, -0.69239E+00, 0.23964E+02, 0.42049E+00 /) xa10lum(GEV500,ILC,1) = 180 xa10(:,GEV500,ILC,1) = (/ & 0.46755E+00, 0.51768E+00, 0.83463E+01, -0.62311E+00, & 0.45704E+00, -0.69165E+00, 0.12372E+02, 0.60192E+00 /) @ <>= @ \textbf{Revision 0} The latest is the default: <>= xa10lum(:,:,0) = xa10lum(:,:,A10NREV) xa10(:,:,:,0) = xa10(:,:,:,A10NREV) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Special Functions} <>= function beta (a, b) real(kind=double) :: a, b, beta beta = exp (dlogam(a) + dlogam(b) - dlogam(a+b)) end function beta @ <>= !!! CERNLIB C304 function dlogam (x) real(kind=double) :: dlogam real(kind=double), dimension(7) :: p1, q1, p2, q2, p3, q3 real(kind=double), dimension(5) :: c, xl real(kind=double) :: x, y, zero, one, two, half, ap, aq integer :: i data ZERO /0.0D0/, ONE /1.0D0/, TWO /2.0D0/, HALF /0.5D0/ data XL /0.0D0,0.5D0,1.5D0,4.0D0,12.0D0/ data p1 /+3.8428736567460D+0, +5.2706893753010D+1, & +5.5584045723515D+1, -2.1513513573726D+2, & -2.4587261722292D+2, -5.7500893603041D+1, & -2.3359098949513D+0/ data q1 /+1.0000000000000D+0, +3.3733047907071D+1, & +1.9387784034377D+2, +3.0882954973424D+2, & +1.5006839064891D+2, +2.0106851344334D+1, & +4.5717420282503D-1/ data p2 /+4.8740201396839D+0, +2.4884525168574D+2, & +2.1797366058896D+3, +3.7975124011525D+3, & -1.9778070769842D+3, -3.6929834005591D+3, & -5.6017773537804D+2/ data q2 /+1.0000000000000D+0, +9.5099917418209D+1, & +1.5612045277929D+3, +7.2340087928948D+3, & +1.0459576594059D+4, +4.1699415153200D+3, & +2.7678583623804D+2/ data p3 /-6.8806240094594D+3, -4.3069969819571D+5, & -4.7504594653440D+6, -2.9423445930322D+6, & +3.6321804931543D+7, -3.3567782814546D+6, & -2.4804369488286D+7/ data q3 /+1.0000000000000D+0, -1.4216829839651D+3, & -1.5552890280854D+5, -3.4152517108011D+6, & -2.0969623255804D+7, -3.4544175093344D+7, & -9.1605582863713D+6/ data c / 1.1224921356561D-1, 7.9591692961204D-2, & -1.7087794611020D-3, 9.1893853320467D-1, & 1.3469905627879D+0/ if (x .le. xl(1)) then print *, 'ERROR: DLOGAM non positive argument: ', X dlogam = zero end if if (x .le. xl(2)) then y = x + one ap = p1(1) aq = q1(1) do i = 2, 7 ap = p1(i) + y * ap aq = q1(i) + y * aq end do y = - log(x) + x * ap / aq else if (x .le. xl(3)) then ap = p1(1) aq = q1(1) do i = 2, 7 ap = p1(i) + x * ap aq = q1(i) + x * aq end do y = (x - one) * ap / aq else if (x .le. xl(4)) then ap = p2(1) aq = q2(1) do i = 2, 7 ap = p2(i) + x * ap aq = q2(i) + x * aq end do y = (x-two) * ap / aq else if (x .le. xl(5)) then ap = p3(1) aq = q3(1) do i = 2, 7 ap = p3(i) + x * ap aq = q3(i) + x * aq end do y = ap / aq else y = one / x**2 y = (x-half) * log(x) - x + c(4) + & (c(1) + y * (c(2) + y * c(3))) / ((c(5) + y) * x) end if dlogam = y end function dlogam @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Non-Singular Distributions} @ <>= public :: kirke <>= function kirke (x1, x2, p1, p2) real(kind=double) :: x1, x2 real(kind=double) :: kirke integer :: p1, p2 <> kirke = -1.0 if (abs(p1) .eq. C1_ELECTRON) then if (abs(p2) .eq. C1_ELECTRON) then kirke = kirkee (x1, x2) else if (p2 .eq. C1_PHOTON) then kirke = kirkeg (x1, x2) end if else if (p1 .eq. C1_PHOTON) then if (abs(p2) .eq. C1_ELECTRON) then kirke = kirkeg (x2, x1) else if (p2 .eq. C1_PHOTON) then kirke = kirkgg (x1, x2) end if endif end function kirke @ %def kirke @ <>= public :: kirkee <>= function kirkee (x1, x2) real(kind=double) :: x1, x2 real(kind=double) :: kirkee real(kind=double) :: d1, d2 <> kirkee = -1.0 if ((circe1_params%ver .eq. 1) .or. (circe1_params%ver .eq. 0)) then <> <<[[else]] handle invalid versions>> end function kirkee @ %def kirkee @ <<8-byte aligned part of circe1 parameters>>= real(kind=double) :: elect0, gamma0 @ \begin{equation} \int_{1-\epsilon}^{1^+}\!\textrm{d}x\,d_{e^\pm}^{\alpha1\rho} (x) = a_0^{\alpha\rho} + a_1^{\alpha\rho} \int_{1-\epsilon}^{1^-}\!\textrm{d}x\, x^{a_2^{\alpha\rho}} (1-x)^{a_3^{\alpha\rho}} \end{equation} Approximately \begin{equation} \int_{1-\epsilon}^{1^+}\!\textrm{d}x\,d_{e^\pm}^{\alpha1\rho} (x) = a_0^{\alpha\rho} + a_1^{\alpha\rho} \int_{1-\epsilon}^{1^-}\!\textrm{d}x\, (1-x)^{a_3^{\alpha\rho}} = a_0^{\alpha\rho} + a_1^{\alpha\rho} \int_{0^+}^{\epsilon}\!\textrm{d}\xi\, \xi^{a_3^{\alpha\rho}} \end{equation} and therefore \begin{equation} \int_{1-\epsilon}^{1^+}\!\textrm{d}x\,d_{e^\pm}^{\alpha1\rho} (x) = a_0^{\alpha\rho} + a_1^{\alpha\rho} \frac{1-\epsilon^{a_3^{\alpha\rho}+1}}{a_3^{\alpha\rho}+1} \end{equation} This simple approximation is good enough <>= circe1_params%elect0 = circe1_params%a1(0) + circe1_params%a1(1) * KIREPS**(circe1_params%a1(3)+1) / (circe1_params%a1(3)+1) circe1_params%elect0 = circe1_params%elect0 / KIREPS circe1_params%gamma0 = circe1_params%a1(4) * KIREPS**(circe1_params%a1(5)+1) / (circe1_params%a1(5)+1) circe1_params%gamma0 = circe1_params%gamma0 / KIREPS @ but we can also use incomplete Beta functions for the exact result: <>= circe1_params%elect0 = circe1_params%a1(0) + circe1_params%a1(1) * beta (circe1_params%a1(2)+1, circe1_params%a1(3)+1) & * (1d0 - betinc (circe1_params%a1(2)+1, circe1_params%a1(3)+1, 1d0 - KIREPS)) circe1_params%elect0 = circe1_params%elect0 / KIREPS circe1_params%gamma0 = circe1_params%a1(7) + circe1_params%a1(4) * beta (circe1_params%a1(5)+1, circe1_params%a1(6)+1) & * betinc (circe1_params%a1(5)+1, circe1_params%a1(6)+1, KIREPS) circe1_params%gamma0 = circe1_params%gamma0 / KIREPS @ <>= real(kind=double) :: betinc external betinc @ <>= if (x1 .gt. 1d0) then d1 = 0d0 elseif (x1 .ge. (1d0 - KIREPS)) then d1 = circe1_params%elect0 elseif (x1 .ge. 0d0) then d1 = circe1_params%a1(1) * x1**circe1_params%a1(2) * (1d0 - x1)**circe1_params%a1(3) else d1 = 0d0 endif if (x2 .gt. 1d0) then d2 = 0d0 elseif (x2 .ge. (1d0 - KIREPS)) then d2 = circe1_params%elect0 elseif (x2 .ge. 0d0) then d2 = circe1_params%a1(1) * x2**circe1_params%a1(2) * (1d0 - x2)**circe1_params%a1(3) else d2 = 0d0 endif kirkee = d1 * d2 @ <>= if (x1 .gt. 1d0) then d1 = 0d0 elseif (x1 .ge. (1d0 - KIREPS)) then d1 = circe1_params%elect0 elseif (x1 .ge. 0d0) then d1 = circe1_params%a1(1) * x1**circe1_params%a1(2) * (1d0 - x1)**circe1_params%a1(3) else d1 = 0d0 endif if (x2 .gt. 1d0) then d2 = 0d0 elseif (x2 .gt. KIREPS) then d2 = circe1_params%a1(4) * x2**circe1_params%a1(5) * (1d0 - x2)**circe1_params%a1(6) elseif (x2 .ge. 0d0) then d2 = circe1_params%gamma0 else d2 = 0d0 endif kirkeg = d1 * d2 @ <>= if (x1 .gt. 1d0) then d1 = 0d0 elseif (x1 .gt. KIREPS) then d1 = circe1_params%a1(4) * x1**circe1_params%a1(5) * (1d0 - x1)**circe1_params%a1(6) elseif (x1 .ge. 0d0) then d1 = circe1_params%gamma0 else d1 = 0d0 endif if (x2 .gt. 1d0) then d2 = 0d0 elseif (x2 .gt. KIREPS) then d2 = circe1_params%a1(4) * x2**circe1_params%a1(5) * (1d0 - x2)**circe1_params%a1(6) elseif (x2 .ge. 0d0) then d2 = circe1_params%gamma0 else d2 = 0d0 endif kirkgg = d1 * d2 @ <>= public :: kirkeg <>= function kirkeg (x1, x2) real(kind=double) :: x1, x2 real(kind=double) :: kirkeg real(kind=double) :: d1, d2 <> kirkeg = -1.0 if ((circe1_params%ver .eq. 1) .or. (circe1_params%ver .eq. 0)) then <> <<[[else]] handle invalid versions>> end function kirkeg @ %def kirkeg @ <>= public :: kirkgg <>= function kirkgg (x1, x2) real(kind=double) :: x1, x2 real(kind=double) :: kirkgg real(kind=double) :: d1, d2 <> kirkgg = -1.0 if ((circe1_params%ver .eq. 1) .or. (circe1_params%ver .eq. 0)) then <> <<[[else]] handle invalid versions>> end function kirkgg @ %def kirkgg @ <>= function betinc (a, b, x) real(kind=double) :: x, a, b real(kind=double) :: betinc real(kind=double) :: bt if (x .lt. 0d0 .or. x .gt. 1d0) then betinc = 0d0 else if (x .eq. 0d0 .or. x .eq. 1d0) then bt = 0d0 else bt = exp(dlogam(a+b)-dlogam(a)-dlogam(b) & + a*log(x) + b*log(1d0-x)) end if if (x .lt. (a+1d0)/ (a+b+2d0)) then betinc = bt*betacf (a, b, x) / a else betinc = 1d0 - bt*betacf (b, a, 1d0-x) / b end if end if end function betinc @ <>= function betacf (a, b, x) real(kind=double) :: x, a, b real(kind=double) :: betacf integer, parameter :: itmax = 100 real(kind=double), parameter = eps = 3d-7 real(kind=double) :: am, bm, curr, prev, qab, qap, qam, bz, & ap, bp, app, bpp, em, tem, d integer :: m am = 1d0 bm = 1d0 curr = 1d0 qab = a + b qap = a + 1d0 qam = a - 1d0 bz = 1d0 - qab * x / qap do m = 1, ITMAX em = m tem = 2*em d = em * (b - m) * x / ((qam + tem) * (a + tem)) ap = curr + d*am bp = bz + d*bm d = - (a + em) * (qab + em) * x / ((a + tem) * (qap + tem)) app = ap + d * curr bpp = bp + d * bz prev = curr am = ap / bpp bm = bp / bpp curr = app / bpp bz = 1d0 if (abs (curr - prev) .lt. EPS * abs (curr)) then betacf = curr return end if end do print *, 'betacf: failed to converge' betacf = 0d0 end @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Generators} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Random-Number Generator} The generator routines do not fix or provide a random-number generator. The caller has to provide an implementation which is transferred to the subroutines in one of two possible forms: \begin{enumerate} \item as a subroutine which generates a single random number, working on an implicit external state \item as an object with a method the generates a single random number, working on an internal state \end{enumerate} These snippets should be used by the procedures that use a RNG: <>= rng, rng_obj <>= procedure(rng_proc), optional :: rng class(rng_type), intent(inout), optional :: rng_obj <>= call rng_call (u, <>) <>= subroutine rng_call (u, <>) real(kind=double), intent(out) :: u <> if (present (rng)) then call rng (u) else if (present (rng_obj)) then call rng_obj%generate (u) else call circem ('PANIC', & 'generator requires either rng or rng_obj argument') end if end subroutine rng_call @ %def rng_call @ This defines the procedure version of the RNG, corresponding to the traditional F77 [[external]] interface. The abstract interface enables the compiler to check conformance. <>= abstract interface subroutine rng_proc (u) import :: double real(kind=double), intent(out) :: u end subroutine rng_proc end interface @ %def rng_proc @ Here we define the object version of the RNG. It has to implement a [[generate]] method which parallels the [[rng_proc]] procedure above. <>= public :: rng_type <>= type, abstract :: rng_type contains procedure(rng_generate), deferred :: generate end type rng_type @ %def rng_type <>= abstract interface subroutine rng_generate (rng_obj, u) import :: rng_type, double class(rng_type), intent(inout) :: rng_obj real(kind=double), intent(out) :: u end subroutine rng_generate end interface @ %def rng_generate @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Version 1} Beta distributions have the practical advantage that they have been popular among mathematicians.\cite{Devroye:1986:random_deviates} <>= public :: girce <>= subroutine girce (x1, x2, p1, p2, <>) real(kind=double), intent(out) :: x1, x2 integer :: p1, p2 <> real(kind=double) :: u, w <> <<[[x1m]], [[x2m]] kludge, part 1>> <>= w = 1d0 / (1d0 + circgg (-1d0, -1d0)) <> if (u*u .le. w) then p1 = C1_POSITRON else p1 = C1_PHOTON end if <> if (u*u .le. w) then p2 = C1_ELECTRON else p2 = C1_PHOTON end if @ The flavor selection is incorrect, because the relative weights depend on the minimum energy fractions. We resort to a moderately inefficient kludge, because we don't have the distribution functions available yet. We'll have to implement incomplete Beta functions and other horrible things for this. Fortunately, the efficiency can not drop below the relative contribution of~$e^+e^-$. \index{inefficiencies} <<[[x1m]], [[x2m]] kludge, part 1>>= do @ Crude rejection: <<[[x1m]], [[x2m]] kludge, part 2>>= if ((x1 .ge. circe1_params%x1m) .and. (x2 .ge. circe1_params%x2m)) exit end do @ <>= public :: gircee <>= subroutine gircee (x1, x2, <>) real(kind=double), intent(out) :: x1, x2 <> real(kind=double) :: u <> x1 = 1 x2 = 1 if ((circe1_params%ver .eq. 1) .or. (circe1_params%ver .eq. 0)) then <> <<[[else]] handle invalid versions>> end subroutine gircee @ %def gircee @ For version 1 of the parametrizations we rely on [[girceb]], a fast generator of $\beta$-distribitions: \begin{eqnarray} \beta_{x_{\text{min}},x_{\text{max}}}^{a,b}(x) & = & x^{a-1}(1-x)^{b-1}\cdot \frac{\Theta(x_{\text{max}}-x)\Theta(x-x_{\text{min}})}% {I(x_{\text{min}},a,b)-I(x_{\text{max}},a,b)} \\ I(x,a,b) & = & \int_x^1\!d\xi\, \xi^{a-1}(1-\xi)^{b-1} \end{eqnarray} <>= <> if (u .le. circe1_params%a1(0)) then x1 = 1d0 else x1 = 1d0 - girceb (0d0, 1d0-circe1_params%x1m, & circe1_params%a1(3)+1d0, circe1_params%a1(2)+1d0, & <>) endif <> if (u .le. circe1_params%a1(0)) then x2 = 1d0 else x2 = 1d0 - girceb (0d0, 1d0-circe1_params%x2m, & circe1_params%a1(3)+1d0, circe1_params%a1(2)+1d0, & <>) endif @ <>= public :: girceg <>= subroutine girceg (x1, x2, <>) real(kind=double), intent(out) :: x1, x2 <> real(kind=double) :: u <> x1 = 1 x2 = 1 if ((circe1_params%ver .eq. 1) .or. (circe1_params%ver .eq. 0)) then <> <<[[else]] handle invalid versions>> end subroutine girceg @ %def girceg @ <>= <> if (u .le. circe1_params%a1(0)) then x1 = 1d0 else x1 = 1d0 - girceb (0d0, 1d0-circe1_params%x1m, & circe1_params%a1(3)+1d0, circe1_params%a1(2)+1d0, & <>) endif x2 = girceb (circe1_params%x2m, 1d0, & circe1_params%a1(5)+1d0, circe1_params%a1(6)+1d0, & <>) @ <>= public :: gircgg <>= subroutine gircgg (x1, x2, <>) real(kind=double), intent(out) :: x1, x2 <> <> x1 = 1 x2 = 1 if ((circe1_params%ver .eq. 1) .or. (circe1_params%ver .eq. 0)) then <> <<[[else]] handle invalid versions>> end subroutine gircgg @ <>= x1 = girceb (circe1_params%x1m, 1d0, & circe1_params%a1(5)+1d0, circe1_params%a1(6)+1d0, & <>) x2 = girceb (circe1_params%x2m, 1d0, & circe1_params%a1(5)+1d0, circe1_params%a1(6)+1d0, & <>) @ %def gircgg @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Version 2} Retired. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Version 3 and 4} Identical to version 1. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Utilities} @ For version 1 of the parametrizations we need a fast generator of $\beta$-distribitions: \begin{equation} \beta_{x_{\text{min}},x_{\text{max}}}^{a,b}(x) = x^{a-1}(1-x)^{b-1}\cdot \frac{\Theta(x_{\text{max}}-x)\Theta(x-x_{\text{min}})}% {I(x_{\text{min}},a,b)-I(x_{\text{max}},a,b)} \end{equation} with the \emph{incomplete Beta-function~$I$:} \begin{eqnarray} I(x,a,b) & = & \int_x^1\!d\xi\, \xi^{a-1}(1-\xi)^{b-1} \\ B(a,b) & = & I(0,a,b) \end{eqnarray} This problem has been studied extensively~\cite{Devroye:1986:random_deviates} and we can use an algorithm~\cite{Atkinson/Whittaker:1979:beta_distribution} that is very fast for~$0>= public :: girceb <>= function girceb (xmin, xmax, a, b, <>) real(kind=double) :: xmin, xmax, a, b real(kind=double) :: girceb <> real(kind=double) :: t, p, u, umin, umax, x, w <> <> do <> <> if (w .gt. u) exit end do girceb = x end function girceb @ %def girceb @ In fact, this algorithm works for~$0>= if ((a .ge. 1d0) .or. (b .le. 1d0)) then girceb = -1d0 call circem ('ERROR', 'beta-distribution expects a<1>= <> p = b*t / (b*t + a * (1d0 - t)**b) @ The dominating distributions can be generated by simple mappings \begin{eqnarray} \phi: [0,1] & \to & [0,1] \\ u & \mapsto & \begin{cases} t\left(\frac{u}{p}\right)^\frac{1}{a} &t\;\text{for}\;u>p \end{cases} \end{eqnarray} The beauty of the algorithm is that we can use a single uniform deviate~$u$ for both intervals: <>= <> u = umin + (umax - umin) * u if (u .le. p) then x = t * (u/p)**(1d0/a) w = (1d0 - x)**(b-1d0) else x = 1d0 - (1d0 - t) * ((1d0 - u)/(1d0 - p))**(1d0/b) w = (x/t)**(a-1d0) end if @ The weights that are derived by dividing the distribution by the dominating distributions are already normalized correctly: \begin{eqnarray} w: [0,1] & \to & [0,1] \\ x & \mapsto & \begin{cases} (1-x)^{b-1} &\in[(1-t)^{b-1},1]\;\text{for}\;x\le t\\ \left(\frac{x}{t}\right)^{a-1} &\in[t^{1-a},1] \;\text{for}\;x\ge t \end{cases} \end{eqnarray} @ To derive~$u_{\text{min},\text{max}}$ from~$x_{\text{min},\text{max}}$ we can use~$\phi^{-1}$: \begin{eqnarray} \phi^{-1}: [0,1] & \to & [0,1] \\ x & \mapsto & \begin{cases} p\left(\frac{x}{t}\right)^a &p\;\text{for}\;x>t \end{cases} \end{eqnarray} We start with~$u_{\text{min}}$. For efficiency, we handle the most common cases (small~$x_{\text{min}}$) first: <>= if (xmin .le. 0d0) then umin = 0d0 elseif (xmin .lt. t) then umin = p * (xmin/t)**a elseif (xmin .eq. t) then umin = p elseif (xmin .lt. 1d0) then umin = 1d0 - (1d0 - p) * ((1d0 - xmin)/(1d0 - t))**b else umin = 1d0 endif @ Same procedure for~$u_{\text{max}}$; again, handle the most common cases (large~$x_{\text{max}}$) first: <>= if (xmax .ge. 1d0) then umax = 1d0 elseif (xmax .gt. t) then umax = 1d0 - (1d0 - p) * ((1d0 - xmax)/(1d0 - t))**b elseif (xmax .eq. t) then umax = p elseif (xmax .gt. 0d0) then umax = p * (xmax/t)**a else umax = 0d0 endif @ Check for absurd cases. <>= if (umax .lt. umin) then girceb = -1d0 return endif @ It remains to choose he best value for~$t$. The rejection efficiency~$\epsilon$ of the algorithm is given by the ratio of the dominating distribution and the distribution \begin{equation} \frac{1}{\epsilon(t)} = \frac{B(a,b)}{ab} \left(bt^{a} + at^{a-1}(1-t)^b\right). \end{equation} It is maximized for \begin{equation} bt - bt(1-t)^{b-1} + (a-1)(1-t)^b = 0 \end{equation} This equation has a solution which can be determined numerically. While this determination is far too expensive compared to a moderate loss in efficiency, we could perform it once after fitting the coefficients~$a$, $b$. Nevertheless, it has been shown,\cite{Atkinson/Whittaker:1979:beta_distribution} that \begin{equation} t = \frac{1-a}{b+1-a} \end{equation} results in non-vanishing efficiency for all values~$1>= t = (1d0 - a) / (b + 1d0 - a) @ <>= public :: circem <>= subroutine circem (errlvl, errmsg) character(len=*) :: errlvl, errmsg integer, save :: errcnt = 0 if (errlvl .eq. 'MESSAGE') then print *, 'circe1:message: ', errmsg else if (errlvl .eq. 'WARNING') then if (errcnt .lt. 100) then errcnt = errcnt + 1 print *, 'circe1:warning: ', errmsg else if (errcnt .eq. 100) then errcnt = errcnt + 1 print *, 'circe1:message: more than 100 messages' print *, 'circe1:message: turning warnings off' end if else if (errlvl .eq. 'ERROR') then if (errcnt .lt. 200) then errcnt = errcnt + 1 print *, 'circe1:error: ', errmsg else if (errcnt .eq. 200) then errcnt = errcnt + 1 print *, 'circe1:message: more than 200 messages' print *, 'circe1:message: turning error messages off' endif else if (errlvl .eq. 'PANIC') then if (errcnt .lt. 300) then errcnt = errcnt + 1 print *, 'circe1:panic: ', errmsg else if (errcnt .eq. 300) then errcnt = errcnt + 1 print *, 'circe1:message: more than 300 messages' print *, 'circe1:message: turning panic messages off' end if else print *, 'circe1:panic: invalid error code ', errlvl end if end subroutine circem @ %def circem @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Examples} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Distributions} <<[[circe1_plot.f90]]>>= program circe1_plot use kinds use circe1 implicit none real(kind=double) :: xmin, xmax, y, roots integer :: xory, nstep, p1, p2, acc, ver, rev, i real(kind=double) :: x, logx, d read *, xory, xmin, xmax, nstep, y, p1, p2, roots, acc, ver, rev call circes (0d0, 0d0, roots, acc, ver, rev, 0) do i = 0, nstep logx = log (xmin) + i * log (xmax/xmin) / nstep x = exp (logx) d = 0d0 if (xory .eq. 1) then if (p1 .eq. C1_PHOTON) then d = circe (x, y, p1, p2) else d = circe (1d0 - x, y, p1, p2) end if else if (xory .eq. 2) then if (p1 .eq. C1_PHOTON) then d = circe (y, x, p1, p2) else d = circe (y, 1d0 - x, p1, p2) end if end if if (d .gt. 1d-4) print *, x, d end do end program circe1_plot @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Library functions} If Fortran77 only had first class functions, then the following cruft would not be necessary. OK, here's the outline of the adaptive Gauss integration routine from CERNLIB: <>= real(kind=double) :: f, a, b, eps external f real(kind=double), parameter :: Z1 = 1, HF = Z1/2, CST = 5*Z1/1000 integer :: i real(kind=double) :: h, const, aa, bb, c1, c2, s8, s16, u <> h = 0 if (b .eq. a) go to 99 const = CST / dabs(b-a) bb = a 1 continue aa = bb bb = b 2 continue c1 = HF*(bb+aa) c2 = HF*(bb-aa) s8 = 0 do i = 1, 4 u = c2*x(i) @ Here are now the first two function calls that we have to fill in later in various ways: <>= s8 = s8 + w(i) * (f (c1+u) + f (c1-u)) @ Continuing <>= end do s16 = 0 do i = 5, 12 u = c2*x(i) @ And here are the other two function calls: <>= s16 = s16 + w(i) * (f (c1+u) + f (c1-u)) @ Terminating: <>= end do s16 = c2*s16 if (dabs(s16-c2*s8) .le. eps*(1+dabs(s16))) then h = h + s16 if (bb .ne. b) go to 1 else bb = c1 if (1 + const*dabs(c2) .ne. 1) go to 2 h = 0 print *, 'gauss: too high accuracy required' go to 99 end if 99 continue @ This one is still reasonably straightforward \begin{equation} \text{[[gauss1]]}: (f,a,b) \mapsto \int_a^b\!dx\,f(x) \end{equation} <<[[circe1_sample.f90: public]]>>= public :: gauss1 <<[[circe1_sample.f90: subroutines]]>>= function gauss1 (f, a, b, eps) real(kind=double) :: gauss1 <> s8 = s8 + w(i) * (f (c1+u) + f (c1-u)) <> s16 = s16 + w(i) * (f (c1+u) + f (c1-u)) <> gauss1 = h end function gauss1 @ %def gauss1 @ But this almost identical repeat \begin{equation} \text{[[gaussx]]}: (f,a,b) \mapsto \left( y \mapsto \int_a^b\!dx\,f(y,x) \right) \end{equation} would not be necassary in a modern programming language with currying: <<[[circe1_sample.f90: public]]>>= public :: gaussx <<[[circe1_sample.f90: subroutines]]>>= function gaussx (f, y, a, b, eps) real(kind=double) :: y real(kind=double) :: gaussx <> s8 = s8 + w(i) * (f (y, c1+u) + f (y, c1-u)) <> s16 = s16 + w(i) * (f (y, c1+u) + f (y, c1-u)) <> gaussx = h end function gaussx @ %def gaussx @ Fortunately, this is the last one we need \begin{multline} \text{[[gauss2]]}: (f,a,b,a_1,b_1) \mapsto \int_a^b\!dx\,\int_{a_1}^{b_1}\!dy\,f(x,y) \\ = \text{[[gauss1]]} \left( \text{[[gaussx]]}(f,a,b), a_1, b_1\right) \end{multline} <<[[circe1_sample.f90: public]]>>= public :: gauss2 <<[[circe1_sample.f90: subroutines]]>>= function gauss2 (f, a, b, a1, b1, eps) real(kind=double) :: a1, b1 real(kind=double) :: gauss2 <> s8 = s8 + w(i) * (gaussx (f, c1+u, a1, b1, eps) & + gaussx (f, c1-u, a1, b1, eps)) <> s16 = s16 + w(i) * (gaussx (f, c1+u, a1, b1, eps) & + gaussx (f, c1-u, a1, b1, eps)) <> gauss2 = h end function gauss2 @ %def gauss2 @ <>= real(kind=double), dimension(12), parameter :: & x = (/ 9.6028985649753623d-1, & 7.9666647741362674d-1, & 5.2553240991632899d-1, & 1.8343464249564980d-1, & 9.8940093499164993d-1, & 9.4457502307323258d-1, & 8.6563120238783174d-1, & 7.5540440835500303d-1, & 6.1787624440264375d-1, & 4.5801677765722739d-1, & 2.8160355077925891d-1, & 9.5012509837637440d-2 /), & w = (/ 1.0122853629037626d-1, & 2.2238103445337447d-1, & 3.1370664587788729d-1, & 3.6268378337836198d-1, & 2.7152459411754095d-2, & 6.2253523938647893d-2, & 9.5158511682492785d-2, & 1.2462897125553387d-1, & 1.4959598881657673d-1, & 1.6915651939500254d-1, & 1.8260341504492359d-1, & 1.8945061045506850d-1 /) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Generators} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Dumping Parameters} <<[[params.f90]]>>= program params use kinds use circe1 implicit none integer :: acc, ver, i real(kind=double), dimension(7), parameter :: roots = & (/ 90D0, 170D0, 350D0, 500D0, 800D0, 1000D0, 1500D0 /) do ver = 7, 8 print *, "VERSION ", ver do acc = TESLA, XBNDEE do 12 i = 1, 7 print *, "==============================" call circes (0d0, 0d0, roots(i), acc, ver, 20020307, 0) call dump () end do end do end do end program params @ <<[[params.f90]]>>= subroutine dump <> character(len=9) :: name select case (acc) case (SBAND) name = 'SBAND' case (TESLA) name = 'TESLA' case (JLCNLC) name = 'JLCNLC' case (SBNDEE) name = 'SBAND/EE' case (TESLEE) name = 'TESLA/EE' case (XBNDEE) name = 'JLCNLC/EE' case (ILC) name = 'ILC' case default print *, "Accelerator mode not recognized" end select write (*, 1000) name, circe1_params%roots write (*, 1001) 'e^+/e^-', circe1_params%lumi write (*, 1002) 'e^+/e^-', circe1_params%a1(0) write (*, 1003) 'e^+/e^-', 1 - circe1_params%a1(0) write (*, 1004) 'e^+/e^-', circe1_params%a1(1), circe1_params%a1(2), circe1_params%a1(3) write (*, 1003) 'gamma', circe1_params%a1(7) write (*, 1004) 'gamma', circe1_params%a1(4), circe1_params%a1(5), circe1_params%a1(6) 1000 format (A9, ' @ ', F5.0, ' GeV') 1001 format (4X, A7, ' lumi = ', F7.2,' * 10^32 cm^-2 sec^-1') 1002 format (4X, A7, ' delta strength = ', F9.5) 1003 format (4X, A7, ' integral(cont.) = ', F9.5) 1004 format (4X, A7, ' distribution = ', F9.5, ' * x^{', F9.5, '} * (1-x)^{', F9.5, '}') end subroutine dump @ % Local Variables: % mode:noweb % noweb-doc-mode:latex-mode % noweb-code-mode:f90-mode % indent-tabs-mode:nil % page-delimiter:"^@ %%%.*\n" % End: Index: trunk/circe1/src/taorng.nw =================================================================== --- trunk/circe1/src/taorng.nw (revision 8740) +++ trunk/circe1/src/taorng.nw (revision 8741) @@ -1,388 +1,387 @@ % taorng.nw -- -% $Id$ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \NeedsTeXFormat{LaTeX2e} \documentclass[a4paper]{article} \usepackage[euler]{thopp} \usepackage{amsmath,amsfonts} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \usepackage{noweb} \setlength{\unitlength}{1mm} \setlength{\nwmarginglue}{1em} %%% Saving paper: \def\nwendcode{\endtrivlist \endgroup} \nwcodepenalty=0 \let\nwdocspar\relax %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Some decorations depend on local stuff. Make it optional. \IfFileExists{thohacks.sty}% {\usepackage{thohacks}}% {\let\timestamp\today}% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \makeindex \begin{document} \title{% [[taorng]]:\\ The Random Number Generator from\\ \textit{The Art of Computer Programming}} \author{% Thorsten Ohl% \thanks{e-mail: \texttt{ohl@physik.uni-wuerzburg.de}}\\ \hfil\\ Universit\"at W\"urzburg \\ Emil-Hilb-Weg 22\\ D-97089 W\"urzburg\\ Germany} \preprintno{\hfil} \date{% \textbf{unpublished draft, printed \timestamp}} \maketitle \begin{abstract} This is the random number generated suggested by Don E.~Knuth in his errata list to \textit{The Art of Computer Programming}. \end{abstract} \tableofcontents %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Introduction} <>= ! Copyright (C) 1996 by Thorsten.Ohl@Physik.TH-Darmstadt.de ! ! Circe 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. ! ! Circe 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. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Implementation} <<[[taorng.f90]]>>= c taorng.f90 -- <> <> <> @ <<*>>= ! taorng.f -- <> <> <> @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{User routines} A random real $r \in [0,1)$: <>= function taorng (seed) integer :: seed real(kind=double) :: taorng <> real(kind=double), parameter :: INVMM = 1D0/MM) <> taorng = INVMM * a(i) end function taorng @ %def taorng @ DEK call for at least $N \ge 100$, but recommends $N \ge 1000$: <>= integer, parameter :: N = 1000 @ <>= <> integer :: i integer, dimension(N) :: a(N) data i / N / save a, i i = i + 1 if (i .gt. N) then call taorna (a, N, seed) i = 1 end if @ A random integer $i$ with $0 \le i < 2^{30} = 1073741824$ <>= function taorni (seed) implicit none integer seed <> taorni = a(i) end function taorng @ <>= integer, parameter :: MM = 2**30 @ Fill the array $a_1,\ldots,a_n$ with random integers $0 \le a_i < 2^{30}$ <>= subroutine taorna (a, n, seed) integer, dimension(:), intent(in) :: a integer :: n, seed <> <> <> if ((seed .gt. 0) .or. (.not. init)) then <> <> init = .true. end if <> end subroutine taorna @ %def taorna @ <>= integer, parameter :: KK = 100, LL = 37, & TT = 20, KKK = KK+KK-1 integer, parameter :: SEEDMX = 2**30 - 1 <> @ <>= integer, dimension(KKK) :: x(KKK) integer :: j, ss, t @ <>= integer, dimension(KK), save :: ranx logical, save :: init = .false. @ <>= do j = 1, KK a(j) = ranx(j) end do do j = KK+1, N a(j) = a(j-KK) - a(j-LL) if (a(j) .lt. 0) a(j) = a(j) + MM end do do j = 1, LL ranx(j) = a(N+j-KK) - a(N+j-LL) if (ranx(j) .lt. 0) ranx(j) = ranx(j) + MM end do do j = LL+1, KK ranx(j) = a(N+j-KK) - ranx(j-LL) if (ranx(j) .lt. 0) ranx(j) = ranx(j) + MM end do @ <>= if ((seed .lt. 0) .or. (seed .gt. SEEDMX)) then print *, 'rnstrt: seed (', seed, ') not in (0,', SEEDMX, ')!' print *, 'rnstrt: seed set to 0.' seed = 0 end if @ <>= ss = seed - mod (seed, 2) + 2 do j = 1, KK x(j) = ss ss = ss + ss if (ss .ge. MM) ss = ss - MM + 2 end do do j = KK+1, KKK x(j) = 0 end do x(2) = x(2) + 1 ss = seed t = TT - 1 do do j = KK, 2, -1 x(j+j-1) = x(j) end do do j = KKK, KK-LL+1, -2 x(KKK-j+2) = x(j) - mod (x(j), 2) end do do j = KKK, KK+1, -1 if (mod (x(j), 2) .eq. 1) then x(j-(KK-LL)) = x(j-(KK-LL)) - x(j) if (x(j-(KK-LL)) .lt. 0) & x(j-(KK-LL)) = x(j-(KK-LL)) + MM x(j-KK) = x(j-KK) - x(j) if (x(j-KK) .lt. 0) x(j-KK) = x(j-KK) + MM end if end do if (mod (ss, 2) .eq. 1) then do j = KK, 1, -1 x(j+1) = x(j) end do x(1) = x(KK+1) if (mod (x(KK+1), 2) .eq. 1) then x(LL+1) = x(LL+1) - x(KK+1) if (x(LL+1) .lt. 0) x(LL+1) = x(LL+1) + MM end if end if if (ss .ne. 0) then ss = ss / 2 else t = t - 1 end if if (t .le. 0) exit end do do j = 1, LL ranx(j+KK-LL) = x(j) end do do j = LL+1, KK ranx(J-LL) = x(j) end do @ <>= program rtest use kinds implicit none real(kind=double) :: r1, r2, dekran, taorng integer :: i print *, dekran (0), taorng (0) do i = 1, 100 000 000 r1 = dekran (0) r2 = taorng (0) if (r1 .ne. r2) print *, r1, ' != ', r2 end do print *, dekran (0), taorng (0) end program rtest function dekran (seed) integer :: seed real(kind=double) :: dekran real(kind=double), parameter :: MM = 2D0**30, INVMM = 1D0/MM !!! N >= 100, but n >= 1000 recommended integer, parameter :: N = 1000 integer, save :: i integer, dimension(N), save :: a logical, save :: init = .false. if ((seed .gt. 0) .or. (.not. init)) then call rnstrt (seed) init = .true. i = N + 1 end if if (i .gt. N) then call rnarry (a, N) i = 1 end if dekran = INVMM * a(i) i = i + 1 end function dekran @ <>= subroutine rnarry (aa, n) integer :: n integer, dimension(n) :: aa integer, parameter :: KK = 100, LL = 37, MM = 2**30 integer, dimension(KK), save :: ranx !!! common /rstate/ ranx !!! save /rstate/ integer :: j do j = 1, KK aa(j) = ranx(j) end do do j = KK+1, n aa(j) = aa(j-KK) - aa(j-LL) if (aa(j) .lt. 0) aa(j) = aa(j) + MM end do do j = 1, LL ranx(j) = aa(n+j-KK) - aa(n+j-LL) if (ranx(j) .lt. 0) ranx(j) = ranx(j) + MM end do do j = LL+1, KK ranx(j) = aa(n+j-KK) - ranx(j-LL) if (ranx(j) .lt. 0) ranx(j) = ranx(j) + MM end do end subroutine rnarry @ %def rnarry @ <>= subroutine rnstrt (seed) integer :: seed integer, parameter :: KK = 100, LL = 37, MM = 2**30, TT = 20, & KKK = KK+KK-1 integer, parameter :: SEEDMX = 2**30 - 1 integer, dimension(KK), save :: ranx(KK) !!! common /rstate/ ranx !!! save /rstate/ integer, dimension(KKK) :: x(KKK) integer :: j, ss, t if ((seed .lt. 0) .or. (seed .gt. SEEDMX)) then print *, 'rnstrt: seed (', seed, ') not in (0,', SEEDMX, ')!' print *, 'rnstrt: seed set to 0.' seed = 0 end if ss = seed - mod (seed, 2) + 2 do j = 1, KK x(j) = ss ss = ss + ss if (ss .ge. MM) ss = ss - MM + 2 end do do j = KK+1, KKK x(j) = 0 end do x(2) = x(2) + 1 ss = seed t = TT - 1 do do j = KK, 2, -1 x(j+j-1) = x(j) end do do j = KKK, KK-LL+1, -2 x(KKK-j+2) = x(j) - mod (x(j), 2) end do do j = KKK, KK+1, -1 if (mod (x(j), 2) .eq. 1) then x(j-(KK-LL)) = x(j-(KK-LL)) - x(j) if (x(j-(KK-LL)) .lt. 0) x(j-(KK-LL)) = x(j-(KK-LL)) + MM x(j-KK) = x(j-KK) - x(j) if (x(j-KK) .lt. 0) x(j-KK) = x(j-KK) + MM end if end do if (mod (ss, 2) .eq. 1) then do j = KK, 1, -1 x(j+1) = x(j) end do x(1) = x(KK+1) if (mod (x(KK+1), 2) .eq. 1) then x(LL+1) = x(LL+1) - x(KK+1) if (x(LL+1) .lt. 0) x(LL+1) = x(LL+1) + MM end if end if if (ss .ne. 0) then ss = ss / 2 else t = t - 1 end if if (t .le. 0) exit end do do j = 1, LL ranx(j+KK-LL) = x(j) end do do j = LL+1, KK ranx(J-LL) = x(j) end do end subroutine rnstrt @ %def rnstrt @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection*{Acknowledgements} Thanks to Don Knuth for making it available. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection*{Identifiers} \nowebindex \subsection*{Refinements} \nowebchunks \InputIfFileExists{\jobname.ind}{}{} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{thebibliography} \bibitem{Knu96b} D.E.~Knuth, 1996, (unpublished). \bibitem{Knu96b} D.E.~Knuth, 1996, (unpublished). \end{thebibliography} {circe} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \end{document} \endinput Local Variables: mode:noweb noweb-doc-mode:latex-mode noweb-code-mode:fortran-mode indent-tabs-mode:nil page-delimiter:"^@ %%%.*\n" End: Index: trunk/circe2/share/doc/tex-comments.sh =================================================================== --- trunk/circe2/share/doc/tex-comments.sh (revision 8740) +++ trunk/circe2/share/doc/tex-comments.sh (revision 8741) @@ -1,23 +1,23 @@ #! /usr/bin/awk -f -# $Id: tex-comments.sh 314 2010-04-17 20:32:33Z ohl $ +# tex-comments.sh -- /^@begin docs / { code = 0 } /^@begin code / { code = 1 } code && /^@text .*![:$]/ { if (match($0, /!:.*$/)) { printf("%s\n", substr($0, 1, RSTART-1)) printf("@literal ! {\\setupmodname %s}\n", substr($0, RSTART+2)) next } if (match($0, /!\$.*$/)) { printf("%s\n", substr($0, 1, RSTART-1)) printf("@literal ! {\\setupmodname$ %s $}\n", substr($0, RSTART+2)) next } } # Hide a trick for Poor Man's Elemental Procedures code { gsub(/`'_/, "_") } { print } Index: trunk/circe2/share/data/Makefile.am =================================================================== --- trunk/circe2/share/data/Makefile.am (revision 8740) +++ trunk/circe2/share/data/Makefile.am (revision 8741) @@ -1,28 +1,27 @@ # Makefile.am -- -# $Id: Makefile.am 314 2010-04-17 20:32:33Z ohl $ ######################################################################## DATAFILES = \ ilc200.circe \ ilc230.circe \ ilc250.circe \ ilc350.circe \ ilc500.circe \ 250_SetA_ee024.circe \ 250_SetA_eg024.circe \ 250_SetA_ge024.circe \ 250_SetA_gg024.circe \ 500_TDR_ws_ee021.circe \ 500_TDR_ws_eg021.circe \ 500_TDR_ws_ge021.circe \ 500_TDR_ws_gg021.circe \ cepc240.circe \ cepc250.circe \ teslagg_500_polavg.circe \ teslagg_500.circe EXTRA_DIST = $(DATAFILES) ## Data files needed for running CIRCE2 datacirce2dir = $(pkgdatadir)/../circe2/data dist_datacirce2_DATA = $(DATAFILES) Index: trunk/circe2/src/tao_random_numbers.f90 =================================================================== --- trunk/circe2/src/tao_random_numbers.f90 (revision 8740) +++ trunk/circe2/src/tao_random_numbers.f90 (revision 8741) @@ -1,787 +1,784 @@ ! tao_random_numbers.f90 -- ! Copyright (C) 1998 by Thorsten Ohl ! ! VAMP 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. ! ! VAMP 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 use kinds implicit none integer, parameter, private :: tao_i32 = selected_int_kind (9) integer, parameter, private :: tao_r64 = selected_real_kind (15) 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 :: write_state_array private :: read_state_array private :: & integer_stateless, integer_array_stateless, & real_stateless, real_array_stateless private :: integer_static, integer_state, & integer_array_static, integer_array_state, & real_static, real_state, real_array_static, real_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_number module procedure integer_static, integer_state, & integer_array_static, integer_array_state, & real_static, real_state, real_array_static, real_array_state end interface 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=tao_i32), parameter, private :: M = 2**30 integer(kind=tao_i32), dimension(K), save, private :: s_state logical, save, private :: s_virginal = .true. integer(kind=tao_i32), 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 private integer(kind=tao_i32), dimension(K) :: x end type tao_random_raw_state type, public :: tao_random_state private type(tao_random_raw_state) :: state integer(kind=tao_i32), dimension(:), allocatable :: buffer integer :: buffer_end, last end type tao_random_state - character(len=*), public, parameter :: TAO_RANDOM_NUMBERS_RCS_ID = & - "$Id: tao_random_numbers.nw 314 2010-04-17 20:32:33Z 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) 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 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(kind=default), intent(in) :: consumption call luxury_state_integer (s, int (consumption * size (s%buffer))) end subroutine luxury_state_real 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(kind=default), 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 pure subroutine generate (a, state) integer(kind=tao_i32), 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=tao_i32), 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=tao_i32), 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_tao_i32) do j= 2*K-1, K+1, -1 if (modulo (x(j), int(2, tao_i32)) == 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_tao_i32) == 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=tao_i32), 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=tao_i32), 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=tao_r64), 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=tao_r64), 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=tao_r64), 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=tao_r64), 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=tao_i32), 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=tao_i32), dimension(:), intent(inout) :: state, buffer integer, intent(in) :: buffer_end integer, intent(inout) :: last real(kind=default), intent(out) :: r real(kind=default), parameter :: NORM = 1.0_default / 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 integer_array_stateless & (state, buffer, buffer_end, last, v, num) integer(kind=tao_i32), 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=tao_i32), dimension(:), intent(inout) :: state, buffer integer, intent(in) :: buffer_end integer, intent(inout) :: last real(kind=default), dimension(:), intent(out) :: v integer, optional, intent(in) :: num real(kind=default), parameter :: NORM = 1.0_default / 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 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(kind=default), 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(kind=default), 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(kind=default), 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(kind=default), 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=tao_r64), 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: trunk/vamp/share/doc/preview2.tex =================================================================== --- trunk/vamp/share/doc/preview2.tex (revision 8740) +++ trunk/vamp/share/doc/preview2.tex (revision 8741) @@ -1,1110 +1,1110 @@ -% $Id: preview2.tex 314 2010-04-17 20:32:33Z ohl $ +% preview2.tex -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \iffalse %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% To: hep-ph@xxx.lanl.gov Subject: put \\ Title: Yet Another Approach to Small and Medium Scale Parallelization of Adaptive Monte Carlo Integration Author: Thorsten Ohl (TU Darmstadt) Comments: ?? pages, LaTeX (using amsmath.sty) Report-no: IKDA 98/?? \\ ... \\ \fi %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \NeedsTeXFormat{LaTeX2e} \newif\ifPDFLaTeX \expandafter\ifx\csname pdfoutput\endcsname\relax \PDFLaTeXfalse \else \PDFLaTeXtrue \fi \ifPDFLaTeX \documentclass[12pt,a4paper]{article} \usepackage{type1cm} \usepackage{amsmath,amssymb,amscd} \allowdisplaybreaks \usepackage{feynmp} \setlength{\unitlength}{1mm} \usepackage{emp} \empaddtoprelude{input graph;} \setlength{\unitlength}{1mm} \DeclareGraphicsRule{*}{mps}{*}{} \usepackage[colorlinks]{hyperref} \def\pdffit{fit} \else %%% `normal' LaTeX2e \documentclass[12pt,a4paper]{article} \usepackage{amsmath,amssymb,amscd} \allowdisplaybreaks \usepackage{feynmp} \setlength{\unitlength}{1mm} \usepackage{emp} \empaddtoprelude{input graph;} \fi \usepackage{verbatim} \makeatletter \def\verbatimcmd{% \small \@verbatim \catcode`\\=0 \catcode`\{=1 \catcode`\}=2 % \catcode`\$=3 \frenchspacing\@vobeyspaces\verbatim@start} \def\endverbatimcmd{% \let\par\relax \def\verbatim@{\endtrivlist\endgroup}% \begingroup} \makeatother \newcommand{\verbatimesc}[1]{% \textit{$\langle\langle$\ #1\ $\rangle\rangle$}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \DeclareMathOperator{\Vol}{Vol} \DeclareMathOperator{\atan}{atan} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \makeindex \begin{document} \title{% Yet~Another~Approach to Small~and~Medium~Scale~Parallelization of Adaptive~Monte~Carlo~Integration} \author{% Thorsten Ohl% \thanks{e-mail: \texttt{ohl@hep.tu-darmstadt.de}} {}\thanks{Supported by Bundesministerium f\"ur Bildung, Wissenschaft, Forschung und Technologie, Germany.}\\ \hfil \\ Darmstadt University of Technology \\ Schlo\ss gartenstr.~9 \\ D-64289 Darmstadt \\ Germany} \date{% IKDA 98/??\\ hep-ph/yymmnnn\\ July 1998} \maketitle \begin{abstract} \ldots \end{abstract} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{empfile} \begin{fmffile}{\jobname pics} \fmfset{curly_len}{2mm} \fmfset{wiggly_len}{3mm} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% (Ab)use FeynMF for drawing portable commutative diagrams \fmfcmd{% style_def isomorphism expr p = cdraw (subpath (0, 1 - arrow_len/pixlen(p,10)) of p); cfill (harrow (p, 1)) enddef; style_def morphism expr p = draw_dots (subpath (0, 1 - arrow_len/pixlen(p,10)) of p); cfill (harrow (p, 1)) enddef;} \def\fmfcd(#1,#2){% \begin{minipage}{#1\unitlength}% \vspace*{.5\baselineskip}% \begin{fmfgraph*}(#1,#2)% \fmfset{arrow_len}{3mm}% \fmfset{arrow_ang}{10}% \fmfstraight} \def\endfmfcd{% \end{fmfgraph*}% \vspace*{.5\baselineskip}% \end{minipage}} \newcommand{\fmfcdmorphism}[4]{% \fmf{#1,label.side=#2,label.dist=3pt,label={\small $#4$}}{#3}} \newcommand{\fmfcdisomorph}[3][left]{% \fmfcdmorphism{isomorphism}{#1}{#2}{#3}} \newcommand{\fmfcdmorph}[3][left]{% \fmfcdmorphism{morphism}{#1}{#2}{#3}} \newcommand{\fmfcdeq}[1]{\fmf{double}{#1}} \def\fmfcdsetaux[#1]#2{% \fmfv{decor.shape=circle,decor.size=18pt,foreground=white, label.dist=0,label=$#1$}{#2}} \makeatletter \def\fmfcdset{\@dblarg{\fmfcdsetaux}} \makeatother %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{empcmds} numeric pi; pi = 180; vardef adap_fct_one (expr x) = (x + sind(2*x*pi)/8) enddef; vardef adap_fct_two (expr x) = (x + sind(4*x*pi)/16) enddef; vardef adap_fct (expr x) = adap_fct_two (x) enddef; vardef drawbar expr p = draw ((0,-.5)--(0,.5)) scaled 1mm shifted p enddef; \end{empcmds} \begin{empcmds} vardef pseudo (expr xlo, xhi, ylo, yhi, equ_lo, equ_hi, equ_div, adap_lo, adap_hi, adap_div, r, do_labels, do_arrow) = pair equ_grid.lo, equ_grid.hi, adap_grid[]lo, adap_grid[]hi; ypart (equ_grid.lo) = ypart (equ_grid.hi); ypart (adap_grid[1]lo) = ypart (adap_grid[1]hi); ypart (adap_grid[2]lo) = ypart (adap_grid[2]hi); xpart (equ_grid.lo) = xpart (adap_grid[1]lo) = xpart (adap_grid[2]lo); xpart (equ_grid.hi) = xpart (adap_grid[1]hi) = xpart (adap_grid[2]hi); equ_grid.hi = (xhi, yhi); adap_grid[1]lo = .5[equ_grid.lo,adap_grid[2]lo]; adap_grid[2]lo = (xlo, ylo); numeric rp, rm; rp = ceiling r; rm = floor r; pickup pencircle scaled .5pt; for i = adap_lo upto adap_hi: draw (i/adap_div)[adap_grid[1]lo,adap_grid[1]hi] -- (adap_fct(i/adap_div))[adap_grid[2]lo,adap_grid[2]hi] withcolor 0.7white; endfor if do_arrow: fill (rm/adap_div)[adap_grid[1]lo,adap_grid[1]hi] -- (rp/adap_div)[adap_grid[1]lo,adap_grid[1]hi] -- (adap_fct(rp/adap_div))[adap_grid[2]lo,adap_grid[2]hi] -- (adap_fct(rm/adap_div))[adap_grid[2]lo,adap_grid[2]hi] -- cycle withcolor 0.7white; fi if do_labels: label.lft (btex \texttt{0} etex, equ_grid.lo); label.rt (btex \texttt{d\%ng} etex, equ_grid.hi); fi draw (equ_lo/equ_div)[equ_grid.lo,equ_grid.hi] -- (equ_hi/equ_div)[equ_grid.lo,equ_grid.hi]; for i = equ_lo upto equ_hi: drawbar (i/equ_div)[equ_grid.lo,equ_grid.hi]; endfor if do_labels: label.lft (btex $\xi$, \texttt{i: 0} etex, adap_grid[1]lo); label.rt (btex \texttt{ubound(d\%x)} etex, adap_grid[1]hi); label.lft (btex \texttt{d\%x: 0} etex, adap_grid[2]lo); label.rt (btex \texttt{1} etex, adap_grid[2]hi); fi draw (adap_lo/adap_div)[adap_grid[1]lo,adap_grid[1]hi] -- (adap_hi/adap_div)[adap_grid[1]lo,adap_grid[1]hi]; draw (adap_fct(adap_lo/adap_div))[adap_grid[2]lo,adap_grid[2]hi] -- (adap_fct(adap_hi/adap_div))[adap_grid[2]lo,adap_grid[2]hi]; for i = adap_lo upto adap_hi: drawbar (i/adap_div)[adap_grid[1]lo,adap_grid[1]hi]; drawbar (adap_fct(i/adap_div))[adap_grid[2]lo,adap_grid[2]hi]; endfor if do_arrow: pickup pencircle scaled 1pt; pair cell, ia, grid; ia = (r/adap_div)[adap_grid[1]lo,adap_grid[1]hi]; cell = ia shifted (equ_grid.hi - adap_grid[1]hi); grid = (adap_fct(r/adap_div))[adap_grid[2]lo,adap_grid[2]hi]; if do_labels: label.top (btex \texttt{cell - r} etex, cell); fi drawarrow cell -- ia; drawarrow ia -- grid; if do_labels: label.bot (btex \texttt{x} etex, grid); fi fi enddef; \end{empcmds} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Introduction} The problem of the parallelization of adaptive Monte Carlo integration algorithms has gained some attention recently~\cite{Krecker:1997:Parallel-Vegas,Veseli:1998:Parallel-Vegas}. Both authors present parallel versions of the Vegas algorithm~\cite{Lepage:1978:vegas}. The implementations start from the classic implementation of Vegas and add synchronization barriers, either mutexes for threads accessing shared memory or explicit message passing. This approach results in compact code and achieves high performance, but the implementations of threads bases parallelism on one hand and message passing on the other are very different. Therefore, a close coupling of parallelization and of the integration algorithm sacrifices flexibility. Even the move from one message passing library to another is a non trivial exercise with many subtle failure modes. The same is true for any improvement of the integration algorithm. Instead, we suggest a \emph{mathematical} model of parallelism for adaptive Monte Carlo integration that is independent both of a concrete paradigm for parallelism and of the programming language used for an implementation. We decompose the algorithm and prove that certain parts can be executed in \emph{any} order without changing the result. As a corollary, we know that they can be executed in parallel. The algorithms presented below have been implemented successfully in the library VAMP~\cite{Ohl:1998:VAMP}, along with other, independent, improvements of Vegas~\cite{Ohl:1998:VAMP-preview}. In section~\ref{sec:vegas} we discuss the features of Vegas, that are important for our model. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Vegas} \label{sec:vegas} In this section we discuss the features of Vegas, that are important for building a model of parallelism, but are not discussed in~\cite{Lepage:1978:vegas}. Vegas uses two \emph{grids}: an adaptive grid~$G^A$, which is used to adapt the distribution of the sampling points and a stratification grid~$G^S$ for stratified sampling. The latter is static and depends only on the number of dimensions and on the number of sampling points. Both grids factorize into \emph{divisions}~$d_{A,S}^i$ \begin{subequations} \begin{align} G^A &= d^A_1 \otimes d^A_2 \otimes \cdots \otimes d^A_n \\ G^S &= d^S_1 \otimes d^S_2 \otimes \cdots \otimes d^S_n \,. \end{align} \end{subequations} The divisions come in three kinds \begin{subequations} \begin{align} \label{eq:importance} d^S_i &= \emptyset &&\text{(importance sampling)} \\ \label{eq:stratified} d^A_i &= d^S_i/m &&\text{(stratified sampling)} \\ \label{eq:pseudo} d^A_i &\not= d^S_i/m &&\text{(pseudo-stratified sampling)}\,. \end{align} \end{subequations} In the classic implementation of Vegas~\cite{Lepage:1978:vegas}, \emph{all} divisions are of the same type. In a more general implementation~\cite{Ohl:1998:VAMP}, this is not required and it can be useful to use stratification only in a few dimensions. \begin{empcmds} vardef layout = pair ul, ur, ll, lr; ypart (ul) = ypart (ur); ypart (ll) = ypart (lr); xpart (ul) = xpart (ll); xpart (ur) = xpart (lr); numeric weight_width, weight_dist; weight_width = 0.1w; weight_dist = 0.05w; ll = (.1w,.1w); ur = (w-weight_width-weight_dist,h-weight_width-weight_dist); numeric equ_div, adap_div, rx, ry, rxp, rxm, ryp, rym; equ_div = 3; adap_div = 8; rx = 5.2; ry = 3.6; rxp = ceiling rx; rxm = floor rx; ryp = ceiling ry; rym = floor ry; numeric pi; pi = 180; vardef adap_fct_x (expr x) = (x + sind(2*x*pi)/8) enddef; vardef weight_x (expr x) = (1 + 2*sind(1*x*pi)**2) / 3 enddef; vardef adap_fct_y (expr x) = (x + sind(4*x*pi)/16) enddef; vardef weight_y (expr x) = (1 + 2*sind(2*x*pi)**2) / 3 enddef; vardef grid_pos (expr i, j) = (adap_fct_y(j/adap_div))[(adap_fct_x(i/adap_div))[ll,lr], (adap_fct_x(i/adap_div))[ul,ur]] enddef; vardef grid_square (expr i, j) = grid_pos (i,j) -- grid_pos (i+1,j) -- grid_pos (i+1,j+1) -- grid_pos (i,j+1) -- cycle enddef; enddef; vardef decoration = fill (lr shifted (weight_y(0)*(weight_width,0)) for y = .1 step .1 until 1.01: .. y[lr,ur] shifted (weight_y(y)*(weight_width,0)) endfor -- ur -- lr -- cycle) shifted (weight_dist,0) withcolor 0.7white; fill (ul shifted (weight_x(0)*(0,weight_width)) for x = .1 step .1 until 1.01: .. x[ul,ur] shifted (weight_x(x)*(0,weight_width)) endfor -- ur -- ul -- cycle) shifted (0,weight_dist) withcolor 0.7white; picture px, py; px = btex $p_1(x_1)$ etex; py = btex $p_2(x_2)$ etex; label.top (image (unfill bbox px; draw px), .5[ul,ur] shifted (0,weight_dist)); label.rt (image (unfill bbox py; draw py), .75[lr,ur] shifted (weight_dist,0)); label.lrt (btex $\mathcal{D}_{1,1}$ etex, ll); label.bot (btex $x_1$ etex, .5[ll,lr]); label.bot (btex $\mathcal{D}_{2,1}$ etex, lr); label.ulft (btex $\mathcal{D}_{1,2}$ etex, ll); label.lft (btex $x_2$ etex, .5[ll,ul]); label.lft (btex $\mathcal{D}_{2,2}$ etex, ul); enddef; \end{empcmds} \begin{figure} \begin{center} \begin{emp}(55,50) layout; fill grid_square (rxm,rym) withcolor 0.7white; pickup pencircle scaled .7pt; for i = 0 upto adap_div: draw grid_pos(i,0) -- grid_pos(i,adap_div); draw grid_pos(0,i) -- grid_pos(adap_div,i); endfor pickup pencircle scaled 2pt; drawdot grid_pos(rx,ry); decoration; \end{emp} \begin{emp}(55,50) layout; vardef grid_sub_pos (expr i, di, j, dj) = (dj/equ_div)[(di/equ_div)[grid_pos(i,j),grid_pos(i+1,j)], (di/equ_div)[grid_pos(i,j+1),grid_pos(i+1,j+1)]] enddef; vardef grid_sub_square (expr i, di, j, dj) = grid_sub_pos (i,di,j,dj) -- grid_sub_pos (i,di+1,j,dj) -- grid_sub_pos (i,di+1,j,dj+1) -- grid_sub_pos (i,di,j,dj+1) -- cycle enddef; fill grid_square (rxm,rym) withcolor 0.8white; fill grid_sub_square (rxm,0,rym,1) withcolor 0.6white; pickup pencircle scaled .7pt; for i = 0 upto adap_div: draw grid_pos(i,0) -- grid_pos(i,adap_div); draw grid_pos(0,i) -- grid_pos(adap_div,i); endfor pickup pencircle scaled .5pt; for i = 0 upto (adap_div-1): for j = 1 upto (equ_div-1): draw grid_sub_pos(i,j,0,0) -- grid_sub_pos(i,j,adap_div,0) dashed evenly; draw grid_sub_pos(0,0,i,j) -- grid_sub_pos(adap_div,0,i,j) dashed evenly; endfor endfor pickup pencircle scaled 2pt; drawdot grid_pos(rx,ry); decoration; \end{emp} \end{center} \caption{\label{fig:nonstrat/strat}% Vegas grid structure for importance sampling~(\ref{eq:importance}) on the left and for genuinely stratified sampling~(\ref{eq:stratified}) on the right. The latter is used in low dimensions only.} \end{figure} Two-dimensional grids for the cases~(\ref{eq:importance}) and~(\ref{eq:stratified}) are illustrated in figure~\ref{fig:nonstrat/strat}. In case~(\ref{eq:importance}), there is no stratification grid and the points are picked at random in the whole region according to~$G_A$. In case~(\ref{eq:stratified}), the adaptive grid~$G_A$ is a regular subgrid of the stratification grid~$G_S$ and an equal number of points are picked at random in each cell of~$G_S$. Since~$d^A_i = d^S_i/m$, the points will be distributed according to~$G_A$ as well. \begin{empcmds} numeric pi; pi = 180; vardef adap_fct_one (expr x) = (x + sind(2*x*pi)/8) enddef; vardef adap_fct_two (expr x) = (x + sind(4*x*pi)/16) enddef; vardef adap_fct (expr x) = adap_fct_two (x) enddef; vardef drawbar expr p = draw ((0,-.5)--(0,.5)) scaled 1mm shifted p enddef; \end{empcmds} \begin{empcmds} vardef pseudo (expr xlo, xhi, ylo, yhi, equ_lo, equ_hi, equ_div, adap_lo, adap_hi, adap_div, r, do_labels, do_arrow) = pair equ_grid.lo, equ_grid.hi, adap_grid[]lo, adap_grid[]hi; ypart (equ_grid.lo) = ypart (equ_grid.hi); ypart (adap_grid[1]lo) = ypart (adap_grid[1]hi); ypart (adap_grid[2]lo) = ypart (adap_grid[2]hi); xpart (equ_grid.lo) = xpart (adap_grid[1]lo) = xpart (adap_grid[2]lo); xpart (equ_grid.hi) = xpart (adap_grid[1]hi) = xpart (adap_grid[2]hi); equ_grid.hi = (xhi, yhi); adap_grid[1]lo = .5[equ_grid.lo,adap_grid[2]lo]; adap_grid[2]lo = (xlo, ylo); numeric rp, rm; rp = ceiling r; rm = floor r; pickup pencircle scaled .5pt; for i = adap_lo upto adap_hi: draw (i/adap_div)[adap_grid[1]lo,adap_grid[1]hi] -- (adap_fct(i/adap_div))[adap_grid[2]lo,adap_grid[2]hi] withcolor 0.7white; endfor if do_arrow: fill (rm/adap_div)[adap_grid[1]lo,adap_grid[1]hi] -- (rp/adap_div)[adap_grid[1]lo,adap_grid[1]hi] -- (adap_fct(rp/adap_div))[adap_grid[2]lo,adap_grid[2]hi] -- (adap_fct(rm/adap_div))[adap_grid[2]lo,adap_grid[2]hi] -- cycle withcolor 0.7white; fi if do_labels: label.lft (btex \texttt{0} etex, equ_grid.lo); label.rt (btex \texttt{d\%ng} etex, equ_grid.hi); fi draw (equ_lo/equ_div)[equ_grid.lo,equ_grid.hi] -- (equ_hi/equ_div)[equ_grid.lo,equ_grid.hi]; for i = equ_lo upto equ_hi: drawbar (i/equ_div)[equ_grid.lo,equ_grid.hi]; endfor if do_labels: label.lft (btex $\xi$, \texttt{i: 0} etex, adap_grid[1]lo); label.rt (btex \texttt{ubound(d\%x)} etex, adap_grid[1]hi); label.lft (btex \texttt{d\%x: 0} etex, adap_grid[2]lo); label.rt (btex \texttt{1} etex, adap_grid[2]hi); fi draw (adap_lo/adap_div)[adap_grid[1]lo,adap_grid[1]hi] -- (adap_hi/adap_div)[adap_grid[1]lo,adap_grid[1]hi]; draw (adap_fct(adap_lo/adap_div))[adap_grid[2]lo,adap_grid[2]hi] -- (adap_fct(adap_hi/adap_div))[adap_grid[2]lo,adap_grid[2]hi]; for i = adap_lo upto adap_hi: drawbar (i/adap_div)[adap_grid[1]lo,adap_grid[1]hi]; drawbar (adap_fct(i/adap_div))[adap_grid[2]lo,adap_grid[2]hi]; endfor if do_arrow: pickup pencircle scaled 1pt; pair cell, ia, grid; ia = (r/adap_div)[adap_grid[1]lo,adap_grid[1]hi]; cell = ia shifted (equ_grid.hi - adap_grid[1]hi); grid = (adap_fct(r/adap_div))[adap_grid[2]lo,adap_grid[2]hi]; if do_labels: label.top (btex \texttt{cell - r} etex, cell); fi drawarrow cell -- ia; drawarrow ia -- grid; if do_labels: label.bot (btex \texttt{x} etex, grid); fi fi enddef; \end{empcmds} \begin{figure} \begin{center} \begin{emp}(120,30) pseudo (.3w, .8w, .1h, .8h, 0, 8, 8, 0, 12, 12, 5.2, true, true); \end{emp} \end{center} \caption{\label{fig:pseudo}% One-dimensional illustration of the \texttt{vegas} grid structure for pseudo stratified sampling, which is used in high dimensions.} \end{figure} A one-dimensional illustration of~(\ref{eq:pseudo}) is shown in figure~(\ref{fig:pseudo}). The case~(\ref{eq:pseudo}) is the most complicated. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Parallelization} \label{sec:parallelization} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Formalization of Adaptive Sampling} \label{sec:adaptive-sampling} In order to discuss the problems with parallelizing adaptive integration algorithms and to present solutions, it helps to introduce some mathematical notation. A sampling~$S$ is a map from the space~$\pi$ of point sets and the space~$F$ of functions to the real (or complex) numbers \begin{equation*} \begin{aligned} S: \pi \times F & \to \mathbf{R} \\ (p,f) & \mapsto I = S(p,f) \end{aligned} \end{equation*} For our purposes, we have to be more specific about the nature of the point set. In general, the point set will be characterized by a sequence of pseudo random numbers~$\rho\in R$ and by one or more grids~$G\in\Gamma$ used for importance or stratified sampling. A simple sampling \begin{equation} \label{eq:S0} \begin{aligned} S_0: R \times \Gamma \times A \times F \times\mathbf{R}\times\mathbf{R} & \to R \times \Gamma \times A \times F \times\mathbf{R}\times\mathbf{R}\\ (\rho, G, a, f, \mu_1, \mu_2) & \mapsto (\rho', G, a', f, \mu_1', \mu_2') = S_0 (\rho, G, a, f, \mu_1, \mu_2) \end{aligned} \end{equation} estimates the $n$-th moments $\mu_n'\in\mathbf{R}$ of the function~$f\in F$. The integral and its standard deviation can be derived easily from the moments \begin{subequations} \begin{align} I &= \mu_1 \\ \sigma^2 &= \frac{1}{N-1} \left(\mu_2 - \mu_1^2\right) \end{align} \end{subequations} while the latter are more convenient for the following discussion. In addition, $S_0$ collects auxiliary information to be used in the grid refinement, denoted by~$a\in A$. The unchanged arguments~$G$ and~$f$ have been added to the result of~$S_0$ in~(\ref{eq:S0}), so that~$S_0$ has identical domain and codomain and can therefore be iterated. Previous estimates~$\mu_n$ may be used in the estimation of~$\mu_n'$, but a particular~$S_0$ is free to ignore them as well. Using a little notational freedom, we augment~$\mathbf{R}$ and~$A$ with a special value~$\bot$, which will always be discarded by~$S_0$. In an adaptive integration algorithm, there is also a refinement operation~$r:\Gamma\times A \to\Gamma$ that can be extended naturally to the codomain of~$S_0$ \begin{equation} \begin{aligned} r: R \times \Gamma \times A \times F \times\mathbf{R}\times\mathbf{R} & \to R \times \Gamma \times A \times F \times\mathbf{R}\times\mathbf{R}\\ (\rho, G, a, f, \mu_1, \mu_2) & \mapsto (\rho, G', a, f, \mu_1, \mu_2) = r (\rho, G, a, f, \mu_1, \mu_2) \end{aligned} \end{equation} so that~$S=rS_0$ is well defined and we can specify $n$-step adaptive sampling as \begin{equation} \label{eq:Sn} S_n = S_0 (rS_0)^n \end{equation} Since, in a typical application, only the estimate of the integral and the standard deviation are used, a projection can be applied to the result of~$S_n$: \begin{equation} \label{eq:P} \begin{aligned} P: R \times \Gamma \times A \times F \times\mathbf{R}\times\mathbf{R} & \to \mathbf{R}\times\mathbf{R}\\ (\rho, G, a, f, \mu_1, \mu_2) & \mapsto (I,\sigma) \end{aligned} \end{equation} Then \begin{equation} (I,\sigma) = P S_0 (rS_0)^n (\rho, G_0, \bot, f, \bot, \bot) \end{equation} and a good refinement prescription~$r$, such as Vegas, will minimize the~$\sigma$. For parallelization, it is crucial to find a division of~$S_n$ or any part of it into \emph{independent} pieces that can be evaluated in parallel. In order to be effective, $r$ has to be applied to \emph{all} of~$a$ and therefore a sychronization of~$G$ before and after~$r$ is appropriately. Forthermore, $r$ usually uses only a tiny fraction of the CPU time and it makes little sense to invest a lot of effort into parallelizing it beyond what the Fortran compiler can infer from array notation. On the other hand, $S_0$ can be parallelized naturally, because all operations are linear, including he computation of~$a$. We only have to make sure that the cost of communicating the results of~$S_0$ and~$r$ back and forth during the computation of~$S_n$ do not offset any performance gain from parallel processing. When we construct a decomposition of~$S_0$ and proof that it does not change the results, i.e. \begin{equation} S_0 = \iota S_0 \phi \end{equation} where~$\phi$ is a forking operation and~$\iota$ is a joining operation, we are faced with the technical problem of a parallel random number source~$\rho$. \begin{equation} \begin{CD} \bigoplus_{i=1}^N G_i @>{\bigoplus_{i=1}^N S_0}>> \bigoplus_{i=1}^N G_i \\ @A{\phi}AA @V{\iota}VV \\ G @>S_0>> G \end{CD} \end{equation} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Weakly Commutative Diagrams} \label{sec:weak-CD} As made explicit in~(\ref{eq:S0}, $S_0$ changes the state of the random number general~$\rho$, demanding \emph{identical} results therefore imposes a strict ordering on the operations and defeats parallelization. It is possible to devise implementations of~$S_0$ and~$\rho$ that circumvent this problem by distributing subsequences of~$\rho$ in such a way among processes that results do not depend on the number of parallel processes. However, a reordering of the random number sequence will only change the result by the statistical error, as long as the scale of the allowed reorderings is \emph{bounded} and much smaller than the period of the random number generator~\footnote{Arbirtrary reorderings on the scale of the period of the random number generators could select constant sequences and have to be forbidden.} Below, we will therefore use the notation $x\approx y$ for ``equal for an appropriate finite reordering of the~$\rho$ used in calculating~$x$ and~$y$''. For our porposes, the relation~$x\approx y$ is strong enough and allows simple and efficient implementations. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Multilinear Structure of the Sampling Algorithm} \label{sec:multi-linear} Since~$S_0$ is essentially a summation, it is natural to expect a linear structure \begin{subequations} \label{eq:S0-parallel} \begin{equation} \bigoplus_i S_0(\rho_i, G_i, a_i, f, \mu_{1,i}, \mu_{2,i}) \approx S_0 (\rho, G, a, f, \mu_1, \mu_2) \end{equation} where \begin{align} \rho &= \bigoplus_i \rho_i \\ G &= \bigoplus_i G_i \\ a &= \bigoplus_i a_i \\ \mu_n &= \bigoplus_i \mu_{n,i} \end{align} \end{subequations} for appropriate definitions of ``$\oplus$''. For the moments, we have standard addition \begin{equation} \mu_{n,1} \oplus \mu_{n,2} = \mu_{n,1} + \mu_{n,2} \end{equation} and since we only demand equality up to reordering, we only need that the~$\rho_i$ are statistically independent. This leaves us with~$G$ and~$a$ and we have to discuss importance sampling ans stratified sampling separately. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Importance Sampling} In the case of naive Monte Carlo and importance sampling the natural decomposition of~$G$ is to take~$j$ copies of the same grid~$G/j$ which is identical to~$G$, each with one $j$-th of the total sampling points. As long as the~$a$ are linear themselves, we can add them up just like the moments \begin{equation} a_1 \oplus a_2 = a_1 + a_2 \end{equation} and we have found a decomposition~(\ref{eq:S0-parallel}). In the case of Vegas, the~$a_i$ are sums of function values at the sampling points. Thus they are obviously linear and this approach is applicable to Vegas in the importance sampling mode. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Stratified Sampling} The situation is more complicated in the case of stratified sampling. The first complication is that in pure stratified sampling there are only two sampling points per cell. Splitting the grid in two pieces as above provide only a very limited amount of parallelization. The second complication is that the~$a$ are no longer linear, since they corrspond to a sampling of the variance per cell and no longer of function values themselves. However, as long as the samplings contribute to disjoint bins only, we can still ``add'' the variances by combining bins. The solution is therefore to divide the grid into disjoint bins along the divisions of the stratification grid and to assign a set of bins to each processor. Finer decompositions will incur higher communications costs and other resource utilization. An implementation based on~PVM is described in~\cite{Veseli:1998:Parallel-Vegas}, which miminizes the overhead by running identical copies of the grid~$G$ on each processor. Since most of the time is usually spent in function evaluations, it makes sense to run a full~$S_0$ on each processor, skipping function evaluations everywhere but in the region assigned to the processor. This is a neat trick, which is unfortunately tied to the computational model of message passing systems such as~PVM and~MPI~\cite{MPI}. More general paradigms can not be supported since the separation of the state for the processors is not explicit (it is implicit in the separated address space of the PVM or MPI processes). However, it is possible to implement~(\ref{eq:S0-parallel}) directly in an efficient manner. This is based on the observation that the grid~$G$ used by Vegas is factorized into divisions~$D^j$ for each dimension \begin{equation} \label{eq:factorize} G = \bigotimes_{j=1}^{n_{\text{dim}}} D^j \end{equation} and decompositions of the~$D^j$ induce decompositions of~$G$ \begin{multline} \label{eq:decomp} G_1 \oplus G_2 = \left( \bigotimes_{j=1}^{i-1} D^j \otimes D^i_1 \otimes \bigotimes_{i=j+1}^{n_{\text{dim}}} D^j \right) \oplus \left( \bigotimes_{j=1}^{i-1} D^j \otimes D^i_2 \otimes \bigotimes_{i=j+1}^{n_{\text{dim}}} D^j \right) \\ = \bigotimes_{j=1}^{i-1} D^j \otimes \left( D^i_1 \oplus D^i_2 \right) \otimes \bigotimes_{j=i+1}^{n_{\text{dim}}} D^j \end{multline} We can translate~(\ref{eq:decomp}) directly to code that performs the decomposition~$D^i = D^i_1 \oplus D^i_2$ discussed below and simply duplicates the other divisions~$D^{j\not=i}$. A decomposition along multiple dimensions is implemented by a recursive application of~(\ref{eq:decomp}). In Vegas, the auxiliary information~$a$ inherits a factorization similar to the grid~$(\ref{eq:factorize})$ \begin{equation} \label{eq:factorize'} a = (d^1,\ldots,d^{n_{\text{dim}}}) \end{equation} but not a multilinear structure. Instead, \emph{as long as the decomposition respects the stratification grid}, we find the in place of~(\ref{eq:decomp}) \begin{equation} \label{eq:decomp'} a_1 \oplus a_2 = (d^1_1 + d^1_2,\ldots, d^i_1 \oplus d^i_2, \ldots, d^{n_{\text{dim}}}_1 + d^{n_{\text{dim}}}_2) \end{equation} with ``$+$'' denoting the standard addition of the bin contents and ``$\oplus$'' denoting the aggregation of disjoint bins. If the decomposition of the division would break up cells of the stratification grid~(\ref{eq:decomp'}) would be incorrect, because, as discussed above, the variance is not linear. Now it remains to find a decomposition \begin{equation} D^i = D^i_1 \oplus D^i_2 \end{equation} for both the pure stratification mode and the pseudo stratification mode of vegas (cf.\ figure~\ref{fig:nonstrat/strat}). In the pure stratification mode, the stratification grid is strictly finer than the adaptive grid and we can decompose along either of them immediately. Technically, a decomposition along the coarser of the two is straightforward. Since the adaptive grid already has more than 25~bins, a decomposition along the stratification grid makes no practical sense and the decomposition along the adaptive grid has been implemented. The sampling algorithm~$S_0$ can be applied \emph{unchanged} to the individual grids resulting from the decomposition. \begin{figure} \begin{center} \begin{emp}(120,90) pseudo (.3w, .8w, .7h, .9h, 0, 8, 8, 0, 12, 12, 5.2, true, true); % lcm (lcm (3, 8) / 3, 12) pseudo (.3w, .8w, .4h, .6h, 0, 8, 8, 0, 24, 24, 5.2*2, false, true); % forks pseudo (.2w, .7w, .1h, .3h, 0, 2, 8, 0, 6, 24, 5.2*2, false, false); pseudo (.3w, .8w, .1h, .3h, 2, 5, 8, 6, 15, 24, 5.2*2, false, true); pseudo (.4w, .9w, .1h, .3h, 5, 8, 8, 15, 24, 24, 5.2*2, false, false); label.urt (btex \texttt{ds(1)} etex, (.2w, 0)); label.top (btex \texttt{ds(2)} etex, (.5w, 0)); label.ulft (btex \texttt{ds(3)} etex, (.9w, 0)); \end{emp} \end{center} \caption{\label{fig:pseudo-fork}% Forking one dimension~\texttt{d} of a grid into three parts \texttt{ds(1)}, \texttt{ds(2)}, and~\texttt{ds(3)}. The picture illustrates the most complex case of pseudo stratified sampling (cf.~fig.~\ref{fig:pseudo}).} \end{figure} For pseudo stratified sampling (cf.\ figure~\ref{fig:pseudo}), the situation is more complicated, because the adaptive and the stratification grid do not share bin boundaries. Since Vegas does \emph{not} use the variance in this mode, it would be theoretically possible to decompose along the adaptive grid and to mimic the incomplete bins of the stratification grid in the sampling algorithm. However, this would be a technical complication, destroying the universality of~$S_0$. Therefore, the adaptive grid is subdivided in a first step in \begin{equation} \mathop{\textrm{lcm}} \left( \frac{\mathop{\textrm{lcm}}(n_f,n_g)}{n_f}, n_x \right) \end{equation} bins,\footnote{The coarsest grid covering the division of~$n_g$ bins into~$n_f$ forks has $n_g / \mathop{\textrm{gcd}}(n_f,n_g) = \mathop{\textrm{lcm}}(n_f,n_g) / n_f$ bins per fork.} such that the adaptive grid is strictly finer than the stratification grid. This procedure is shown in figure~\ref{fig:pseudo-fork}. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{State and Message Passing} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Random Numbers} In the parallel example sitting on top of MPI~\cite{MPI} takes advantage of the ability of Knuth's generator~\cite{Knuth:1997:TAOCP2} to generate statistically independent subsequences. However, since the state of the random number generator is explicit in all procedure calls, other means of obtaining subsequences can be implemented in a trivial wrapper. The results of the parallel example will depend on the number of processors, because this effects the subsequences being used. Of course, the variation will be compatible with the statistical error. It must be stressed that the results are deterministic for a given number of processors and a given set of random number generator seeds. Since parallel computing environments allow to fix the number of processors, debugging of exceptional conditions is possible. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Practice} In this section we show three implementations of~$S_n$: one serial, and two parallel, based on HPF~\cite{HPF1.1,HPF2.0} and MPI~\cite{MPI}, respectively. From these examples, it should be obvious how to adapt VAMP to other parallel computing paradigms. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Serial} Here is a bare bones serail version of~$S_n$, for comparison with the parallel versions below. The real implementation of \verb|vamp_sample_grid| in the module \verb|vamp| includes some error handling, diagnostics and the projection~$P$ (cf.~(\ref{eq:P})): \begin{verbatimcmd} subroutine vamp_sample_grid (rng, g, iterations, func) type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g integer, intent(in) :: iterations \verbatimesc{Interface declaration for \texttt{func}} integer :: iteration iterate: do iteration = 1, iterations call vamp_sample_grid0 (rng, g, func) call vamp_refine_grid (g) end do iterate end subroutine vamp_sample_grid \end{verbatimcmd} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{HPF} The HPF version of~$S_n$ is based on decomposing the grid~\verb|g| as described in section~\ref{sec:multi-linear} and lining up the components in an array~\verb|gs|. The elements of~\verb|gs| can then be processed im parallel. This version can be compiled with any Fortran compiler and a more complete version of this procedure (including error handling, diagnostics and the projection~$P$) is included with VAMP as \verb|vamp_sample_grid_parallel| in the module \verb|vamp|. This way, the algorithm can be tested on a serial machine, but there will obviously be no performance gain.\par Instead of one random number generator state~\verb|rng|, it takes an array consisting of one state per processor. These \verb|rng(:)| are assumed to be initialized, such that the resulting sequences are statistically independent. For this purpose, Knuth's random number generator~\cite{Knuth:1997:TAOCP2} is most convenient and is included with VAMP (see the example on page~\pageref{pg:tao-hpf}). Before each~$S_0$, the procedure \verb|vamp_distribute_work| determines a good decomposition of the grid~\verb|d| into \verb|size(rng)| pieces. This decomposition is encoded in the array \verb|d| where \verb|d(1,:)| holds the dimensions along which to split the grid and \verb|d(2,:)| holds the corrsponding number of divisions. Using this information, the grid is decomposed by \verb|vamp_fork_grid|. The HPF compiler will then distribute the \verb|!hpf$ independent| loop among the processors. Finally, \verb|vamp_join_grid| gathers the results. \begin{verbatimcmd} subroutine vamp_sample_grid_hpf (rng, g, iterations, func) type(tao_random_state), dimension(:), intent(inout) :: rng type(vamp_grid), intent(inout) :: g integer, intent(in) :: iterations \verbatimesc{Interface declaration for \texttt{func}} type(vamp_grid), dimension(:), allocatable :: gs, gx !hpf$ processors p(number_of_processors()) !hpf$ distribute gs(cyclic(1)) onto p integer, dimension(:,:), pointer :: d integer :: iteration, num_workers iterate: do iteration = 1, iterations call vamp_distribute_work (size (rng), vamp_rigid_divisions (g), d) num_workers = max (1, product (d(2,:))) if (num_workers > 1) then allocate (gs(num_workers), gx(vamp_fork_grid_joints (d))) call vamp_create_empty_grid (gs) call vamp_fork_grid (g, gs, gx, d) !hpf$ independent do i = 1, num_workers call vamp_sample_grid0 (rng(i), gs(i), func) end do call vamp_join_grid (g, gs, gx, d) call vamp_delete_grid (gs) deallocate (gs, gx) else call vamp_sample_grid0 (rng(1), g, func) end if call vamp_refine_grid (g) end do iterate end subroutine vamp_sample_grid_hpf \end{verbatimcmd} Since \verb|vamp_sample_grid0| performes the bulk of the computation, an almost linear speedup with the number of processors can be achieved, if \verb|vamp_distribute_work| finds a good decomposition of the grid. The version of \verb|vamp_distribute_work| distributed with VAMP does a good job in most cases, but will not be able to use all processors if their number is a prime number larger than the number of divisions in the stratification grid. Therefore it can be beneficial to tune \verb|vamp_distribute_work| to specific hardware. Furthermore, using a finer stratification grid can improve performance.\par For definiteness, here is an example of how to set up the array of random number generators for HPF. Note that this simple seeding procedure only guarantees statistically independent sequences with Knuth's random number generator~\cite{Knuth:1997:TAOCP2} and will fail with other approaches. \label{pg:tao-hpf} \begin{verbatimcmd} type(tao_random_state), dimension(:), allocatable :: rngs !hpf$ processors p(number_of_processors()) !hpf$ distribute gs(cyclic(1)) onto p integer :: i, seed ! ... allocate (rngs(number_of_processors())) seed = 42 !: can be read from a file, of course \ldots !hpf$ independent do i = 1, size (rngs) call tao_random_create (rngs(i), seed + i) end do ! ... call vamp_sample_grid_hpf (rngs, g, 6, func) ! ... \end{verbatimcmd} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{MPI} The MPI version is more low level, because we have to keep track of message passing ourselves. Note that we have made this synchronization points explicit with three \verb|if ... then ... else ... end if| blocks: forking, sampling, and joining. These blocks could be merged (without any performance gain) at the expense of readability. We assume that \verb|rng| has been initialized in each process such that the sequences are again statistically independent. \begin{verbatimcmd} subroutine vamp_sample_grid_mpi (rng, g, iterations, func) type(tao_random_state), dimension(:), intent(inout) :: rng type(vamp_grid), intent(inout) :: g integer, intent(in) :: iterations \verbatimesc{Interface declaration for \texttt{func}} type(vamp_grid), dimension(:), allocatable :: gs, gx integer, dimension(:,:), pointer :: d integer :: num_proc, proc_id, iteration, num_workers call mpi90_size (num_proc) call mpi90_rank (proc_id) iterate: do iteration = 1, iterations if (proc_id == 0) then call vamp_distribute_work (num_proc, vamp_rigid_divisions (g), d) num_workers = max (1, product (d(2,:))) end if call mpi90_broadcast (num_workers, 0) if (proc_id == 0) then allocate (gs(num_workers), gx(vamp_fork_grid_joints (d))) call vamp_create_empty_grid (gs) call vamp_fork_grid (g, gs, gx, d) do i = 2, num_workers call vamp_send_grid (gs(i), i-1, 0) end do else if (proc_id < num_workers) then call vamp_receive_grid (g, 0, 0) end if if (proc_id == 0) then if (num_workers > 1) then call vamp_sample_grid0 (rng, gs(1), func) else call vamp_sample_grid0 (rng, g, func) end if else if (proc_id < num_workers) then call vamp_sample_grid0 (rng, g, func) end if if (proc_id == 0) then do i = 2, num_workers call vamp_receive_grid (gs(i), i-1, 0) end do call vamp_join_grid (g, gs, gx, d) call vamp_delete_grid (gs) deallocate (gs, gx) call vamp_refine_grid (g) else if (proc_id < num_workers) then call vamp_send_grid (g, 0, 0) end if end do iterate end subroutine vamp_sample_grid_mpi \end{verbatimcmd} A more complete version of this procedure is included with VAMP as well, this time as \verb|vamp_sample_grid| in the MPI support module \verb|vampi|. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Performance} \label{sec:performance} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Conclusions} \label{sec:conclusions} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% \bibliography{jpsi} \begin{thebibliography}{10} \bibitem{Krecker:1997:Parallel-Vegas} R.~Krecker, Comp.\ Phys.\ Comm.\ \textbf{106}, 258 (1997). \bibitem{Veseli:1998:Parallel-Vegas} S.~Veseli, Comp.\ Phys.\ Comm.\ \textbf{108}, 9 (1998). \bibitem{Lepage:1978:vegas} G.~P.~Lepage, J.~Comp.\ Phys.\ \textbf{27}, 192 (1978); G.~P.~Lepage, Cornell Preprint, CLNS-80/447, March 1980. \bibitem{Ohl:1998:VAMP} T.~Ohl, \textit{\texttt{VAMP}, Version 1.0: Vegas AMPlified: Anisotropy, Multi-channel sampling and Parallelization}, Preprint, Darmstadt University of Technology, 1998 (in preparation). \bibitem{Ohl:1998:VAMP-preview} T.~Ohl, \textit{Vegas Revisited: Adaptive Monte Carlo Integration Beyond Factorization}, hep-ph/9806432, Preprint IKDA 98/15, Darmstadt University of Technology, 1998. \bibitem{FORTRAN77} American National Standards Institute, \textit{American National Standard Programming Languages FORTRAN, ANSI X3.9-1978,} New York, 1978. \bibitem{Fortran90} International Standards Organization, \textit{ISO/IEC 1539:1991, Information technology --- Programming Languages --- Fortran,} Geneva, 1991. \bibitem{Fortran95} International Standards Organization, \textit{ISO/IEC 1539:1997, Information technology --- Programming Languages --- Fortran,} Geneva, 1997. \bibitem{HPF1.1} High Performance Fortran Forum, \textit{High Performance Fortran Language Specification, Version 1.1}, Rice University, Houston, Texas, 1994. \bibitem{HPF2.0} High Performance Fortran Forum, \textit{High Performance Fortran Language Specification, Version 2.0}, Rice University, Houston, Texas, 1997. \bibitem{MPI} Message Passing Interface Forum, \textit{MPI: A Message Passing Interface Standard}, Technical Report CS-94230, University of Tennessee, Knoxville, Tennessee, 1994. \bibitem{Knuth:1997:TAOCP2} D.~E. Knuth, \textit{Seminumerical Algorithms} (third edition), Vol.~2 of \textit{The Art of Computer Programming}, (Addison-Wesley, 1997). \bibitem{Kleiss/Pittau:1994:multichannel} R.~Kleiss, R.~Pittau, \textit{Weight Optimization in Multichannel Monte Carlo,} Comp.\ Phys.\ Comm.\ \textbf{83}, 141 (1994). \bibitem{Marsaglia:1996:CD} George Marsaglia, \textit{The Marsaglia Random Number CD-ROM}, FSU, Dept.~of Statistics and SCRI, 1996. \end{thebibliography} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \end{fmffile} \end{empfile} \end{document} % Local Variables: % mode:latex % indent-tabs-mode:nil % page-delimiter:"^%%%.*\n" % End: Index: trunk/vamp/share/doc/tex-comments.sh =================================================================== --- trunk/vamp/share/doc/tex-comments.sh (revision 8740) +++ trunk/vamp/share/doc/tex-comments.sh (revision 8741) @@ -1,23 +1,23 @@ #! /usr/bin/awk -f -# $Id: tex-comments.sh 314 2010-04-17 20:32:33Z ohl $ +# tex-comments.sh -- /^@begin docs / { code = 0 } /^@begin code / { code = 1 } code && /^@text .*![:$]/ { if (match($0, /!:.*$/)) { printf("%s\n", substr($0, 1, RSTART-1)) printf("@literal ! {\\setupmodname %s}\n", substr($0, RSTART+2)) next } if (match($0, /!\$.*$/)) { printf("%s\n", substr($0, 1, RSTART-1)) printf("@literal ! {\\setupmodname$ %s $}\n", substr($0, RSTART+2)) next } } # Hide a trick for Poor Man's Elemental Procedures code { gsub(/`'_/, "_") } { print } Index: trunk/vamp/share/doc/preview.tex =================================================================== --- trunk/vamp/share/doc/preview.tex (revision 8740) +++ trunk/vamp/share/doc/preview.tex (revision 8741) @@ -1,799 +1,799 @@ -% $Id: preview.tex 314 2010-04-17 20:32:33Z ohl $ +% preview.tex -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \iffalse %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% To: hep-ph@xxx.lanl.gov Subject: put \\ Title: Vegas Revisited: Adaptive Monte Carlo Integration Beyond Factorization Author: Thorsten Ohl (TU Darmstadt) Comments: 12 pages, LaTeX (using amsmath.sty) Report-no: IKDA 98/15 \\ We present a new adaptive Monte Carlo integration algorithm for ill-behaved integrands with non-factorizable singularities. The algorithm combines Vegas with multi channel sampling and performs significantly better than Vegas for a large class of integrals appearing in physics. \\ \fi %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \NeedsTeXFormat{LaTeX2e} \newif\ifPDFLaTeX \expandafter\ifx\csname pdfoutput\endcsname\relax \PDFLaTeXfalse \else \PDFLaTeXtrue \fi \ifPDFLaTeX \documentclass[12pt,a4paper]{article} \usepackage{type1cm} \usepackage{amsmath,amssymb} \allowdisplaybreaks \usepackage{feynmp} \setlength{\unitlength}{1mm} \usepackage{emp} \empaddtoprelude{input graph;} \setlength{\unitlength}{1mm} \DeclareGraphicsRule{*}{mps}{*}{} \usepackage[colorlinks]{hyperref} \def\pdffit{fit} \else %%% `normal' LaTeX2e \documentclass[12pt,a4paper]{article} \usepackage{amsmath,amssymb} \allowdisplaybreaks \usepackage{feynmp} \setlength{\unitlength}{1mm} \usepackage{emp} \empaddtoprelude{input graph;} \fi %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \DeclareMathOperator{\Vol}{Vol} \DeclareMathOperator{\atan}{atan} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \makeindex \begin{document} \title{% Vegas Revisited: Adaptive Monte Carlo Integration Beyond Factorization} \author{% Thorsten Ohl% \thanks{e-mail: \texttt{ohl@hep.tu-darmstadt.de}} {}\thanks{Supported by Bundesministerium f\"ur Bildung, Wissenschaft, Forschung und Technologie, Germany.}\\ \hfil \\ Darmstadt University of Technology \\ Schlo\ss gartenstr.~9 \\ D-64289 Darmstadt \\ Germany} \date{% IKDA 98/15\\ hep-ph/9806432\\ June 1998} \maketitle \begin{abstract} We present a new adaptive Monte Carlo integration algorithm for ill-behaved integrands with non-factorizable singularities. The algorithm combines Vegas with multi channel sampling and performs significantly better than Vegas for a large class of integrals appearing in physics. \end{abstract} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{empfile} \begin{fmffile}{\jobname pics} \fmfset{curly_len}{2mm} \fmfset{wiggly_len}{3mm} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% (Ab)use FeynMF for drawing portable commutative diagrams \fmfcmd{% style_def isomorphism expr p = cdraw (subpath (0, 1 - arrow_len/pixlen(p,10)) of p); cfill (harrow (p, 1)) enddef; style_def morphism expr p = draw_dots (subpath (0, 1 - arrow_len/pixlen(p,10)) of p); cfill (harrow (p, 1)) enddef;} \def\fmfcd(#1,#2){% \begin{minipage}{#1\unitlength}% \vspace*{.5\baselineskip}% \begin{fmfgraph*}(#1,#2)% \fmfset{arrow_len}{3mm}% \fmfset{arrow_ang}{10}% \fmfstraight} \def\endfmfcd{% \end{fmfgraph*}% \vspace*{.5\baselineskip}% \end{minipage}} \newcommand{\fmfcdmorphism}[4]{% \fmf{#1,label.side=#2,label.dist=3pt,label={\small $#4$}}{#3}} \newcommand{\fmfcdisomorph}[3][left]{% \fmfcdmorphism{isomorphism}{#1}{#2}{#3}} \newcommand{\fmfcdmorph}[3][left]{% \fmfcdmorphism{morphism}{#1}{#2}{#3}} \newcommand{\fmfcdeq}[1]{\fmf{double}{#1}} \def\fmfcdsetaux[#1]#2{% \fmfv{decor.shape=circle,decor.size=18pt,foreground=white, label.dist=0,label=$#1$}{#2}} \makeatletter \def\fmfcdset{\@dblarg{\fmfcdsetaux}} \makeatother %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Introduction} Throughout physics, it is frequently necessary to evaluate the integral~$I(f)$ of a function~$f$ on a manifold~$M$ using a measure~$\mu$ \begin{equation} \label{eq:I(f)} I(f) = \int_M\!\textrm{d}\mu(p)\,f(p)\,. \end{equation} More often than not, an analytical evaluation in terms of elementary or known special functions is impossible and we have to rely on numerical methods for estimating~$I(f)$. A typical example is given by the integration of differential cross sections on a part of phase space to obtain predictions for event rates in scattering experiments. In more than three dimensions, standard quadrature formulae are not practical and Monte Carlo integration is the only option. As is well known, $I(f)$ is estimated by \begin{equation} \label{eq:E(f)} E(f) = \left\langle \frac{f}{g} \right\rangle_g = \frac{1}{N} \sum_{i=1}^{N} \frac{f(p_i)}{g(p_i)}\,, \end{equation} where~$g$ is the probability density (with respect to the measure~$\mu$) of the randomly distributed~$p_i$, e.\,g.~$g(p)=1/\Vol(M)$ for uniformly distributed~$p_i$. The error of this estimate is given by the square root of the variance \begin{equation} \label{eq:V(f)} V(f) = \frac{1}{N-1} \left(\left\langle\left(\frac{f}{g}\right)^2\right\rangle_g - \left\langle\frac{f}{g}\right\rangle_g^2 \right) \end{equation} which suggests to choose a~$g$ that minimizes~$V(f)$. If~$f$ is a wildly fluctuating function, this optimization of~$g$ is indispensable for obtaining a useful accuracy. Typical causes for large fluctuations are integrable singularities of~$f$ or~$\mu$ inside of~$M$ or non-integrable singularities very close to~$M$. Therefore, we will use the term ``singularity'' for those parts of~$M$ in which there are large fluctuations in~$f$ or~$\mu$. Manual optimization of~$g$ is often too time consuming, in particular if the dependence of the integral on external parameters (in the integrand and in the boundaries) is to be studied. Adaptive numerical approaches are more attractive in these cases. The problem of optimizing~$g$ numerically has been solved for \emph{factorizable} distributions~$g$ and measures~$\mu$ by the classic Vegas~\cite{Lepage:1978:vegas} algorithm long ago. Factorizable~$g$ and~$\mu$ are special, because the computational costs for optimization rise only linearly with the number of dimensions. In all other cases, there is a prohibitive exponential rise of the computational costs with the number of dimensions. The property of factorization depends on the coordinate system, of course. Consider, for example, the functions \begin{subequations} \label{eq:f1f2} \begin{align} f_1(x_1,x_2) & = \frac{1}{(x_1-a_1)^2 + b_1^2} \\ f_2(x_1,x_2) & = \frac{1}{\left(\sqrt{x_1^2+x_2^2}-a_2\right)^2 + b_2^2} \end{align} \end{subequations} on~$M=(-1,1)\otimes(-1,1)$ with the measure~$\textrm{d}\mu=\textrm{d}x_1\wedge\textrm{d}x_2$. Obviously, $f_1$ is factorizable in Cartesian coordinates, while~$f_2$ is factorizable in polar coordinates. Vegas will sample either function efficiently for arbitrary~$b_{1,2}$ in suitable coordinate systems, but there is no coordinate system in which Vegas can sample the sum~$f_1+f_2$ efficiently for small~$b_{1,2}$. In this note, we present a generalization of the Vegas algorithm from factorizable distributions to sums of factorizable distributions, where each term may be factorizable in a \emph{different} coordinate system. This larger class includes most of the integrands appearing in particle physics and empirical studies have shown a dramatic increase of accuracy for typical integrals. Technically, this generalization is the combination of the Vegas algorithm with adaptive multi channel sampling~\cite{Kleiss/Pittau:1994:multichannel}. In section~\ref{sec:maps}, we will discuss the coordinate transformations employed by the algorithm and in section~\ref{sec:MC}, we will describe the adaptive multi channel algorithm. Finally, I will discuss the performance of a first implementation of the algorithm in section~\ref{sec:performance} and conclude. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Maps} \label{sec:maps} The problem of estimating~$I(f)$ can be divided naturally into two parts: parametrization of~$M$ and sampling of the function~$f$. While the estimate will not depend on the parametrization, the error will. In general, we need an atlas with more that one chart~$\phi$ to cover the manifold~$M$. We can ignore this technical complication in the following, because, for the purpose of integration, we can decompose~$M$ such that each piece is covered by a single chart. Moreover, a single chart suffices in most cases of practical interest, since we are at liberty to remove sets of measure zero from~$M$. For example, after removing a single point, the unit sphere can be covered by a single chart. Nevertheless, even if we are not concerned with the global properties of~$M$ that require the use of more than one chart, the language of differential geometry will allow us to use our geometrical intuition. Instead of pasting together locally flat pieces, we will paste together \emph{factorizable} pieces, which can be overlapping, because integration is an additive operation. For actual computations, it is convenient to use the same domain for the charts of all manifolds. The obvious choice for $n$-dimensional manifolds is the open $n$-dimensional unit hypercube \begin{equation} U = (0,1)^{\otimes n}\,. \end{equation} Sometimes, it will be instructive to view the chart as a composition~$\phi=\psi\circ\chi$ with an irregularly shaped~$P\in\mathbf{R}^n$ as an intermediate step \begin{equation} \begin{fmfcd}(40,20) \fmfbottom{P,R} \fmftop{U} \fmfcdset{U} \fmfcdset{P} \fmfcdset[\mathbf{R}]{R} \fmfcdset{M} \fmfcdisomorph{U,M}{\phi} \fmfcdisomorph[right]{U,P}{\chi} \fmfcdisomorph{P,M}{\psi} \fmfcdmorph[right]{P,R}{f\circ\psi} \fmfcdmorph{M,R}{f} \fmfcdmorph{U,R}{f\circ\phi} \end{fmfcd} \end{equation} (in all commutative diagrams, solid arrows are reserved for bijections and dotted arrows are used for other morphisms). The integral~(\ref{eq:I(f)}) can now be written \begin{equation} I(f) = \int_0^1\!\textrm{d}^nx\, \left|\frac{\partial\phi}{\partial x}\right| f(\phi(x)) \end{equation} and it remains to sample~$|\partial\phi/\partial x|\cdot(f\circ\phi)$ on~$U$. Below, it will be crucial that there is more than one way to map~$U$ onto~$M$ \begin{equation} \label{eq:pi} \begin{fmfcd}(40,20) \fmfleft{U',U} \fmfright{P',P} \fmfcdset{U} \fmfcdset{U'} \fmfcdset{P} \fmfcdset{P'} \fmfcdset{M} \fmfcdisomorph{U,M}{\phi} \fmfcdisomorph{U',M}{\phi'} \fmfcdisomorph[right]{P,M}{\psi} \fmfcdisomorph[right]{P',M}{\psi'} \fmfcdisomorph[right]{U,U'}{\pi_U} \fmfcdisomorph{P,P'}{\pi_P} \fmfcdisomorph{U,P}{\chi} \fmfcdisomorph{U',P'}{\chi'} \end{fmfcd} \end{equation} and that we are free to select the map most suitable for our purposes. The ideal choice for~$\phi$ would be a solution of the partial differential equation $|\partial\phi/\partial x| = 1/(f\circ\phi)$, but this is equivalent to an analytical evaluation of~$I(f)$ and is impossible for the cases under consideration. A more realistic goal is to find a~$\phi$ such that $|\partial\phi/\partial x|\cdot(f\circ\phi)$ has factorizable singularities and is therefore sampled well by Vegas. This is still a non-trivial problem, however. \begin{figure} \begin{center} \hfill\\ \vspace*{\baselineskip} \begin{fmfgraph*}(30,20) \fmfleft{p1,p2} \fmfright{q1,k,q2} \fmflabel{$p_1$}{p1} \fmflabel{$p_2$}{p2} \fmflabel{$q_1$}{q1} \fmflabel{$q_2$}{q2} \fmflabel{$k$}{k} \fmf{fermion}{p1,v,p2} \fmf{photon}{v,vq} \fmf{fermion,tension=.5}{q1,vq} \fmf{fermion,tension=.5,label=$s_2$,label.side=left}{vq,vg} \fmf{fermion,tension=.5}{vg,q2} \fmffreeze \fmf{gluon}{vg,k} \fmfdot{v,vq,vg} \end{fmfgraph*} \qquad\qquad \begin{fmfgraph*}(30,20) \fmfleft{p1,p2} \fmfright{q1,k,q2} \fmflabel{$p_1$}{p1} \fmflabel{$p_2$}{p2} \fmflabel{$q_1$}{q1} \fmflabel{$q_2$}{q2} \fmflabel{$k$}{k} \fmf{fermion}{p1,v,p2} \fmf{photon}{v,vq} \fmf{fermion,tension=.5}{q1,vg} \fmf{fermion,tension=.5,label=$s_1$,label.side=left}{vg,vq} \fmf{fermion,tension=.5}{vq,q2} \fmffreeze \fmf{gluon}{vg,k} \fmfdot{v,vq,vg} \end{fmfgraph*} \end{center} \caption{\label{fig:glue}% $e^+e^-\to q\bar qg$} \end{figure} For example, consider the phase space integration for gluon radiation $e^+e^-\to q\bar qg$. From the Feynman diagrams in figure~\ref{fig:glue} it is obvious that the squared matrix element will have singularities in the variables~$s_{1/2}=(q_{1/2}+k)^2$. Thus, adaptive sampling using Vegas would benefit from a parametrization using both~$s_1$ and~$s_2$ as coordinates in the intermediate space~$P$. Unfortunately, the invariant phase space measure for such a parametrization involves the Gram determinant in the form~$1/\sqrt{\Delta_4(p_1,p_2,q_1,q_2)}$, which will lead to non-factorizable singularities at the edges of phase space. Note that the very elegant phase space parametrizations of the RAMBO~\cite{Kleiss/Stirling/Ellis:1986:RAMBO} type are not useful in this case, because there is no simple relation between the coordinates on~$U$ and the invariants in which the squared matrix elements can have singularities. On the other hand, it is straightforward to find parametrizations that factorize the dependency on~$s_1$ or~$s_2$ \emph{separately}. Returning to the general case, consider~$N_c$ different maps~$\phi_i:U\to M$ and probability densities~$g_i:U\to [0,\infty)$. Then the function \begin{equation} \label{eq:g(p)} g = \sum_{i=1}^{N_c} \alpha_i (g_i\circ\phi_i^{-1}) \left|\frac{\partial\phi_i^{-1}}{\partial p}\right| \end{equation} is a probability density~$g:M\to [0,\infty)$ \begin{equation} \int_M\! \textrm{d}\mu(p)\, g(p) = 1\,, \end{equation} as long as the~$g_i$ and~$\alpha_i$ are properly normalized \begin{equation} \label{eq:alpha} \int_0^1\!g_i(x)\textrm{d}^nx = 1\,,\;\;\; \sum_{i=1}^{N_c} \alpha_i = 1\,,\;\;\; 0 \le \alpha_i \le 1 \,. \end{equation} {}From the definition~(\ref{eq:g(p)}), we have obviously \begin{equation} \label{eq:I(f)MC} I(f) = \sum_{i=1}^{N_c} \alpha_i \int_M\! g_i(\phi_i^{-1}(p)) \left|\frac{\partial\phi_i^{-1}}{\partial p}\right| \textrm{d}\mu(p)\, \frac{f(p)}{g(p)} \end{equation} and, after pulling back from~$M$ to~$U$ \begin{equation} I(f) = \sum_{i=1}^{N_c} \alpha_i \int_0^1\!g_i(x)\textrm{d}^nx\, \frac{f(\phi_i(x))}{g(\phi_i(x))}\,, \end{equation} we find the estimate \begin{equation} \label{eq:E(f)MC} E(f) = \sum_{i=1}^{N_c} \alpha_i \left\langle \frac{f\circ\phi_i}{g\circ\phi_i} \right\rangle_{g_i}\,. \end{equation} The factorized~$g_i$ in~(\ref{eq:I(f)MC}) and~(\ref{eq:E(f)MC}) can be optimized using the classic Vegas algorithm~\cite{Lepage:1978:vegas} unchanged. However, since we have to sample with a separate adaptive grid for each channel, a new implementation~\cite{Ohl:1998:VAMP} is required for technical reasons. Using the maps~$\pi_{ij}=\phi_j^{-1}\circ\phi_i:U\to U$ introduced in~(\ref{eq:pi}), we can write the~$g\circ\phi_i:U\to[0,\infty)$ from~(\ref{eq:E(f)MC}) as \begin{equation} \label{eq:gophi_i} g\circ\phi_i = \left|\frac{\partial\phi_i}{\partial x}\right|^{-1} \left( \alpha_i g_i + \sum_{\substack{j=1\\j\not=i}}^{N_c} \alpha_j (g_j\circ\pi_{ij}) \left|\frac{\partial\pi_{ij}}{\partial x}\right| \right)\,. \end{equation} {}From a geometrical perspective, the maps~$\pi_{ij}$ are just the coordinate transformations from the coordinate systems in which the other singularities factorize into the coordinate system in which the current singularity factorizes. Note that the integral in~(\ref{eq:I(f)MC}) does not change, when we use~$\phi_i:U\to M_i\supseteq M$, if we extent~$f$ from~$M$ to~$M_i$ by the definition~$f(M_i\setminus M)=0$. This is useful, for instance, when we want to cover~$(-1,1)\otimes(-1,1)$ by both Cartesian and polar coordinates. This causes, however, a problem with the~$\pi_{12}$ in~(\ref{eq:gophi_i}). In the diagram \begin{equation} \begin{fmfcd}(75,15) \fmfbottom{d1,U1,d2,U2,d3} \fmftop{P1,M1,M,M2,P2} \fmfcdset[U]{U1} \fmfcdset[U]{U2} \fmfcdset[P_1]{P1} \fmfcdset[M_1]{M1} \fmfcdset{M} \fmfcdset[M_2]{M2} \fmfcdset[P_2]{P2} \fmfcdisomorph[right]{U1,M1}{\phi_1} \fmfcdisomorph{U1,P1}{\chi_1} \fmfcdisomorph{P1,M1}{\psi_1} \fmfcdisomorph{U2,M2}{\phi_2} \fmfcdisomorph[right]{U2,P2}{\chi_2} \fmfcdisomorph[right]{P2,M2}{\psi_2} \fmfcdmorph{U1,U2}{\pi_{12}} \fmfcdmorph[right]{M,M1}{\iota_1} \fmfcdmorph{M,M2}{\iota_2} \end{fmfcd} \end{equation} the injections~$\iota_{1,2}$ are not onto and since~$\pi_{12}$ is not necessarily a bijection anymore, the Jacobian~$\left|\partial\pi_{ij}/\partial x\right|$ may be ill-defined. But since~$f(M_i\setminus M)=0$, we only need the unique bijections~$\phi'_{1,2}$ and~$\pi'_{12}$ that make the diagram \begin{equation} \begin{fmfcd}(90,15) \fmfbottom{d1,U1,U1',U2',U2,d3} \fmftop{P1,M1,M1',M2',M2,P2} \fmfcdset[U]{U1} \fmfcdset[U_1]{U1'} \fmfcdset[U_2]{U2'} \fmfcdset[U]{U2} \fmfcdset[P_1]{P1} \fmfcdset[M_1]{M1} \fmfcdset[M]{M1'} \fmfcdset[M]{M2'} \fmfcdset[M_2]{M2} \fmfcdset[P_2]{P2} \fmfcdisomorph{U1',M1'}{\phi'_1} \fmfcdisomorph[right]{U1,M1}{\phi_1} \fmfcdisomorph{U1,P1}{\chi_1} \fmfcdisomorph{P1,M1}{\psi_1} \fmfcdisomorph[right]{U2',M2'}{\phi'_2} \fmfcdisomorph{U2,M2}{\phi_2} \fmfcdisomorph[right]{U2,P2}{\chi_2} \fmfcdisomorph[right]{P2,M2}{\psi_2} \fmfcdmorph{U1',U1}{\iota^U_1} \fmfcdisomorph{U1',U2'}{\pi'_{12}} \fmfcdmorph[right]{U2',U2}{\iota^U_2} \fmfcdmorph[right]{M1',M1}{\iota_1} \fmfcdeq{M1',M2'} \fmfcdmorph{M2',M2}{\iota_2} \end{fmfcd} \end{equation} commute. In many applications, the dependence of an integral on external parameters has to be studied. Often, the~$\pi_{ij}$ will not depend on these parameters and we can rely on Vegas to optimize the~$g_i$ for each parameter set. In the next section, we will show how to optimize the~$\alpha_i$ numerically as well. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Multichannel} \label{sec:MC} Up to now, we have not specified the~$\alpha_i$, they are only subject to the conditions~(\ref{eq:alpha}). Intuitively, we expect the best results when the~$\alpha_i$ are proportional to the contribution of their corresponding singularities to the integral. The option of tuning the~$\alpha_i$ manually is not attractive if the optimal values depend on varying external parameters. Instead, we use a numerical procedure~\cite{Kleiss/Pittau:1994:multichannel} for tuning the~$\alpha_i$. We want to minimize the variance~(\ref{eq:V(f)}) with respect to the~$\alpha_i$. This is equivalent to minimizing \begin{equation} \label{eq:W(alpha)} W(f,\alpha) = \int_M\! g(p) \textrm{d}\mu(p)\, \left(\frac{f(p)}{g(p)}\right)^2 \end{equation} with respect to~$\alpha$ with the subsidiary condition~$\sum_i\alpha_i=1$. After adding a Lagrange multiplier, the stationary points of the variation are given by the solutions to the equations \begin{equation} \label{eq:PDG(W)} \forall i: W_i(f,\alpha) = W(f,\alpha) \end{equation} where \begin{equation} W_i(f,\alpha) = -\frac{\partial}{\partial\alpha_i} W(f,\alpha) = \int_0^1\!g_i(x)\textrm{d}^nx\, \left(\frac{f(\phi_i(x))}{g(\phi_i(x))}\right)^2 \end{equation} and \begin{equation} W(f,\alpha) = \sum_{i=1}^{N_c} \alpha_i W_i(f,\alpha)\,. \end{equation} It can easily be shown~\cite{Kleiss/Pittau:1994:multichannel} that the stationary points~(\ref{eq:PDG(W)}) correspond to local minima. If we use \begin{equation} N_i = \alpha_i N \end{equation} to distribute~$N$ sampling points among the channels, the~$W_i(f,\alpha)$ are just the contributions from channel~$i$ to the total variance. Thus we recover the familiar result from stratified sampling, that the overall variance is minimized by spreading the variance evenly among channels. The~$W_i(f,\alpha)$ can be estimated with very little extra effort while sampling~$I(f)$ (cf.~\ref{eq:E(f)MC}) \begin{equation} \label{eq:Vi(alpha)} V_i(f,\alpha) = \left\langle \left(\frac{f\circ\phi_i}{g\circ\phi_i}\right)^2 \right\rangle_{g_i}\,. \end{equation} Note that the factor of~$g_i/g$ from the corresponding formula in~\cite{Kleiss/Pittau:1994:multichannel} is absent from~(\ref{eq:Vi(alpha)}), because we are already sampling with the weight~$g_i$ in each channel separately. The equations~(\ref{eq:PDG(W)}) are a fixed point of the prescription \begin{equation} \label{eq:update} \alpha_i \mapsto \alpha_i' = \frac{\alpha_i \left(V_i(f,\alpha)\right)^\beta} {\sum_i\alpha_i \left(V_i(f,\alpha)\right)^\beta}, \;\;\;(\beta>0) \end{equation} for updating the weights~$\alpha_i$. There is no guarantee that this fixed point will be reached from a particular starting value, such as~$\alpha_i=1/N_c$, through successive applications of~(\ref{eq:update}). Nevertheless, it is clear that~(\ref{eq:update}) will concentrate on the channels with large contributions to the variance, as suggested by stratified sampling. Furthermore, empirical studies show that~(\ref{eq:update}) is successful in practical applications. The value~$\beta=1/2$ has been proposed in~\cite{Kleiss/Pittau:1994:multichannel}, but it can be beneficial in some cases to use smaller values like~$\beta=1/4$ to dampen statistical fluctuations. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Performance} \label{sec:performance} Both the implementation and the practical use of the algorithm proposed in this note are more involved than the application of the original Vegas algorithm. Therefore it is necessary to investigate whether the additional effort pays off in terms of better performance. A test version of an implementation of this algorithm, ``VAMP'', in Fortran~\cite{Fortran95} has been used for empirical studies. This implementation features other improvements over ``Vegas Classic''---most notably system independent and portable support for parallel processing and support for unweighted event generation---and will be published when the documentation~\cite{Ohl:1998:VAMP} is finalized. The preliminary version is available from the author upon request. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Costs} There are two main sources of additional computational costs: at each sampling point the function~$g\circ\phi_i$ has be evaluated, which requires the computation of the~$N_c-1$ maps~$\pi_{ij}$ together with their Jacobians and of the~$N_c-1$ probability distributions~$g_i$ of the other Vegas grids (cf.~(\ref{eq:gophi_i})). The retrieval of the current~$g_i$s requires a bisection search in each dimension, i.e.~a total of~$O((N_c-1)\cdot n_{\text{dim}}\cdot \log_2 (n_{\text{div}}))$ executions of the inner loop of the search. For simple integrands, this can indeed be a few times more costly than the evaluation of the integrand itself. The computation of the~$\pi_{ij}$ can be costly as well. However, unlike the~$g_i$, this computation can usually be tuned manually. This can be worth the effort if many estimations of similar integrals are to be performed. Empirically, straightforward implementations of the~$\pi_{ij}$ add costs of the same order as the evaluation of the~$g_i$. Finally, additional iterations are needed for adapting the weights~$\alpha_i$ of the multi channel algorithm described in~(\ref{sec:MC}). Their cost is negligible, however, because they are usually performed with far fewer sampling points than the final iterations. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Gains} Even in cases in which the evaluation of~$g_i$ increases computation costs by a whole order of magnitude, any reduction of the error by more than a factor of~4 will make the multi channel algorithm economical. In fact, it is easy to construct examples in which the error will be reduced by more than two orders of magnitude. The function \begin{multline} \label{eq:f(x)} f(x) = \frac{b}{144\atan(1/2b)} \biggl( \frac{3\pi\Theta(r_3<1)}{r_3^2((r_3-1/2)^2+b^2)} + \frac{2\pi\Theta(r_2<1,|x_3|<1)}{r_2((r_2-1/2)^2+b^2)} \\ + \frac{\Theta(-10.01$). Instead, it is penalized by the higher computational costs. On the other hand, the accuracy of the classic Vegas algorithm deteriorates like a power with smaller values of~$b$. At the same time, the multi channel algorithm can adapt itself to the steeper functions, leading to a much slower loss of precision. The function~$f$ in~(\ref{eq:f(x)}) has been constructed as a showcase for the multi channel algorithm, of course. Nevertheless, more complicated realistic examples from particle physics appear to gain about an order of magnitude in accuracy. Furthermore, the new algorithm allows \emph{unweighted} event generation. This is hardly ever possible with the original Vegas implementation, because the remaining fluctuations typically reduce the average weight to very small numbers. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{A Cheaper Alternative} There is an alternative approach that avoids the evaluation of the~$g_i$s, sacrificing flexibility. Fixing the~$g_i$ at unity, we have for~$\tilde g:M\to [0,\infty)$ \begin{equation} \label{eq:tildeg(p)} \tilde g = \sum_{i=1}^{N_c} \alpha_i \left|\frac{\partial\phi_i^{-1}}{\partial p}\right| \end{equation} and the integral becomes \begin{equation} I(f) = \sum_{i=1}^{N_c} \alpha_i \int_M\! \left|\frac{\partial\phi_i^{-1}}{\partial p}\right| \textrm{d}\mu(p)\, \frac{f(p)}{\tilde g(p)} = \sum_{i=1}^{N_c} \alpha_i \int_0^1\!\textrm{d}^nx\, \frac{f(\phi_i(x))}{\tilde g(\phi_i(x))}\,. \end{equation} Vegas can now be used to perform adaptive integrations of \begin{equation} I_i(f) = \int_0^1\!\textrm{d}^nx\, \frac{f(\phi_i(x))}{\tilde g(\phi_i(x))} \end{equation} individually. In some cases it is possible to construct a set of~$\phi_i$ such that~$I_i(f)$ can estimated efficiently. The optimization of the weights~$\alpha_i$ can again be effected by the multi channel algorithm described in~(\ref{sec:MC}). The disadvantage of this approach is that the optimal~$\phi_i$ will depend sensitively on external parameters and the integration limits. In the approach based on the~$g$ in~(\ref{eq:g(p)}) Vegas can take care of the integration limits automatically. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Conclusions} \label{sec:conclusions} We have presented an algorithm for adaptive Monte Carlo integration of functions with non-factorizable singularities. The algorithm shows a significantly better performance for many ill-behaved integrals than Vegas. The applications of this algorithm are not restricted to particle physics, but a particularly attractive application is provided by automated tools for the calculation of scattering cross sections. While these tools can currently calculate differential cross sections without manual intervention, the phase space integrations still require hand tuning of mappings for importance sampling for each parameter set. The present algorithm can overcome this problem, since it requires to solve the geometrical problem of calculating the maps~$\pi_{ij}$ in~(\ref{eq:gophi_i}) for all possible invariants only \emph{once}. The selection and optimization of the channels can then be performed algorithmically. The application of the algorithms presented here to quasi Monte Carlo integration forms an interesting subject for future research. Other options include maps~$\phi_i$ depending on external parameters, which can be optimized as well. A simple example are rotations, which can align the coordinate systems with the singularities, using correlation matrices~\cite{Ohl:1998:VAMP}. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% \bibliography{jpsi} \begin{thebibliography}{10} \bibitem{Lepage:1978:vegas} G.~P.~Lepage, J.~Comp.\ Phys.\ \textbf{27}, 192 (1978); G.~P.~Lepage, Cornell Preprint, CLNS-80/447, March 1980. \bibitem{Kleiss/Pittau:1994:multichannel} R.~Kleiss, R.~Pittau, Comp.\ Phys.\ Comm.\ \textbf{83}, 141 (1994). \bibitem{Kleiss/Stirling/Ellis:1986:RAMBO} R. Kleiss, W. J. Stirling, S. D. Ellis, Comp.\ Phys.\ Comm.\ \textbf{40}, 359 (1986); R. Kleiss, W. J. Stirling, Nucl.\ Phys.\ \textbf{B385}, 413 (1992). \bibitem{Ohl:1998:VAMP} T.~Ohl, \textit{\texttt{VAMP}, Version 1.0: Vegas AMPlified: Anisotropy, Multi-channel sampling and Parallelization}, Preprint, Darmstadt University of Technology, 1998 (in preparation). \bibitem{Fortran95} International Standards Organization, \textit{ISO/IEC 1539:1997, Information technology --- Programming Languages --- Fortran,} Geneva, 1997. \end{thebibliography} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \end{fmffile} \end{empfile} \end{document} % Local Variables: % mode:latex % indent-tabs-mode:nil % page-delimiter:"^@ %%%.*\n" % End: Index: trunk/vamp/share/misc/illustrations.F =================================================================== --- trunk/vamp/share/misc/illustrations.F (revision 8740) +++ trunk/vamp/share/misc/illustrations.F (revision 8741) @@ -1,174 +1,174 @@ -! $Id: illustrations.F 314 2010-04-17 20:32:33Z ohl $ +! illustrations.F -- module foo use kinds private public :: f, g, phi, w private :: f0, phi0 integer, parameter, private :: N = 2 real(kind=double), dimension(N), public :: x0, x0_true, a, weights contains function phi0 (x, x0, a) result (phi0_x) real(kind=double), intent(in) :: x, x0, a real(kind=double) :: phi0_x phi0_x = x0 & + a * tan (x * atan ((1 - x0) / a) - (1 - x) * atan (x0 / a)) end function phi0 function f0 (x, x0, a) result (f0_x) real(kind=double), intent(in) :: x, x0, a real(kind=double) :: f0_x f0_x = a / ((x - x0)**2 + a**2) & / (atan ((1 - x0) / a) + atan (x0 / a)) end function f0 function phi (x, channel) result (phi_x) real(kind=double), intent(in) :: x integer, intent(in) :: channel real(kind=double) :: phi_x phi_x = phi0 (x, x0(channel), a(channel)) end function phi function g (x, channel) result (g_x) real(kind=double), intent(in) :: x integer, intent(in) :: channel real(kind=double) :: g_x integer :: ch if (channel == 0) then g_x = 0.0 do ch = 1, N g_x = g_x + weights(ch) * f0 (x, x0(ch), a(ch)) end do else g_x = f0 (x, x0(channel), a(channel)) end if end function g function f (x) result (f_x) real(kind=double), intent(in) :: x real(kind=double) :: f_x complex(kind=double) :: s_x s_x = 1.0 / cmplx (x - x0_true(1), a(1)) & + 1.0 / cmplx (x - x0_true(2), a(2)) f_x = conjg (s_x) * s_x end function f function w (x, channel) result (w_x) real(kind=double), intent(in) :: x integer, intent(in) :: channel real(kind=double) :: w_x real(kind=double) :: x_prime if (channel > 0) then x_prime = phi (x, channel) w_x = f (x_prime) / g (x_prime, 0) else if (channel < 0) then x_prime = phi (x, -channel) w_x = g (x_prime, -channel) / g (x_prime, 0) else w_x = f (x) end if end function w end module foo program illustrations use kinds use foo real(kind=double) :: x, s, shift integer :: i, i_max integer, parameter :: io_unit = 10 character(len=*), parameter :: fmt = "(5(1X,F12.6))" weights = 1.0 a = 0.1 shift = 0.15 x0_true(1) = 0.2 x0_true(2) = 0.8 x0(1) = x0_true(1) - shift * a(1) x0(2) = x0_true(2) + shift * a(2) weights = weights / sum (weights) i_max = 250 print *, "PHI" open (unit = io_unit, action = "write", status = "replace", file = "phi1.plot") do i = 0, i_max x = real (i, kind = double) / i_max write (unit = io_unit, fmt = fmt) x, phi (x, 1) end do close (unit = io_unit) open (unit = io_unit, action = "write", status = "replace", file = "phi2.plot") do i = 0, i_max x = real (i, kind = double) / i_max write (unit = io_unit, fmt = fmt) x, phi (x, 2) end do close (unit = io_unit) print *, "F/G" open (unit = io_unit, action = "write", status = "replace", file = "fog.plot") do i = 0, i_max x = real (i, kind = double) / i_max write (unit = io_unit, fmt = fmt) x, f (x) / g (x, 0) end do close (unit = io_unit) print *, "F, G, G1, G2" s = f(x0(1)) / g(x0(1), 0) open (unit = io_unit, action = "write", status = "replace", file = "f.plot") do i = 0, i_max x = real (i, kind = double) / i_max write (unit = io_unit, fmt = fmt) x, f (x) end do close (unit = io_unit) open (unit = io_unit, action = "write", status = "replace", file = "g.plot") do i = 0, i_max x = real (i, kind = double) / i_max write (unit = io_unit, fmt = fmt) x, s * g (x, 0) end do close (unit = io_unit) open (unit = io_unit, action = "write", status = "replace", file = "g1.plot") do i = 0, i_max x = real (i, kind = double) / i_max write (unit = io_unit, fmt = fmt) x, s/2 * g (x, 1) end do close (unit = io_unit) open (unit = io_unit, action = "write", status = "replace", file = "g2.plot") do i = 0, i_max x = real (i, kind = double) / i_max write (unit = io_unit, fmt = fmt) x, s/2 * g (x, 2) end do close (unit = io_unit) print *, "W1, W2, W12" open (unit = io_unit, action = "write", status = "replace", file = "w1.plot") do i = 0, i_max x = real (i, kind = double) / i_max write (unit = io_unit, fmt = fmt) x, w (x, 1) / s end do close (unit = io_unit) open (unit = io_unit, action = "write", status = "replace", file = "w2.plot") do i = 0, i_max x = real (i, kind = double) / i_max write (unit = io_unit, fmt = fmt) x, w (x, 2) / s end do close (unit = io_unit) open (unit = io_unit, action = "write", status = "replace", file = "w12.plot") do i = 0, i_max x = real (i, kind = double) / i_max write (unit = io_unit, fmt = fmt) x, (w (x, 1) + w (x, 2)) / (2*s) end do close (unit = io_unit) x0 = x0_true print *, "W/true" open (unit = io_unit, action = "write", status = "replace", file = "w1t.plot") do i = 0, i_max x = real (i, kind = double) / i_max write (unit = io_unit, fmt = fmt) x, w (x, 1) / s end do close (unit = io_unit) open (unit = io_unit, action = "write", status = "replace", file = "w2t.plot") do i = 0, i_max x = real (i, kind = double) / i_max write (unit = io_unit, fmt = fmt) x, w (x, 2) / s end do close (unit = io_unit) end program illustrations Index: trunk/vamp/src/utils.nw =================================================================== --- trunk/vamp/src/utils.nw (revision 8740) +++ trunk/vamp/src/utils.nw (revision 8741) @@ -1,410 +1,406 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP utils code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: utils.nw 314 2010-04-17 20:32:33Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Miscellaneous Utilities} <<[[utils.f90]]>>= ! utils.f90 -- <> module utils use kinds implicit none private <> <> <> <> - character(len=*), public, parameter :: UTILS_RCS_ID = & - "$Id: utils.nw 314 2010-04-17 20:32:33Z ohl $" contains <> end module utils @ %def utils @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Memory Management} <>= public :: create_array_pointer private :: create_integer_array_pointer private :: create_real_array_pointer private :: create_integer_array2_pointer private :: create_real_array2_pointer @ <>= interface create_array_pointer module procedure & create_integer_array_pointer, & create_real_array_pointer, & create_integer_array2_pointer, & create_real_array2_pointer end interface @ %def create_array_pointer @ <>= if (associated (lhs)) then if (size (lhs) /= n) then deallocate (lhs) if (present (lb)) then allocate (lhs(lb:n+lb-1)) else allocate (lhs(n)) end if end if else if (present (lb)) then allocate (lhs(lb:n+lb-1)) else allocate (lhs(n)) end if end if lhs = 0 @ <>= if (associated (lhs)) then if (any (ubound (lhs) /= n)) then deallocate (lhs) if (present (lb)) then allocate (lhs(lb(1):n(1)+lb(1)-1,lb(2):n(2)+lb(2)-1)) else allocate (lhs(n(1),n(2))) end if end if else if (present (lb)) then allocate (lhs(lb(1):n(1)+lb(1)-1,lb(2):n(2)+lb(2)-1)) else allocate (lhs(n(1),n(2))) end if end if lhs = 0 @ <>= pure subroutine create_integer_array_pointer (lhs, n, lb) integer, dimension(:), pointer :: lhs integer, intent(in) :: n integer, intent(in), optional :: lb <> end subroutine create_integer_array_pointer @ %def create_integer_array_pointer @ <>= pure subroutine create_real_array_pointer (lhs, n, lb) real(kind=default), dimension(:), pointer :: lhs integer, intent(in) :: n integer, intent(in), optional :: lb <> end subroutine create_real_array_pointer @ %def create_real_array_pointer @ <>= pure subroutine create_integer_array2_pointer (lhs, n, lb) integer, dimension(:,:), pointer :: lhs integer, dimension(:), intent(in) :: n integer, dimension(:), intent(in), optional :: lb <> end subroutine create_integer_array2_pointer @ %def create_integer_array2_pointer @ <>= pure subroutine create_real_array2_pointer (lhs, n, lb) real(kind=default), dimension(:,:), pointer :: lhs integer, dimension(:), intent(in) :: n integer, dimension(:), intent(in), optional :: lb <> end subroutine create_real_array2_pointer @ %def create_real_array2_pointer @ Copy an allocatable array component of a derived type, reshaping the target if necessary. The target can be [[disassociated]], but its association \emph{must not} be undefined. <>= public :: copy_array_pointer private :: copy_integer_array_pointer private :: copy_real_array_pointer private :: copy_integer_array2_pointer private :: copy_real_array2_pointer @ <>= interface copy_array_pointer module procedure & copy_integer_array_pointer, & copy_real_array_pointer, & copy_integer_array2_pointer, & copy_real_array2_pointer end interface @ %def copy_array_pointer @ <>= pure subroutine copy_integer_array_pointer (lhs, rhs, lb) integer, dimension(:), pointer :: lhs integer, dimension(:), intent(in) :: rhs integer, intent(in), optional :: lb call create_integer_array_pointer (lhs, size (rhs), lb) lhs = rhs end subroutine copy_integer_array_pointer @ %def copy_integer_array_pointer @ <>= pure subroutine copy_real_array_pointer (lhs, rhs, lb) real(kind=default), dimension(:), pointer :: lhs real(kind=default), dimension(:), intent(in) :: rhs integer, intent(in), optional :: lb call create_real_array_pointer (lhs, size (rhs), lb) lhs = rhs end subroutine copy_real_array_pointer @ %def copy_real_array_pointer @ <>= pure subroutine copy_integer_array2_pointer (lhs, rhs, lb) integer, dimension(:,:), pointer :: lhs integer, dimension(:,:), intent(in) :: rhs integer, dimension(:), intent(in), optional :: lb call create_integer_array2_pointer & (lhs, (/ size (rhs, dim=1), size (rhs, dim=2) /), lb) lhs = rhs end subroutine copy_integer_array2_pointer @ %def copy_integer_array2_pointer @ <>= pure subroutine copy_real_array2_pointer (lhs, rhs, lb) real(kind=default), dimension(:,:), pointer :: lhs real(kind=default), dimension(:,:), intent(in) :: rhs integer, dimension(:), intent(in), optional :: lb call create_real_array2_pointer & (lhs, (/ size (rhs, dim=1), size (rhs, dim=2) /), lb) lhs = rhs end subroutine copy_real_array2_pointer @ %def copy_real_array2_pointer @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Sorting} <>= public :: swap private :: swap_integer, swap_real @ <>= interface swap module procedure swap_integer, swap_real end interface @ %def swap @ <>= elemental subroutine swap_integer (a, b) integer, intent(inout) :: a, b integer :: tmp tmp = a a = b b = tmp end subroutine swap_integer @ %def swap_integer @ <>= elemental subroutine swap_real (a, b) real(kind=default), intent(inout) :: a, b real(kind=default) :: tmp tmp = a a = b b = tmp end subroutine swap_real @ %def swap_real @ Straight insertion: <>= pure subroutine sort_real (key, reverse) real(kind=default), dimension(:), intent(inout) :: key logical, intent(in), optional :: reverse logical :: rev integer :: i, j <> do i = 1, size (key) - 1 <> if (j /= i) then call swap (key(i), key(j)) end if end do end subroutine sort_real @ %def sort_real @ <>= if (present (reverse)) then rev = reverse else rev = .false. end if @ <>= if (rev) then j = sum (maxloc (key(i:))) + i - 1 else j = sum (minloc (key(i:))) + i - 1 end if @ <>= pure subroutine sort_real_and_real_array (key, table, reverse) real(kind=default), dimension(:), intent(inout) :: key real(kind=default), dimension(:,:), intent(inout) :: table logical, intent(in), optional :: reverse logical :: rev integer :: i, j <> do i = 1, size (key) - 1 <> if (j /= i) then call swap (key(i), key(j)) call swap (table(:,i), table(:,j)) end if end do end subroutine sort_real_and_real_array @ %def sort_real_and_real_array @ <>= pure subroutine sort_real_and_integer (key, table, reverse) real(kind=default), dimension(:), intent(inout) :: key integer, dimension(:), intent(inout) :: table logical, intent(in), optional :: reverse logical :: rev integer :: i, j <> do i = 1, size (key) - 1 <> if (j /= i) then call swap (key(i), key(j)) call swap (table(i), table(j)) end if end do end subroutine sort_real_and_integer @ %def sort_real_and_integer @ <>= public :: sort private :: sort_real, sort_real_and_real_array, sort_real_and_integer @ <>= interface sort module procedure & sort_real, sort_real_and_real_array, & sort_real_and_integer end interface @ %def sort @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Mathematics} <>= public :: outer_product @ Admittedly, one has to get used to this notation for the tensor product: <>= pure function outer_product (x, y) result (xy) real(kind=default), dimension(:), intent(in) :: x, y real(kind=default), dimension(size(x),size(y)) :: xy xy = spread (x, dim=2, ncopies=size(y)) & * spread (y, dim=1, ncopies=size(x)) end function outer_product @ %def outer_product @ Greatest common divisor and least common multiple <>= public :: factorize, gcd, lcm private :: gcd_internal @ For our purposes, a straightforward implementation of Euclid's algorithm suffices: <>= pure recursive function gcd_internal (m, n) result (gcd_m_n) integer, intent(in) :: m, n integer :: gcd_m_n if (n <= 0) then gcd_m_n = m else gcd_m_n = gcd_internal (n, modulo (m, n)) end if end function gcd_internal @ %def gcd_internal @ Wrap an elemental procedure around the recursive procedure: <>= elemental function gcd (m, n) result (gcd_m_n) integer, intent(in) :: m, n integer :: gcd_m_n gcd_m_n = gcd_internal (m, n) end function gcd @ %def gcd @ As long as [[m*n]] does not overflow, we can use~$\mathop{\textrm{gcd}}(m,n) \mathop{\textrm{lcm}}(m,n) = mn$: <>= elemental function lcm (m, n) result (lcm_m_n) integer, intent(in) :: m, n integer :: lcm_m_n lcm_m_n = (m * n) / gcd (m, n) end function lcm @ %def lcm @ A very simple minded factorization procedure, that is not fool proof at all. It maintains [[n == product (factors(1:i))]], however, and will work in all cases of practical relevance. <>= pure subroutine factorize (n, factors, i) integer, intent(in) :: n integer, dimension(:), intent(out) :: factors integer, intent(out) :: i integer :: nn, p nn = n i = 0 do p = 1, size (PRIMES) try: do if (modulo (nn, PRIMES(p)) == 0) then i = i + 1 factors(i) = PRIMES(p) nn = nn / PRIMES(p) if (i >= size (factors)) then factors(i) = nn return end if else exit try end if end do try if (nn == 1) then return end if end do end subroutine factorize @ %def factorize @ <>= integer, dimension(13), parameter, private :: & PRIMES = (/ 2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41 /) @ %def PRIMES @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{I/O} <>= public :: find_free_unit @ <>= integer, parameter, private :: MIN_UNIT = 11, MAX_UNIT = 99 @ %def MIN_UNIT MAX_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 @ %def find_free_unit @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/prelude.nw =================================================================== --- trunk/vamp/src/prelude.nw (revision 8740) +++ trunk/vamp/src/prelude.nw (revision 8741) @@ -1,2377 +1,2360 @@ -% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- -% $Id: prelude.nw 314 2010-04-17 20:32:33Z ohl $ +% prelude.nw -- -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \iffalse %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% To: hep-ph@xxx.lanl.gov Subject: put \\ Title: VAMP, Version 1.0: Vegas AMPlified: Anisotropy, Multi-channel sampling and Parallelization. Author: Thorsten Ohl (TU Darmstadt) Comments: ?? pages, LaTeX (using amsmath.sty). Report-no: IKDA 99/?? \\ We present an new implementation of the classic Vegas algorithm for adaptive multi-dimensional Monte Carlo integration in Fortran. This implementation improves the performance for a large class of integrands, supporting stratified sampling in higher dimensions through automatic identification of the directions of largest variation. This implementation also supports multi channel sampling with individual adaptive grids. The sampling can be performed in parallel on workstation clusters and other parallel hardware. \\ \fi %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \NeedsTeXFormat{LaTeX2e} \newif\ifbook \RequirePackage{ifpdf} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \ifpdf %%% PDF LaTeX %%% \documentclass[12pt,a4paper]{report} \documentclass[12pt,a4paper,chapters]{flex} \booktrue%%%\bookfalse \def\preprintno#1{\relax} \usepackage{type1cm} \pdfoutput=1 \usepackage{amsmath,amssymb,amscd} \usepackage{feynmp} \setlength{\unitlength}{1mm} \usepackage[pdftex]{emp} \empaddtoprelude{input graph} \setlength{\unitlength}{1mm} \DeclareGraphicsRule{*}{mps}{*}{} \usepackage[pdftex]{color} \usepackage[pdftex,colorlinks]{hyperref} %%%%%% Don't draw borders: %%%\def\pdfBorderAttrs{/Border [0 0 0] } %%%%%% Default: \def\pdffit{fitbh} %%%\def\pdffit{fit} %%%\makeatletter %%% \def\new@pdflink#1{\def\hyper@hash{}\pdfdest name{#1!}\pdffit} %%%\makeatother \usepackage{thophys} \usepackage{thohacks} \let\timestamp\today %%% \usepackage{mcite} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \else %%% Normal LaTeX %%% \documentclass[12pt]{report} %%% @HEPPH@ %%% \documentclass[12pt,a4paper]{report} %%% @SINGLE@ %%% \documentclass[12pt,a4paper]{report} %%% @DOUBLE@ \documentclass[a4paper]{report} %%% @PREPRINT@ %%% \documentclass[a4paper,chapters]{flex} %%% @???@ \booktrue%%%\bookfalse %%% @PREPRINT@ %%% \usepackage[euler]{thopp} %%% @???@ \usepackage{thopp} %%% @PREPRINT@ \preprintno{\hfil} %%% @PREPRINT@ \usepackage{thophys} \usepackage{amsmath,amssymb,amscd} \allowdisplaybreaks \usepackage{feynmp} \setlength{\unitlength}{1mm} \usepackage{emp} \empaddtoprelude{input graph;} %%% \empaddtoprelude{prologues:=1;} \setlength{\unitlength}{1mm} %%% \usepackage{mcite} \IfFileExists{thohacks.sty}% {\usepackage{thohacks}}% {\let\timestamp\today \newenvironment{dubious}{\begin{itemize}\item[!!!]}{\end{itemize}}}% \special{% !userdict begin /bop-hook { gsave 50 650 translate 300 rotate /Times-Roman findfont 216 scalefont setfont 0 0 moveto 0.9 setgray (DRAFT) show grestore } def end} \fi %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \usepackage{noweb} %%% \usepackage{nocondmac} \setlength{\nwmarginglue}{1em} \noweboptions{smallcode,noidentxref}%%%{webnumbering} %%% Saving paper: \def\nwendcode{\endtrivlist\endgroup} \nwcodepenalty=0 \let\nwdocspar\relax %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% This should be part of flex.cls and/or thopp.sty \makeatletter \@ifundefined{frontmatter}% {\def\frontmatter{\pagenumbering{roman}}% \def\mainmatter{\cleardoublepage\pagenumbering{arabic}}} {} \makeatother %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\newenvironment{RCS}% - {\newwrite\RCSfile - \immediate\openout\RCSfile=\jobname.rcs\relax}% - {\immediate\closeout\RCSfile} -\def\RCSId$#1: #2 ${% - %%%\message{RCSId: #2}% - \immediate\write\RCSfile{\string\texttt{#2}\string\\} - \ignorespaces} -\def\RCSInfo{{ - \InputIfFileExists{\jobname.rcs}% - {\catcode`\_=11}% - {No RCS information available!}}} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \newenvironment{procedures}% {\begin{list}{}% {\setlength{\leftmargin}{2em}% \setlength{\rightmargin}{2em}% \setlength{\itemindent}{-1em}% \setlength{\listparindent}{0pt}% \renewcommand{\makelabel}{\hfil}}% \raggedright}% {\end{list}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% more floats: \setcounter{topnumber}{3} % 2 \setcounter{bottomnumber}{3} % 2 \setcounter{totalnumber}{5} % 3 \renewcommand{\topfraction}{0.95} % 0.7 \renewcommand{\bottomfraction}{0.95} % 0.3 \renewcommand{\textfraction}{0.05} % 0.2 \renewcommand{\floatpagefraction}{0.8} % 0.5 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \def\Version/{1.0} \def\Date/{October 1999} \DeclareMathOperator{\atan}{atan} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \makeindex \begin{document} \title{% \texttt{VAMP}, Version \Version/: Vegas AMPlified:\\ Anisotropy, Multi-channel sampling and Parallelization} \author{% Thorsten Ohl% \thanks{e-mail: \texttt{ohl@hep.tu-darmstadt.de}}% {}\thanks{Supported by Bundesministerium f\"ur Bildung, Wissenschaft, Forschung und Technologie, Germany.}\\ \hfil \\ Darmstadt University of Technology \\ Schlo\ss gartenstr.~9 \\ D-64289 Darmstadt \\ Germany} \date{% IKDA 98/??\\ hep-ph/yymmnnn\\ \Date/\\ \textbf{DRAFT: \timestamp}} \maketitle \ifbook \frontmatter \fi \expandafter\ifx\csname abstract\endcsname\relax\else \begin{abstract} We present an new implementation of the classic Vegas algorithm for adaptive multi-dimensional Monte Carlo integration in Fortran95. This implementation improves the performance for a large class of integrands, supporting stratified sampling in higher dimensions through automatic identification of the directions of largest variation. This implementation also supports multi channel sampling with individual adaptive grids. Sampling can be performed in parallel on workstation clusters and other parallel hardware. Note that for maintenance of the code, and especially its usage within the event generator WHIZARD, some features of Fortran2003 have been added. \end{abstract} \fi %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section*{Revision Control} -\RCSInfo \newpage \tableofcontents %%% \listoffigures %%% \listoftables -\begin{RCS} -\RCSId$Id: prelude.nw 314 2010-04-17 20:32:33Z ohl $ \newpage \begin{empfile} \begin{fmffile}{\jobname pics} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section*{Program Summary:} \begin{itemize} \item \textbf{Title of program:} VAMP, Version \Version/ (\Date/) %CPC% \item \textbf{Catalogue number:} %CPC% ???? \item \textbf{Program obtainable} %CPC% from CPC Program Library, Queen's University of Belfast, %CPC% N.~Ireland (see application form in this issue) or by anonymous \verb|ftp| from the host \hfil\allowbreak\verb|crunch.ikp.physik.th-darmstadt.de| in the directory \allowbreak\verb|pub/ohl/vamp|. \item \textbf{Licensing provisions:} Free software under the GNU General Public License. \item \textbf{Programming language used:} From version 2.2.0 of the program: Fortran2003~\cite{Fortran03} Until version 2.1.x of the program: Fortran95~\cite{Fortran95} (Fortran90~\cite{Fortran90} and F~\cite{Metcalf/Reid:1996:F} versions available as well) \item \textbf{Number of program lines in distributed program, including test data, etc.:} $\approx$ 4300 (excluding comments) \item \textbf{Computer/Operating System:} Any with a Fortran95 (or Fortran90 or F) programming environment. \item \textbf{Memory required to execute with typical data:} Negligible on the scale of typical applications calling the library. \item \textbf{Typical running time:} A small fraction (typically a few percent) of the running time of applications calling the library. \item \textbf{Purpose of program:} \item \textbf{Nature of physical problem:} \item \textbf{Method of solution:} \item \textbf{Keywords:} adaptive integration, event generation, parallel processing \end{itemize} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \ifbook \mainmatter \else \newpage \fi @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Introduction} We present a reimplementation of the classic Vegas~\cite{Lepage:1978:vegas,Lepage:1980:vegas} algorithm for adaptive multi-dimensional integration in Fortran95~\cite{Fortran95,Adams/etal:1997:Fortran95}\footnote{% Fully functional versions conforming to preceeding Fortran standard~\protect\cite{Fortran90}, High Performance Fortran~(HPF)~\cite{HPF1.1,HPF2.0,Koelbel/etal:1994:HPF}, and to the Fortran90 subset~F~\protect\cite{Metcalf/Reid:1996:F} are available as well. A translation to the obsolete FORTRAN77 standard~\protect\cite{FORTRAN77} is possible in principle, but extremely tedious and error prone if the full functionality shall be preserved.} (Note that for the maintenance of the program and especially its usage within the event generator WHIZARD parts of the program have been adapted to Fortran2003). The purpose of this reimplementation is two-fold: for pedagogical reasons it is useful to employ Fortran95 features (in particular the array language) together with literate programming~\cite{Knuth:1991:literate_programming} for expressing the algorithm more concisely and more transparently. On the other hand we use a Fortran95 abstract type to separate the state from the functions. This allows multiple instances of Vegas with different adaptions to run in parallel and in paves the road for a more parallelizable implementation. The variable names are more in line with~\cite{Lepage:1978:vegas} than with~\cite{Lepage:1980:vegas} or with~\cite{Press/etal:1992:NumRecC,Press/etal:1992:NumRec77,% Press/etal:1996:NumRec90}, which is almost identical to~\cite{Lepage:1980:vegas}. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection*{Copyleft} Mention the GNU General Public License (maybe we can switch to the GNU Library General Public License) <>= ! Copyright (C) 1998 by Thorsten Ohl ! ! VAMP 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. ! ! VAMP 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. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @ Mention that the tangled sources are not the preferred form of distribution: <>= ! 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. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Algorithms} \begin{dubious} The notation has to be synchronized with~\cite{Ohl:1998:VAMP-preview}! \end{dubious} We establish some notation to allow a concise discussion. Notation: \begin{subequations} \label{eq:defs} \begin{align} \text{expectation:}&& E(f) &= \frac{1}{|\mathcal{D}|} \int_{\mathcal{D}}\!\textrm{d}x\,f(x)\\ \text{variance:}&& V(f) &= E(f^2) - (E(f))^2 \\ \text{estimate of expectation (average):}&& \braket{X|f} &= \frac{1}{|X|} \sum_{x\in X} f(x)\\ \text{estimate of variance:}&& \sigma^2_X(f) &= \frac{1}{|X|-1} \left( \braket{X|f^2} - \braket{X|f}^2 \right) \end{align} \end{subequations} Where~$|X|$ is the size of the point set and~$|\mathcal{D}|=\int_{\mathcal{D}}\!\textrm{d}x$ the size of the integration region. If~$\mathcal{E}(\braket{f})$ denotes the ensemble average of~$\braket{X|f}$ over random point sets~$X$ with~$|X|=N$, we have for expectation and variance \begin{subequations} \begin{align} \mathcal{E}(\braket{f}) &= E(f) \\ \mathcal{E}(\sigma^2(f)) &= V(f) \\ \intertext{and the ensemble variance of the expectation is also given by the variance} \mathcal{V}(\braket{f}) &= \frac{1}{N} V(f) \end{align} \end{subequations} Therefore, it can be estimated from~$\sigma^2_X(f)$. Below, we will also use the notation~$\mathcal{E}_g$ for the ensemble average over random point sets~$X_g$ with probability distribution~$g$. We will write~$E_g(f)=E(fg)$ as well. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Importance Sampling} If, instead of uniformly distributed points~$X$, we use points~$X_g$ distributed according to a probability density~$g$, we can easily keep the expectation constant \begin{align} \mathcal{E}_g({\braket{f}}) &= E_g\left(\frac{f}{g}\right) = E(f) \\ \intertext{while the variance transformes non-trivially} \mathcal{V}_g({\braket{f}}) &= \frac{1}{N} V_g\left(\frac{f}{g}\right) = \frac{1}{N} \left( E_g\left(\frac{f^2}{g^2}\right) - \left(E_g\left(\frac{f}{g}\right)\right)^2 \right) \end{align} and the error is minimized when~$f/g$ is constant, i.e.~$g$ is a good approximation of~$f$. The non-trivial problem is to find a~$g$ that can be generated efficiently and is a good approximation at the same time. One of the more popular approaches is to use a mapping~$\phi$ of the integration domain \begin{equation} \begin{aligned} \phi: \mathcal{D} &\to \Delta\\ x &\mapsto \xi = \phi(x) \end{aligned} \end{equation} In the new coordinates, the distribution is multiplied by the Jacobian of the inverse map~$\phi^{-1}$: \begin{equation} \int_{\mathcal{D}}\!\textrm{d}x\, f(\phi(x)) = \int_\Delta\!\textrm{d}\xi\, J_{\phi^{-1}}(\xi) f(\xi) \end{equation} A familiar example is given by the map \begin{equation} \begin{aligned} \phi: [0,1] &\to \mathbf{R} \\ x &\mapsto \xi = x^0 + a \cdot \tan\left( \left(x-\frac{1}{2}\right)\pi \right) \end{aligned} \end{equation} with the inverse~$\phi^{-1}(\xi)=\atan((\xi-x_0)/a)/\pi+1/2$ and the corresponding Jacobian reproducing a resonance \begin{equation} J_{\phi^{-1}}(\xi) = \frac{\mathrm{d}\phi^{-1}(\xi)}{\mathrm{d}\xi} = \frac{a}{\pi}\,\frac{1}{(\xi-x^0)^2 + a^2} \end{equation} Obviously, this works only for a few special distributions. Fortunately, we can combine several of these mappings to build efficient integration algorithms, as will be explained in section~\ref{sec:MC} below. Another approach is to construct the approximation numerically, by appropriate binning of the integration domain~(cf.~\cite{Lepage:1978:vegas,Lepage:1980:vegas, Kawabata:1986:Bases/Spring}. The most popular technique for this will be discussed below in section~\ref{sec:vegas}. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Stratified Sampling} The technique of importance sampling concentrates the sampling points in the region where the contribution to the integrand is largest. Alternatively we can also concentrates the sampling points in the region where the contribution to the variance is largest. If we divide the sampling region~$\mathcal{D}$ into~$n$ disjoint subregions~$\mathcal{D}^i$ \begin{equation} \mathcal{D} = \bigcup_{i=1}^n \mathcal{D}^i,\;\;\; \mathcal{D}^i \cap \mathcal{D}^j = \emptyset\;\;(i\not=j) \end{equation} a new estimator is \begin{dubious} Bzzzt! Wrong. These multi-channel formulae are incorrect for partitionings and must be fixed. \end{dubious} \begin{equation} \overline{\braket{X|f}} = \sum_{i=1}^n \frac{N_i}{N} \braket{X_{\theta_i}|f} \end{equation} where \begin{equation} \theta_i(x) = \begin{cases} 1 & \text{ for } x\in \mathcal{D}^i \\ 0 & \text{ for } x\not\in \mathcal{D}^i \end{cases} \end{equation} and \begin{equation} \sum_{i=1}^n N_i = N \end{equation} since the expectation is linear \begin{equation} \mathcal{E}(\overline{\braket{f}}) = \sum_{i=1}^n \frac{N_i}{N} \mathcal{E}_{\theta_i}(\braket{f}) = \sum_{i=1}^n \frac{N_i}{N} E_{\theta_i}(f) = \sum_{i=1}^n \frac{N_i}{N} E(f\theta_i) = E(f) \end{equation} On the other hand, the variance of the estimator~$\overline{\braket{X|f}}$ is \begin{equation} \mathcal{V}(\overline{\braket{f}}) = \sum_{i=1}^n \frac{N_i}{N} \mathcal{V}_{\theta_i}(\braket{f}) \end{equation} This is minimized for \begin{equation} N_i \propto \sqrt{V(f\cdot\theta_{\mathcal{D}^i})} \end{equation} as a simple variation of~$\mathcal{V}(\overline{\braket{f}})$ shows. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Vegas} \label{sec:vegas} \begin{dubious} Under construction! \end{dubious} \begin{empcmds} vardef layout = pair ul, ur, ll, lr; ypart (ul) = ypart (ur); ypart (ll) = ypart (lr); xpart (ul) = xpart (ll); xpart (ur) = xpart (lr); numeric weight_width, weight_dist; weight_width = 0.1w; weight_dist = 0.05w; ll = (.1w,.1w); ur = (w-weight_width-weight_dist,h-weight_width-weight_dist); numeric equ_div, adap_div, rx, ry, rxp, rxm, ryp, rym; equ_div = 3; adap_div = 8; rx = 5.2; ry = 3.6; rxp = ceiling rx; rxm = floor rx; ryp = ceiling ry; rym = floor ry; numeric pi; pi = 180; vardef adap_fct_x (expr x) = (x + sind(2*x*pi)/8) enddef; vardef weight_x (expr x) = (1 + 2*sind(1*x*pi)**2) / 3 enddef; vardef adap_fct_y (expr x) = (x + sind(4*x*pi)/16) enddef; vardef weight_y (expr x) = (1 + 2*sind(2*x*pi)**2) / 3 enddef; vardef grid_pos (expr i, j) = (adap_fct_y(j/adap_div))[(adap_fct_x(i/adap_div))[ll,lr], (adap_fct_x(i/adap_div))[ul,ur]] enddef; vardef grid_square (expr i, j) = grid_pos (i,j) -- grid_pos (i+1,j) -- grid_pos (i+1,j+1) -- grid_pos (i,j+1) -- cycle enddef; enddef; vardef decoration = fill (lr shifted (weight_y(0)*(weight_width,0)) for y = .1 step .1 until 1.01: .. y[lr,ur] shifted (weight_y(y)*(weight_width,0)) endfor -- ur -- lr -- cycle) shifted (weight_dist,0) withcolor 0.7white; fill (ul shifted (weight_x(0)*(0,weight_width)) for x = .1 step .1 until 1.01: .. x[ul,ur] shifted (weight_x(x)*(0,weight_width)) endfor -- ur -- ul -- cycle) shifted (0,weight_dist) withcolor 0.7white; picture px, py; px = btex $p_1(x_1)$ etex; py = btex $p_2(x_2)$ etex; label.top (image (unfill bbox px; draw px), .5[ul,ur] shifted (0,weight_dist)); label.rt (image (unfill bbox py; draw py), .75[lr,ur] shifted (weight_dist,0)); label.lrt (btex $\mathcal{D}_{1,1}$ etex, ll); label.bot (btex $x_1$ etex, .5[ll,lr]); label.bot (btex $\mathcal{D}_{2,1}$ etex, lr); label.ulft (btex $\mathcal{D}_{1,2}$ etex, ll); label.lft (btex $x_2$ etex, .5[ll,ul]); label.lft (btex $\mathcal{D}_{2,2}$ etex, ul); enddef; \end{empcmds} \begin{figure} \begin{center} \begin{emp}(55,50) layout; fill grid_square (rxm,rym) withcolor 0.7white; pickup pencircle scaled .7pt; for i = 0 upto adap_div: draw grid_pos(i,0) -- grid_pos(i,adap_div); draw grid_pos(0,i) -- grid_pos(adap_div,i); endfor pickup pencircle scaled 2pt; drawdot grid_pos(rx,ry); decoration; \end{emp} \begin{emp}(55,50) layout; vardef grid_sub_pos (expr i, di, j, dj) = (dj/equ_div)[(di/equ_div)[grid_pos(i,j),grid_pos(i+1,j)], (di/equ_div)[grid_pos(i,j+1),grid_pos(i+1,j+1)]] enddef; vardef grid_sub_square (expr i, di, j, dj) = grid_sub_pos (i,di,j,dj) -- grid_sub_pos (i,di+1,j,dj) -- grid_sub_pos (i,di+1,j,dj+1) -- grid_sub_pos (i,di,j,dj+1) -- cycle enddef; fill grid_square (rxm,rym) withcolor 0.8white; fill grid_sub_square (rxm,0,rym,1) withcolor 0.6white; pickup pencircle scaled .7pt; for i = 0 upto adap_div: draw grid_pos(i,0) -- grid_pos(i,adap_div); draw grid_pos(0,i) -- grid_pos(adap_div,i); endfor pickup pencircle scaled .5pt; for i = 0 upto (adap_div-1): for j = 1 upto (equ_div-1): draw grid_sub_pos(i,j,0,0) -- grid_sub_pos(i,j,adap_div,0) dashed evenly; draw grid_sub_pos(0,0,i,j) -- grid_sub_pos(adap_div,0,i,j) dashed evenly; endfor endfor pickup pencircle scaled 2pt; drawdot grid_pos(rx,ry); decoration; \end{emp} \end{center} \caption{\label{fig:nonstrat/strat}% \texttt{vegas} grid structure for non-stratified sampling (left) and for genuinely stratified sampling (right), which is used in low dimensions. N.B.: the grid and the weight functions~$p_{1,2}$ are only in qualitative agreement.} \end{figure} \begin{empcmds} numeric pi; pi = 180; vardef adap_fct_one (expr x) = (x + sind(2*x*pi)/8) enddef; vardef adap_fct_two (expr x) = (x + sind(4*x*pi)/16) enddef; vardef adap_fct (expr x) = adap_fct_two (x) enddef; vardef drawbar expr p = draw ((0,-.5)--(0,.5)) scaled 1mm shifted p enddef; \end{empcmds} \begin{empcmds} vardef pseudo (expr xlo, xhi, ylo, yhi, equ_lo, equ_hi, equ_div, adap_lo, adap_hi, adap_div, r, do_labels, do_arrow) = pair equ_grid.lo, equ_grid.hi, adap_grid[]lo, adap_grid[]hi; ypart (equ_grid.lo) = ypart (equ_grid.hi); ypart (adap_grid[1]lo) = ypart (adap_grid[1]hi); ypart (adap_grid[2]lo) = ypart (adap_grid[2]hi); xpart (equ_grid.lo) = xpart (adap_grid[1]lo) = xpart (adap_grid[2]lo); xpart (equ_grid.hi) = xpart (adap_grid[1]hi) = xpart (adap_grid[2]hi); equ_grid.hi = (xhi, yhi); adap_grid[1]lo = .5[equ_grid.lo,adap_grid[2]lo]; adap_grid[2]lo = (xlo, ylo); numeric rp, rm; rp = ceiling r; rm = floor r; pickup pencircle scaled .5pt; for i = adap_lo upto adap_hi: draw (i/adap_div)[adap_grid[1]lo,adap_grid[1]hi] -- (adap_fct(i/adap_div))[adap_grid[2]lo,adap_grid[2]hi] withcolor 0.7white; endfor if do_arrow: fill (rm/adap_div)[adap_grid[1]lo,adap_grid[1]hi] -- (rp/adap_div)[adap_grid[1]lo,adap_grid[1]hi] -- (adap_fct(rp/adap_div))[adap_grid[2]lo,adap_grid[2]hi] -- (adap_fct(rm/adap_div))[adap_grid[2]lo,adap_grid[2]hi] -- cycle withcolor 0.7white; fi if do_labels: label.lft (btex \texttt{0} etex, equ_grid.lo); label.rt (btex \texttt{d\%ng} etex, equ_grid.hi); fi draw (equ_lo/equ_div)[equ_grid.lo,equ_grid.hi] -- (equ_hi/equ_div)[equ_grid.lo,equ_grid.hi]; for i = equ_lo upto equ_hi: drawbar (i/equ_div)[equ_grid.lo,equ_grid.hi]; endfor if do_labels: label.lft (btex $\xi$, \texttt{i: 0} etex, adap_grid[1]lo); label.rt (btex \texttt{ubound(d\%x)} etex, adap_grid[1]hi); label.lft (btex \texttt{d\%x: 0} etex, adap_grid[2]lo); label.rt (btex \texttt{1} etex, adap_grid[2]hi); fi draw (adap_lo/adap_div)[adap_grid[1]lo,adap_grid[1]hi] -- (adap_hi/adap_div)[adap_grid[1]lo,adap_grid[1]hi]; draw (adap_fct(adap_lo/adap_div))[adap_grid[2]lo,adap_grid[2]hi] -- (adap_fct(adap_hi/adap_div))[adap_grid[2]lo,adap_grid[2]hi]; for i = adap_lo upto adap_hi: drawbar (i/adap_div)[adap_grid[1]lo,adap_grid[1]hi]; drawbar (adap_fct(i/adap_div))[adap_grid[2]lo,adap_grid[2]hi]; endfor if do_arrow: pickup pencircle scaled 1pt; pair cell, ia, grid; ia = (r/adap_div)[adap_grid[1]lo,adap_grid[1]hi]; cell = ia shifted (equ_grid.hi - adap_grid[1]hi); grid = (adap_fct(r/adap_div))[adap_grid[2]lo,adap_grid[2]hi]; if do_labels: label.top (btex \texttt{cell - r} etex, cell); fi drawarrow cell -- ia; drawarrow ia -- grid; if do_labels: label.bot (btex \texttt{x} etex, grid); fi fi enddef; \end{empcmds} \begin{figure} \begin{center} \begin{emp}(120,30) pseudo (.3w, .8w, .1h, .8h, 0, 8, 8, 0, 12, 12, 5.2, true, true); \end{emp} \end{center} \caption{\label{fig:pseudo}% One-dimensional illustration of the \texttt{vegas} grid structure for pseudo stratified sampling, which is used in high dimensions.} \end{figure} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Vegas' Inflexibility} \label{sec:vegas/inflexibility} \label{sec:quadrupole} The classic implementation of the Vegas algorithm~\cite{Lepage:1978:vegas,Lepage:1980:vegas} treats all dimensions alike. This constraint allows a very concise FORTRAN77-style coding of the algorithm, but there is no theoretical reason for having the same number of divisions in each direction. On the contrary, under these circumstances, even a dimension in which the integrand is rather smooth will contribute to the exponential blow-up of cells for stratified sampling. It is obviously beneficial to use a finer grid in those directions in which the fluctuations are stronger, while a coarser grid will suffice in the other directions. One small step along this line is implemented in Version~5.0 of the package \texttt{BASES/SPRING}~\cite{Kawabata:1986:Bases/Spring}, where one set of ``wild'' variables is separated from ``smooth'' variables~\cite{GRACE:1993:Manual}. The present reimplementation of the Vegas algorithm allows the application to choose the number of divisions in each direction freely. The routines that reshape the grid accept an integer array with the number of divisions as an optional argument~[[num_div]]. It is easy to construct examples in which the careful use of this feature reduces the variance significantly. Currently, no attempt is made for automatic optimization of the number of divisions. One reasonable approach is to monitor Vegas' grid adjustments and to increase the number of division in those directions where Vegas' keeps adjusting because of fluctuations. For each direction, a numerical measure of these fluctuations is given by the spread in the~$m_i$. The total number of cells can be kept constant by reducing the number of divisions in the other directions appropriately. Thus \begin{equation} n_{\text{div},j} \to \frac{Q_j n_{\text{div},j}}{\left(\prod_j Q_j\right)^{1/n_{\text{dim}}}} \end{equation} where we have used the damped standard deviation \begin{equation} Q_j = \left(\sqrt{\mathop{\textrm{Var}}(\{m\}_j)}\right)^\alpha \end{equation} instead of the spread. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Vegas' Dark Side} \label{sec:vegas/problem} \begin{dubious} Under construction! \end{dubious} A partial solution of this problem will be presented in section~\ref{sec:revolving}. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Multi Channel Sampling} \label{sec:MC} Even if Vegas performs well for a large class of integrands, many important applications do not lead to a factorizable distribution. The class of integrands that can be integranted efficiently by Vegas can be enlarged substantially by using multi channel methods. The new class will include almost all integrals appearing in high energy physics simulations. \begin{dubious} The first version of this section is now obsolete. Consult~\cite{Ohl:1998:VAMP-preview} instead. \end{dubious} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Revolving} \label{sec:revolving} \begin{dubious} Under construction! \end{dubious} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Parallelization} \label{sec:parallelization} Traditionally, parallel processing has not played a large r\^ole in simulations for high energy physics. A natural and trivial method of utilizing many processors will run many instances of the same (serial) program with different values of the input parameters in parallel. Typical matrix elements and phase space integrals offer few opportunities for small scale parallelization. On the other hand, parameter fitting has become possible recently for observables involving a phase space integration. In this case, fast evaluation of the integral is essential and parallel execution becomes an interesting option. A different approach to parallelizing Vegas has been presented recently~\cite{Veseli:1998:Parallel-Vegas}. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Multilinear Structure of the Sampling Algorithm} \label{sec:multi-linear} In order to discuss the problems with parallelizing adaptive integration algorithms and to present solutions, it helps to introduce some mathematical notation. A sampling~$S$ is a map from the space~$\pi$ of point sets and the space~$F$ of functions to the real (or complex) numbers \begin{equation*} \begin{aligned} S: \pi \times F & \to \mathbf{R} \\ (p,f) & \mapsto I = S(p,f) \end{aligned} \end{equation*} For our purposes, we have to be more specific about the nature of the point set. In general, the point set will be characterized by a sequence of pseudo random numbers~$\rho\in R$ and by one or more grids~$G\in\Gamma$ used for importance or stratified sampling. A simple sampling \begin{equation} \label{eq:S0} \begin{aligned} S_0: R \times \Gamma \times A \times F \times\mathbf{R}\times\mathbf{R} & \to R \times \Gamma \times A \times F \times\mathbf{R}\times\mathbf{R}\\ (\rho, G, a, f, \mu_1, \mu_2) & \mapsto (\rho', G, a', f, \mu_1', \mu_2') = S_0 (\rho, G, a, f, \mu_1, \mu_2) \end{aligned} \end{equation} estimates the $n$-th moments $\mu_n'\in\mathbf{R}$ of the function~$f\in F$. The integral and its standard deviation can be derived easily from the moments \begin{subequations} \begin{align} I &= \mu_1 \\ \sigma^2 &= \frac{1}{N-1} \left(\mu_2 - \mu_1^2\right) \end{align} \end{subequations} while the latter are more convenient for the following discussion. In addition, $S_0$ collects auxiliary information to be used in the grid refinement, denoted by~$a\in A$. The unchanged arguments~$G$ and~$f$ have been added to the result of~$S_0$ in~(\ref{eq:S0}), so that~$S_0$ has identical domain and codomain and can therefore be iterated. Previous estimates~$\mu_n$ may be used in the estimation of~$\mu_n'$, but a particular~$S_0$ is free to ignore them as well. Using a little notational freedom, we augment~$\mathbf{R}$ and~$A$ with a special value~$\cdot$, which will always be discarded by~$S_0$. In an adaptive integration algorithm, there is also a refinement operation~$r:\Gamma\times A \to\Gamma$ that can be extended naturally to the codomain of~$S_0$ \begin{equation} \begin{aligned} r: R \times \Gamma \times A \times F \times\mathbf{R}\times\mathbf{R} & \to R \times \Gamma \times A \times F \times\mathbf{R}\times\mathbf{R}\\ (\rho, G, a, f, \mu_1, \mu_2) & \mapsto (\rho, G', a, f, \mu_1, \mu_2) = r (\rho, G, a, f, \mu_1, \mu_2) \end{aligned} \end{equation} so that~$S=rS_0$ is well defined and we can specify $n$-step adaptive sampling as \begin{equation} \label{eq:Sn} S_n = S_0 (rS_0)^n \end{equation} Since, in a typical application, only the estimate of the integral and the standard deviation are used, a projection can be applied to the result of~$S_n$: \begin{equation} \label{eq:P} \begin{aligned} P: R \times \Gamma \times A \times F \times\mathbf{R}\times\mathbf{R} & \to \mathbf{R}\times\mathbf{R}\\ (\rho, G, a, f, \mu_1, \mu_2) & \mapsto (I,\sigma) \end{aligned} \end{equation} Then \begin{equation} (I,\sigma) = P S_0 (rS_0)^n (\rho, G_0, \cdot, f, \cdot, \cdot) \end{equation} and a good refinement prescription~$r$, such as Vegas, will minimize the~$\sigma$. For parallelization, it is crucial to find a division of~$S_n$ or any part of it into \emph{independent} pieces that can be evaluated in parallel. In order to be effective, $r$ has to be applied to \emph{all} of~$a$ and therefore a sychronization of~$G$ before and after~$r$ is appropriately. Forthermore, $r$ usually uses only a tiny fraction of the CPU time and it makes little sense to invest a lot of effort into parallelizing it beyond what the Fortran compiler can infer from array notation. On the other hand, $S_0$ can be parallelized naturally, because all operations are linear, including he computation of~$a$. We only have to make sure that the cost of communicating the results of~$S_0$ and~$r$ back and forth during the computation of~$S_n$ do not offset any performance gain from parallel processing. When we construct a decomposition of~$S_0$ and proof that it does not change the results, i.e. \begin{equation} S_0 = \iota S_0 \phi \end{equation} where~$\phi$ is a forking operation and~$\iota$ is a joining operation, we are faced with the technical problem of a parallel random number source~$\rho$. As made explicit in~(\ref{eq:S0}, $S_0$ changes the state of the random number general~$\rho$, demanding \emph{identical} results therefore imposes a strict ordering on the operations and defeats parallelization. It is possible to devise implementations of~$S_0$ and~$\rho$ that circumvent this problem by distributing subsequences of~$\rho$ in such a way among processes that results do not depend on the number of parallel processes. However, a reordering of the random number sequence will only change the result by the statistical error, as long as the scale of the allowed reorderings is \emph{bounded} and much smaller than the period of the random number generator~\footnote{Arbirtrary reorderings on the scale of the period of the random number generators could select constant sequences and have to be forbidden.} Below, we will therefore use the notation $x\approx y$ for ``equal for an appropriate finite reordering of the~$\rho$ used in calculating~$x$ and~$y$''. For our porposes, the relation~$x\approx y$ is strong enough and allows simple and efficient implementations. Since~$S_0$ is essentially a summation, it is natural to expect a linear structure \begin{subequations} \label{eq:S0-parallel} \begin{equation} \bigoplus_i S_0(\rho_i, G_i, a_i, f, \mu_{1,i}, \mu_{2,i}) \approx S_0 (\rho, G, a, f, \mu_1, \mu_2) \end{equation} where \begin{align} \rho &= \bigoplus_i \rho_i \\ G &= \bigoplus_i G_i \\ a &= \bigoplus_i a_i \\ \mu_n &= \bigoplus_i \mu_{n,i} \end{align} \end{subequations} for appropriate definitions of ``$\oplus$''. For the moments, we have standard addition \begin{equation} \mu_{n,1} \oplus \mu_{n,2} = \mu_{n,1} + \mu_{n,2} \end{equation} and since we only demand equality up to reordering, we only need that the~$\rho_i$ are statistically independent. This leaves us with~$G$ and~$a$ and we have to discuss importance sampling ans stratified sampling separately. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Importance Sampling} In the case of naive Monte Carlo and importance sampling the natural decomposition of~$G$ is to take~$j$ copies of the same grid~$G/j$ which is identical to~$G$, each with one $j$-th of the total sampling points. As long as the~$a$ are linear themselves, we can add them up just like the moments \begin{equation} a_1 \oplus a_2 = a_1 + a_2 \end{equation} and we have found a decomposition~(\ref{eq:S0-parallel}). In the case of Vegas, the~$a_i$ are sums of function values at the sampling points. Thus they are obviously linear and this approach is applicable to Vegas in the importance sampling mode. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Stratified Sampling} The situation is more complicated in the case of stratified sampling. The first complication is that in pure stratified sampling there are only two sampling points per cell. Splitting the grid in two pieces as above provide only a very limited amount of parallelization. The second complication is that the~$a$ are no longer linear, since they corrspond to a sampling of the variance per cell and no longer of function values themselves. However, as long as the samplings contribute to disjoint bins only, we can still ``add'' the variances by combining bins. The solution is therefore to divide the grid into disjoint bins along the divisions of the stratification grid and to assign a set of bins to each processor. Finer decompositions will incur higher communications costs and other resource utilization. An implementation based on~PVM is described in~\cite{Veseli:1998:Parallel-Vegas}, which miminizes the overhead by running identical copies of the grid~$G$ on each processor. Since most of the time is usually spent in function evaluations, it makes sense to run a full~$S_0$ on each processor, skipping function evaluations everywhere but in the region assigned to the processor. This is a neat trick, which is unfortunately tied to the computational model of message passing systems such as~PVM and~MPI~\cite{MPI}. More general paradigms can not be supported since the separation of the state for the processors is not explicit (it is implicit in the separated address space of the PVM or MPI processes). However, it is possible to implement~(\ref{eq:S0-parallel}) directly in an efficient manner. This is based on the observation that the grid~$G$ used by Vegas is factorized into divisions~$D^j$ for each dimension \begin{equation} \label{eq:factorize} G = \bigotimes_{j=1}^{n_{\text{dim}}} D^j \end{equation} and decompositions of the~$D^j$ induce decompositions of~$G$ \begin{multline} \label{eq:decomp} G_1 \oplus G_2 = \left( \bigotimes_{j=1}^{i-1} D^j \otimes D^i_1 \otimes \bigotimes_{i=j+1}^{n_{\text{dim}}} D^j \right) \oplus \left( \bigotimes_{j=1}^{i-1} D^j \otimes D^i_2 \otimes \bigotimes_{i=j+1}^{n_{\text{dim}}} D^j \right) \\ = \bigotimes_{j=1}^{i-1} D^j \otimes \left( D^i_1 \oplus D^i_2 \right) \otimes \bigotimes_{j=i+1}^{n_{\text{dim}}} D^j \end{multline} We can translate~(\ref{eq:decomp}) directly to code that performs the decomposition~$D^i = D^i_1 \oplus D^i_2$ discussed below and simply duplicates the other divisions~$D^{j\not=i}$. A decomposition along multiple dimensions is implemented by a recursive application of~(\ref{eq:decomp}). In Vegas, the auxiliary information~$a$ inherits a factorization similar to the grid~$(\ref{eq:factorize})$ \begin{equation} \label{eq:factorize'} a = (d^1,\ldots,d^{n_{\text{dim}}}) \end{equation} but not a multilinear structure. Instead, \emph{as long as the decomposition respects the stratification grid}, we find the in place of~(\ref{eq:decomp}) \begin{equation} \label{eq:decomp'} a_1 \oplus a_2 = (d^1_1 + d^1_2,\ldots, d^i_1 \oplus d^i_2, \ldots, d^{n_{\text{dim}}}_1 + d^{n_{\text{dim}}}_2) \end{equation} with ``$+$'' denoting the standard addition of the bin contents and ``$\oplus$'' denoting the aggregation of disjoint bins. If the decomposition of the division would break up cells of the stratification grid~(\ref{eq:decomp'}) would be incorrect, because, as discussed above, the variance is not linear. Now it remains to find a decomposition \begin{equation} D^i = D^i_1 \oplus D^i_2 \end{equation} for both the pure stratification mode and the pseudo stratification mode of vegas (cf.\ figure~\ref{fig:nonstrat/strat}). In the pure stratification mode, the stratification grid is strictly finer than the adaptive grid and we can decompose along either of them immediately. Technically, a decomposition along the coarser of the two is straightforward. Since the adaptive grid already has more than 25~bins, a decomposition along the stratification grid makes no practical sense and the decomposition along the adaptive grid has been implemented. The sampling algorithm~$S_0$ can be applied \emph{unchanged} to the individual grids resulting from the decomposition. \begin{figure} \begin{center} \begin{emp}(120,90) pseudo (.3w, .8w, .7h, .9h, 0, 8, 8, 0, 12, 12, 5.2, true, true); % lcm (lcm (3, 8) / 3, 12) pseudo (.3w, .8w, .4h, .6h, 0, 8, 8, 0, 24, 24, 5.2*2, false, true); % forks pseudo (.2w, .7w, .1h, .3h, 0, 2, 8, 0, 6, 24, 5.2*2, false, false); pseudo (.3w, .8w, .1h, .3h, 2, 5, 8, 6, 15, 24, 5.2*2, false, true); pseudo (.4w, .9w, .1h, .3h, 5, 8, 8, 15, 24, 24, 5.2*2, false, false); label.urt (btex \texttt{ds(1)} etex, (.2w, 0)); label.top (btex \texttt{ds(2)} etex, (.5w, 0)); label.ulft (btex \texttt{ds(3)} etex, (.9w, 0)); \end{emp} \end{center} \caption{\label{fig:pseudo-fork}% Forking one dimension~\texttt{d} of a grid into three parts \texttt{ds(1)}, \texttt{ds(2)}, and~\texttt{ds(3)}. The picture illustrates the most complex case of pseudo stratified sampling (cf.~fig.~\ref{fig:pseudo}).} \end{figure} For pseudo stratified sampling (cf.\ figure~\ref{fig:pseudo}), the situation is more complicated, because the adaptive and the stratification grid do not share bin boundaries. Since Vegas does \emph{not} use the variance in this mode, it would be theoretically possible to decompose along the adaptive grid and to mimic the incomplete bins of the stratification grid in the sampling algorithm. However, this would be a technical complication, destroying the universality of~$S_0$. Therefore, the adaptive grid is subdivided in a first step in \begin{equation} \mathop{\textrm{lcm}} \left( \frac{\mathop{\textrm{lcm}}(n_f,n_g)}{n_f}, n_x \right) \end{equation} bins,\footnote{The coarsest grid covering the division of~$n_g$ bins into~$n_f$ forks has $n_g / \mathop{\textrm{gcd}}(n_f,n_g) = \mathop{\textrm{lcm}}(n_f,n_g) / n_f$ bins per fork.} such that the adaptive grid is strictly finer than the stratification grid. This procedure is shown in figure~\ref{fig:pseudo-fork}. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{State and Message Passing} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Random Numbers} In the parallel example sitting on top of MPI~\cite{MPI} takes advantage of the ability of Knuth's generator~\cite{Knuth:1997:TAOCP2} to generate statistically independent subsequences. However, since the state of the random number generator is explicit in all procedure calls, other means of obtaining subsequences can be implemented in a trivial wrapper. The results of the parallel example will depend on the number of processors, because this effects the subsequences being used. Of course, the variation will be compatible with the statistical error. It must be stressed that the results are deterministic for a given number of processors and a given set of random number generator seeds. Since parallel computing environments allow to fix the number of processors, debugging of exceptional conditions is possible. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Practice} In this section we show three implementations of~$S_n$: one serial, and two parallel, based on HPF~\cite{HPF1.1,HPF2.0,Koelbel/etal:1994:HPF} and MPI~\cite{MPI}, respectively. From these examples, it should be obvious how to adapt VAMP to other parallel computing paradigms. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Serial} Here is a bare bones serail version of~$S_n$, for comparison with the parallel versions below. The real implementation of [[vamp_sample_grid]] in the module [[vamp]] includes some error handling, diagnostics and the projection~$P$ (cf.~(\ref{eq:P})): <>= subroutine vamp_sample_grid (rng, g, iterations, func) type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g integer, intent(in) :: iterations <> integer :: iteration iterate: do iteration = 1, iterations call vamp_sample_grid0 (rng, g, func) call vamp_refine_grid (g) end do iterate end subroutine vamp_sample_grid @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{HPF} The HPF version of~$S_n$ is based on decomposing the grid~[[g]] as described in section~\ref{sec:multi-linear} and lining up the components in an array~[[gs]]. The elements of~[[gs]] can then be processed im parallel. This version can be compiled with any Fortran compiler and a more complete version of this procedure (including error handling, diagnostics and the projection~$P$) is included with VAMP as [[vamp_sample_grid_parallel]] in the module [[vamp]]. This way, the algorithm can be tested on a serial machine, but there will obviously be no performance gain.\par Instead of one random number generator state~[[rng]], it takes an array consisting of one state per processor. These [[rng(:)]] are assumed to be initialized, such that the resulting sequences are statistically independent. For this purpose, Knuth's random number generator~\cite{Knuth:1997:TAOCP2} is most convenient and is included with VAMP (see the example on page~\pageref{pg:tao-hpf}). Before each~$S_0$, the procedure [[vamp_distribute_work]] determines a good decomposition of the grid~[[d]] into [[size(rng)]] pieces. This decomposition is encoded in the array [[d]] where [[d(1,:)]] holds the dimensions along which to split the grid and [[d(2,:)]] holds the corrsponding number of divisions. Using this information, the grid is decomposed by [[vamp_fork_grid]]. The HPF compiler will then distribute the [[!hpf$ independent]] loop among the processors. Finally, [[vamp_join_grid]] gathers the results. <>= subroutine vamp_sample_grid_hpf (rng, g, iterations, func) type(tao_random_state), dimension(:), intent(inout) :: rng type(vamp_grid), intent(inout) :: g integer, intent(in) :: iterations <> type(vamp_grid), dimension(:), allocatable :: gs, gx !hpf$ processors p(number_of_processors()) !hpf$ distribute gs(cyclic(1)) onto p integer, dimension(:,:), pointer :: d integer :: iteration, num_workers iterate: do iteration = 1, iterations call vamp_distribute_work (size (rng), vamp_rigid_divisions (g), d) num_workers = max (1, product (d(2,:))) if (num_workers > 1) then allocate (gs(num_workers), gx(vamp_fork_grid_joints (d))) call vamp_create_empty_grid (gs) call vamp_fork_grid (g, gs, gx, d) !hpf$ independent do i = 1, num_workers call vamp_sample_grid0 (rng(i), gs(i), func) end do call vamp_join_grid (g, gs, gx, d) call vamp_delete_grid (gs) deallocate (gs, gx) else call vamp_sample_grid0 (rng(1), g, func) end if call vamp_refine_grid (g) end do iterate end subroutine vamp_sample_grid_hpf @ Since [[vamp_sample_grid0]] performes the bulk of the computation, an almost linear speedup with the number of processors can be achieved, if [[vamp_distribute_work]] finds a good decomposition of the grid. The version of [[vamp_distribute_work]] distributed with VAMP does a good job in most cases, but will not be able to use all processors if their number is a prime number larger than the number of divisions in the stratification grid. Therefore it can be beneficial to tune [[vamp_distribute_work]] to specific hardware. Furthermore, using a finer stratification grid can improve performance.\par For definiteness, here is an example of how to set up the array of random number generators for HPF. Note that this simple seeding procedure only guarantees statistically independent sequences with Knuth's random number generator~\cite{Knuth:1997:TAOCP2} and will fail with other approaches. \label{pg:tao-hpf} <>= type(tao_random_state), dimension(:), allocatable :: rngs !hpf$ processors p(number_of_processors()) !hpf$ distribute gs(cyclic(1)) onto p integer :: i, seed ! ... allocate (rngs(number_of_processors())) seed = 42 !: can be read from a file, of course \ldots !hpf$ independent do i = 1, size (rngs) call tao_random_create (rngs(i), seed + i) end do ! ... call vamp_sample_grid_hpf (rngs, g, 6, func) ! ... @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{MPI} The MPI version is more low level, because we have to keep track of message passing ourselves. Note that we have made this synchronization points explicit with three [[if ... then ... else ... end if]] blocks: forking, sampling, and joining. These blocks could be merged (without any performance gain) at the expense of readability. We assume that [[rng]] has been initialized in each process such that the sequences are again statistically independent. <>= subroutine vamp_sample_grid_mpi (rng, g, iterations, func) type(tao_random_state), dimension(:), intent(inout) :: rng type(vamp_grid), intent(inout) :: g integer, intent(in) :: iterations <> type(vamp_grid), dimension(:), allocatable :: gs, gx integer, dimension(:,:), pointer :: d integer :: num_proc, proc_id, iteration, num_workers call mpi90_size (num_proc) call mpi90_rank (proc_id) iterate: do iteration = 1, iterations if (proc_id == 0) then call vamp_distribute_work (num_proc, vamp_rigid_divisions (g), d) num_workers = max (1, product (d(2,:))) end if call mpi90_broadcast (num_workers, 0) if (proc_id == 0) then allocate (gs(num_workers), gx(vamp_fork_grid_joints (d))) call vamp_create_empty_grid (gs) call vamp_fork_grid (g, gs, gx, d) do i = 2, num_workers call vamp_send_grid (gs(i), i-1, 0) end do else if (proc_id < num_workers) then call vamp_receive_grid (g, 0, 0) end if if (proc_id == 0) then if (num_workers > 1) then call vamp_sample_grid0 (rng, gs(1), func) else call vamp_sample_grid0 (rng, g, func) end if else if (proc_id < num_workers) then call vamp_sample_grid0 (rng, g, func) end if if (proc_id == 0) then do i = 2, num_workers call vamp_receive_grid (gs(i), i-1, 0) end do call vamp_join_grid (g, gs, gx, d) call vamp_delete_grid (gs) deallocate (gs, gx) call vamp_refine_grid (g) else if (proc_id < num_workers) then call vamp_send_grid (g, 0, 0) end if end do iterate end subroutine vamp_sample_grid_mpi @ A more complete version of this procedure is included with VAMP as well, this time as [[vamp_sample_grid]] in the MPI support module [[vampi]]. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Design Trade Offs} \label{sec:design} There have been three competing design goals for vegas, that are not fully compatible and had to be reconciled with compromises: \begin{itemize} \item \textit{Ease-Of-Use:} few procedures, few arguments. \item \textit{Parallelizability:} statelessness \item \textit{Performance and Flexibility:} rich interface, functionality. \end{itemize} In fact, parallelizability and ease-of-use are complementary. A parallelizable implementation has to expose \emph{all} the internal state. In our case, this includes the state of the random number generator and the adaptive grid. A simple interface would hide such details from the user. The modern language features introduced to Fortran in~1990~\cite{Fortran90} allows to reconcile these competing goals. Two abstract data types [[vamp_state]] and [[tao_random_state]] hide the details of the implementation from the user and encapsulate the two states in just two variables. Another problem with parallelizability arised from the lack of a general exception mechanism in Fortran. The Fortran90 standard~\cite{Fortran95} forbids \emph{any} input/output (even to the terminal) as well as [[stop]] statements in parallelizable ([[pure]]) procedures. This precludes simple approaches to monitoring and error handling. In Vegas we use a simple hand crafted exception mechanism~(see chapter~\ref{sec:exceptions}) for communicating error conditions to the out layers of the applications. Unfortunately this requires the explicit passing of state in argument lists. An unfortunate consequence of the similar approach to monitoring is that monitoring is \emph{not} possible during execution. Instead, intermediate results can only be examined after a parallelized section of code has completed. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Programming Language} We have chosen to implement VAMP in Fortran90/95, which some might consider a questionable choice today. Nevertheless, we are convinced that Fortran90/95 (with all it's weaknesses) is, by a wide margin, the right tool for the job. Let us consider the alternatives \begin{itemize} \item FORTRAN77 is still the dominant language in high energy physics and all running experiment's software environments are based on it. However, the standard~\cite{FORTRAN77} is obsolete now and the successors~\cite{Fortran90,Fortran95} have added many desirable features, while retaining almost all of FORTRAN77 a a subset. \item \texttt{C}/\texttt{C++} appears to be the most popular programming language in industry and among young high energy physicists. Large experiments have taken a bold move and are basing their software environment on \texttt{C++}. \item Typed higher order functional programming languages (ML, Haskell, etc.) are a very promising development. Unfortunately, there is not yet enough industry support for high performance optimizing compilers. While the performance penalty of these languages is not as high as commonly believed (research compilers, which do not perform extensive processor specific optimizations, result in code that runs by a factor of two or three slower than equivalent Fortran code), it is relevant for long running, computing intensive applications. In addition, these languages are syntactically and idiomatically very different from Fortran and \texttt{C}. Another implementation of VAMP in ML will be undertaken for research purposes to investigate new algorithms that can only be expressed awkwardly in Fortran, but we do not expect it to gain immediate popularity. \end{itemize} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Usage} \section{Basic Usage} \begin{procedures} \item{} [[type(vamp_grid)]] \hfil\goodbreak \item{} [[subroutine vamp_create_grid]] (% [[g]], [[domain]] [,~[[num_calls]]{}] [,~[[exc]]{}]) \hfil\goodbreak Create a fresh grid for the integration domain \begin{equation} \mathcal{D} = [D_{1,1},D_{2,1}] \times [D_{1,2},D_{2,2}] \times \ldots \times [D_{1,n},D_{2,n}] \end{equation} dropping all accumulated results. This function \emph{must not} be called twice on the first argument, without an intervening [[vamp_delete_grid]]. Iff the variable [[num_calls]] is given, it will be the number of sampling points per iteration for the call to [[vamp_sample_grid]]. \item{} [[subroutine vamp_delete_grid]] (% [[g]] [,~[[exc]]{}]) \hfil\goodbreak \item{} [[subroutine vamp_discard_integral]] (% [[g]] [,~[[num_calls]]{}] [,~[[exc]]{}]) \hfil\goodbreak Keep the current optimized grid, but drop the accumulated results for the integral (value and errors). Iff the variable [[num_calls]] is given, it will be the new number of sampling points per iteration for the calls to [[vamp_sample_grid]]. \item{} [[subroutine vamp_reshape_grid]] (% [[g]] [,~[[num_calls]]{}] [,~[[exc]]{}]) \hfil\goodbreak Keep the current optimized grid and the accumulated results for the integral (value and errors). The variable [[num_calls]] is the new number of sampling points per iteration for the calls to [[vamp_sample_grid]]. \item{} [[subroutine vamp_sample_grid]] (% [[rng]], [[g]], [[func]], [[iterations]] [,~[[integral]]{}] [,~[[std_dev]]{}] [,~[[avg_chi2]]{}] [,~[[exc]]{}] [,~[[history]]{}]) \hfil\goodbreak Sample the function [[func]] using the grid [[g]] for [[iterations]] iterations and optimize the grid after each iteration. The results are returned in [[integral]], [[std_dev]] and [[avg_chi2]]. The random number generator uses and updates the state stored in [[rng]]. The explicit random number state is inconvenient, but required for parallelizability. \item{} [[subroutine vamp_integrate]] (% [[rng]], [[g]], [[func]], [[calls]] [,~[[integral]]{}] [,~[[std_dev]]{}] [,~[[avg_chi2]]{}] [,~[[exc]]{}] [,~[[history]]{}]) \hfil\goodbreak This is a wrapper around the above routines, that is steered by a [[integer, dimension(2,:)]] array [[calls]]. For each~[[i]], there will be [[calls(1,i)]] iterations with [[calls(2,i)]] sampling points. \item{} [[subroutine vamp_integrate]] (% [[rng]], [[domain]], [[func]], [[calls]] [,~[[integral]]{}] [,~[[std_dev]]{}] [,~[[avg_chi2]]{}] [,~[[exc]]{}] [,~[[history]]{}]) \hfil\goodbreak A second specific form of [[vamp_integrate]]. This one keeps a private grid and provides the shortest---and most inflexible---calling sequence. \end{procedures} <>= interface function func (xi, data, weights, channel, grids) result (f) use kinds use vamp_grid_type !NODEP! import vamp_data_t real(kind=default), dimension(:), intent(in) :: xi class(vamp_data_t), intent(in) :: data real(kind=default), dimension(:), intent(in), optional :: weights integer, intent(in), optional :: channel type(vamp_grid), dimension(:), intent(in), optional :: grids real(kind=default) :: f end function func end interface @ %def func @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Basic Example} In Fortran95, the function to be sampled \emph{must} be \texttt{pure}, i.e. have no side effects to allow parallelization. The optional arguments [[weights]] and [[channel]] \emph{must} be declared to allow the compiler to verify the interface, but they are ignored during basic use. Their use for multi channel sampling will be explained below. Here's a Gaussian \begin{equation} f(x) = e^{-\frac{1}{2}\sum_i x_i^2} \end{equation} <<[[basic.f90]]>>= module basic_fct use kinds implicit none private public :: fct contains function fct (x, weights, channel) result (f_x) real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:), intent(in), optional :: weights integer, intent(in), optional :: channel real(kind=default) :: f_x f_x = exp (-0.5 * sum (x*x)) end function fct end module basic_fct @ In the main program, we need to import five modules. The customary module [[kinds]] defines [[double]] as the kind for double precision floating point numbers. The model [[exceptions]] provides simple error handling support (parallelizable routines are not allowed to issue error messages themselve, but must pass them along). The module [[tao_random_numbers]] hosts the random number generator used and [[vamp]] is the adaptive interation module proper. Finally, the application module [[basic_fct]] has to be imported as well. <<[[basic.f90]]>>= program basic use kinds use exceptions use tao_random_numbers use vamp use basic_fct implicit none @ Then we define four variables for an error message, the random number generator state and the adaptive integration grid. We also declare a variable for holding the integration domain and variables for returning the result. In this case we integrate the 7-dimensional hypercube. <<[[basic.f90]]>>= type(exception) :: exc type(tao_random_state) :: rng type(vamp_grid) :: grid real(kind=default), dimension(2,7) :: domain real(kind=default) :: integral, error, chi2 domain(1,:) = -1.0 domain(2,:) = 1.0 @ Initialize and seed the random number generator. Initialize the grid for 10\,000 sampling points. <<[[basic.f90]]>>= call tao_random_create (rng, seed=0) call clear_exception (exc) call vamp_create_grid (grid, domain, num_calls=10000, exc=exc) call handle_exception (exc) @ Warm up the grid in six low statistics iterations. Clear the error status before and check it after the sampling. <<[[basic.f90]]>>= call clear_exception (exc) call vamp_sample_grid (rng, grid, fct, 6, exc=exc) call handle_exception (exc) @ Throw away the intermediate results and reshape the grid for 100\,000 sampling points---keeping the adapted grid---and do four iterations of a higher statistics integration <<[[basic.f90]]>>= call clear_exception (exc) call vamp_discard_integral (grid, num_calls=100000, exc=exc) call handle_exception (exc) call clear_exception (exc) call vamp_sample_grid (rng, grid, fct, 4, integral, error, chi2, exc=exc) call handle_exception (exc) print *, "integral = ", integral, "+/-", error, " (chi^2 = ", chi2, ")" end program basic @ Since this is the most common use, there is a convenience routine available and the following code snippet is equivalent: <>= integer, dimension(2,2) :: calls calls(:,1) = (/ 6, 10000 /) calls(:,2) = (/ 4, 100000 /) call clear_exception (exc) call vamp_integrate (rng, domain, fct, calls, integral, error, chi2, exc=exc) call handle_exception (exc) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Advanced Usage} \begin{dubious} Caveat emptor: no magic of literate programming can guarantee that the following remains in sync with the implementation. This has to be maintained manually. \end{dubious} All [[real]] variables are declared as [[real(kind=default)]] in the source and the variable [[double]] is imported from the module [[kinds]] (see appendix~\ref{sec:kinds}). The representation of real numbers can therefore be changed by changing [[double]] in [[kinds]]. \subsection{Types} \begin{procedures} \item{} [[type(vamp_grid)]] \hfil\goodbreak \item{} [[type(vamp_grids)]] \hfil\goodbreak \item{} [[type(vamp_history)]] \hfil\goodbreak \item{} [[type(exception)]] \hfil\goodbreak (from module [[exceptions]]) \end{procedures} \subsection{Shared Arguments} Arguments keep their name across procedures, in order to make the Fortran90 keyword interface consistent. \begin{procedures} \item{} [[real, intent(in) :: accuracy]] \hfil\goodbreak Terminate~$S_n$ after $n'>= call vamp_marshal_grid_size (g, isize, dsize) allocate (ibuf(isize), dbuf(dsize)) call mpi_comm_rank (MPI_COMM_WORLD, proc_id, errno) select case (proc_id) case (0) call vamp_marshal_grid (g, ibuf, dbuf) call mpi_send (ibuf, size (ibuf), MPI_INTEGER, & 1, 1, MPI_COMM_WORLD, errno) call mpi_send (dbuf, size (dbuf), MPI_DOUBLE_PRECISION, & 1, 2, MPI_COMM_WORLD, errno) case (1) call mpi_recv (ibuf, size (ibuf), MPI_INTEGER, & 0, 1, MPI_COMM_WORLD, status, errno) call mpi_recv (dbuf, size (dbuf), MPI_DOUBLE_PRECISION, & 0, 2, MPI_COMM_WORLD, status, errno) call vamp_unmarshal_grid (g, ibuf, dbuf) end select @ assuming that [[double]] is such that [[MPI_DOUBLE_PRECISION]] corresponds to [[real(kind=default)]]. The module [[vampi]] provides two high level functions [[vamp_send_grid]] and [[vamp_receive_grid]] that handle the low level details: <>= call mpi_comm_rank (MPI_COMM_WORLD, proc_id, errno) select case (proc_id) case (0) call vamp_send_grid (g, 1, 0) case (1) call vamp_receive_grid (g, 0, 0) end select @ \begin{procedures} \item{} [[subroutine vamp_marshal_history_size]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_marshal_history]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_unmarshal_history]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \end{procedures} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Multi Channel Procedures} \begin{equation} \label{eq:gophi_i!} g\circ\phi_i = \left|\frac{\partial\phi_i}{\partial x}\right|^{-1} \left( \alpha_i g_i + \sum_{\substack{j=1\\j\not=i}}^{N_c} \alpha_j (g_j\circ\pi_{ij}) \left|\frac{\partial\pi_{ij}}{\partial x}\right| \right)\,. \end{equation} @ <>= interface pure function phi (xi, channel) result (x) use kinds real(kind=default), dimension(:), intent(in) :: xi integer, intent(in) :: channel real(kind=default), dimension(size(xi)) :: x end function phi end interface @ %def phi @ <>= interface pure function ihp (x, channel) result (xi) use kinds real(kind=default), dimension(:), intent(in) :: x integer, intent(in) :: channel real(kind=default), dimension(size(x)) :: xi end function ihp end interface @ %def ihp @ <>= interface pure function jacobian (x, data, channel) result (j) use kinds use vamp_grid_type !NODEP! import vamp_data_t real(kind=default), dimension(:), intent(in) :: x class(vamp_data_t), intent(in) :: data integer, intent(in) :: channel real(kind=default) :: j end function jacobian end interface @ %def jacobian \begin{procedures} \item{} [[function vamp_multi_channel]] (% [[func]], [[phi]], [[ihp]], [[jacobian]], [[x]], [[weightsl]], [[grids]]) \hfil\goodbreak \begin{procedures} \item{} [[real(kind=default), dimension(:), intent(in) :: x]] \hfil\goodbreak \item{} [[real(kind=default), dimension(:), intent(in) :: weights]] \hfil\goodbreak \item{} [[integer, intent(in) :: channel]] \hfil\goodbreak \item{} [[type(vamp_grid), dimension(:), intent(in) :: grids]] \hfil\goodbreak \end{procedures} \item{} [[function vamp_multi_channel0]] (% [[func]], [[phi]], [[jacobian]], [[x]], [[weightsl]]) \hfil\goodbreak \begin{procedures} \item{} [[real(kind=default), dimension(:), intent(in) :: x]] \hfil\goodbreak \item{} [[real(kind=default), dimension(:), intent(in) :: weights]] \hfil\goodbreak \item{} [[integer, intent(in) :: channel]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_check_jacobian]] (% [[rng]], [[n]], [[channel]], [[region]], [[delta]], [,~[[x_delta]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(tao_random_state), intent(inout) :: rng]] \hfil\goodbreak \item{} [[integer, intent(in) :: n]] \hfil\goodbreak \item{} [[integer, intent(in) :: channel]] \hfil\goodbreak \item{} [[real(kind=default), dimension(:,:), intent(in) :: region]] \hfil\goodbreak \item{} [[real(kind=default), intent(out) :: delta]] \hfil\goodbreak \item{} [[real(kind=default), dimension(:), intent(out), optional :: x_delta]] \hfil\goodbreak \end{procedures} Verify that \begin{equation} g(\phi(x)) = \frac{1}{\left|\frac{\partial\phi}{\partial x}\right|(x)} \end{equation} \item{} [[subroutine vamp_copy_grids]] (% [[lhs]], [[rhs]]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grids), intent(inout) :: lhs]] \hfil\goodbreak \item{} [[type(vamp_grids), intent(in) :: rhs]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_delete_grids]] (% [[g]]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grids), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_create_grids]] (% [[g]], [[domain]], [[num_calls]], [[weights]] [,~[[maps]]{}] [,~[[stratified]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grids), intent(inout) :: g]] \hfil\goodbreak \item{} [[real, dimension(:,:), intent(in) :: domain]] \hfil\goodbreak \item{} [[integer, intent(in) :: num_calls]] \hfil\goodbreak \item{} [[real, dimension(:), intent(in) :: weights]] \hfil\goodbreak \item{} [[real, dimension(:,:,:), intent(in) :: maps]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_create_empty_grids]] (% [[g]]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grids), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_discard_integrals]] (% [[g]] [,~[[num_calls]]{}] [,~[[stratified]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grids), intent(inout) :: g]] \hfil\goodbreak \item{} [[integer, intent(in) :: num_calls]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_refine_weights]] (% [[g]] [,~[[power]]{}) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grids), intent(inout) :: g]] \hfil\goodbreak \item{} [[real, intent(in) :: power]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_update_weights]] (% [[g]], [[weights]] [,~[[num_calls]]{}] [,~[[stratified]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grids), intent(inout) :: g]] \hfil\goodbreak \item{} [[real, dimension(:), intent(in) :: weights]] \hfil\goodbreak \item{} [[integer, intent(in) :: num_calls]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_reshape_grids]] (% [[g]], [[num_calls]] [,~[[stratified]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grids), intent(inout) :: g]] \hfil\goodbreak \item{} [[integer, intent(in) :: num_calls]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_reduce_channels]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_sample_grids]] (% [[g]], [[func]], [[iterations]] [,~[[integral]]{}] [,~[[std_dev]]{}] [,~[[accuracy]]{}] [,~[[covariance]]{}] [,~[[variance]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grids), intent(inout) :: g]] \hfil\goodbreak \item{} [[func]] \hfil\goodbreak \item{} [[integer, intent(in) :: iterations]] \hfil\goodbreak \end{procedures} \item{} [[function vamp_sum_channels]] (% [[x]], [[weights]], [[func]]) \hfil\goodbreak \begin{procedures} \item{} [[real, dimension(:), intent(in) :: x]] \hfil\goodbreak \item{} [[real, dimension(:), intent(in) :: weights]] \hfil\goodbreak \item{} [[func]] \hfil\goodbreak \end{procedures} \end{procedures} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Event Generation} \begin{procedures} \item{} [[subroutine vamp_next_event]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \item{} [[subroutine vamp_warmup_grid]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \item{} [[func]] \hfil\goodbreak \item{} [[integer, intent(in) :: iterations]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_warmup_grids]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grids), intent(inout) :: g]] \hfil\goodbreak \item{} [[func]] \hfil\goodbreak \item{} [[integer, intent(in) :: iterations]] \hfil\goodbreak \end{procedures} \end{procedures} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Parallelization} \begin{procedures} \item{} [[subroutine vamp_fork_grid]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_join_grid]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_fork_grid_joints]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_sample_grid_parallel]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_distribute_work]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \end{procedures} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Diagnostics} \begin{procedures} \item{} [[subroutine vamp_create_history]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_copy_history]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_delete_history]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_terminate_history]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_get_history]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_get_history_single]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_print_history]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \begin{dubious} Discuss why the value of the integral in each channel differs. \end{dubious} \end{procedures} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Other Procedures} \begin{procedures} \item{} [[subroutine vamp_rigid_divisions]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[function vamp_get_covariance]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_nullify_covariance]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[function vamp_get_variance]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \item{} [[subroutine vamp_nullify_variance]] (% [[g]], [,~[[...]]{}]) \hfil\goodbreak \begin{procedures} \item{} [[type(vamp_grid), intent(inout) :: g]] \hfil\goodbreak \end{procedures} \end{procedures} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{(Currently) Undocumented Procedures} \begin{procedures} \item{} [[subroutine ]] (% [[...]], [,~[[...]]{}]) \hfil\goodbreak \item{} [[function ]] (% [[...]], [,~[[...]]{}]) \hfil\goodbreak \end{procedures} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/vamp_test.nw =================================================================== --- trunk/vamp/src/vamp_test.nw (revision 8740) +++ trunk/vamp/src/vamp_test.nw (revision 8741) @@ -1,565 +1,555 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP vamp_test code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: vamp_test.nw 314 2010-04-17 20:32:33Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Self Test} \section{No Mapping Mode} \label{sec:test} In this chapter we perfom a test of the major features of Vamp. A function with many peaks is integrated with the traditional Vegas algorithm, using a multi-channel approach and in parallel. The function is constructed to have a known analytical integral (which is chosen to be one) in order to be able to gauge the accuracy of the reselt and error estimate. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Serial Test} <<[[vamp_test.f90]]>>= ! vamp_test.f90 -- <> <> <> @ <>= module vamp_test_functions use kinds use constants, only: PI use coordinates use vamp, only: vamp_grid, vamp_multi_channel use vamp, only: vamp_data_t implicit none private public :: f, j, phi, ihp, w public :: lorentzian private :: lorentzian_normalized real(kind=default), public :: width contains <> end module vamp_test_functions @ \begin{equation} \int_{x_1}^{x_2}\!\mathrm{d}x\, \frac{1}{(x-x_0)^2+a^2} = \frac{1}{a} \left( \atan\left(\frac{x_2-x_0}{a}\right) - \atan\left(\frac{x_1-x_0}{a}\right) \right) = N(x_0,x_1,x_2,a) \end{equation} <>= pure function lorentzian_normalized (x, x0, x1, x2, a) result (f) real(kind=default), intent(in) :: x, x0, x1, x2, a real(kind=default) :: f if (x1 <= x .and. x <= x2) then f = 1 / ((x - x0)**2 + a**2) & * a / (atan2 (x2 - x0, a) - atan2 (x1 - x0, a)) else f = 0 end if end function lorentzian_normalized @ %def lorentzian_normalized @ \begin{equation} \int\!\mathrm{d}^nx\,f(x) = \int\!\mathrm{d}\Omega_n\,r^{n-1}\mathrm{d}r f(x) = 1 \end{equation} <>= pure function lorentzian (x, x0, x1, x2, r0, a) result (f) real(kind=default), dimension(:), intent(in) :: x, x0, x1, x2 real(kind=default), intent(in) :: r0, a real(kind=default) :: f real(kind=default) :: r, r1, r2 integer :: n n = size (x) if (n > 1) then r = sqrt (dot_product (x-x0, x-x0)) r1 = 0.4_default r2 = min (minval (x2-x0), minval (x0-x1)) if (r1 <= r .and. r <= r2) then f = lorentzian_normalized (r, r0, r1, r2, a) * r**(1-n) / surface (n) else f = 0 end if else f = lorentzian_normalized (x(1), x0(1), x1(1), x2(1), a) endif end function lorentzian @ %def lorentzian @ <>= pure function f (x, data, weights, channel, grids) result (f_x) real(kind=default), dimension(:), intent(in) :: x class(vamp_data_t), intent(in) :: data real(kind=default), dimension(:), intent(in), optional :: weights integer, intent(in), optional :: channel type(vamp_grid), dimension(:), intent(in), optional :: grids real(kind=default) :: f_x real(kind=default), dimension(size(x)) :: minus_one, plus_one, zero, w_i, f_i integer :: n, i n = size(x) minus_one = -1 zero = 0 plus_one = 1 w_i = 1 do i = 1, n if (all (abs (x(i+1:)) <= 1)) then f_i = lorentzian (x(1:i), zero(1:i), minus_one(1:i), plus_one(1:i), & 0.7_default, width) & / 2.0_default**(n-i) else f_i = 0 end if end do f_x = dot_product (w_i, f_i) / sum (w_i) end function f @ <>= pure function phi (xi, channel) result (x) real(kind=default), dimension(:), intent(in) :: xi integer, intent(in) :: channel real(kind=default), dimension(size(xi)) :: x real(kind=default) :: r real(kind=default), dimension(0) :: dummy integer :: n n = size(x) if (channel == 1) then x = xi else if (channel == 2) then r = (xi(1) + 1) / 2 * sqrt (2.0_default) x(1:2) = spherical_cos_to_cartesian (r, PI * xi(2), dummy) x(3:) = xi(3:) else if (channel < n) then r = (xi(1) + 1) / 2 * sqrt (real (channel, kind=default)) x(1:channel) = spherical_cos_to_cartesian (r, PI * xi(2), xi(3:channel)) x(channel+1:) = xi(channel+1:) else if (channel == n) then r = (xi(1) + 1) / 2 * sqrt (real (channel, kind=default)) x = spherical_cos_to_cartesian (r, PI * xi(2), xi(3:)) else x = 0 end if end function phi @ <>= pure function ihp (x, channel) result (xi) real(kind=default), dimension(:), intent(in) :: x integer, intent(in) :: channel real(kind=default), dimension(size(x)) :: xi real(kind=default) :: r, phi integer :: n n = size(x) if (channel == 1) then xi = x else if (channel == 2) then call cartesian_to_spherical_cos (x(1:2), r, phi) xi(1) = 2 * r / sqrt (2.0_default) - 1 xi(2) = phi / PI xi(3:) = x(3:) else if (channel < n) then call cartesian_to_spherical_cos (x(1:channel), r, phi, xi(3:channel)) xi(1) = 2 * r / sqrt (real (channel, kind=default)) - 1 xi(2) = phi / PI xi(channel+1:) = x(channel+1:) else if (channel == n) then call cartesian_to_spherical_cos (x, r, phi, xi(3:)) xi(1) = 2 * r / sqrt (real (channel, kind=default)) - 1 xi(2) = phi / PI else xi = 0 end if end function ihp @ <>= pure function j (x, data, channel) result (j_x) real(kind=default), dimension(:), intent(in) :: x class(vamp_data_t), intent(in) :: data integer, intent(in) :: channel real(kind=default) :: j_x if (channel == 1) then j_x = 1 else if (channel > 1) then j_x = 2 / sqrt (real (channel, kind=default)) !: $1/|\mathrm{d}r/\mathrm{d}\xi_1|$ j_x = j_x / PI !: $1/|\mathrm{d}\phi/\mathrm{d}\xi_2|$ j_x = j_x * cartesian_to_spherical_cos_j (x(1:channel)) else j_x = 0 end if end function j @ <>= function w (x, data, weights, channel, grids) result (w_x) real(kind=default), dimension(:), intent(in) :: x class(vamp_data_t), intent(in) :: data real(kind=default), dimension(:), intent(in), optional :: weights integer, intent(in), optional :: channel type(vamp_grid), dimension(:), intent(in), optional :: grids real(kind=default) :: w_x w_x = vamp_multi_channel (f, data, phi, ihp, j, x, weights, channel, grids) end function w @ <>= module vamp_tests use kinds use exceptions use histograms use tao_random_numbers use coordinates use vamp use vamp_test_functions !NODEP! implicit none private <> contains <> end module vamp_tests @ %def vamp_tests @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \paragraph{Verification} <>= ! public :: check_jacobians, check_inverses, check_inverses3 public :: check_inverses, check_inverses3 @ <>= subroutine check_jacobians (rng, region, weights, samples) type(tao_random_state), intent(inout) :: rng real(kind=default), dimension(:,:), intent(in) :: region real(kind=default), dimension(:), intent(in) :: weights integer, intent(in) :: samples real(kind=default), dimension(size(region,dim=2)) :: x real(kind=default) :: d integer :: ch do ch = 1, size(weights) call vamp_check_jacobian (rng, samples, j, NO_DATA, phi, ch, region, d, x) print *, "channel", ch, ": delta(j)/j=", real(d), ", @x=", real (x) end do end subroutine check_jacobians @ %def check_jacobians @ <>= subroutine check_inverses (rng, region, weights, samples) type(tao_random_state), intent(inout) :: rng real(kind=default), dimension(:,:), intent(in) :: region real(kind=default), dimension(:), intent(in) :: weights integer, intent(in) :: samples real(kind=default), dimension(size(region,dim=2)) :: x1, x2, x_dx real(kind=default) :: dx, dx_max integer :: ch, i dx_max = 0 x_dx = 0 do ch = 1, size(weights) do i = 1, samples call tao_random_number (rng, x1) x2 = ihp (phi (x1, ch), ch) dx = sqrt (dot_product (x1-x2, x1-x2)) if (dx > dx_max) then dx_max = dx x_dx = x1 end if end do print *, "channel", ch, ": |x-x|=", real(dx), ", @x=", real (x_dx) end do end subroutine check_inverses @ %def check_inverses @ <>= subroutine check_inverses3 (rng, region, samples) type(tao_random_state), intent(inout) :: rng real(kind=default), dimension(:,:), intent(in) :: region integer, intent(in) :: samples real(kind=default), dimension(size(region,dim=2)) :: x1, x2, x_dx, x_dj real(kind=default) :: r, phi, jac, caj, dx, dx_max, dj, dj_max real(kind=default), dimension(size(x1)-2) :: cos_theta integer :: i dx_max = 0 x_dx = 0 dj_max = 0 x_dj = 0 do i = 1, samples call tao_random_number (rng, x1) call cartesian_to_spherical_cos_2 (x1, r, phi, cos_theta, jac) call spherical_cos_to_cartesian_2 (r, phi, cos_theta, x2, caj) dx = sqrt (dot_product (x1-x2, x1-x2)) dj = jac*caj - 1 if (dx > dx_max) then dx_max = dx x_dx = x1 end if if (dj > dj_max) then dj_max = dj x_dj = x1 end if end do print *, "channel 3 : j*j-1=", real(dj), ", @x=", real (x_dj) print *, "channel 3 : |x-x|=", real(dx), ", @x=", real (x_dx) end subroutine check_inverses3 @ %def check_inverses3 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \paragraph{Integration} <>= public :: single_channel, multi_channel @ <>= subroutine single_channel (rng, region, samples, iterations, & integral, standard_dev, chi_squared) type(tao_random_state), intent(inout) :: rng real(kind=default), dimension(:,:), intent(in) :: region integer, dimension(:), intent(in) :: samples, iterations real(kind=default), intent(out) :: integral, standard_dev, chi_squared type(vamp_grid) :: gr type(vamp_history), dimension(iterations(1)+iterations(2)) :: history call vamp_create_history (history) call vamp_create_grid (gr, region, samples(1)) call vamp_sample_grid (rng, gr, f, NO_DATA, iterations(1), history = history) call vamp_discard_integral (gr, samples(2)) call vamp_sample_grid & (rng, gr, f, NO_DATA, iterations(2), & integral, standard_dev, chi_squared, & history = history(iterations(1)+1:)) call vamp_write_grid (gr, "vamp_test.grid") call vamp_delete_grid (gr) call vamp_print_history (history, "single") call vamp_delete_history (history) end subroutine single_channel @ %def single_channel @ <>= subroutine multi_channel (rng, region, weights, samples, iterations, powers, & integral, standard_dev, chi_squared) type(tao_random_state), intent(inout) :: rng real(kind=default), dimension(:,:), intent(in) :: region real(kind=default), dimension(:), intent(inout) :: weights integer, dimension(:), intent(in) :: samples, iterations real(kind=default), dimension(:), intent(in) :: powers real(kind=default), intent(out) :: integral, standard_dev, chi_squared type(vamp_grids) :: grs <> end subroutine multi_channel @ %def multi_channel @ <>= type(vamp_history), dimension(iterations(1)+iterations(2)+size(powers)-1) :: & history type(vamp_history), dimension(size(history),size(weights)) :: histories integer :: it, nit nit = size (powers) call vamp_create_history (history) call vamp_create_history (histories) call vamp_create_grids (grs, region, samples(1), weights) call vamp_sample_grids (rng, grs, w, NO_DATA, iterations(1) - 1, & history = history, histories = histories) call vamp_print_history (history, "multi") call vamp_print_history (histories, "multi") do it = 1, nit call vamp_sample_grids (rng, grs, w, NO_DATA, 1, & history = history(iterations(1)+it-1:), & histories = histories(iterations(1)+it-1:,:)) call vamp_print_history (history(iterations(1)+it-1:), "multi") call vamp_print_history (histories(iterations(1)+it-1:,:), "multi") call vamp_refine_weights (grs, powers(it)) end do call vamp_discard_integrals (grs, samples(2)) call vamp_sample_grids & (rng, grs, w, NO_DATA, iterations(2), & integral, standard_dev, chi_squared, & history = history(iterations(1)+nit:), & histories = histories(iterations(1)+nit:,:)) call vamp_print_history (history(iterations(1)+nit:), "multi") call vamp_print_history (histories(iterations(1)+nit:,:), "multi") call vamp_write_grids (grs, "vamp_test.grids") call vamp_delete_grids (grs) call vamp_print_history (history, "multi") call vamp_print_history (histories, "multi") call vamp_delete_history (history) call vamp_delete_history (histories) @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \paragraph{Input/Output} <>= public :: print_results @ <>= subroutine print_results (prefix, prev_ticks, & integral, std_dev, chi2, acceptable, failures) character(len=*), intent(in) :: prefix integer, intent(in) :: prev_ticks real(kind=default), intent(in) :: integral, std_dev, chi2, acceptable integer, intent(inout) :: failures integer :: ticks, ticks_per_second real(kind=default) :: pull call system_clock (ticks, ticks_per_second) pull = (integral - 1) / std_dev print "(1X,A,A,F6.2,A)", prefix, & ": time = ", real (ticks - prev_ticks) / ticks_per_second, " secs" print *, prefix, ": int, err, chi2: ", & real (integral), real (std_dev), real (chi2) if (abs (pull) > acceptable) then failures = failures + 1 print *, prefix, ": inacceptable pull:", real (pull) else print *, prefix, ": acceptable pull:", real (pull) end if end subroutine print_results @ %def print_results @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \paragraph{Main Program} <<[[vamp_test.f90]]>>= program vamp_test use kinds use tao_random_numbers use coordinates - use divisions, only: DIVISIONS_RCS_ID use vamp use vamp_test_functions !NODEP! use vamp_tests !NODEP! implicit none integer :: start_ticks, status integer, dimension(2) :: iterations, samples real(kind=default), dimension(2,5) :: region real(kind=default), dimension(5) :: weight_vector real(kind=default), dimension(10) :: powers real(kind=default) :: single_integral, single_standard_dev, single_chi_squared real(kind=default) :: multi_integral, multi_standard_dev, multi_chi_squared type(tao_random_state) :: rng real(kind=default), parameter :: ACCEPTABLE = 4 integer :: failures failures = 0 call tao_random_create (rng, 0) call get_environment_variable (name="VAMP_RANDOM_TESTS", status=status) if (status == 0) then call system_clock (start_ticks) else start_ticks = 42 end if call tao_random_seed (rng, start_ticks) iterations = (/ 4, 3 /) samples = (/ 20000, 200000 /) region(1,:) = -1.0 region(2,:) = 1.0 width = 0.0001 print *, "Starting VAMP 1.0 self test..." print *, "serial code" - print *, VAMP_RCS_ID - print *, DIVISIONS_RCS_ID call system_clock (start_ticks) call single_channel (rng, region, samples, iterations, & single_integral, single_standard_dev, single_chi_squared) call print_results ("SINGLE", start_ticks, & single_integral, single_standard_dev, single_chi_squared, & 10*ACCEPTABLE, failures) weight_vector = 1 powers = 0.25_default call system_clock (start_ticks) call multi_channel (rng, region, weight_vector, samples, iterations, & powers, multi_integral, multi_standard_dev, multi_chi_squared) call print_results ("MULTI", start_ticks, & multi_integral, multi_standard_dev, multi_chi_squared, & ACCEPTABLE, failures) call system_clock (start_ticks) ! call check_jacobians (rng, region, weight_vector, samples(1)) call check_inverses (rng, region, weight_vector, samples(1)) call check_inverses3 (rng, region, samples(1)) if (failures == 0) then stop 0 else if (failures == 1) then stop 1 else stop 2 end if end program vamp_test @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Parallel Test} <<[[vampi_test.f90]]>>= ! vampi_test.f90 -- <> <> @ The following is identical to [[vamp_tests]], except for~[[use vampi]]: <<[[vampi_test.f90]]>>= module vampi_tests use kinds use exceptions use histograms use tao_random_numbers use coordinates use vampi use vamp_test_functions !NODEP! implicit none private <> contains <> end module vampi_tests @ %def vampi_tests @ <<[[vampi_test.f90]]>>= program vampi_test use kinds use tao_random_numbers use coordinates - use divisions, only: DIVISIONS_RCS_ID - use vamp, only: VAMP_RCS_ID use vampi use mpi90 use vamp_test_functions !NODEP! use vampi_tests !NODEP! implicit none integer :: num_proc, proc_id, start_ticks logical :: perform_io integer, dimension(2) :: iterations, samples real(kind=default), dimension(2,5) :: region real(kind=default), dimension(5) :: weight_vector real(kind=default), dimension(10) :: powers real(kind=default) :: single_integral, single_standard_dev, single_chi_squared real(kind=default) :: multi_integral, multi_standard_dev, multi_chi_squared type(tao_random_state) :: rng integer :: iostat, command character(len=72) :: command_line integer, parameter :: & CMD_ERROR = -1, CMD_END = 0, & CMD_NOP = 1, CMD_SINGLE = 2, CMD_MULTI = 3, CMD_CHECK = 4 call tao_random_create (rng, 0) call mpi90_init () call mpi90_size (num_proc) call mpi90_rank (proc_id) perform_io = (proc_id == 0) call system_clock (start_ticks) call tao_random_seed (rng, start_ticks + proc_id) iterations = (/ 4, 3 /) samples = (/ 20000, 200000 /) samples = (/ 200000, 2000000 /) region(1,:) = -1.0 region(2,:) = 1.0 width = 0.0001 if (perform_io) then print *, "Starting VAMP 1.0 self test..." if (num_proc > 1) then print *, "parallel code running on ", num_proc, " processors" else print *, "parallel code running serially" end if - print *, VAMP_RCS_ID - print *, VAMPI_RCS_ID - print *, DIVISIONS_RCS_ID end if command_loop: do <> call mpi90_broadcast (command, 0) call system_clock (start_ticks) select case (command) <> case (CMD_END) exit command_loop case (CMD_NOP) ! do nothing case (CMD_ERROR) ! do nothing end select end do command_loop call mpi90_finalize () end program vampi_test @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Output} <<[[vamp_test.out]]>>= @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/vamp.nw =================================================================== --- trunk/vamp/src/vamp.nw (revision 8740) +++ trunk/vamp/src/vamp.nw (revision 8741) @@ -1,4536 +1,4530 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP main code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: vamp.nw 317 2010-04-18 00:31:03Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{The Abstract Datatype \texttt{vamp\_grid}} <<[[vamp.f90]]>>= ! vamp.f90 -- <> @ \begin{dubious} \index{Fortran problem} NAG f95 requires this split. Check with the Fortran community, if it is really necessary, or a bug! The problem is that this split forces us the expose the components of [[vamp_grid]]. \textbf{NB:} with the introduction of [[vamp_equivalences]], this question has (probably) become academic. \end{dubious} <<[[vamp.f90]]>>= module vamp_grid_type use kinds use divisions private <> end module vamp_grid_type @ %def vamp_grid_type @ \begin{dubious} By WK for WHIZARD. \end{dubious} <<[[vamp.f90]]>>= module vamp_equivalences use kinds use divisions use vamp_grid_type !NODEP! implicit none private <> <> <> - character(len=*), public, parameter :: VAMP_EQUIVALENCES_RCS_ID = & - "$Id: vamp.nw 317 2010-04-18 00:31:03Z ohl $" contains <> end module vamp_equivalences @ %def vamp_equivalences @ <>= type, public :: vamp_equivalence_t integer :: left, right integer, dimension(:), allocatable :: permutation integer, dimension(:), allocatable :: mode end type vamp_equivalence_t @ <>= type, public :: vamp_equivalences_t type(vamp_equivalence_t), dimension(:), allocatable :: eq integer :: n_eq, n_ch integer, dimension(:), allocatable :: pointer logical, dimension(:), allocatable :: independent integer, dimension(:), allocatable :: equivalent_to_ch integer, dimension(:), allocatable :: multiplicity integer, dimension(:), allocatable :: symmetry logical, dimension(:,:), allocatable :: div_is_invariant end type vamp_equivalences_t @ <>= integer, parameter, public :: & VEQ_IDENTITY = 0, VEQ_INVERT = 1, VEQ_SYMMETRIC = 2, VEQ_INVARIANT = 3 @ <>= subroutine vamp_equivalence_init (eq, n_dim) type(vamp_equivalence_t), intent(inout) :: eq integer, intent(in) :: n_dim allocate (eq%permutation(n_dim), eq%mode(n_dim)) end subroutine vamp_equivalence_init @ %def vamp_equivalence_init @ <>= public :: vamp_equivalences_init @ <>= subroutine vamp_equivalences_init (eq, n_eq, n_ch, n_dim) type(vamp_equivalences_t), intent(inout) :: eq integer, intent(in) :: n_eq, n_ch, n_dim integer :: i eq%n_eq = n_eq eq%n_ch = n_ch allocate (eq%eq(n_eq)) allocate (eq%pointer(n_ch+1)) do i=1, n_eq call vamp_equivalence_init (eq%eq(i), n_dim) end do allocate (eq%independent(n_ch), eq%equivalent_to_ch(n_ch)) allocate (eq%multiplicity(n_ch), eq%symmetry(n_ch)) allocate (eq%div_is_invariant(n_ch, n_dim)) eq%independent = .true. eq%equivalent_to_ch = 0 eq%multiplicity = 0 eq%symmetry = 0 eq%div_is_invariant = .false. end subroutine vamp_equivalences_init @ %def vamp_equivalences_init @ <>= subroutine vamp_equivalence_final (eq) type(vamp_equivalence_t), intent(inout) :: eq deallocate (eq%permutation, eq%mode) end subroutine vamp_equivalence_final @ %def vamp_equivalence_final @ <>= public :: vamp_equivalences_final @ <>= subroutine vamp_equivalences_final (eq) type(vamp_equivalences_t), intent(inout) :: eq ! integer :: i ! do i=1, eq%n_eq ! call vamp_equivalence_final (eq%eq(i)) ! end do if (allocated (eq%eq)) deallocate (eq%eq) if (allocated (eq%pointer)) deallocate (eq%pointer) if (allocated (eq%multiplicity)) deallocate (eq%multiplicity) if (allocated (eq%symmetry)) deallocate (eq%symmetry) if (allocated (eq%independent)) deallocate (eq%independent) if (allocated (eq%equivalent_to_ch)) deallocate (eq%equivalent_to_ch) if (allocated (eq%div_is_invariant)) deallocate (eq%div_is_invariant) eq%n_eq = 0 eq%n_ch = 0 end subroutine vamp_equivalences_final @ %def vamp_equivalences_final @ <>= subroutine vamp_equivalence_write (eq, unit) integer, intent(in), optional :: unit integer :: u type(vamp_equivalence_t), intent(in) :: eq u = 6; if (present (unit)) u = unit write (u, "(3x,A,2(1x,I0))") "Equivalent channels:", eq%left, eq%right write (u, "(5x,A,99(1x,I0))") "Permutation:", eq%permutation write (u, "(5x,A,99(1x,I0))") "Mode: ", eq%mode end subroutine vamp_equivalence_write @ %def vamp_equivalence_write @ <>= public :: vamp_equivalences_write @ <>= subroutine vamp_equivalences_write (eq, unit) type(vamp_equivalences_t), intent(in) :: eq integer, intent(in), optional :: unit integer :: u integer :: ch, i u = 6; if (present (unit)) u = unit write (u, "(1x,A)") "Inequivalent channels:" if (allocated (eq%independent)) then do ch=1, eq%n_ch if (eq%independent(ch)) then write (u, "(3x,A,1x,I0,A,4x,A,I0,4x,A,I0,4x,A,999(L1))") & "Channel", ch, ":", & "Mult. = ", eq%multiplicity(ch), & "Symm. = ", eq%symmetry(ch), & "Invar.: ", eq%div_is_invariant(ch,:) end if end do else write (u, "(3x,A)") "[not allocated]" end if write (u, "(1x,A)") "Equivalence list:" if (allocated (eq%eq)) then do i=1, size (eq%eq) call vamp_equivalence_write (eq%eq(i), u) end do else write (u, "(3x,A)") "[not allocated]" end if end subroutine vamp_equivalences_write @ %def vamp_equivalences_write @ <>= public :: vamp_equivalence_set @ <>= subroutine vamp_equivalence_set (eq, i, left, right, perm, mode) type(vamp_equivalences_t), intent(inout) :: eq integer, intent(in) :: i integer, intent(in) :: left, right integer, dimension(:), intent(in) :: perm, mode eq%eq(i)%left = left eq%eq(i)%right = right eq%eq(i)%permutation = perm eq%eq(i)%mode = mode end subroutine vamp_equivalence_set @ %def vamp_equivalence_set @ <>= public :: vamp_equivalences_complete @ <>= subroutine vamp_equivalences_complete (eq) type(vamp_equivalences_t), intent(inout) :: eq integer :: i, ch ch = 0 do i=1, eq%n_eq if (ch /= eq%eq(i)%left) then ch = eq%eq(i)%left eq%pointer(ch) = i end if end do eq%pointer(ch+1) = eq%n_eq + 1 do ch=1, eq%n_ch call set_multiplicities (eq%eq(eq%pointer(ch):eq%pointer(ch+1)-1)) end do ! call write (6, eq) contains subroutine set_multiplicities (eq_ch) type(vamp_equivalence_t), dimension(:), intent(in) :: eq_ch integer :: i if (.not. all(eq_ch%left == ch) .or. eq_ch(1)%right > ch) then do i = 1, size (eq_ch) call vamp_equivalence_write (eq_ch(i)) end do stop "VAMP: Equivalences: Something's wrong with equivalence ordering" end if eq%symmetry(ch) = count (eq_ch%right == ch) if (mod (size(eq_ch), eq%symmetry(ch)) /= 0) then do i = 1, size (eq_ch) call vamp_equivalence_write (eq_ch(i)) end do stop "VAMP: Equivalences: Something's wrong with permutation count" end if eq%multiplicity(ch) = size (eq_ch) / eq%symmetry(ch) eq%independent(ch) = all (eq_ch%right >= ch) eq%equivalent_to_ch(ch) = eq_ch(1)%right eq%div_is_invariant(ch,:) = eq_ch(1)%mode == VEQ_INVARIANT end subroutine set_multiplicities end subroutine vamp_equivalences_complete @ %def vamp_equivalences_complete @ <<[[vamp.f90]]>>= module vamp_rest use kinds use utils use exceptions use divisions use tao_random_numbers use vamp_stat use linalg use iso_fortran_env use vamp_grid_type !NODEP! use vamp_equivalences !NODEP! implicit none private <> <> <> <> <> - character(len=*), public, parameter :: VAMP_RCS_ID = & - "$Id: vamp.nw 317 2010-04-18 00:31:03Z ohl $" contains <> end module vamp_rest @ %def vamp_rest @ <<[[vamp.f90]]>>= module vamp use vamp_grid_type !NODEP! use vamp_rest !NODEP! use vamp_equivalences !NODEP! public end module vamp @ %def vamp @ N.B.: In \texttt{Fortran95} we will be able to give default initializations to components of the type. In particular, we can use the [[null ()]] intrinsic to initialize the pointers to a disassociated state. Until then, the user \emph{must} call the initializer [[vamp_create_grid]] himself of herself, because we can't check for the allocation status of the pointers in \texttt{Fortran90} or~\texttt{F}. \index{deficiencies in \protect\texttt{Fortran90} and \protect\texttt{F}} \begin{dubious} Augment this datatype by [[real(kind=default), dimension(2) :: mu_plus, mu_minus]] to record positive and negative weight separately, so that we can estimmate the efficiency for reweighting from indefinite weights to $\{+1,-1\}$. [WK 2015/11/06: done. Those values are recorded but not used inside \texttt{vamp}. They can be retrieved by the caller.] \end{dubious} \begin{dubious} WK 2015/11/06: [[f_min]] and [[f_max]] work with the absolute value of the matrix element, so they record the minimum and maximum absolute value. \end{dubious} <>= type, public :: vamp_grid ! private !: forced by \texttt{use} association in interface type(division_t), dimension(:), pointer :: div => null () real(kind=default), dimension(:,:), pointer :: map => null () real(kind=default), dimension(:), pointer :: mu_x => null () real(kind=default), dimension(:), pointer :: sum_mu_x => null () real(kind=default), dimension(:,:), pointer :: mu_xx => null () real(kind=default), dimension(:,:), pointer :: sum_mu_xx => null () real(kind=default), dimension(2) :: mu real(kind=default), dimension(2) :: mu_plus, mu_minus real(kind=default) :: sum_integral, sum_weights, sum_chi2 real(kind=default) :: calls, dv2g, jacobi real(kind=default) :: f_min, f_max real(kind=default) :: mu_gi, sum_mu_gi integer, dimension(:), pointer :: num_div => null () integer :: num_calls, calls_per_cell logical :: stratified = .true. logical :: all_stratified = .true. logical :: quadrupole = .false. logical :: independent integer :: equivalent_to_ch, multiplicity end type vamp_grid @ %def vamp_grid @ <>= public :: vamp_copy_grid, vamp_delete_grid @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Container for application data} \begin{dubious} By WK for WHIZARD. We define an empty data type that the application can extend according to its needs. The purpose is to hold all sorts of data that are predefined and accessed during the call of the sampling function. The actual interface for the sampling function is PURE. Nevertheless, we can implement side effects via pointer components of a [[vamp_data_t]] extension. \end{dubious} <>= type, public :: vamp_data_t end type vamp_data_t @ %def vamp_data_t @ This is the object to be passed if we want nothing else: <>= type(vamp_data_t), parameter, public :: NO_DATA = vamp_data_t () @ %def NO_DATA @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Initialization} <>= public :: vamp_create_grid, vamp_create_empty_grid @ %def vamp_create_grid vamp_create_empty_grid @ Create a fresh grid for the integration domain \begin{equation} \mathcal{D} = [D_{1,1},D_{2,1}] \times [D_{1,2},D_{2,2}] \times \ldots \times [D_{1,n},D_{2,n}] \end{equation} dropping all accumulated results. This function \emph{must not} be called twice on the first argument, without an intervening [[vamp_delete_grid]]. Iff the second variable is given, it will be the number of sampling points for the call to [[vamp_sample_grid]]. <>= pure subroutine vamp_create_grid & (g, domain, num_calls, num_div, & stratified, quadrupole, covariance, map, exc) type(vamp_grid), intent(inout) :: g real(kind=default), dimension(:,:), intent(in) :: domain integer, intent(in) :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole, covariance real(kind=default), dimension(:,:), intent(in), optional :: map type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "vamp_create_grid" real(kind=default), dimension(size(domain,dim=2)) :: & x_min, x_max, x_min_true, x_max_true integer :: ndim ndim = size (domain, dim=2) allocate (g%div(ndim), g%num_div(ndim)) x_min = domain(1,:) x_max = domain(2,:) if (present (map)) then allocate (g%map(ndim,ndim)) g%map = map x_min_true = x_min x_max_true = x_max call map_domain (g%map, x_min_true, x_max_true, x_min, x_max) call create_division (g%div, x_min, x_max, x_min_true, x_max_true) else nullify (g%map) call create_division (g%div, x_min, x_max) end if g%num_calls = num_calls if (present (num_div)) then g%num_div = num_div else g%num_div = NUM_DIV_DEFAULT end if g%stratified = .true. g%quadrupole = .false. g%independent = .true. g%equivalent_to_ch = 0 g%multiplicity = 1 nullify (g%mu_x, g%mu_xx, g%sum_mu_x, g%sum_mu_xx) call vamp_discard_integral & (g, num_calls, num_div, stratified, quadrupole, covariance, exc) end subroutine vamp_create_grid @ %def vamp_create_grid @ %def ndim domain dx grid @ Below, we assume that $[[NUM_DIV_DEFAULT]] \ge 6$, but we will never go that low anyway. <>= integer, private, parameter :: NUM_DIV_DEFAULT = 20 @ %def NUM_DIV_DEFAULT @ Given a linear map~$M$, find a domain~$\mathcal{D}_0$ such that \begin{equation} \mathcal{D} \subset M \mathcal{D}_0 \end{equation} <>= private :: map_domain @ If we can assume that~$M$ is orthogonal~$M^{-1}=M^T$, then we just have to rotate~$\mathcal{D}$ and determine the maximal and minimal extension of the corners: \begin{equation} \mathcal{D}_0^T = \overline{\mathcal{D}^T M} \end{equation} The corners are just the powerset of the maximal and minimal extension in each coordinate. It is determined most easily with binary counting: <>= pure subroutine map_domain (map, true_xmin, true_xmax, xmin, xmax) real(kind=default), dimension(:,:), intent(in) :: map real(kind=default), dimension(:), intent(in) :: true_xmin, true_xmax real(kind=default), dimension(:), intent(out) :: xmin, xmax real(kind=default), dimension(2**size(xmin),size(xmin)) :: corners integer, dimension(size(xmin)) :: zero_to_n integer :: j, ndim, perm ndim = size (xmin) zero_to_n = (/ (j, j=0,ndim-1) /) do perm = 1, 2**ndim corners (perm,:) = & merge (true_xmin, true_xmax, btest (perm-1, zero_to_n)) end do corners = matmul (corners, map) xmin = minval (corners, dim=1) xmax = maxval (corners, dim=1) end subroutine map_domain @ %def map_domain @ <>= elemental subroutine vamp_create_empty_grid (g) type(vamp_grid), intent(inout) :: g nullify (g%div, g%num_div, g%map, g%mu_x, g%mu_xx, g%sum_mu_x, g%sum_mu_xx) end subroutine vamp_create_empty_grid @ %def vamp_create_empty_grid @ <>= public :: vamp_discard_integral @ Keep the current optimized grid, but drop the accumulated results for the integral (value and errors). Iff the second variable is given, it will be the new number of sampling points for the next call to [[vamp_sample_grid]]. <>= pure subroutine vamp_discard_integral & (g, num_calls, num_div, stratified, quadrupole, covariance, exc, & & independent, equivalent_to_ch, multiplicity) type(vamp_grid), intent(inout) :: g integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole, covariance type(exception), intent(inout), optional :: exc logical, intent(in), optional :: independent integer, intent(in), optional :: equivalent_to_ch, multiplicity character(len=*), parameter :: FN = "vamp_discard_integral" g%mu = 0.0 g%mu_plus = 0.0 g%mu_minus = 0.0 g%mu_gi = 0.0 g%sum_integral = 0.0 g%sum_weights = 0.0 g%sum_chi2 = 0.0 g%sum_mu_gi = 0.0 if (associated (g%sum_mu_x)) then g%sum_mu_x = 0.0 g%sum_mu_xx = 0.0 end if call set_grid_options (g, num_calls, num_div, stratified, quadrupole, & independent, equivalent_to_ch, multiplicity) if ((present (num_calls)) & .or. (present (num_div)) & .or. (present (stratified)) & .or. (present (quadrupole)) & .or. (present (covariance))) then call vamp_reshape_grid & (g, g%num_calls, g%num_div, & g%stratified, g%quadrupole, covariance, exc) end if end subroutine vamp_discard_integral @ %def vamp_discard_integral @ %def sum_integral sum_weights sum_chi2 @ <>= private :: set_grid_options @ <>= pure subroutine set_grid_options & (g, num_calls, num_div, stratified, quadrupole, & independent, equivalent_to_ch, multiplicity) type(vamp_grid), intent(inout) :: g integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole logical, intent(in), optional :: independent integer, intent(in), optional :: equivalent_to_ch, multiplicity if (present (num_calls)) then g%num_calls = num_calls end if if (present (num_div)) then g%num_div = num_div end if if (present (stratified)) then g%stratified = stratified end if if (present (quadrupole)) then g%quadrupole = quadrupole end if if (present (independent)) then g%independent = independent end if if (present (equivalent_to_ch)) then g%equivalent_to_ch = equivalent_to_ch end if if (present (multiplicity)) then g%multiplicity = multiplicity end if end subroutine set_grid_options @ %def set_grid_options @ %def num_calls num_div stratified quadrupole @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Setting Up the Initial Grid} Keep the current optimized grid and the accumulated results for the integral (value and errors). The second variable will be the new number of sampling points for the next call to [[vamp_sample_grid]]. <>= pure subroutine vamp_reshape_grid_internal & (g, num_calls, num_div, & stratified, quadrupole, covariance, exc, use_variance, & independent, equivalent_to_ch, multiplicity) type(vamp_grid), intent(inout) :: g integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole, covariance type(exception), intent(inout), optional :: exc logical, intent(in), optional :: use_variance logical, intent(in), optional :: independent integer, intent(in), optional :: equivalent_to_ch, multiplicity integer :: ndim, num_cells integer, dimension(size(g%div)) :: ng character(len=*), parameter :: FN = "vamp_reshape_grid_internal" ndim = size (g%div) call set_grid_options & (g, num_calls, num_div, stratified, quadrupole, & & independent, equivalent_to_ch, multiplicity) <> g%all_stratified = all (stratified_division (g%div)) if (present (covariance)) then ndim = size (g%div) if (covariance .and. (.not. associated (g%mu_x))) then allocate (g%mu_x(ndim), g%mu_xx(ndim,ndim)) allocate (g%sum_mu_x(ndim), g%sum_mu_xx(ndim,ndim)) g%sum_mu_x = 0.0 g%sum_mu_xx = 0.0 else if ((.not. covariance) .and. (associated (g%mu_x))) then deallocate (g%mu_x, g%mu_xx, g%sum_mu_x, g%sum_mu_xx) end if end if end subroutine vamp_reshape_grid_internal @ %def vamp_reshape_grid_internal @ %def stratified @ The [[use_variance]] argument is too dangerous for careless users, because the [[variance]] in the divisions will contain garbage before sampling and after reshaping. Build a fence with another routine. @ <>= private :: vamp_reshape_grid_internal public :: vamp_reshape_grid @ <>= pure subroutine vamp_reshape_grid & (g, num_calls, num_div, stratified, quadrupole, covariance, exc, & independent, equivalent_to_ch, multiplicity) type(vamp_grid), intent(inout) :: g integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole, covariance type(exception), intent(inout), optional :: exc logical, intent(in), optional :: independent integer, intent(in), optional :: equivalent_to_ch, multiplicity call vamp_reshape_grid_internal & (g, num_calls, num_div, stratified, quadrupole, covariance, & exc, use_variance = .false., & independent=independent, equivalent_to_ch=equivalent_to_ch, & multiplicity=multiplicity) end subroutine vamp_reshape_grid @ %def vamp_reshape_grid @ \texttt{vegas} operates in three different modes, which are chosen according to explicit user requests and to the relation of the requested number of sampling points to the dimensionality of the integration domain.\par The simplest case is when the user has overwritten the default of stratified sampling with the optional argument [[stratified]] in the call to [[vamp_create_grid]]. Then sample points will be choosen randomly with equal probability in each cell of the adaptive grid, as displayed in figure~\ref{fig:nonstrat}.\par The implementation is actually shared with the stratified case described below, by pretending that there is just a single stratification cell. The number of divisions for the adaptive grid is set to a compile time maximum value.\par If the user has agreed on stratified sampling then there are two cases, depending on the dimensionality of the integration region and the number of sample points. First we determine the number of divisions~$n_g$ (i.\,e.~[[ng]]) of the rigid grid such that there will be two sampling points per cell. \begin{equation} N_{\text{calls}} = 2\cdot (n_g)^{n_{\text{dim}}} \end{equation} The additional optional argument~$\hat n_g$ specifies an anisotropy in the shape \begin{equation} n_{g,j} = \frac{\hat n_{g,j}}{\left(\prod_j\hat n_{g,j}\right)^{1/n_{\text{dim}}}} \left(\frac{N}{2}\right)^{1/n_{\text{dim}}} \end{equation} NB: \begin{equation} \prod_j n_{g,j} = \frac{N}{2} \end{equation} <>= if (g%stratified) then ng = (g%num_calls / 2.0 + 0.25)**(1.0/ndim) ! ng = ng * real (g%num_div, kind=default) & ! / (product (real (g%num_div, kind=default)))**(1.0/ndim) else ng = 1 end if call reshape_division (g%div, g%num_div, ng, use_variance) call clear_integral_and_variance (g%div) num_cells = product (rigid_division (g%div)) g%calls_per_cell = max (g%num_calls / num_cells, 2) g%calls = real (g%calls_per_cell) * real (num_cells) @ %def ng num_cells calls calls_per_cell @ \begin{equation} [[jacobi]] = J = \frac{\text{Volume}}{N_{\text{calls}}} \end{equation} and \begin{equation} [[dv2g]] = \frac{N_{\text{calls}}^2 \left((\Delta x)^{n_{\text{dim}}}\right)^2} {N_{\text{calls/cell}}^2(N_{\text{calls/cell}}-1)} = \frac{\left(\frac{N_{\text{calls}}}{N_{\text{cells}}}\right)^2} {N_{\text{calls/cell}}^2(N_{\text{calls/cell}}-1)} \end{equation} <>= g%jacobi = product (volume_division (g%div)) / g%calls g%dv2g = (g%calls / num_cells)**2 & / g%calls_per_cell / g%calls_per_cell / (g%calls_per_cell - 1.0) @ %def jacobi dv2g @ <>= call vamp_nullify_f_limits (g) @ When the grid is refined or reshaped, the recorded minimum and maximum of the sampling function should be nullified: @ <>= public :: vamp_nullify_f_limits @ <>= elemental subroutine vamp_nullify_f_limits (g) type(vamp_grid), intent(inout) :: g g%f_min = 1.0 g%f_max = 0.0 end subroutine vamp_nullify_f_limits @ %def vamp_nullify_f_limits @ %def f_min f_max @ <>= public :: vamp_rigid_divisions public :: vamp_get_covariance, vamp_nullify_covariance public :: vamp_get_variance, vamp_nullify_variance @ <>= pure function vamp_rigid_divisions (g) result (ng) type(vamp_grid), intent(in) :: g integer, dimension(size(g%div)) :: ng ng = rigid_division (g%div) end function vamp_rigid_divisions @ %def vamp_rigid_divisions @ <>= pure function vamp_get_covariance (g) result (cov) type(vamp_grid), intent(in) :: g real(kind=default), dimension(size(g%div),size(g%div)) :: cov if (associated (g%mu_x)) then if (abs (g%sum_weights) <= tiny (cov(1,1))) then where (g%sum_mu_xx == 0.0_default) cov = 0.0 elsewhere cov = huge (cov(1,1)) endwhere else cov = g%sum_mu_xx / g%sum_weights & - outer_product (g%sum_mu_x, g%sum_mu_x) / g%sum_weights**2 end if else cov = 0.0 end if end function vamp_get_covariance @ %def vamp_get_covariance @ <>= elemental subroutine vamp_nullify_covariance (g) type(vamp_grid), intent(inout) :: g if (associated (g%mu_x)) then g%sum_mu_x = 0 g%sum_mu_xx = 0 end if end subroutine vamp_nullify_covariance @ %def vamp_nullify_covariance @ <>= elemental function vamp_get_variance (g) result (v) type(vamp_grid), intent(in) :: g real(kind=default) :: v if (abs (g%sum_weights) <= tiny (v)) then if (g%sum_mu_gi == 0.0_default) then v = 0.0 else v = huge (v) end if else v = g%sum_mu_gi / g%sum_weights end if end function vamp_get_variance @ %def vamp_get_variance @ <>= elemental subroutine vamp_nullify_variance (g) type(vamp_grid), intent(inout) :: g g%sum_mu_gi = 0 end subroutine vamp_nullify_variance @ %def vamp_nullify_variance @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Sampling} <>= public :: vamp_sample_grid public :: vamp_sample_grid0 public :: vamp_refine_grid public :: vamp_refine_grids @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Simple Non-Adaptive Sampling: $S_0$} <>= subroutine vamp_sample_grid0 & (rng, g, func, data, channel, weights, grids, exc, & negative_weights) type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, intent(in), optional :: channel real(kind=default), dimension(:), intent(in), optional :: weights type(vamp_grid), dimension(:), intent(in), optional :: grids type(exception), intent(inout), optional :: exc <> character(len=*), parameter :: FN = "vamp_sample_grid0" logical, intent(in), optional :: negative_weights <> integer :: ndim logical :: neg_w ndim = size (g%div) neg_w = .false. if (present (negative_weights)) neg_w = negative_weights <> <> loop_over_cells: do <> <> <> end do loop_over_cells <> end subroutine vamp_sample_grid0 @ %def vamp_sample_grid0 @ Count cells like a $n_g$-ary number---i.e.~$(1,\ldots,1,1)$, $(1,\ldots,1,2)$, $\ldots$, $(1,\ldots,1,n_g)$, $(1,\ldots,2,1)$, $\ldots$, $(n_g,\ldots,n_g,n_g-1)$, $(n_g,\ldots,n_g,n_g)$---and terminate when [[all (cell == 1)]] again. <>= do j = ndim, 1, -1 cell(j) = modulo (cell(j), rigid_division (g%div(j))) + 1 if (cell(j) /= 1) then cycle loop_over_cells end if end do exit loop_over_cells @ %def cell @ <>= g%mu = 0.0 g%mu_plus = 0.0 g%mu_minus = 0.0 cell = 1 call clear_integral_and_variance (g%div) if (associated (g%mu_x)) then g%mu_x = 0.0 g%mu_xx = 0.0 end if if (present (channel)) then g%mu_gi = 0.0 end if @ <>= real(kind=default), parameter :: & eps = tiny (1._default) / epsilon (1._default) character(len=6) :: buffer @ <>= integer :: j, k integer, dimension(size(g%div)) :: cell @ %def j k cell @ <>= sum_f = 0.0 sum_f_plus = 0.0 sum_f_minus = 0.0 sum_f2 = 0.0 sum_f2_plus = 0.0 sum_f2_minus = 0.0 do k = 1, g%calls_per_cell <> <<[[f = wgt * func (x, weights, channel)]], iff [[x]] inside [[true_domain]]>> <> end do @ %def sum_f sum_f2 sum_f_plus sum_f_minus @ We are using the generic procedure [[tao_random_number]] from the [[tao_random_numbers]] module for generating an array of uniform deviates. \index{dependences on external modules} \index{deficiencies in \protect\texttt{Fortran90} and \protect\texttt{F}} A better alternative would be to pass the random number generator as an argument to [[vamp_sample_grid]]. Unfortunately, it is not possible to pass \emph{generic} procedures in \texttt{Fortran90}, \texttt{Fortran95}, or \texttt{F}. While we could export a specific procedure from [[tao_random_numbers]], a more serious problem is that we have to pass the state [[rng]] of the random number generator as a [[tao_random_state]] anyway and we have to hardcode the random number generator anyway. <>= call tao_random_number (rng, r) call inject_division (g%div, real (r, kind=default), & cell, x, x_mid, ia, wgts) wgt = g%jacobi * product (wgts) if (associated (g%map)) then x = matmul (g%map, x) end if @ %def r ia wgt wgts x x_mid @ This somewhat contorted nested [[if]] constructs allow to minimize the number of calls to [[func]]. This is useful, since [[func]] is the most expensive part of real world applications. Also [[func]] might be singular outside of [[true_domain]].\par The original \texttt{vegas} used to call [[f = wgt * func (x, wgt)]] below to allow [[func]] to use [[wgt]] (i.e.~$1/p(x)$) for integrating another function at the same time. This form of ``parallelism'' relies on side effects and is therefore impossible with pure functions. Consequently, it is not supported in the current implementation. <<[[f = wgt * func (x, weights, channel)]], iff [[x]] inside [[true_domain]]>>= if (associated (g%map)) then if (all (inside_division (g%div, x))) then f = wgt * func (x, data, weights, channel, grids) else f = 0.0 end if else f = wgt * func (x, data, weights, channel, grids) end if @ %def f @ <>= if (g%f_min > g%f_max) then g%f_min = abs (f) * g%calls g%f_max = abs (f) * g%calls else if (abs (f) * g%calls < g%f_min) then g%f_min = abs (f) * g%calls else if (abs (f) * g%calls > g%f_max) then g%f_max = abs (f) * g%calls end if @ <>= f2 = f * f sum_f = sum_f + f sum_f2 = sum_f2 + f2 if (f > 0) then sum_f_plus = sum_f_plus + f sum_f2_plus = sum_f2_plus + f * f else if (f < 0) then sum_f_minus = sum_f_minus + f sum_f2_minus = sum_f2_minus + f * f end if call record_integral (g%div, ia, f) ! call record_efficiency (g%div, ia, f/g%f_max) if ((associated (g%mu_x)) .and. (.not. g%all_stratified)) then g%mu_x = g%mu_x + x * f g%mu_xx = g%mu_xx + outer_product (x, x) * f end if if (present (channel)) then g%mu_gi = g%mu_gi + f2 end if @ %def f2 sum_f sum_f2 sum_f_plus sum_f_minus sum_f2_plus sum_f2_minus @ <>= real(kind=default) :: wgt, f, f2 real(kind=default) :: sum_f, sum_f2, var_f real(kind=default) :: sum_f_plus, sum_f2_plus, var_f_plus real(kind=default) :: sum_f_minus, sum_f2_minus, var_f_minus real(kind=default), dimension(size(g%div)):: x, x_mid, wgts real(kind=default), dimension(size(g%div)):: r integer, dimension(size(g%div)) :: ia @ %def wgt f f2 @ %def sum_f sum_f2 var_f @ %def sum_f_plus sum_f2_plus var_f_plus @ %def sum_f_minus sum_f2_minus var_f_minus @ %def r x x_mid wgts wgt ia @ \begin{equation} \sigma^2 \cdot N^2_{\text{calls/cell}}(N_{\text{calls/cell}}-1) = \mathop{\textrm{var}}(f) = N^2\sigma^2 \left( \left\langle \frac{f^2}{p} \right\rangle - \langle f \rangle^2 \right) \end{equation} \label{pg:var_f} <>= var_f = sum_f2 * g%calls_per_cell - sum_f**2 var_f_plus = sum_f2_plus * g%calls_per_cell - sum_f_plus**2 var_f_minus = sum_f2_minus * g%calls_per_cell - sum_f_minus**2 if (var_f <= 0.0) then var_f = tiny (1.0_default) end if if (sum_f_plus /= 0 .and. var_f_plus <= 0) then var_f_plus = tiny (1.0_default) end if if (sum_f_minus /= 0 .and. var_f_minus <= 0) then var_f_minus = tiny (1.0_default) end if g%mu = g%mu + (/ sum_f, var_f /) g%mu_plus = g%mu_plus + (/ sum_f_plus, var_f_plus /) g%mu_minus = g%mu_minus + (/ sum_f_minus, var_f_minus /) call record_variance (g%div, ia, var_f) if ((associated (g%mu_x)) .and. g%all_stratified) then if (associated (g%map)) then x_mid = matmul (g%map, x_mid) end if g%mu_x = g%mu_x + x_mid * var_f g%mu_xx = g%mu_xx + outer_product (x_mid, x_mid) * var_f end if @ %def sum_x sum_xx var_f @ \begin{equation} \sigma^2 = \frac{\left(\frac{N_{\text{calls}}}{N_{\text{cells}}}\right)^2}% {N^2_{\text{calls/cell}}(N_{\text{calls/cell}}-1)} \sum_{\text{cells}} \sigma^2_{\text{cell}} \cdot N^2_{\text{calls/cell}}(N_{\text{calls/cell}}-1) \end{equation} where the~$N_{\text{calls}}^2$ cancels the corresponding factor in the Jacobian and the~$N_{\text{cells}}^{-2}$ is the result of stratification. In order to avoid numerical noise for some OS when using 80bit precision, we wrap the numerical resetting into a negative weights-only if-clause. <>= g%mu(2) = g%mu(2) * g%dv2g if (g%mu(2) < eps * max (g%mu(1)**2, 1._default)) then g%mu(2) = eps * max (g%mu(1)**2, 1._default) end if if (neg_w) then g%mu_plus(2) = g%mu_plus(2) * g%dv2g if (g%mu_plus(2) < eps * max (g%mu_plus(1)**2, 1._default)) then g%mu_plus(2) = eps * max (g%mu_plus(1)**2, 1._default) end if g%mu_minus(2) = g%mu_minus(2) * g%dv2g if (g%mu_minus(2) < eps * max (g%mu_minus(1)**2, 1._default)) then g%mu_minus(2) = eps * max (g%mu_minus(1)**2, 1._default) end if end if @ <>= if (g%mu(1)>0) then g%sum_integral = g%sum_integral + g%mu(1) / g%mu(2) g%sum_weights = g%sum_weights + 1.0 / g%mu(2) g%sum_chi2 = g%sum_chi2 + g%mu(1)**2 / g%mu(2) if (associated (g%mu_x)) then if (g%all_stratified) then g%mu_x = g%mu_x / g%mu(2) g%mu_xx = g%mu_xx / g%mu(2) else g%mu_x = g%mu_x / g%mu(1) g%mu_xx = g%mu_xx / g%mu(1) end if g%sum_mu_x = g%sum_mu_x + g%mu_x / g%mu(2) g%sum_mu_xx = g%sum_mu_xx + g%mu_xx / g%mu(2) end if if (present (channel)) then g%sum_mu_gi = g%sum_mu_gi + g%mu_gi / g%mu(2) end if else if (neg_w) then g%sum_integral = g%sum_integral + g%mu(1) / g%mu(2) g%sum_weights = g%sum_weights + 1.0 / g%mu(2) g%sum_chi2 = g%sum_chi2 + g%mu(1)**2 / g%mu(2) if (associated (g%mu_x)) then if (g%all_stratified) then g%mu_x = g%mu_x / g%mu(2) g%mu_xx = g%mu_xx / g%mu(2) else g%mu_x = g%mu_x / g%mu(1) g%mu_xx = g%mu_xx / g%mu(1) end if g%sum_mu_x = g%sum_mu_x + g%mu_x / g%mu(2) g%sum_mu_xx = g%sum_mu_xx + g%mu_xx / g%mu(2) end if if (present (channel)) then g%sum_mu_gi = g%sum_mu_gi + g%mu_gi / g%mu(2) end if else if (present(channel) .and. g%mu(1)==0) then write (buffer, "(I6)") channel call raise_exception (exc, EXC_WARN, "! vamp", & "Function identically zero in channel " // buffer) else if (present(channel) .and. g%mu(1)<0) then write (buffer, "(I6)") channel call raise_exception (exc, EXC_ERROR, "! vamp", & "Negative integral in channel " // buffer) end if g%sum_integral = 0 g%sum_chi2 = 0 g%sum_weights = 0 end if @ %def sum_integral sum_chi2 sum_weights @ <>= if (present (channel) .neqv. present (weights)) then call raise_exception (exc, EXC_FATAL, FN, & "channel and weights required together") return end if @ <>= public :: vamp_probability @ <>= pure function vamp_probability (g, x) result (p) type(vamp_grid), intent(in) :: g real(kind=default), dimension(:), intent(in) :: x real(kind=default) :: p p = product (probability (g%div, x)) end function vamp_probability @ %def vamp_probability @ \begin{dubious} [[%variance]] should be private to [[division]] \end{dubious} <>= subroutine vamp_apply_equivalences (g, eq) type(vamp_grids), intent(inout) :: g type(vamp_equivalences_t), intent(in) :: eq integer :: n_ch, n_dim, nb, i, ch, ch_src, dim, dim_src integer, dimension(:,:), allocatable :: n_bin real(kind=default), dimension(:,:,:), allocatable :: var_tmp n_ch = size (g%grids) if (n_ch == 0) return n_dim = size (g%grids(1)%div) allocate (n_bin(n_ch, n_dim)) do ch = 1, n_ch do dim = 1, n_dim n_bin(ch, dim) = size (g%grids(ch)%div(dim)%variance) end do end do allocate (var_tmp (maxval(n_bin), n_dim, n_ch)) var_tmp = 0 do i=1, eq%n_eq ch = eq%eq(i)%left ch_src = eq%eq(i)%right do dim=1, n_dim nb = n_bin(ch_src, dim) dim_src = eq%eq(i)%permutation(dim) select case (eq%eq(i)%mode(dim)) case (VEQ_IDENTITY) var_tmp(:nb,dim,ch) = var_tmp(:nb,dim,ch) & & + g%grids(ch_src)%div(dim_src)%variance case (VEQ_INVERT) var_tmp(:nb,dim,ch) = var_tmp(:nb,dim,ch) & & + g%grids(ch_src)%div(dim_src)%variance(nb:1:-1) case (VEQ_SYMMETRIC) var_tmp(:nb,dim,ch) = var_tmp(:nb,dim,ch) & & + g%grids(ch_src)%div(dim_src)%variance / 2 & & + g%grids(ch_src)%div(dim_src)%variance(nb:1:-1)/2 case (VEQ_INVARIANT) var_tmp(:nb,dim,ch) = 1 end select end do end do do ch=1, n_ch do dim=1, n_dim g%grids(ch)%div(dim)%variance = var_tmp(:n_bin(ch, dim),dim,ch) end do end do deallocate (var_tmp) deallocate (n_bin) end subroutine vamp_apply_equivalences @ %def vamp_apply_equivalences @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Grid Refinement: $r$} \begin{equation} n_{\text{div},j} \to \frac{Q_j n_{\text{div},j}}{\left(\prod_j Q_j\right)^{1/n_{\text{dim}}}} \end{equation} where \begin{equation} Q_j = \left(\sqrt{\mathop{\textrm{Var}}(\{m\}_j)}\right)^\alpha \end{equation} <>= pure subroutine vamp_refine_grid (g, exc) type(vamp_grid), intent(inout) :: g type(exception), intent(inout), optional :: exc real(kind=default), dimension(size(g%div)) :: quad integer :: ndim if (g%quadrupole) then ndim = size (g%div) quad = (quadrupole_division (g%div))**QUAD_POWER call vamp_reshape_grid_internal & (g, use_variance = .true., exc = exc, & num_div = int (quad / product (quad)**(1.0/ndim) * g%num_div)) else call refine_division (g%div) call vamp_nullify_f_limits (g) end if end subroutine vamp_refine_grid @ %def vamp_refine_grid @ <>= subroutine vamp_refine_grids (g) type(vamp_grids), intent(inout) :: g integer :: ch do ch=1, size(g%grids) call refine_division (g%grids(ch)%div) call vamp_nullify_f_limits (g%grids(ch)) end do end subroutine vamp_refine_grids @ %def vamp_refine_grids @ <>= real(kind=default), private, parameter :: QUAD_POWER = 0.5_default @ %def QUAD_POWER @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Adaptive Sampling: $S_n = S_0(rS_0)^n$} <>= subroutine vamp_sample_grid & (rng, g, func, data, iterations, & integral, std_dev, avg_chi2, accuracy, & channel, weights, grids, exc, history) type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, intent(in) :: iterations real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 real(kind=default), intent(in), optional :: accuracy integer, intent(in), optional :: channel real(kind=default), dimension(:), intent(in), optional :: weights type(vamp_grid), dimension(:), intent(in), optional :: grids type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> character(len=*), parameter :: FN = "vamp_sample_grid" real(kind=default) :: local_integral, local_std_dev, local_avg_chi2 integer :: iteration, ndim ndim = size (g%div) iterate: do iteration = 1, iterations call vamp_sample_grid0 & (rng, g, func, data, channel, weights, grids, exc) call vamp_average_iterations & (g, iteration, local_integral, local_std_dev, local_avg_chi2) <> <> if (iteration < iterations) call vamp_refine_grid (g) end do iterate <> end subroutine vamp_sample_grid @ %def local_integral local_std_dev local_avg_chi2 @ %def vamp_sample_grid @ %def func iterations integral std_dev avg_chi2 accuracy @ %def iteration @ Assuming that the iterations have been statistically independent, we can combine them with the usual formulae. \begin{subequations} \begin{align} \bar I &= \sigma_I^2 \sum_i \frac{I_i}{\sigma_i^2} \\ \frac{1}{\sigma_I^2} &= \sum_i \frac{1}{\sigma_i^2} \\ \chi^2 &= \sum_i \frac{(I_i-\bar I)^2}{\sigma_i^2} = \sum_i \frac{I_i^2}{\sigma_i^2} - \bar I \sum_i \frac{I_i}{\sigma_i^2} \end{align} \end{subequations} <>= elemental subroutine vamp_average_iterations_grid & (g, iteration, integral, std_dev, avg_chi2) type(vamp_grid), intent(in) :: g integer, intent(in) :: iteration real(kind=default), intent(out) :: integral, std_dev, avg_chi2 real(kind=default), parameter :: eps = 1000 * epsilon (1._default) if (g%sum_weights>0) then integral = g%sum_integral / g%sum_weights std_dev = sqrt (1.0 / g%sum_weights) avg_chi2 = & max ((g%sum_chi2 - g%sum_integral * integral) / (iteration-0.99), & 0.0_default) if (avg_chi2 < eps * g%sum_chi2) avg_chi2 = 0 else integral = 0 std_dev = 0 avg_chi2 = 0 end if end subroutine vamp_average_iterations_grid @ %def vamp_average_iterations_grid @ <>= public :: vamp_average_iterations private :: vamp_average_iterations_grid @ %def vamp_average_iterations @ <>= interface vamp_average_iterations module procedure vamp_average_iterations_grid end interface @ %def vamp_average_iterations @ Lepage suggests~\cite{Lepage:1978:vegas} to reweight the contributions as in the following improved formulae, which we might implement as an option later. \begin{subequations} \begin{align} \bar I &= \frac{1}{\left(\sum_i\frac{I_i^2}{\sigma_i^2}\right)^2} \sum_i I_i \frac{I_i^2}{\sigma_i^2} \\ \frac{1}{\sigma_I^2} &= \frac{1}{(\bar I)^2} \sum_i \frac{I_i^2}{\sigma_i^2} \\ \chi^2 &= \sum_i \frac{(I_i-\bar I)^2}{(\bar I)^2} \frac{I_i^2}{\sigma_i^2} \end{align} \end{subequations} @ Iff possible, copy the result to the caller's variables: <>= if (present (integral)) then integral = local_integral end if if (present (std_dev)) then std_dev = local_std_dev end if if (present (avg_chi2)) then avg_chi2 = local_avg_chi2 end if @ %def local_integral local_std_dev local_avg_chi2 @ %def integral std_dev avg_chi2 @ <>= if (present (accuracy)) then if (local_std_dev <= accuracy * local_integral) then call raise_exception (exc, EXC_INFO, FN, & "requested accuracy reached") exit iterate end if end if @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Forking and Joining} <>= public :: vamp_fork_grid private :: vamp_fork_grid_single, vamp_fork_grid_multi public :: vamp_join_grid private :: vamp_join_grid_single, vamp_join_grid_multi @ %def vamp_fork_grid vamp_join_grid @ <>= interface vamp_fork_grid module procedure vamp_fork_grid_single, vamp_fork_grid_multi end interface interface vamp_join_grid module procedure vamp_join_grid_single, vamp_join_grid_multi end interface @ %def vamp_fork_grid vamp_join_grid @ Caveat emptor: splitting divisions can lead to $[[num_div]]<3$ an the application must not try to refine such grids before merging them again! [[d == 0]] is special. <>= pure subroutine vamp_fork_grid_single (g, gs, d, exc) type(vamp_grid), intent(in) :: g type(vamp_grid), dimension(:), intent(inout) :: gs integer, intent(in) :: d type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "vamp_fork_grid_single" type(division_t), dimension(:), allocatable :: d_tmp integer :: i, j, num_grids, num_div, ndim, num_cells num_grids = size (gs) ndim = size (g%div) <> do j = 1, ndim if (j == d) then <<[[call fork_division (g%div(j), gs%div(j), g%calls_per_cell, ...)]]>> else <<[[call copy_division (gs%div(j), g%div(j))]]>> end if end do if (d == 0) then <> end if <> end subroutine vamp_fork_grid_single @ %def vamp_fork_grid_single @ Divide the sampling points among identical grids <>= if (any (stratified_division (g%div))) then call raise_exception (exc, EXC_FATAL, FN, & "d == 0 incompatiple w/ stratification") else gs(2:)%calls_per_cell = ceiling (real (g%calls_per_cell) / num_grids) gs(1)%calls_per_cell = g%calls_per_cell - sum (gs(2:)%calls_per_cell) end if @ <>= do i = 1, num_grids call copy_array_pointer (gs(i)%num_div, g%num_div) if (associated (g%map)) then call copy_array_pointer (gs(i)%map, g%map) end if if (associated (g%mu_x)) then call create_array_pointer (gs(i)%mu_x, ndim) call create_array_pointer (gs(i)%sum_mu_x, ndim) call create_array_pointer (gs(i)%mu_xx, (/ ndim, ndim /)) call create_array_pointer (gs(i)%sum_mu_xx, (/ ndim, ndim /)) end if end do @ Reset results <>= gs%mu(1) = 0.0 gs%mu(2) = 0.0 gs%mu_plus(1) = 0.0 gs%mu_plus(2) = 0.0 gs%mu_minus(1) = 0.0 gs%mu_minus(2) = 0.0 gs%sum_integral = 0.0 gs%sum_weights = 0.0 gs%sum_chi2 = 0.0 gs%mu_gi = 0.0 gs%sum_mu_gi = 0.0 @ <>= gs%stratified = g%stratified gs%all_stratified = g%all_stratified gs%quadrupole = g%quadrupole @ <>= do i = 1, num_grids num_cells = product (rigid_division (gs(i)%div)) gs(i)%calls = gs(i)%calls_per_cell * num_cells gs(i)%num_calls = gs(i)%calls gs(i)%jacobi = product (volume_division (gs(i)%div)) / gs(i)%calls gs(i)%dv2g = (gs(i)%calls / num_cells)**2 & / gs(i)%calls_per_cell / gs(i)%calls_per_cell / (gs(i)%calls_per_cell - 1.0) end do gs%f_min = g%f_min * (gs%jacobi * gs%calls) / (g%jacobi * g%calls) gs%f_max = g%f_max * (gs%jacobi * gs%calls) / (g%jacobi * g%calls) @ This could be self-explaining, if the standard would allow \ldots. Note that we can get away with copying just the pointers, because [[fork_division]] does the dirty work for the memory management. <<[[call fork_division (g%div(j), gs%div(j), g%calls_per_cell, ...)]]>>= allocate (d_tmp(num_grids)) do i = 1, num_grids d_tmp(i) = gs(i)%div(j) end do call fork_division (g%div(j), d_tmp, g%calls_per_cell, gs%calls_per_cell, exc) do i = 1, num_grids gs(i)%div(j) = d_tmp(i) end do deallocate (d_tmp) <> @ <>= if (present (exc)) then if (exc%level > EXC_WARN) then return end if end if @ We have to do a deep copy ([[gs(i)%div(j) = g%div(j)]] does not suffice), because [[copy_division]] handles the memory management. <<[[call copy_division (gs%div(j), g%div(j))]]>>= do i = 1, num_grids call copy_division (gs(i)%div(j), g%div(j)) end do @ <>= num_div = size (g%div) do i = 1, size (gs) if (associated (gs(i)%div)) then if (size (gs(i)%div) /= num_div) then allocate (gs(i)%div(num_div)) call create_empty_division (gs(i)%div) end if else allocate (gs(i)%div(num_div)) call create_empty_division (gs(i)%div) end if end do @ <>= pure subroutine vamp_join_grid_single (g, gs, d, exc) type(vamp_grid), intent(inout) :: g type(vamp_grid), dimension(:), intent(inout) :: gs integer, intent(in) :: d type(exception), intent(inout), optional :: exc type(division_t), dimension(:), allocatable :: d_tmp integer :: i, j, num_grids num_grids = size (gs) do j = 1, size (g%div) if (j == d) then <<[[call join_division (g%div(j), gs%div(j))]]>> else <<[[call sum_division (g%div(j), gs%div(j))]]>> end if end do <> end subroutine vamp_join_grid_single @ %def vamp_join_grid_single @ <<[[call join_division (g%div(j), gs%div(j))]]>>= allocate (d_tmp(num_grids)) do i = 1, num_grids d_tmp(i) = gs(i)%div(j) end do call join_division (g%div(j), d_tmp, exc) deallocate (d_tmp) <> @ <<[[call sum_division (g%div(j), gs%div(j))]]>>= allocate (d_tmp(num_grids)) do i = 1, num_grids d_tmp(i) = gs(i)%div(j) end do call sum_division (g%div(j), d_tmp) deallocate (d_tmp) @ <>= g%f_min = minval (gs%f_min * (g%jacobi * g%calls) / (gs%jacobi * gs%calls)) g%f_max = maxval (gs%f_max * (g%jacobi * g%calls) / (gs%jacobi * gs%calls)) g%mu(1) = sum (gs%mu(1)) g%mu(2) = sum (gs%mu(2)) g%mu_plus(1) = sum (gs%mu_plus(1)) g%mu_plus(2) = sum (gs%mu_plus(2)) g%mu_minus(1) = sum (gs%mu_minus(1)) g%mu_minus(2) = sum (gs%mu_minus(2)) g%mu_gi = sum (gs%mu_gi) g%sum_mu_gi = g%sum_mu_gi + g%mu_gi / g%mu(2) g%sum_integral = g%sum_integral + g%mu(1) / g%mu(2) g%sum_chi2 = g%sum_chi2 + g%mu(1)**2 / g%mu(2) g%sum_weights = g%sum_weights + 1.0 / g%mu(2) if (associated (g%mu_x)) then do i = 1, num_grids g%mu_x = g%mu_x + gs(i)%mu_x g%mu_xx = g%mu_xx + gs(i)%mu_xx end do g%sum_mu_x = g%sum_mu_x + g%mu_x / g%mu(2) g%sum_mu_xx = g%sum_mu_xx + g%mu_xx / g%mu(2) end if @ The following is made a little bit hairy by the fact that [[vamp_fork_grid]] can't join grids onto a non-existing grid\footnote{It would be possible to make it possible by changing many things under the hood, but it doesn't really make sense, anyway.} therefore we have to keep a tree of joints. Maybe it would be the right thing to handle this tree of joints as a tree with pointers, but since we need the leaves flattened anyway (as food for multiple [[vamp_sample_grid]]) we use a similar storage layout for the joints. <>= type(vamp_grid), dimension(:), allocatable :: gx integer, dimension(:,:), allocatable :: dim ... allocate (gx(vamp_fork_grid_joints (dim))) call vamp_fork_grid (g, gs, gx, dim, exc) ... call vamp_join_grid (g, gs, gx, dim, exc) @ <>= pure recursive subroutine vamp_fork_grid_multi (g, gs, gx, d, exc) type(vamp_grid), intent(in) :: g type(vamp_grid), dimension(:), intent(inout) :: gs, gx integer, dimension(:,:), intent(in) :: d type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "vamp_fork_grid_multi" integer :: i, offset, stride, joints_offset, joints_stride select case (size (d, dim=2)) case (0) return case (1) call vamp_fork_grid_single (g, gs, d(1,1), exc) case default offset = 1 stride = product (d(2,2:)) joints_offset = 1 + d(2,1) joints_stride = vamp_fork_grid_joints (d(:,2:)) call vamp_create_empty_grid (gx(1:d(2,1))) call vamp_fork_grid_single (g, gx(1:d(2,1)), d(1,1), exc) do i = 1, d(2,1) call vamp_fork_grid_multi & (gx(i), gs(offset:offset+stride-1), & gx(joints_offset:joints_offset+joints_stride-1), & d(:,2:), exc) offset = offset + stride joints_offset = joints_offset + joints_stride end do end select end subroutine vamp_fork_grid_multi @ %def vamp_fork_grid_multi @ <>= public :: vamp_fork_grid_joints @ \begin{equation} \label{eq:num_joints} \sum_{n=1}^{N-1} \prod_{i_n=1}^{n} d_{i_n} = d_1(1+d_2(1+d_3(1+\ldots(1+d_{N-1})\ldots))) \end{equation} <>= pure function vamp_fork_grid_joints (d) result (s) integer, dimension(:,:), intent(in) :: d integer :: s integer :: i s = 0 do i = size (d, dim=2) - 1, 1, -1 s = (s + 1) * d(2,i) end do end function vamp_fork_grid_joints @ %def vamp_fork_grid_joints @ <>= pure recursive subroutine vamp_join_grid_multi (g, gs, gx, d, exc) type(vamp_grid), intent(inout) :: g type(vamp_grid), dimension(:), intent(inout) :: gs, gx integer, dimension(:,:), intent(in) :: d type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "vamp_join_grid_multi" integer :: i, offset, stride, joints_offset, joints_stride select case (size (d, dim=2)) case (0) return case (1) call vamp_join_grid_single (g, gs, d(1,1), exc) case default offset = 1 stride = product (d(2,2:)) joints_offset = 1 + d(2,1) joints_stride = vamp_fork_grid_joints (d(:,2:)) do i = 1, d(2,1) call vamp_join_grid_multi & (gx(i), gs(offset:offset+stride-1), & gx(joints_offset:joints_offset+joints_stride-1), & d(:,2:), exc) offset = offset + stride joints_offset = joints_offset + joints_stride end do call vamp_join_grid_single (g, gx(1:d(2,1)), d(1,1), exc) call vamp_delete_grid (gx(1:d(2,1))) end select end subroutine vamp_join_grid_multi @ %def vamp_join_grid_multi @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Parallel Execution} <>= public :: vamp_sample_grid_parallel public :: vamp_distribute_work @ HPF~\cite{HPF1.1,HPF2.0,Koelbel/etal:1994:HPF}: <>= subroutine vamp_sample_grid_parallel & (rng, g, func, data, iterations, & integral, std_dev, avg_chi2, accuracy, & channel, weights, grids, exc, history) type(tao_random_state), dimension(:), intent(inout) :: rng type(vamp_grid), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, intent(in) :: iterations real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 real(kind=default), intent(in), optional :: accuracy integer, intent(in), optional :: channel real(kind=default), dimension(:), intent(in), optional :: weights type(vamp_grid), dimension(:), intent(in), optional :: grids type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> character(len=*), parameter :: FN = "vamp_sample_grid_parallel" real(kind=default) :: local_integral, local_std_dev, local_avg_chi2 type(exception), dimension(size(rng)) :: excs type(vamp_grid), dimension(:), allocatable :: gs, gx !hpf$ processors p(number_of_processors()) !hpf$ distribute gs(cyclic(1)) onto p integer, dimension(:,:), pointer :: d integer :: iteration, i integer :: num_workers nullify (d) call clear_exception (excs) iterate: do iteration = 1, iterations call vamp_distribute_work (size (rng), vamp_rigid_divisions (g), d) num_workers = max (1, product (d(2,:))) if (num_workers > 1) then allocate (gs(num_workers), gx(vamp_fork_grid_joints (d))) call vamp_create_empty_grid (gs) !: \texttt{vamp\_fork\_grid} is certainly not local. Speed freaks might !: want to tune it to the processor topology, but the gain will be small. call vamp_fork_grid (g, gs, gx, d, exc) !hpf$ independent do i = 1, num_workers call vamp_sample_grid0 & (rng(i), gs(i), func, data, & channel, weights, grids, exc) end do <> call vamp_join_grid (g, gs, gx, d, exc) call vamp_delete_grid (gs) deallocate (gs, gx) else call vamp_sample_grid0 & (rng(1), g, func, data, channel, weights, grids, exc) end if <> call vamp_average_iterations & (g, iteration, local_integral, local_std_dev, local_avg_chi2) <> <> if (iteration < iterations) call vamp_refine_grid (g) end do iterate deallocate (d) <> end subroutine vamp_sample_grid_parallel @ %def vamp_sample_grid_parallel @ <>= if ((present (exc)) .and. (any (excs(1:num_workers)%level > 0))) then call gather_exceptions (exc, excs(1:num_workers)) end if @ We could sort~$d$ such that~(\ref{eq:num_joints}) is minimized \index{optimizations not implemented yet} \begin{equation} d_1 \le d_2 \le \ldots \le d_N \end{equation} but the gain will be negligible. <>= pure subroutine vamp_distribute_work (num_workers, ng, d) integer, intent(in) :: num_workers integer, dimension(:), intent(in) :: ng integer, dimension(:,:), pointer :: d integer, dimension(32) :: factors integer :: n, num_factors, i, j integer, dimension(size(ng)) :: num_forks integer :: nfork try: do n = num_workers, 1, -1 call factorize (n, factors, num_factors) num_forks = 1 do i = num_factors, 1, -1 j = sum (maxloc (ng / num_forks)) nfork = num_forks(j) * factors(i) if (nfork <= ng(j)) then num_forks(j) = nfork else cycle try end if end do <> end do try end subroutine vamp_distribute_work @ <>= j = count (num_forks > 1) if (associated (d)) then if (size (d, dim = 2) /= j) then deallocate (d) allocate (d(2,j)) end if else allocate (d(2,j)) end if @ <>= j = 1 do i = 1, size (ng) if (num_forks(i) > 1) then d(:,j) = (/ i, num_forks(i) /) j = j + 1 end if end do return @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Diagnostics} <>= type, public :: vamp_history private real(kind=default) :: & integral, std_dev, avg_integral, avg_std_dev, avg_chi2, f_min, f_max integer :: calls logical :: stratified logical :: verbose type(div_history), dimension(:), pointer :: div => null () end type vamp_history @ %def vamp_history @ <>= if (present (history)) then if (iteration <= size (history)) then call vamp_get_history & (history(iteration), g, local_integral, local_std_dev, & local_avg_chi2) else call raise_exception (exc, EXC_WARN, FN, "history too short") end if call vamp_terminate_history (history(iteration+1:)) end if @ <>= public :: vamp_create_history, vamp_copy_history, vamp_delete_history public :: vamp_terminate_history public :: vamp_get_history, vamp_get_history_single @ <>= interface vamp_get_history module procedure vamp_get_history_single end interface @ <>= elemental subroutine vamp_create_history (h, ndim, verbose) type(vamp_history), intent(out) :: h integer, intent(in), optional :: ndim logical, intent(in), optional :: verbose if (present (verbose)) then h%verbose = verbose else h%verbose = .false. end if h%calls = 0.0 if (h%verbose .and. (present (ndim))) then if (associated (h%div)) then deallocate (h%div) end if allocate (h%div(ndim)) end if end subroutine vamp_create_history @ %def vamp_create_history @ <>= elemental subroutine vamp_terminate_history (h) type(vamp_history), intent(inout) :: h h%calls = 0.0 end subroutine vamp_terminate_history @ %def vamp_terminate_history @ <>= pure subroutine vamp_get_history_single (h, g, integral, std_dev, avg_chi2) type(vamp_history), intent(inout) :: h type(vamp_grid), intent(in) :: g real(kind=default), intent(in) :: integral, std_dev, avg_chi2 h%calls = g%calls h%stratified = g%all_stratified h%integral = g%mu(1) h%std_dev = sqrt (g%mu(2)) h%avg_integral = integral h%avg_std_dev = std_dev h%avg_chi2 = avg_chi2 h%f_min = g%f_min h%f_max = g%f_max if (h%verbose) then <> call copy_history (h%div, summarize_division (g%div)) end if end subroutine vamp_get_history_single @ %def vamp_get_history_single @ <>= if (associated (h%div)) then if (size (h%div) /= size (g%div)) then deallocate (h%div) allocate (h%div(size(g%div))) end if else allocate (h%div(size(g%div))) end if @ <>= public :: vamp_print_history, vamp_write_history private :: vamp_print_one_history, vamp_print_histories ! private :: vamp_write_one_history, vamp_write_histories @ %def vamp_print_history vamp_print_one_history vamp_print_histories @ %def vamp_write_history vamp_write_one_history vamp_write_histories @ <>= interface vamp_print_history module procedure vamp_print_one_history, vamp_print_histories end interface interface vamp_write_history module procedure vamp_write_one_history_unit, vamp_write_histories_unit end interface @ %def vamp_print_history @ %def vamp_write_history @ <>= subroutine vamp_print_one_history (h, tag) type(vamp_history), dimension(:), intent(in) :: h character(len=*), intent(in), optional :: tag type(div_history), dimension(:), allocatable :: h_tmp character(len=BUFFER_SIZE) :: pfx character(len=1) :: s integer :: i, imax, j if (present (tag)) then pfx = tag else pfx = "[vamp]" end if print "(1X,A78)", repeat ("-", 78) print "(1X,A8,1X,A2,A9,A1,1X,A11,1X,8X,1X," & // "1X,A13,1X,8X,1X,A5,1X,A5)", & pfx, "it", "#calls", "", "integral", "average", "chi2", "eff." imax = size (h) iterations: do i = 1, imax if (h(i)%calls <= 0) then imax = i - 1 exit iterations end if ! *JR: Skip zero channel if (h(i)%f_max==0) cycle if (h(i)%stratified) then s = "*" else s = "" end if print "(1X,A8,1X,I2,I9,A1,1X,E11.4,A1,E8.2,A1," & // "1X,E13.6,A1,E8.2,A1,F5.1,1X,F5.3)", pfx, & i, h(i)%calls, s, h(i)%integral, "(", h(i)%std_dev, ")", & h(i)%avg_integral, "(", h(i)%avg_std_dev, ")", h(i)%avg_chi2, & h(i)%integral / h(i)%f_max end do iterations print "(1X,A78)", repeat ("-", 78) if (all (h%verbose) .and. (imax >= 1)) then if (associated (h(1)%div)) then allocate (h_tmp(imax)) dimensions: do j = 1, size (h(1)%div) do i = 1, imax call copy_history (h_tmp(i), h(i)%div(j)) end do if (present (tag)) then write (unit = pfx, fmt = "(A,A1,I2.2)") & trim (tag(1:min(len_trim(tag),8))), "#", j else write (unit = pfx, fmt = "(A,A1,I2.2)") "[vamp]", "#", j end if call print_history (h_tmp, tag = pfx) print "(1X,A78)", repeat ("-", 78) end do dimensions deallocate (h_tmp) end if end if flush (output_unit) end subroutine vamp_print_one_history @ %def vamp_print_one_history @ <>= integer, private, parameter :: BUFFER_SIZE = 50 @ %def BUFFER_SIZE @ <>= subroutine vamp_print_histories (h, tag) type(vamp_history), dimension(:,:), intent(in) :: h character(len=*), intent(in), optional :: tag character(len=BUFFER_SIZE) :: pfx integer :: i print "(1X,A78)", repeat ("=", 78) channels: do i = 1, size (h, dim=2) if (present (tag)) then write (unit = pfx, fmt = "(A4,A1,I3.3)") tag, "#", i else write (unit = pfx, fmt = "(A4,A1,I3.3)") "chan", "#", i end if call vamp_print_one_history (h(:,i), pfx) end do channels print "(1X,A78)", repeat ("=", 78) flush (output_unit) end subroutine vamp_print_histories @ %def vamp_print_histories @ \begin{dubious} WK \end{dubious} <>= subroutine vamp_write_one_history_unit (u, h, tag) integer, intent(in) :: u type(vamp_history), dimension(:), intent(in) :: h character(len=*), intent(in), optional :: tag type(div_history), dimension(:), allocatable :: h_tmp character(len=BUFFER_SIZE) :: pfx character(len=1) :: s integer :: i, imax, j if (present (tag)) then pfx = tag else pfx = "[vamp]" end if write (u, "(1X,A78)") repeat ("-", 78) write (u, "(1X,A8,1X,A2,A9,A1,1X,A11,1X,8X,1X," & // "1X,A13,1X,8X,1X,A5,1X,A5)") & pfx, "it", "#calls", "", "integral", "average", "chi2", "eff." imax = size (h) iterations: do i = 1, imax if (h(i)%calls <= 0) then imax = i - 1 exit iterations end if ! *WK: Skip zero channel if (h(i)%f_max==0) cycle if (h(i)%stratified) then s = "*" else s = "" end if write (u, "(1X,A8,1X,I2,I9,A1,1X,ES11.4,A1,ES8.2,A1," & // "1X,ES13.6,A1,ES8.2,A1,F5.1,1X,F5.3)") pfx, & i, h(i)%calls, s, h(i)%integral, "(", h(i)%std_dev, ")", & h(i)%avg_integral, "(", h(i)%avg_std_dev, ")", h(i)%avg_chi2, & h(i)%integral / h(i)%f_max end do iterations write (u, "(1X,A78)") repeat ("-", 78) if (all (h%verbose) .and. (imax >= 1)) then if (associated (h(1)%div)) then allocate (h_tmp(imax)) dimensions: do j = 1, size (h(1)%div) do i = 1, imax call copy_history (h_tmp(i), h(i)%div(j)) end do if (present (tag)) then write (unit = pfx, fmt = "(A,A1,I2.2)") & trim (tag(1:min(len_trim(tag),8))), "#", j else write (unit = pfx, fmt = "(A,A1,I2.2)") "[vamp]", "#", j end if call write_history (u, h_tmp, tag = pfx) print "(1X,A78)", repeat ("-", 78) end do dimensions deallocate (h_tmp) end if end if flush (u) end subroutine vamp_write_one_history_unit subroutine vamp_write_histories_unit (u, h, tag) integer, intent(in) :: u type(vamp_history), dimension(:,:), intent(in) :: h character(len=*), intent(in), optional :: tag character(len=BUFFER_SIZE) :: pfx integer :: i write (u, "(1X,A78)") repeat ("=", 78) channels: do i = 1, size (h, dim=2) if (present (tag)) then write (unit = pfx, fmt = "(A4,A1,I3.3)") tag, "#", i else write (unit = pfx, fmt = "(A4,A1,I3.3)") "chan", "#", i end if call vamp_write_one_history_unit (u, h(:,i), pfx) end do channels write (u, "(1X,A78)") repeat ("=", 78) flush (u) end subroutine vamp_write_histories_unit @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Multi Channel} \cite{Kleiss/Pittau:1994:multichannel} \begin{subequations} \begin{align} \label{eq:g(x)} g(x) &= \sum_i \alpha_i g_i(x) \\ \label{eq:w(x)} w(x) &= \frac{f(x)}{g(x)} \end{align} \end{subequations} We want to minimize the variance~$W(\alpha)$ with the subsidiary condition~$\sum_i\alpha_i = 1$. We indroduce a Lagrange multiplier~$\lambda$: \begin{equation} \tilde W(\alpha) = W(\alpha) + \lambda \left(\sum_i\alpha_i - 1\right) \end{equation} Therefore\ldots \begin{equation} W_i(\alpha) = -\frac{\partial}{\partial\alpha_i} W(\alpha) = \int\!dx\, g_i(x) (w(x))^2 \approx \left\langle \frac{g_i(x)}{g(x)} (w(x))^2 \right\rangle \end{equation} \begin{dubious} \index{Fortran sucks!} \index{functional programming rules!} Here it \emph{really} hurts that \texttt{Fortran} has no \emph{first-class} functions. The following can be expressed much more elegantly in a functional programming language with \emph{first-class} functions, currying and closures. \texttt{Fortran} makes it extra painful since not even procedure pointers are supported. This puts extra burden on the users of this library. \end{dubious} Note that the components of [[vamp_grids]] are not protected. However, this is not a license for application programs to access it. Only Other libraries (e.g.~for parallel processing, like [[vampi]]) should do so. <>= type, public :: vamp_grids !!! private !: \emph{used by \texttt{vampi}} real(kind=default), dimension(:), pointer :: weights => null () type(vamp_grid), dimension(:), pointer :: grids => null () integer, dimension(:), pointer :: num_calls => null () real(kind=default) :: sum_chi2, sum_integral, sum_weights end type vamp_grids @ %def vamp_grids @ \begin{equation} \label{eq:gophi_i} g\circ\phi_i = \left|\frac{\partial\phi_i}{\partial x}\right|^{-1} \left( \alpha_i g_i + \sum_{\substack{j=1\\j\not=i}}^{N_c} \alpha_j (g_j\circ\pi_{ij}) \left|\frac{\partial\pi_{ij}}{\partial x}\right| \right)\,. \end{equation} <>= public :: vamp_multi_channel, vamp_multi_channel0 @ <>= function vamp_multi_channel & (func, data, phi, ihp, jacobian, x, weights, channel, grids) result (w_x) class(vamp_data_t), intent(in) :: data real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:), intent(in) :: weights integer, intent(in) :: channel type(vamp_grid), dimension(:), intent(in) :: grids <> <> <> <> real(kind=default) :: w_x integer :: i real(kind=default), dimension(size(x)) :: phi_x real(kind=default), dimension(size(weights)) :: g_phi_x, g_pi_x phi_x = phi (x, channel) do i = 1, size (weights) if (i == channel) then g_pi_x(i) = vamp_probability (grids(i), x) else g_pi_x(i) = vamp_probability (grids(i), ihp (phi_x, i)) end if end do do i = 1, size (weights) g_phi_x(i) = g_pi_x(i) / g_pi_x(channel) * jacobian (phi_x, data, i) end do w_x = func (phi_x, data, weights, channel, grids) & / dot_product (weights, g_phi_x) end function vamp_multi_channel @ %def vamp_multi_channel @ <>= function vamp_multi_channel0 & (func, data, phi, jacobian, x, weights, channel) result (w_x) class(vamp_data_t), intent(in) :: data real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:), intent(in) :: weights integer, intent(in) :: channel <> <> <> real(kind=default) :: w_x real(kind=default), dimension(size(x)) :: x_prime real(kind=default), dimension(size(weights)) :: g_phi_x integer :: i x_prime = phi (x, channel) do i = 1, size (weights) g_phi_x(i) = jacobian (x_prime, data, i) end do w_x = func (x_prime, data) / dot_product (weights, g_phi_x) end function vamp_multi_channel0 @ %def vamp_multi_channel0 @ \begin{dubious} WK \end{dubious} <>= public :: vamp_jacobian, vamp_check_jacobian @ <>= pure subroutine vamp_jacobian (phi, channel, x, region, jacobian, delta_x) integer, intent(in) :: channel real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:,:), intent(in) :: region real(kind=default), intent(out) :: jacobian real(kind=default), intent(in), optional :: delta_x interface pure function phi (xi, channel) result (x) use kinds real(kind=default), dimension(:), intent(in) :: xi integer, intent(in) :: channel real(kind=default), dimension(size(xi)) :: x end function phi end interface real(kind=default), dimension(size(x)) :: x_min, x_max real(kind=default), dimension(size(x)) :: x_plus, x_minus real(kind=default), dimension(size(x),size(x)) :: d_phi real(kind=default), parameter :: & dx_default = 10.0_default**(-precision(jacobian)/3) real(kind=default) :: dx integer :: j if (present (delta_x)) then dx = delta_x else dx = dx_default end if x_min = region(1,:) x_max = region(2,:) x_minus = max (x_min, x) x_plus = min (x_max, x) do j = 1, size (x) x_minus(j) = max (x_min(j), x(j) - dx) x_plus(j) = min (x_max(j), x(j) + dx) d_phi(:,j) = (phi (x_plus, channel) - phi (x_minus, channel)) & / (x_plus(j) - x_minus(j)) x_minus(j) = max (x_min(j), x(j)) x_plus(j) = min (x_max(j), x(j)) end do call determinant (d_phi, jacobian) jacobian = abs (jacobian) end subroutine vamp_jacobian @ \begin{equation} g(\phi(x)) = \frac{1}{\left|\frac{\partial\phi}{\partial x}\right|(x)} \end{equation} <>= subroutine vamp_check_jacobian & (rng, n, func, data, phi, channel, region, delta, x_delta) type(tao_random_state), intent(inout) :: rng integer, intent(in) :: n class(vamp_data_t), intent(in) :: data integer, intent(in) :: channel real(kind=default), dimension(:,:), intent(in) :: region real(kind=default), intent(out) :: delta real(kind=default), dimension(:), intent(out), optional :: x_delta <> <> real(kind=default), dimension(size(region,dim=2)) :: x, r real(kind=default) :: jac, d real(kind=default), dimension(0) :: wgts integer :: i delta = 0.0 do i = 1, max (1, n) call tao_random_number (rng, r) x = region(1,:) + (region(2,:) - region(1,:)) * r call vamp_jacobian (phi, channel, x, region, jac) d = func (phi (x, channel), data, wgts, channel) * jac & - 1.0_default if (abs (d) >= abs (delta)) then delta = d if (present (x_delta)) then x_delta = x end if end if end do end subroutine vamp_check_jacobian @ %def vamp_check_jacobian @ This is a subroutine to comply with F's rules, otherwise, we would code it as a function. \index{inconvenient F constraints} <>= private :: numeric_jacobian @ <>= pure subroutine numeric_jacobian (phi, channel, x, region, jacobian, delta_x) integer, intent(in) :: channel real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:,:), intent(in) :: region real(kind=default), intent(out) :: jacobian real(kind=default), intent(in), optional :: delta_x <> real(kind=default), dimension(size(x)) :: x_min, x_max real(kind=default), dimension(size(x)) :: x_plus, x_minus real(kind=default), dimension(size(x),size(x)) :: d_phi real(kind=default), parameter :: & dx_default = 10.0_default**(-precision(jacobian)/3) real(kind=default) :: dx integer :: j if (present (delta_x)) then dx = delta_x else dx = dx_default end if x_min = region(1,:) x_max = region(2,:) x_minus = max (x_min, x) x_plus = min (x_max, x) do j = 1, size (x) x_minus(j) = max (x_min(j), x(j) - dx) x_plus(j) = min (x_max(j), x(j) + dx) d_phi(:,j) = (phi (x_plus, channel) - phi (x_minus, channel)) & / (x_plus(j) - x_minus(j)) x_minus(j) = max (x_min(j), x(j)) x_plus(j) = min (x_max(j), x(j)) end do call determinant (d_phi, jacobian) jacobian = abs (jacobian) end subroutine numeric_jacobian @ %def numeric_jacobian @ <>= public :: vamp_create_grids, vamp_create_empty_grids public :: vamp_copy_grids, vamp_delete_grids @ The rules for optional arguments forces us to handle special cases, because we can't just pass a array section of an optional array as an actual argument (cf.~12.4.1.5(4) in~\cite{Fortran95}) even if the dummy argument is optional itself. <>= pure subroutine vamp_create_grids & (g, domain, num_calls, weights, maps, num_div, & stratified, quadrupole, exc) type(vamp_grids), intent(inout) :: g real(kind=default), dimension(:,:), intent(in) :: domain integer, intent(in) :: num_calls real(kind=default), dimension(:), intent(in) :: weights real(kind=default), dimension(:,:,:), intent(in), optional :: maps integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "vamp_create_grids" integer :: ch, nch nch = size (weights) allocate (g%grids(nch), g%weights(nch), g%num_calls(nch)) g%weights = weights / sum (weights) g%num_calls = g%weights * num_calls do ch = 1, size (g%grids) if (present (maps)) then call vamp_create_grid & (g%grids(ch), domain, g%num_calls(ch), num_div, & stratified, quadrupole, map = maps(:,:,ch), exc = exc) else call vamp_create_grid & (g%grids(ch), domain, g%num_calls(ch), num_div, & stratified, quadrupole, exc = exc) end if end do g%sum_integral = 0.0 g%sum_chi2 = 0.0 g%sum_weights = 0.0 end subroutine vamp_create_grids @ %def vamp_create_grids @ <>= pure subroutine vamp_create_empty_grids (g) type(vamp_grids), intent(inout) :: g nullify (g%grids, g%weights, g%num_calls) end subroutine vamp_create_empty_grids @ %def vamp_create_empty_grids @ <>= public :: vamp_discard_integrals @ <>= pure subroutine vamp_discard_integrals & (g, num_calls, num_div, stratified, quadrupole, exc, eq) type(vamp_grids), intent(inout) :: g integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole type(exception), intent(inout), optional :: exc type(vamp_equivalences_t), intent(in), optional :: eq integer :: ch character(len=*), parameter :: FN = "vamp_discard_integrals" g%sum_integral = 0.0 g%sum_weights = 0.0 g%sum_chi2 = 0.0 do ch = 1, size (g%grids) call vamp_discard_integral (g%grids(ch)) end do if (present (num_calls)) then call vamp_reshape_grids & (g, num_calls, num_div, stratified, quadrupole, exc, eq) end if end subroutine vamp_discard_integrals @ %def vamp_discard_integrals @ %def sum_integral sum_weights sum_chi2 @ <>= public :: vamp_update_weights @ We must discard the accumulated integrals, because the weight function~$w=f/\sum_i\alpha_ig_i$ changes: <>= pure subroutine vamp_update_weights & (g, weights, num_calls, num_div, stratified, quadrupole, exc) type(vamp_grids), intent(inout) :: g real(kind=default), dimension(:), intent(in) :: weights integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "vamp_update_weights" if (sum (weights) > 0) then g%weights = weights / sum (weights) else g%weights = 1._default / size(g%weights) end if if (present (num_calls)) then call vamp_discard_integrals (g, num_calls, num_div, & stratified, quadrupole, exc) else call vamp_discard_integrals (g, sum (g%num_calls), num_div, & stratified, quadrupole, exc) end if end subroutine vamp_update_weights @ %def vamp_update_weights @ <>= public :: vamp_reshape_grids @ <>= pure subroutine vamp_reshape_grids & (g, num_calls, num_div, stratified, quadrupole, exc, eq) type(vamp_grids), intent(inout) :: g integer, intent(in) :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole type(exception), intent(inout), optional :: exc type(vamp_equivalences_t), intent(in), optional :: eq integer, dimension(size(g%grids(1)%num_div)) :: num_div_new integer :: ch character(len=*), parameter :: FN = "vamp_reshape_grids" g%num_calls = g%weights * num_calls do ch = 1, size (g%grids) if (g%num_calls(ch) >= 2) then if (present (eq)) then if (present (num_div)) then num_div_new = num_div else num_div_new = g%grids(ch)%num_div end if where (eq%div_is_invariant(ch,:)) num_div_new = 1 end where call vamp_reshape_grid (g%grids(ch), g%num_calls(ch), & num_div_new, stratified, quadrupole, exc = exc, & independent = eq%independent(ch), & equivalent_to_ch = eq%equivalent_to_ch(ch), & multiplicity = eq%multiplicity(ch)) else call vamp_reshape_grid (g%grids(ch), g%num_calls(ch), & num_div, stratified, quadrupole, exc = exc) end if else g%num_calls(ch) = 0 end if end do end subroutine vamp_reshape_grids @ %def vamp_reshape_grids @ <>= public :: vamp_sample_grids @ Even if [[g%num_calls]] is derived from [[g%weights]], we must \emph{not} use the latter, allow for integer arithmetic in [[g%num_calls]].\par <>= subroutine vamp_sample_grids & (rng, g, func, data, iterations, integral, std_dev, avg_chi2, & accuracy, history, histories, exc, eq, warn_error, negative_weights) type(tao_random_state), intent(inout) :: rng type(vamp_grids), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, intent(in) :: iterations real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 real(kind=default), intent(in), optional :: accuracy type(vamp_history), dimension(:), intent(inout), optional :: history type(vamp_history), dimension(:,:), intent(inout), optional :: histories type(exception), intent(inout), optional :: exc type(vamp_equivalences_t), intent(in), optional :: eq logical, intent(in), optional :: warn_error, negative_weights <> integer :: ch, iteration logical :: neg_w type(exception), dimension(size(g%grids)) :: excs logical, dimension(size(g%grids)) :: active real(kind=default), dimension(size(g%grids)) :: weights, integrals, std_devs real(kind=default) :: local_integral, local_std_dev, local_avg_chi2 character(len=*), parameter :: FN = "vamp_sample_grids" integrals = 0 std_devs = 0 neg_w = .false. if (present (negative_weights)) neg_w = negative_weights active = (g%num_calls >= 2) where (active) weights = g%num_calls elsewhere weights = 0.0 endwhere if (sum (weights) /= 0) weights = weights / sum (weights) call clear_exception (excs) iterate: do iteration = 1, iterations do ch = 1, size (g%grids) if (active(ch)) then call vamp_discard_integral (g%grids(ch)) <> else call vamp_nullify_variance (g%grids(ch)) call vamp_nullify_covariance (g%grids(ch)) end if end do if (present(eq)) call vamp_apply_equivalences (g, eq) if (iteration < iterations) then do ch = 1, size (g%grids) active(ch) = (integrals(ch) /= 0) if (active(ch)) then call vamp_refine_grid (g%grids(ch)) end if end do end if if (present (exc) .and. (any (excs%level > 0))) then call gather_exceptions (exc, excs) ! return end if call vamp_reduce_channels (g, integrals, std_devs, active) call vamp_average_iterations & (g, iteration, local_integral, local_std_dev, local_avg_chi2) <> <> end do iterate <> end subroutine vamp_sample_grids @ %def vamp_sample_grids @ We must refine the grids after \emph{all} grids have been sampled, therefore we use [[vamp_sample_grid0]] instead of [[vamp_sample_grid]]: <>= call vamp_sample_grid0 & (rng, g%grids(ch), func, data, & ch, weights, g%grids, excs(ch), neg_w) if (present (exc) .and. present (warn_error)) then if (warn_error) call handle_exception (excs(ch)) end if call vamp_average_iterations & (g%grids(ch), iteration, integrals(ch), std_devs(ch), local_avg_chi2) if (present (histories)) then if (iteration <= ubound (histories, dim=1)) then call vamp_get_history & (histories(iteration,ch), g%grids(ch), & integrals(ch), std_devs(ch), local_avg_chi2) else call raise_exception (exc, EXC_WARN, FN, "history too short") end if call vamp_terminate_history (histories(iteration+1:,ch)) end if @ <>= public :: vamp_reduce_channels @ \begin{subequations} \begin{align} I &= \frac{1}{N} \sum_c N_c I_c \\ \label{eq:multi-sigma} \sigma^2 &= \frac{1}{N^2} \sum_c N_c^2 \sigma_c^2 \\ N & = \sum_c N_c \end{align} \end{subequations} where~(\ref{eq:multi-sigma}) is actually \begin{equation*} \sigma^2 = \frac{1}{N}\left(\mu_2 - \mu_1^1\right) = \frac{1}{N}\left(\frac{1}{N} \sum_c N_c \mu_{2,c} - I^2\right) = \frac{1}{N}\left(\frac{1}{N} \sum_c (N_c^2 \sigma_c^2 + N_c I_c^2) - I^2\right) \end{equation*} but the latter form suffers from numerical instability and~(\ref{eq:multi-sigma}) is thus preferred. <>= pure subroutine vamp_reduce_channels (g, integrals, std_devs, active) type(vamp_grids), intent(inout) :: g real(kind=default), dimension(:), intent(in) :: integrals, std_devs logical, dimension(:), intent(in) :: active real(kind=default) :: this_integral, this_weight, total_calls real(kind=default) :: total_variance if (.not.any(active)) return total_calls = sum (g%num_calls, mask=active) if (total_calls > 0) then this_integral = sum (g%num_calls * integrals, mask=active) / total_calls else this_integral = 0 end if total_variance = sum ((g%num_calls*std_devs)**2, mask=active) if (total_variance > 0) then this_weight = total_calls**2 / total_variance else this_weight = 0 end if g%sum_weights = g%sum_weights + this_weight g%sum_integral = g%sum_integral + this_weight * this_integral g%sum_chi2 = g%sum_chi2 + this_weight * this_integral**2 end subroutine vamp_reduce_channels @ %def vamp_reduce_channels @ <>= public :: vamp_refine_weights @ <>= elemental subroutine vamp_average_iterations_grids & (g, iteration, integral, std_dev, avg_chi2) type(vamp_grids), intent(in) :: g integer, intent(in) :: iteration real(kind=default), intent(out) :: integral, std_dev, avg_chi2 real(kind=default), parameter :: eps = 1000 * epsilon (1._default) if (g%sum_weights>0) then integral = g%sum_integral / g%sum_weights std_dev = sqrt (1.0 / g%sum_weights) avg_chi2 = & max ((g%sum_chi2 - g%sum_integral * integral) / (iteration-0.99), & 0.0_default) if (avg_chi2 < eps * g%sum_chi2) avg_chi2 = 0 else integral = 0 std_dev = 0 avg_chi2 = 0 end if end subroutine vamp_average_iterations_grids @ %def vamp_average_iterations_grids @ <>= private :: vamp_average_iterations_grids @ <>= interface vamp_average_iterations module procedure vamp_average_iterations_grids end interface @ %def vamp_average_iterations @ \begin{equation} \alpha_i \to \alpha_i \sqrt{V_i} \end{equation} <>= pure subroutine vamp_refine_weights (g, power) type(vamp_grids), intent(inout) :: g real(kind=default), intent(in), optional :: power real(kind=default) :: local_power real(kind=default), parameter :: DEFAULT_POWER = 0.5_default if (present (power)) then local_power = power else local_power = DEFAULT_POWER end if call vamp_update_weights & (g, g%weights * vamp_get_variance (g%grids) ** local_power) end subroutine vamp_refine_weights @ %def vamp_refine_weights @ <>= if (present (history)) then if (iteration <= size (history)) then call vamp_get_history & (history(iteration), g, local_integral, local_std_dev, & local_avg_chi2) else call raise_exception (exc, EXC_WARN, FN, "history too short") end if call vamp_terminate_history (history(iteration+1:)) end if @ <>= private :: vamp_get_history_multi @ <>= interface vamp_get_history module procedure vamp_get_history_multi end interface @ <>= pure subroutine vamp_get_history_multi (h, g, integral, std_dev, avg_chi2) type(vamp_history), intent(inout) :: h type(vamp_grids), intent(in) :: g real(kind=default), intent(in) :: integral, std_dev, avg_chi2 h%calls = sum (g%grids%calls) h%stratified = all (g%grids%all_stratified) h%integral = 0.0 h%std_dev = 0.0 h%avg_integral = integral h%avg_std_dev = std_dev h%avg_chi2 = avg_chi2 h%f_min = 0.0 h%f_max = huge (h%f_max) if (h%verbose) then h%verbose = .false. if (associated (h%div)) then deallocate (h%div) end if end if end subroutine vamp_get_history_multi @ %def vamp_get_history_multi @ \begin{dubious} WK \end{dubious} @ <>= public :: vamp_sum_channels @ <>= function vamp_sum_channels (x, weights, func, data, grids) result (g) real(kind=default), dimension(:), intent(in) :: x, weights class(vamp_data_t), intent(in) :: data type(vamp_grid), dimension(:), intent(in), optional :: grids interface function func (xi, data, weights, channel, grids) result (f) use kinds use vamp_grid_type !NODEP! import vamp_data_t real(kind=default), dimension(:), intent(in) :: xi class(vamp_data_t), intent(in) :: data real(kind=default), dimension(:), intent(in), optional :: weights integer, intent(in), optional :: channel type(vamp_grid), dimension(:), intent(in), optional :: grids real(kind=default) :: f end function func end interface real(kind=default) :: g integer :: ch g = 0.0 do ch = 1, size (weights) g = g + weights(ch) * func (x, data, weights, ch, grids) end do end function vamp_sum_channels @ %def vamp_sum_channels @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Mapping} \begin{dubious} \index{unfinished business} This section is still under construction. The basic algorithm is in place, but the heuristics have not be developed yet. \end{dubious} The most naive approach is to use the rotation matrix~$R$ that diagonalizes the covariance~$C$: \begin{equation} R_{ij} = (v_j)_i \end{equation} where \begin{equation} C v_j = \lambda_j v_j \end{equation} with the eigenvalues~$\{\lambda_j\}$ and eigenvectors~$\{v_j\}$. Then \begin{equation} R^T C R = \mathop{\textrm{diag}} (\lambda_1,\ldots) \end{equation} After [[call diagonalize_real_symmetric (cov, evals, evecs)]], we have $\text{[[evals]]}(j)=\lambda_j$ and $\text{[[evecs]]}(\text{[[:]]},j)=v_j$. This is equivalent with $\text{[[evecs]]}(i,j)=R_{ij}$.\par This approach will not work in high dimensions, however. In general,~$R$ will \emph{not} leave most of the axes invariant, even if the covariance matrix is almost isotripic in these directions. I this case the benefit from the rotation is rather small and offset by the negative effects from the misalignment of the integration region.\par A better strategy is to find the axis of the original coordinate system around which a rotation is most beneficial. There are two extreme cases: \begin{itemize} \item ``pancake'': one eigenvalue much smaller than the others \item ``cigar'': one eigenvalue much larger than the others \end{itemize} Actually, instead of rotating around a specfic axis, we can as well diagonalize in a subspace. Empirically, rotation around an axis is better than diagonalizing in a two-dimensional subspace, but diagonalizing in a three-dimensional subspace can be even better. <>= public :: select_rotation_axis public :: select_rotation_subspace @ %def select_rotation_axis @ %def select_rotation_subspace @ <>= if (num_pancake > 0) then print *, "FORCED PANCAKE: ", num_pancake iv = sum (minloc (evals)) else if (num_cigar > 0) then print *, "FORCED CIGAR: ", num_cigar iv = sum (maxloc (evals)) else call more_pancake_than_cigar (evals, like_pancake) if (like_pancake) then iv = sum (minloc (evals)) else iv = sum (maxloc (evals)) end if end if @ %def iv @ <>= subroutine more_pancake_than_cigar (eval, yes_or_no) real(kind=default), dimension(:), intent(in) :: eval logical, intent(out) :: yes_or_no integer, parameter :: N_CL = 2 real(kind=default), dimension(size(eval)) :: evals real(kind=default), dimension(N_CL) :: cluster_pos integer, dimension(N_CL,2) :: clusters evals = eval call sort (evals) call condense (evals, cluster_pos, clusters) print *, clusters(1,2) - clusters(1,1) + 1, "small EVs: ", & evals(clusters(1,1):clusters(1,2)) print *, clusters(2,2) - clusters(2,1) + 1, "large EVs: ", & evals(clusters(2,1):clusters(2,2)) if ((clusters(1,2) - clusters(1,1)) & < (clusters(2,2) - clusters(2,1))) then print *, " => PANCAKE!" yes_or_no = .true. else print *, " => CIGAR!" yes_or_no = .false. end if end subroutine more_pancake_than_cigar @ %def more_pancake_than_cigar @ <>= private :: more_pancake_than_cigar @ %def more_pancake_than_cigar @ In both cases, we can rotate in the plane~$P_{ij}$ closest to eigenvector corresponding to the the singled out eigenvalue. This plane is given by \begin{equation} \max_{i\not= i'} \sqrt{(v_j)_i^2 + (v_j)_{i'}^2} \end{equation} which is simply found by looking for the two largest~$|(v_j)_i|$:\footnote{The [[sum]] intrinsic is a convenient \texttt{Fortran90} trick for turning the rank-one array with one element returned by [[maxloc]] into its value. It has no semantic significance.} <>= abs_evec = abs (evecs(:,iv)) i(1) = sum (maxloc (abs_evec)) abs_evec(i(1)) = -1.0 i(2) = sum (maxloc (abs_evec)) @ %def abs_evec i @ The following is cute, but unfortunately broken, since it fails for dgenerate eigenvalues: <>= abs_evec = abs (evecs(:,iv)) i(1) = sum (maxloc (abs_evec)) i(2) = sum (maxloc (abs_evec, mask = abs_evec < abs_evec(i(1)))) @ %def abs_evec i @ <>= print *, iv, evals(iv), " => ", evecs(:,iv) print *, i(1), abs_evec(i(1)), ", ", i(2), abs_evec(i(2)) print *, i(1), evecs(i(1),iv), ", ", i(2), evecs(i(2),iv) @ <>= cos_theta = evecs(i(1),iv) sin_theta = evecs(i(2),iv) norm = 1.0 / sqrt (cos_theta**2 + sin_theta**2) cos_theta = cos_theta * norm sin_theta = sin_theta * norm @ %def cos_theta sin_theta norm @ \begin{equation} \hat R(\theta;i,j) = \begin{pmatrix} 1 & & & & & & \\ & \ddots & & & & & \\ & & \cos\theta & \cdots & -\sin\theta & & \\ & & \vdots & 1 & \vdots & & \\ & & \sin\theta & \cdots & \cos\theta & & \\ & & & & & \ddots & \\ & & & & & & 1 \end{pmatrix} \end{equation} <>= call unit (r) r(i(1),i) = (/ cos_theta, - sin_theta /) r(i(2),i) = (/ sin_theta, cos_theta /) @ %def r @ <>= subroutine select_rotation_axis (cov, r, pancake, cigar) real(kind=default), dimension(:,:), intent(in) :: cov real(kind=default), dimension(:,:), intent(out) :: r integer, intent(in), optional :: pancake, cigar integer :: num_pancake, num_cigar logical :: like_pancake real(kind=default), dimension(size(cov,dim=1),size(cov,dim=2)) :: evecs real(kind=default), dimension(size(cov,dim=1)) :: evals, abs_evec integer :: iv integer, dimension(2) :: i real(kind=default) :: cos_theta, sin_theta, norm <> call diagonalize_real_symmetric (cov, evals, evecs) <> <> <> <> end subroutine select_rotation_axis @ %def select_rotation_axis @ <>= if (present (pancake)) then num_pancake = pancake else num_pancake = -1 endif if (present (cigar)) then num_cigar = cigar else num_cigar = -1 endif @ Here's a less efficient version that can be easily generalized to more than two dimension, however: <>= subroutine select_subspace_explicit (cov, r, subspace) real(kind=default), dimension(:,:), intent(in) :: cov real(kind=default), dimension(:,:), intent(out) :: r integer, dimension(:), intent(in) :: subspace real(kind=default), dimension(size(subspace)) :: eval_sub real(kind=default), dimension(size(subspace),size(subspace)) :: & cov_sub, evec_sub cov_sub = cov(subspace,subspace) call diagonalize_real_symmetric (cov_sub, eval_sub, evec_sub) call unit (r) r(subspace,subspace) = evec_sub end subroutine select_subspace_explicit @ %def select_subspace_explicit @ <>= subroutine select_subspace_guess (cov, r, ndim, pancake, cigar) real(kind=default), dimension(:,:), intent(in) :: cov real(kind=default), dimension(:,:), intent(out) :: r integer, intent(in) :: ndim integer, intent(in), optional :: pancake, cigar integer :: num_pancake, num_cigar logical :: like_pancake real(kind=default), dimension(size(cov,dim=1),size(cov,dim=2)) :: evecs real(kind=default), dimension(size(cov,dim=1)) :: evals, abs_evec integer :: iv, i integer, dimension(ndim) :: subspace <> call diagonalize_real_symmetric (cov, evals, evecs) <> <> call select_subspace_explicit (cov, r, subspace) end subroutine select_subspace_guess @ %def select_subspace_guess @ <>= abs_evec = abs (evecs(:,iv)) subspace(1) = sum (maxloc (abs_evec)) do i = 2, ndim abs_evec(subspace(i-1)) = -1.0 subspace(i) = sum (maxloc (abs_evec)) end do @ <>= interface select_rotation_subspace module procedure select_subspace_explicit, select_subspace_guess end interface @ %def select_rotation_subspace @ <>= private :: select_subspace_explicit private :: select_subspace_guess @ %def select_subspace_explicit @ %def select_subspace_guess @ <>= public :: vamp_print_covariance @ %def vamp_print_covariance @ <>= subroutine vamp_print_covariance (cov) real(kind=default), dimension(:,:), intent(in) :: cov real(kind=default), dimension(size(cov,dim=1)) :: & evals, abs_evals, tmp real(kind=default), dimension(size(cov,dim=1),size(cov,dim=2)) :: & evecs, abs_evecs integer, dimension(size(cov,dim=1)) :: idx integer :: i, i_max, j i_max = size (evals) call diagonalize_real_symmetric (cov, evals, evecs) call sort (evals, evecs) abs_evals = abs (evals) abs_evecs = abs (evecs) print "(1X,A78)", repeat ("-", 78) print "(1X,A)", "Eigenvalues and eigenvectors:" print "(1X,A78)", repeat ("-", 78) do i = 1, i_max print "(1X,I2,A1,1X,E11.4,1X,A1,10(10(1X,F5.2)/,18X))", & i, ":", evals(i), "|", evecs(:,i) end do print "(1X,A78)", repeat ("-", 78) print "(1X,A)", "Approximate subspaces:" print "(1X,A78)", repeat ("-", 78) do i = 1, i_max idx = (/ (j, j=1,i_max) /) tmp = abs_evecs(:,i) call sort (tmp, idx, reverse = .true.) print "(1X,I2,A1,1X,E11.4,1X,A1,10(1X,I5))", & i, ":", evals(i), "|", idx(1:min(10,size(idx))) print "(17X,A1,10(1X,F5.2))", & "|", evecs(idx(1:min(10,size(idx))),i) end do print "(1X,A78)", repeat ("-", 78) end subroutine vamp_print_covariance @ %def vamp_print_covariance @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Condensing Eigenvalues} In order to decide whether we have a ``pancake'' or a ``cigar'', we have to classify the eiegenvalues of the covariance matrix. We do this by condensing the~$n_{\text{dim}}$ eigenvalues into ~$n_{\text{cl}}\ll n_{\text{dim}}$ clusters. <>= ! private :: condense public :: condense @ The rough description is as follows: in each step, combine the nearst neighbours (according to an approbriate metric) to form a smaller set. This is an extremely simplified, discretized modeling of molecules condensing under the influence of some potential. \begin{dubious} If there's not a clean separation, this algorithm is certainly chaotic and we need to apply some form of damping! \end{dubious} @ <>= cl_pos = x cl_num = size (cl_pos) cl = spread ((/ (i, i=1,cl_num) /), dim = 2, ncopies = 2) @ %def cl_pos cl_num cl @ It appears that the logarithmic metric \begin{subequations} \begin{align} d_0 (x,y) &= \left|\log\left(\frac{x}{y}\right)\right| \\ \intertext{performs better than the linear metric} d_1 (x,y) &= |x-y| \\ \intertext{% since the latter won't separate very small eiegenvalues from the bulk. Another option is} d_\alpha (x,y) &= |x^\alpha-y^\alpha| \end{align} \end{subequations} with~$\alpha\not=1$, in particular~$\alpha\approx-1$. I haven't studied it yet, though. \begin{dubious} \index{more empirical studies helpful} but I should perform more empirical studies to determine whether the logarithmic or the linear metric is more appropriate in realistic cases. \end{dubious} <>= if (linear_metric) then gap = sum (minloc (cl_pos(2:cl_num) - cl_pos(1:cl_num-1))) else gap = sum (minloc (cl_pos(2:cl_num) / cl_pos(1:cl_num-1))) end if wgt0 = cl(gap,2) - cl(gap,1) + 1 wgt1 = cl(gap+1,2) - cl(gap+1,1) + 1 cl_pos(gap) = (wgt0 * cl_pos(gap) + wgt1 * cl_pos(gap+1)) / (wgt0 + wgt1) cl(gap,2) = cl(gap+1,2) @ %def gap wgt0 wgt1 cl_pos cl @ <>= cl_pos(gap+1:cl_num-1) = cl_pos(gap+2:cl_num) cl(gap+1:cl_num-1,:) = cl(gap+2:cl_num,:) @ %def cl_pos cl @ <>= subroutine condense (x, cluster_pos, clusters, linear) real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:), intent(out) :: cluster_pos integer, dimension(:,:), intent(out) :: clusters logical, intent(in), optional :: linear logical :: linear_metric real(kind=default), dimension(size(x)) :: cl_pos real(kind=default) :: wgt0, wgt1 integer :: cl_num integer, dimension(size(x),2) :: cl integer :: i, gap linear_metric = .false. if (present (linear)) then linear_metric = linear end if <> do cl_num = size (cl_pos), size (cluster_pos) + 1, -1 <> print *, cl_num, ": action = ", condense_action (x, cl) end do cluster_pos = cl_pos(1:cl_num) clusters = cl(1:cl_num,:) end subroutine condense @ %def condense @ <>= ! private :: condense_action public :: condense_action @ \begin{equation} S = \sum_{c\in\text{clusters}} \mathop{\textrm{var}}\nolimits^{\frac{\alpha}{2}}(c) \end{equation} <>= function condense_action (positions, clusters) result (s) real(kind=default), dimension(:), intent(in) :: positions integer, dimension(:,:), intent(in) :: clusters real(kind=default) :: s integer :: i integer, parameter :: POWER = 2 s = 0 do i = 1, size (clusters, dim = 1) s = s + standard_deviation (positions(clusters(i,1) & :clusters(i,2))) ** POWER end do end function condense_action @ <<[[ctest.f90]]>>= program ctest use kinds use utils use vamp_stat use tao_random_numbers use vamp implicit none integer, parameter :: N = 16, NC = 2 real(kind=default), dimension(N) :: eval real(kind=default), dimension(NC) :: cluster_pos integer, dimension(NC,2) :: clusters integer :: i call tao_random_number (eval) call sort (eval) print *, eval eval(1:N/2) = 0.95*eval(1:N/2) eval(N/2+1:N) = 1.0 - 0.95*(1.0 - eval(N/2+1:N)) print *, eval call condense (eval, cluster_pos, clusters, linear=.true.) do i = 1, NC print "(I2,A,F5.2,A,I2,A,I2,A,A,F5.2,A,F5.2,A,32F5.2)", & i, ": ", cluster_pos(i), & " [", clusters(i,1), "-", clusters(i,2), "]", & " [", eval(clusters(i,1)), " - ", eval(clusters(i,2)), "]", & eval(clusters(i,1)+1:clusters(i,2)) & - eval(clusters(i,1):clusters(i,2)-1) print *, average (eval(clusters(i,1):clusters(i,2))), "+/-", & standard_deviation (eval(clusters(i,1):clusters(i,2))) end do end program ctest @ %def ctest @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Event Generation} Automagically adaptive tools are not always appropriate for unweighted event generation, but we can give it a try. <>= public :: vamp_next_event @ <>= interface vamp_next_event module procedure vamp_next_event_single, vamp_next_event_multi end interface @ <>= private :: vamp_next_event_single, vamp_next_event_multi @ Both event generation routines operate in two modes, depending on whether the optional argument [[weight]] is present. <>= subroutine vamp_next_event_single & (x, rng, g, func, data, & weight, channel, weights, grids, exc) real(kind=default), dimension(:), intent(out) :: x type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g real(kind=default), intent(out), optional :: weight class(vamp_data_t), intent(in) :: data integer, intent(in), optional :: channel real(kind=default), dimension(:), intent(in), optional :: weights type(vamp_grid), dimension(:), intent(in), optional :: grids type(exception), intent(inout), optional :: exc <> character(len=*), parameter :: FN = "vamp_next_event_single" real(kind=default), dimension(size(g%div)):: wgts real(kind=default), dimension(size(g%div)):: r integer, dimension(size(g%div)):: ia real(kind=default) :: f, wgt real(kind=default) :: r0 rejection: do <> if (present (weight)) then <> else <> end if end do rejection end subroutine vamp_next_event_single @ %def vamp_next_event_single @ <>= call tao_random_number (rng, r) call inject_division_short (g%div, real(r, kind=default), x, ia, wgts) wgt = g%jacobi * product (wgts) wgt = g%calls * wgt !: the calling procedure will divide by \#calls if (associated (g%map)) then x = matmul (g%map, x) end if <<[[f = wgt * func (x, weights, channel)]], iff [[x]] inside [[true_domain]]>> ! call record_efficiency (g%div, ia, f/g%f_max) @ <>= weight = f exit rejection @ <>= if (f > g%f_max) then g%f_max = f call raise_exception (exc, EXC_WARN, FN, "weight > 1") exit rejection end if call tao_random_number (rng, r0) if (r0 * g%f_max <= f) then exit rejection end if @ We know that [[g%weights]] are normalized: [[sum (g%weights) == 1.0]]. The basic formula for multi channel sampling is \begin{equation} f(x) = \sum_i \alpha_i g_i(x) w(x) \end{equation} with~$w(x)=f(x)/g(x)=f(x)/\sum_i\alpha_ig_i(x)$ and~$\sum_i\alpha_i=1$. The non-trivial poblem is that the adaptive grid is diferent in each channel, so we can't just reject on~$w(x)$. <>= subroutine vamp_next_event_multi & (x, rng, g, func, data, phi, weight, excess, positive, exc) real(kind=default), dimension(:), intent(out) :: x type(tao_random_state), intent(inout) :: rng type(vamp_grids), intent(inout) :: g class(vamp_data_t), intent(in) :: data real(kind=default), intent(out), optional :: weight real(kind=default), intent(out), optional :: excess logical, intent(out), optional :: positive type(exception), intent(inout), optional :: exc <> <> character(len=*), parameter :: FN = "vamp_next_event_multi" real(kind=default), dimension(size(x)) :: xi real(kind=default) :: r, wgt real(kind=default), dimension(size(g%weights)) :: weights integer :: channel <<[[weights]]: $\alpha_i\to w_{\max,i}\alpha_i$>> rejection: do <>= call tao_random_number (rng, r) select_channel: do channel = 1, size (g%weights) r = r - weights(channel) if (r <= 0.0) then exit select_channel end if end do select_channel channel = min (channel, size (g%weights)) !: for $r=1$ and rounding errors @ <>= weight = wgt * g%weights(channel) / weights(channel) exit rejection @ <>= if (abs (wgt) > g%grids(channel)%f_max) then if (present(excess)) then excess = abs (wgt) / g%grids(channel)%f_max - 1 else call raise_exception (exc, EXC_WARN, FN, "weight > 1") ! print *, "weight > 1 (", wgt/g%grids(channel)%f_max, & ! & ") in channel ", channel end if ! exit rejection else if (present(excess)) excess = 0 end if call tao_random_number (rng, r) if (r * g%grids(channel)%f_max <= abs (wgt)) then if (present (positive)) positive = wgt >= 0 exit rejection end if @ <>= if (wgt > g%grids(channel)%f_max) then g%grids(channel)%f_max = wgt <<[[weights]]: $\alpha_i\to w_{\max,i}\alpha_i$>> call raise_exception (exc, EXC_WARN, FN, "weight > 1") exit rejection end if call tao_random_number (rng, r) if (r * g%grids(channel)%f_max <= wgt) then exit rejection end if @ Using [[vamp_sample_grid (g, ...)]] to warm up the grid~[[g]] has a somewhat subtle problem: the minimum and maximum weights [[g%f_min]] and [[g%f_max]] refer to the grid \emph{before} the final refinement. One could require an additional [[vamp_sample_grid0 (g, ...)]], but users are likely to forget such technical details. A better solution is a wrapper [[vamp_warmup_grid (g, ...)]] that drops the final refinement transparently. <>= public :: vamp_warmup_grid, vamp_warmup_grids @ <>= subroutine vamp_warmup_grid & (rng, g, func, data, iterations, exc, history) type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, intent(in) :: iterations type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> call vamp_sample_grid & (rng, g, func, data, & iterations - 1, exc = exc, history = history) call vamp_sample_grid0 (rng, g, func, data, exc = exc) end subroutine vamp_warmup_grid @ %def vamp_warmup_grid @ \begin{dubious} \texttt{WHERE ... END WHERE} alert! \end{dubious} <>= subroutine vamp_warmup_grids & (rng, g, func, data, iterations, history, histories, exc) type(tao_random_state), intent(inout) :: rng type(vamp_grids), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, intent(in) :: iterations type(vamp_history), dimension(:), intent(inout), optional :: history type(vamp_history), dimension(:,:), intent(inout), optional :: histories type(exception), intent(inout), optional :: exc <> integer :: ch logical, dimension(size(g%grids)) :: active real(kind=default), dimension(size(g%grids)) :: weights active = (g%num_calls >= 2) where (active) weights = g%num_calls elsewhere weights = 0.0 end where weights = weights / sum (weights) call vamp_sample_grids (rng, g, func, data, iterations - 1, & exc = exc, history = history, histories = histories) do ch = 1, size (g%grids) if (g%grids(ch)%num_calls >= 2) then call vamp_sample_grid0 & (rng, g%grids(ch), func, data, & ch, weights, g%grids, exc = exc) end if end do end subroutine vamp_warmup_grids @ %def vamp_warmup_grids @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Convenience Routines} <>= public :: vamp_integrate private :: vamp_integrate_grid, vamp_integrate_region @ <>= interface vamp_integrate module procedure vamp_integrate_grid, vamp_integrate_region end interface @ <>= subroutine vamp_integrate_grid & (rng, g, func, data, calls, integral, std_dev, avg_chi2, num_div, & stratified, quadrupole, accuracy, exc, history) type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, dimension(:,:), intent(in) :: calls real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole real(kind=default), intent(in), optional :: accuracy type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> character(len=*), parameter :: FN = "vamp_integrate_grid" integer :: step, last_step, it last_step = size (calls, dim = 2) it = 1 do step = 1, last_step - 1 call vamp_discard_integral (g, calls(2,step), num_div, & stratified, quadrupole, exc = exc) call vamp_sample_grid (rng, g, func, data, calls(1,step), & exc = exc, history = history(it:)) <> it = it + calls(1,step) end do call vamp_discard_integral (g, calls(2,last_step), exc = exc) call vamp_sample_grid (rng, g, func, data, calls(1,last_step), & integral, std_dev, avg_chi2, accuracy, exc = exc, & history = history(it:)) end subroutine vamp_integrate_grid @ %def vamp_integrate_grid @ <>= subroutine vamp_integrate_region & (rng, region, func, data, calls, & integral, std_dev, avg_chi2, num_div, & stratified, quadrupole, accuracy, map, covariance, exc, history) type(tao_random_state), intent(inout) :: rng real(kind=default), dimension(:,:), intent(in) :: region class(vamp_data_t), intent(in) :: data integer, dimension(:,:), intent(in) :: calls real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole real(kind=default), intent(in), optional :: accuracy real(kind=default), dimension(:,:), intent(in), optional :: map real(kind=default), dimension(:,:), intent(out), optional :: covariance type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> character(len=*), parameter :: FN = "vamp_integrate_region" type(vamp_grid) :: g call vamp_create_grid & (g, region, calls(2,1), num_div, & stratified, quadrupole, present (covariance), map, exc) call vamp_integrate_grid & (rng, g, func, data, calls, & integral, std_dev, avg_chi2, num_div, & accuracy = accuracy, exc = exc, history = history) if (present (covariance)) then covariance = vamp_get_covariance (g) end if call vamp_delete_grid (g) end subroutine vamp_integrate_region @ %def vamp_integrate_region @ <>= public :: vamp_integratex private :: vamp_integratex_region @ <>= interface vamp_integratex module procedure vamp_integratex_region end interface @ <>= subroutine vamp_integratex_region & (rng, region, func, data, calls, integral, std_dev, avg_chi2, & num_div, stratified, quadrupole, accuracy, pancake, cigar, & exc, history) type(tao_random_state), intent(inout) :: rng real(kind=default), dimension(:,:), intent(in) :: region class(vamp_data_t), intent(in) :: data integer, dimension(:,:,:), intent(in) :: calls real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole real(kind=default), intent(in), optional :: accuracy integer, intent(in), optional :: pancake, cigar type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> real(kind=default), dimension(size(region,dim=2)) :: eval real(kind=default), dimension(size(region,dim=2),size(region,dim=2)) :: evec type(vamp_grid) :: g integer :: step, last_step, it it = 1 call vamp_create_grid & (g, region, calls(2,1,1), num_div, & stratified, quadrupole, covariance = .true., exc = exc) call vamp_integrate_grid & (rng, g, func, data, calls(:,:,1), num_div = num_div, & exc = exc, history = history(it:)) <> it = it + sum (calls(1,:,1)) last_step = size (calls, dim = 3) do step = 2, last_step - 1 call diagonalize_real_symmetric (vamp_get_covariance(g), eval, evec) call sort (eval, evec) call select_rotation_axis (vamp_get_covariance(g), evec, pancake, cigar) call vamp_delete_grid (g) call vamp_create_grid & (g, region, calls(2,1,step), num_div, stratified, quadrupole, & covariance = .true., map = evec, exc = exc) call vamp_integrate_grid & (rng, g, func, data, calls(:,:,step), num_div = num_div, & exc = exc, history = history(it:)) <> it = it + sum (calls(1,:,step)) end do call diagonalize_real_symmetric (vamp_get_covariance(g), eval, evec) call sort (eval, evec) call select_rotation_axis (vamp_get_covariance(g), evec, pancake, cigar) call vamp_delete_grid (g) call vamp_create_grid & (g, region, calls(2,1,last_step), num_div, stratified, quadrupole, & covariance = .true., map = evec, exc = exc) call vamp_integrate_grid & (rng, g, func, data, calls(:,:,last_step), & integral, std_dev, avg_chi2, & num_div = num_div, exc = exc, history = history(it:)) call vamp_delete_grid (g) end subroutine vamp_integratex_region @ %def vamp_integratex_region @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{I/O} <>= public :: vamp_write_grid private :: write_grid_unit, write_grid_name public :: vamp_read_grid private :: read_grid_unit, read_grid_name public :: vamp_write_grids private :: write_grids_unit, write_grids_name public :: vamp_read_grids private :: read_grids_unit, read_grids_name @ <>= public :: vamp_read_grids_raw private :: read_grids_raw_unit, read_grids_raw_name public :: vamp_read_grid_raw private :: read_grid_raw_unit, read_grid_raw_name public :: vamp_write_grids_raw private :: write_grids_raw_unit, write_grids_raw_name public :: vamp_write_grid_raw private :: write_grid_raw_unit, write_grid_raw_name @ <>= interface vamp_write_grid module procedure write_grid_unit, write_grid_name end interface interface vamp_read_grid module procedure read_grid_unit, read_grid_name end interface interface vamp_write_grids module procedure write_grids_unit, write_grids_name end interface interface vamp_read_grids module procedure read_grids_unit, read_grids_name end interface @ %def vamp_write_grids @ %def vamp_read_grids @ %def vamp_write_grid @ %def vamp_read_grid @ <>= interface vamp_write_grid_raw module procedure write_grid_raw_unit, write_grid_raw_name end interface interface vamp_read_grid_raw module procedure read_grid_raw_unit, read_grid_raw_name end interface interface vamp_write_grids_raw module procedure write_grids_raw_unit, write_grids_raw_name end interface interface vamp_read_grids_raw module procedure read_grids_raw_unit, read_grids_raw_name end interface @ %def vamp_write_grids_raw @ %def vamp_read_grids_raw @ %def vamp_write_grid_raw @ %def vamp_read_grid_raw @ <>= subroutine write_grid_unit (g, unit, write_integrals) type(vamp_grid), intent(in) :: g integer, intent(in) :: unit logical, intent(in), optional :: write_integrals integer :: i, j write (unit = unit, fmt = descr_fmt) "begin type(vamp_grid) :: g" write (unit = unit, fmt = integer_fmt) "size (g%div) = ", size (g%div) write (unit = unit, fmt = integer_fmt) "num_calls = ", g%num_calls write (unit = unit, fmt = integer_fmt) "calls_per_cell = ", g%calls_per_cell write (unit = unit, fmt = logical_fmt) "stratified = ", g%stratified write (unit = unit, fmt = logical_fmt) "all_stratified = ", g%all_stratified write (unit = unit, fmt = logical_fmt) "quadrupole = ", g%quadrupole write (unit = unit, fmt = double_fmt) "mu(1) = ", g%mu(1) write (unit = unit, fmt = double_fmt) "mu(2) = ", g%mu(2) write (unit = unit, fmt = double_fmt) "mu_plus(1) = ", g%mu_plus(1) write (unit = unit, fmt = double_fmt) "mu_plus(2) = ", g%mu_plus(2) write (unit = unit, fmt = double_fmt) "mu_minus(1) = ", g%mu_minus(1) write (unit = unit, fmt = double_fmt) "mu_minus(2) = ", g%mu_minus(2) write (unit = unit, fmt = double_fmt) "sum_integral = ", g%sum_integral write (unit = unit, fmt = double_fmt) "sum_weights = ", g%sum_weights write (unit = unit, fmt = double_fmt) "sum_chi2 = ", g%sum_chi2 write (unit = unit, fmt = double_fmt) "calls = ", g%calls write (unit = unit, fmt = double_fmt) "dv2g = ", g%dv2g write (unit = unit, fmt = double_fmt) "jacobi = ", g%jacobi write (unit = unit, fmt = double_fmt) "f_min = ", g%f_min write (unit = unit, fmt = double_fmt) "f_max = ", g%f_max write (unit = unit, fmt = double_fmt) "mu_gi = ", g%mu_gi write (unit = unit, fmt = double_fmt) "sum_mu_gi = ", g%sum_mu_gi write (unit = unit, fmt = descr_fmt) "begin g%num_div" do i = 1, size (g%div) write (unit = unit, fmt = integer_array_fmt) i, g%num_div(i) end do write (unit = unit, fmt = descr_fmt) "end g%num_div" write (unit = unit, fmt = descr_fmt) "begin g%div" do i = 1, size (g%div) call write_division (g%div(i), unit, write_integrals) end do write (unit = unit, fmt = descr_fmt) "end g%div" if (associated (g%map)) then write (unit = unit, fmt = descr_fmt) "begin g%map" do i = 1, size (g%div) do j = 1, size (g%div) write (unit = unit, fmt = double_array2_fmt) i, j, g%map(i,j) end do end do write (unit = unit, fmt = descr_fmt) "end g%map" else write (unit = unit, fmt = descr_fmt) "empty g%map" end if if (associated (g%mu_x)) then write (unit = unit, fmt = descr_fmt) "begin g%mu_x" do i = 1, size (g%div) write (unit = unit, fmt = double_array_fmt) i, g%mu_x(i) write (unit = unit, fmt = double_array_fmt) i, g%sum_mu_x(i) do j = 1, size (g%div) write (unit = unit, fmt = double_array2_fmt) i, j, g%mu_xx(i,j) write (unit = unit, fmt = double_array2_fmt) i, j, g%sum_mu_xx(i,j) end do end do write (unit = unit, fmt = descr_fmt) "end g%mu_x" else write (unit = unit, fmt = descr_fmt) "empty g%mu_x" end if write (unit = unit, fmt = descr_fmt) "end type(vamp_grid)" end subroutine write_grid_unit @ %def write_grid_unit @ <>= character(len=*), parameter, private :: & descr_fmt = "(1x,a)", & integer_fmt = "(1x,a17,1x,i15)", & integer_array_fmt = "(1x,i17,1x,i15)", & logical_fmt = "(1x,a17,1x,l1)", & double_fmt = "(1x,a17,1x,e30.22e4)", & double_array_fmt = "(1x,i17,1x,e30.22e4)", & double_array2_fmt = "(2(1x,i8),1x,e30.22e4)" @ %def descr_fmt integer_fmt integer_array_fmt logical_fmt @ %def double_fmt double_array_fmt double_array2_fmt @ <>= subroutine read_grid_unit (g, unit, read_integrals) type(vamp_grid), intent(inout) :: g integer, intent(in) :: unit logical, intent(in), optional :: read_integrals character(len=*), parameter :: FN = "vamp_read_grid" character(len=80) :: chdum integer :: ndim, i, j, idum, jdum read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = integer_fmt) chdum, ndim <> call create_array_pointer (g%num_div, ndim) read (unit = unit, fmt = integer_fmt) chdum, g%num_calls read (unit = unit, fmt = integer_fmt) chdum, g%calls_per_cell read (unit = unit, fmt = logical_fmt) chdum, g%stratified read (unit = unit, fmt = logical_fmt) chdum, g%all_stratified read (unit = unit, fmt = logical_fmt) chdum, g%quadrupole read (unit = unit, fmt = double_fmt) chdum, g%mu(1) read (unit = unit, fmt = double_fmt) chdum, g%mu(2) read (unit = unit, fmt = double_fmt) chdum, g%mu_plus(1) read (unit = unit, fmt = double_fmt) chdum, g%mu_plus(2) read (unit = unit, fmt = double_fmt) chdum, g%mu_minus(1) read (unit = unit, fmt = double_fmt) chdum, g%mu_minus(2) read (unit = unit, fmt = double_fmt) chdum, g%sum_integral read (unit = unit, fmt = double_fmt) chdum, g%sum_weights read (unit = unit, fmt = double_fmt) chdum, g%sum_chi2 read (unit = unit, fmt = double_fmt) chdum, g%calls read (unit = unit, fmt = double_fmt) chdum, g%dv2g read (unit = unit, fmt = double_fmt) chdum, g%jacobi read (unit = unit, fmt = double_fmt) chdum, g%f_min read (unit = unit, fmt = double_fmt) chdum, g%f_max read (unit = unit, fmt = double_fmt) chdum, g%mu_gi read (unit = unit, fmt = double_fmt) chdum, g%sum_mu_gi read (unit = unit, fmt = descr_fmt) chdum do i = 1, size (g%div) read (unit = unit, fmt = integer_array_fmt) idum, g%num_div(i) end do read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = descr_fmt) chdum do i = 1, size (g%div) call read_division (g%div(i), unit, read_integrals) end do read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = descr_fmt) chdum if (chdum == "begin g%map") then call create_array_pointer (g%map, (/ ndim, ndim /)) do i = 1, size (g%div) do j = 1, size (g%div) read (unit = unit, fmt = double_array2_fmt) idum, jdum, g%map(i,j) end do end do read (unit = unit, fmt = descr_fmt) chdum else <> end if read (unit = unit, fmt = descr_fmt) chdum if (chdum == "begin g%mu_x") then call create_array_pointer (g%mu_x, ndim ) call create_array_pointer (g%sum_mu_x, ndim) call create_array_pointer (g%mu_xx, (/ ndim, ndim /)) call create_array_pointer (g%sum_mu_xx, (/ ndim, ndim /)) do i = 1, size (g%div) read (unit = unit, fmt = double_array_fmt) idum, jdum, g%mu_x(i) read (unit = unit, fmt = double_array_fmt) idum, jdum, g%sum_mu_x(i) do j = 1, size (g%div) read (unit = unit, fmt = double_array2_fmt) & idum, jdum, g%mu_xx(i,j) read (unit = unit, fmt = double_array2_fmt) & idum, jdum, g%sum_mu_xx(i,j) end do end do read (unit = unit, fmt = descr_fmt) chdum else <> end if read (unit = unit, fmt = descr_fmt) chdum end subroutine read_grid_unit @ %def read_grid_unit @ <>= if (associated (g%div)) then if (size (g%div) /= ndim) then call delete_division (g%div) deallocate (g%div) allocate (g%div(ndim)) call create_empty_division (g%div) end if else allocate (g%div(ndim)) call create_empty_division (g%div) end if @ <>= if (associated (g%map)) then deallocate (g%map) end if @ <>= if (associated (g%mu_x)) then deallocate (g%mu_x) end if if (associated (g%mu_xx)) then deallocate (g%mu_xx) end if if (associated (g%sum_mu_x)) then deallocate (g%sum_mu_x) end if if (associated (g%sum_mu_xx)) then deallocate (g%sum_mu_xx) end if @ <>= subroutine write_grid_name (g, name, write_integrals) type(vamp_grid), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: write_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "write", status = "replace", file = name) call write_grid_unit (g, unit, write_integrals) close (unit = unit) end subroutine write_grid_name @ %def write_grid_name @ <>= subroutine read_grid_name (g, name, read_integrals) type(vamp_grid), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: read_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "read", status = "old", file = name) call read_grid_unit (g, unit, read_integrals) close (unit = unit) end subroutine read_grid_name @ %def read_grid_name @ <>= subroutine write_grids_unit (g, unit, write_integrals) type(vamp_grids), intent(in) :: g integer, intent(in) :: unit logical, intent(in), optional :: write_integrals integer :: i write (unit = unit, fmt = descr_fmt) "begin type(vamp_grids) :: g" write (unit = unit, fmt = integer_fmt) "size (g%grids) = ", size (g%grids) write (unit = unit, fmt = double_fmt) "sum_integral = ", g%sum_integral write (unit = unit, fmt = double_fmt) "sum_weights = ", g%sum_weights write (unit = unit, fmt = double_fmt) "sum_chi2 = ", g%sum_chi2 write (unit = unit, fmt = descr_fmt) "begin g%weights" do i = 1, size (g%grids) write (unit = unit, fmt = double_array_fmt) i, g%weights(i) end do write (unit = unit, fmt = descr_fmt) "end g%weights" write (unit = unit, fmt = descr_fmt) "begin g%num_calls" do i = 1, size (g%grids) write (unit = unit, fmt = integer_array_fmt) i, g%num_calls(i) end do write (unit = unit, fmt = descr_fmt) "end g%num_calls" write (unit = unit, fmt = descr_fmt) "begin g%grids" do i = 1, size (g%grids) call write_grid_unit (g%grids(i), unit, write_integrals) end do write (unit = unit, fmt = descr_fmt) "end g%grids" write (unit = unit, fmt = descr_fmt) "end type(vamp_grids)" end subroutine write_grids_unit @ %def write_grids_unit @ <>= subroutine read_grids_unit (g, unit, read_integrals) type(vamp_grids), intent(inout) :: g integer, intent(in) :: unit logical, intent(in), optional :: read_integrals character(len=*), parameter :: FN = "vamp_read_grids" character(len=80) :: chdum integer :: i, nch, idum read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = integer_fmt) chdum, nch if (associated (g%grids)) then if (size (g%grids) /= nch) then call vamp_delete_grid (g%grids) deallocate (g%grids, g%weights, g%num_calls) allocate (g%grids(nch), g%weights(nch), g%num_calls(nch)) call vamp_create_empty_grid (g%grids) end if else allocate (g%grids(nch), g%weights(nch), g%num_calls(nch)) call vamp_create_empty_grid (g%grids) end if read (unit = unit, fmt = double_fmt) chdum, g%sum_integral read (unit = unit, fmt = double_fmt) chdum, g%sum_weights read (unit = unit, fmt = double_fmt) chdum, g%sum_chi2 read (unit = unit, fmt = descr_fmt) chdum do i = 1, nch read (unit = unit, fmt = double_array_fmt) idum, g%weights(i) end do read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = descr_fmt) chdum do i = 1, nch read (unit = unit, fmt = integer_array_fmt) idum, g%num_calls(i) end do read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = descr_fmt) chdum do i = 1, nch call read_grid_unit (g%grids(i), unit, read_integrals) end do read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = descr_fmt) chdum end subroutine read_grids_unit @ %def read_grids_unit @ <>= subroutine write_grids_name (g, name, write_integrals) type(vamp_grids), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: write_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "write", status = "replace", file = name) call write_grids_unit (g, unit, write_integrals) close (unit = unit) end subroutine write_grids_name @ %def write_grids_name @ <>= subroutine read_grids_name (g, name, read_integrals) type(vamp_grids), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: read_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "read", status = "old", file = name) call read_grids_unit (g, unit, read_integrals) close (unit = unit) end subroutine read_grids_name @ %def read_grids_name @ <>= subroutine write_grid_raw_unit (g, unit, write_integrals) type(vamp_grid), intent(in) :: g integer, intent(in) :: unit logical, intent(in), optional :: write_integrals integer :: i, j write (unit = unit) MAGIC_GRID_BEGIN write (unit = unit) size (g%div) write (unit = unit) g%num_calls write (unit = unit) g%calls_per_cell write (unit = unit) g%stratified write (unit = unit) g%all_stratified write (unit = unit) g%quadrupole write (unit = unit) g%mu(1) write (unit = unit) g%mu(2) write (unit = unit) g%mu_plus(1) write (unit = unit) g%mu_plus(2) write (unit = unit) g%mu_minus(1) write (unit = unit) g%mu_minus(2) write (unit = unit) g%sum_integral write (unit = unit) g%sum_weights write (unit = unit) g%sum_chi2 write (unit = unit) g%calls write (unit = unit) g%dv2g write (unit = unit) g%jacobi write (unit = unit) g%f_min write (unit = unit) g%f_max write (unit = unit) g%mu_gi write (unit = unit) g%sum_mu_gi do i = 1, size (g%div) write (unit = unit) g%num_div(i) end do do i = 1, size (g%div) call write_division_raw (g%div(i), unit, write_integrals) end do if (associated (g%map)) then write (unit = unit) MAGIC_GRID_MAP do i = 1, size (g%div) do j = 1, size (g%div) write (unit = unit) g%map(i,j) end do end do else write (unit = unit) MAGIC_GRID_EMPTY end if if (associated (g%mu_x)) then write (unit = unit) MAGIC_GRID_MU_X do i = 1, size (g%div) write (unit = unit) g%mu_x(i) write (unit = unit) g%sum_mu_x(i) do j = 1, size (g%div) write (unit = unit) g%mu_xx(i,j) write (unit = unit) g%sum_mu_xx(i,j) end do end do else write (unit = unit) MAGIC_GRID_EMPTY end if write (unit = unit) MAGIC_GRID_END end subroutine write_grid_raw_unit @ %def write_grid_raw_unit @ <>= integer, parameter, private :: MAGIC_GRID = 22222222 integer, parameter, private :: MAGIC_GRID_BEGIN = MAGIC_GRID + 1 integer, parameter, private :: MAGIC_GRID_END = MAGIC_GRID + 2 integer, parameter, private :: MAGIC_GRID_EMPTY = MAGIC_GRID + 3 integer, parameter, private :: MAGIC_GRID_MAP = MAGIC_GRID + 4 integer, parameter, private :: MAGIC_GRID_MU_X = MAGIC_GRID + 5 @ <>= subroutine read_grid_raw_unit (g, unit, read_integrals) type(vamp_grid), intent(inout) :: g integer, intent(in) :: unit logical, intent(in), optional :: read_integrals character(len=*), parameter :: FN = "vamp_read_raw_grid" integer :: ndim, i, j, magic read (unit = unit) magic if (magic /= MAGIC_GRID_BEGIN) then print *, FN, " fatal: expecting magic ", MAGIC_GRID_BEGIN, & ", found ", magic stop end if read (unit = unit) ndim <> call create_array_pointer (g%num_div, ndim) read (unit = unit) g%num_calls read (unit = unit) g%calls_per_cell read (unit = unit) g%stratified read (unit = unit) g%all_stratified read (unit = unit) g%quadrupole read (unit = unit) g%mu(1) read (unit = unit) g%mu(2) read (unit = unit) g%mu_plus(1) read (unit = unit) g%mu_plus(2) read (unit = unit) g%mu_minus(1) read (unit = unit) g%mu_minus(2) read (unit = unit) g%sum_integral read (unit = unit) g%sum_weights read (unit = unit) g%sum_chi2 read (unit = unit) g%calls read (unit = unit) g%dv2g read (unit = unit) g%jacobi read (unit = unit) g%f_min read (unit = unit) g%f_max read (unit = unit) g%mu_gi read (unit = unit) g%sum_mu_gi do i = 1, size (g%div) read (unit = unit) g%num_div(i) end do do i = 1, size (g%div) call read_division_raw (g%div(i), unit, read_integrals) end do read (unit = unit) magic if (magic == MAGIC_GRID_MAP) then call create_array_pointer (g%map, (/ ndim, ndim /)) do i = 1, size (g%div) do j = 1, size (g%div) read (unit = unit) g%map(i,j) end do end do else if (magic == MAGIC_GRID_EMPTY) then <> else print *, FN, " fatal: expecting magic ", MAGIC_GRID_EMPTY, & " or ", MAGIC_GRID_MAP, ", found ", magic stop end if read (unit = unit) magic if (magic == MAGIC_GRID_MU_X) then call create_array_pointer (g%mu_x, ndim ) call create_array_pointer (g%sum_mu_x, ndim) call create_array_pointer (g%mu_xx, (/ ndim, ndim /)) call create_array_pointer (g%sum_mu_xx, (/ ndim, ndim /)) do i = 1, size (g%div) read (unit = unit) g%mu_x(i) read (unit = unit) g%sum_mu_x(i) do j = 1, size (g%div) read (unit = unit) g%mu_xx(i,j) read (unit = unit) g%sum_mu_xx(i,j) end do end do else if (magic == MAGIC_GRID_EMPTY) then <> else print *, FN, " fatal: expecting magic ", MAGIC_GRID_EMPTY, & " or ", MAGIC_GRID_MU_X, ", found ", magic stop end if read (unit = unit) magic if (magic /= MAGIC_GRID_END) then print *, FN, " fatal: expecting magic ", MAGIC_GRID_END, & " found ", magic stop end if end subroutine read_grid_raw_unit @ %def read_grid_raw_unit @ <>= subroutine write_grid_raw_name (g, name, write_integrals) type(vamp_grid), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: write_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "write", status = "replace", & form = "unformatted", file = name) call write_grid_raw_unit (g, unit, write_integrals) close (unit = unit) end subroutine write_grid_raw_name @ %def write_grid_raw_name @ <>= subroutine read_grid_raw_name (g, name, read_integrals) type(vamp_grid), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: read_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "read", status = "old", & form = "unformatted", file = name) call read_grid_raw_unit (g, unit, read_integrals) close (unit = unit) end subroutine read_grid_raw_name @ %def read_grid_raw_name @ <>= subroutine write_grids_raw_unit (g, unit, write_integrals) type(vamp_grids), intent(in) :: g integer, intent(in) :: unit logical, intent(in), optional :: write_integrals integer :: i write (unit = unit) MAGIC_GRIDS_BEGIN write (unit = unit) size (g%grids) write (unit = unit) g%sum_integral write (unit = unit) g%sum_weights write (unit = unit) g%sum_chi2 do i = 1, size (g%grids) write (unit = unit) g%weights(i) end do do i = 1, size (g%grids) write (unit = unit) g%num_calls(i) end do do i = 1, size (g%grids) call write_grid_raw_unit (g%grids(i), unit, write_integrals) end do write (unit = unit) MAGIC_GRIDS_END end subroutine write_grids_raw_unit @ %def write_grids_raw_unit @ <>= integer, parameter, private :: MAGIC_GRIDS = 33333333 integer, parameter, private :: MAGIC_GRIDS_BEGIN = MAGIC_GRIDS + 1 integer, parameter, private :: MAGIC_GRIDS_END = MAGIC_GRIDS + 2 @ <>= subroutine read_grids_raw_unit (g, unit, read_integrals) type(vamp_grids), intent(inout) :: g integer, intent(in) :: unit logical, intent(in), optional :: read_integrals character(len=*), parameter :: FN = "vamp_read_grids_raw" integer :: i, nch, magic read (unit = unit) magic if (magic /= MAGIC_GRIDS_BEGIN) then print *, FN, " fatal: expecting magic ", MAGIC_GRIDS_BEGIN, & " found ", magic stop end if read (unit = unit) nch if (associated (g%grids)) then if (size (g%grids) /= nch) then call vamp_delete_grid (g%grids) deallocate (g%grids, g%weights, g%num_calls) allocate (g%grids(nch), g%weights(nch), g%num_calls(nch)) call vamp_create_empty_grid (g%grids) end if else allocate (g%grids(nch), g%weights(nch), g%num_calls(nch)) call vamp_create_empty_grid (g%grids) end if read (unit = unit) g%sum_integral read (unit = unit) g%sum_weights read (unit = unit) g%sum_chi2 do i = 1, nch read (unit = unit) g%weights(i) end do do i = 1, nch read (unit = unit) g%num_calls(i) end do do i = 1, nch call read_grid_raw_unit (g%grids(i), unit, read_integrals) end do read (unit = unit) magic if (magic /= MAGIC_GRIDS_END) then print *, FN, " fatal: expecting magic ", MAGIC_GRIDS_END, & " found ", magic stop end if end subroutine read_grids_raw_unit @ %def read_grids_raw_unit @ <>= subroutine write_grids_raw_name (g, name, write_integrals) type(vamp_grids), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: write_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "write", status = "replace", & form = "unformatted", file = name) call write_grids_raw_unit (g, unit, write_integrals) close (unit = unit) end subroutine write_grids_raw_name @ %def write_grids_raw_name @ <>= subroutine read_grids_raw_name (g, name, read_integrals) type(vamp_grids), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: read_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "read", status = "old", & form = "unformatted", file = name) call read_grids_raw_unit (g, unit, read_integrals) close (unit = unit) end subroutine read_grids_raw_name @ %def read_grids_raw_name @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Marshaling} [WK] Note: [[mu_plus]] and [[mu_minus]] not transferred (hard-coded buffer indices)! <>= public :: vamp_marshal_grid_size, vamp_marshal_grid, vamp_unmarshal_grid @ <>= pure subroutine vamp_marshal_grid (g, ibuf, dbuf) type(vamp_grid), intent(in) :: g integer, dimension(:), intent(inout) :: ibuf real(kind=default), dimension(:), intent(inout) :: dbuf integer :: i, iwords, dwords, iidx, didx, ndim ndim = size (g%div) ibuf(1) = g%num_calls ibuf(2) = g%calls_per_cell ibuf(3) = ndim if (g%stratified) then ibuf(4) = 1 else ibuf(4) = 0 end if if (g%all_stratified) then ibuf(5) = 1 else ibuf(5) = 0 end if if (g%quadrupole) then ibuf(6) = 1 else ibuf(6) = 0 end if dbuf(1:2) = g%mu dbuf(3) = g%sum_integral dbuf(4) = g%sum_weights dbuf(5) = g%sum_chi2 dbuf(6) = g%calls dbuf(7) = g%dv2g dbuf(8) = g%jacobi dbuf(9) = g%f_min dbuf(10) = g%f_max dbuf(11) = g%mu_gi dbuf(12) = g%sum_mu_gi ibuf(7:6+ndim) = g%num_div iidx = 7 + ndim didx = 13 do i = 1, ndim call marshal_division_size (g%div(i), iwords, dwords) ibuf(iidx) = iwords ibuf(iidx+1) = dwords iidx = iidx + 2 call marshal_division (g%div(i), ibuf(iidx:iidx-1+iwords), & dbuf(didx:didx-1+dwords)) iidx = iidx + iwords didx = didx + dwords end do if (associated (g%map)) then ibuf(iidx) = 1 dbuf(didx:didx-1+ndim**2) = reshape (g%map, (/ ndim**2 /)) didx = didx + ndim**2 else ibuf(iidx) = 0 end if iidx = iidx + 1 if (associated (g%mu_x)) then ibuf(iidx) = 1 dbuf(didx:didx-1+ndim) = g%mu_x didx = didx + ndim dbuf(didx:didx-1+ndim) = g%sum_mu_x didx = didx + ndim dbuf(didx:didx-1+ndim**2) = reshape (g%mu_xx, (/ ndim**2 /)) didx = didx + ndim**2 dbuf(didx:didx-1+ndim**2) = reshape (g%sum_mu_xx, (/ ndim**2 /)) didx = didx + ndim**2 else ibuf(iidx) = 0 end if iidx = iidx + 1 end subroutine vamp_marshal_grid @ %def vamp_marshal_grid @ <>= pure subroutine vamp_marshal_grid_size (g, iwords, dwords) type(vamp_grid), intent(in) :: g integer, intent(out) :: iwords, dwords integer :: i, ndim, iw, dw ndim = size (g%div) iwords = 6 + ndim dwords = 12 do i = 1, ndim call marshal_division_size (g%div(i), iw, dw) iwords = iwords + 2 + iw dwords = dwords + dw end do iwords = iwords + 1 if (associated (g%map)) then dwords = dwords + ndim**2 end if iwords = iwords + 1 if (associated (g%mu_x)) then dwords = dwords + 2 * (ndim + ndim**2) end if end subroutine vamp_marshal_grid_size @ %def vamp_marshal_grid_size @ <>= pure subroutine vamp_unmarshal_grid (g, ibuf, dbuf) type(vamp_grid), intent(inout) :: g integer, dimension(:), intent(in) :: ibuf real(kind=default), dimension(:), intent(in) :: dbuf integer :: i, iwords, dwords, iidx, didx, ndim g%num_calls = ibuf(1) g%calls_per_cell = ibuf(2) ndim = ibuf(3) g%stratified = ibuf(4) /= 0 g%all_stratified = ibuf(5) /= 0 g%quadrupole = ibuf(6) /= 0 g%mu = dbuf(1:2) g%sum_integral = dbuf(3) g%sum_weights = dbuf(4) g%sum_chi2 = dbuf(5) g%calls = dbuf(6) g%dv2g = dbuf(7) g%jacobi = dbuf(8) g%f_min = dbuf(9) g%f_max = dbuf(10) g%mu_gi = dbuf(11) g%sum_mu_gi = dbuf(12) call copy_array_pointer (g%num_div, ibuf(7:6+ndim)) <> iidx = 7 + ndim didx = 13 do i = 1, ndim iwords = ibuf(iidx) dwords = ibuf(iidx+1) iidx = iidx + 2 call unmarshal_division (g%div(i), ibuf(iidx:iidx-1+iwords), & dbuf(didx:didx-1+dwords)) iidx = iidx + iwords didx = didx + dwords end do if (ibuf(iidx) > 0) then call copy_array_pointer & (g%map, reshape (dbuf(didx:didx-1+ibuf(iidx)), (/ ndim, ndim /))) didx = didx + ibuf(iidx) else <> end if iidx = iidx + 1 if (ibuf(iidx) > 0) then call copy_array_pointer (g%mu_x, dbuf(didx:didx-1+ndim)) didx = didx + ndim call copy_array_pointer (g%sum_mu_x, dbuf(didx:didx-1+ndim)) didx = didx + ndim call copy_array_pointer & (g%mu_xx, reshape (dbuf(didx:didx-1+ndim**2), (/ ndim, ndim /))) didx = didx + ndim**2 call copy_array_pointer & (g%sum_mu_xx, reshape (dbuf(didx:didx-1+ndim**2), (/ ndim, ndim /))) didx = didx + ndim**2 else <> end if iidx = iidx + 1 end subroutine vamp_unmarshal_grid @ %def vamp_unmarshal_grid @ <>= public :: vamp_marshal_history_size, vamp_marshal_history public :: vamp_unmarshal_history @ <>= pure subroutine vamp_marshal_history (h, ibuf, dbuf) type(vamp_history), intent(in) :: h integer, dimension(:), intent(inout) :: ibuf real(kind=default), dimension(:), intent(inout) :: dbuf integer :: j, ndim, iidx, didx, iwords, dwords if (h%verbose .and. (associated (h%div))) then ndim = size (h%div) else ndim = 0 end if ibuf(1) = ndim ibuf(2) = h%calls if (h%stratified) then ibuf(3) = 1 else ibuf(3) = 0 end if dbuf(1) = h%integral dbuf(2) = h%std_dev dbuf(3) = h%avg_integral dbuf(4) = h%avg_std_dev dbuf(5) = h%avg_chi2 dbuf(6) = h%f_min dbuf(7) = h%f_max iidx = 4 didx = 8 do j = 1, ndim call marshal_div_history_size (h%div(j), iwords, dwords) ibuf(iidx) = iwords ibuf(iidx+1) = dwords iidx = iidx + 2 call marshal_div_history (h%div(j), ibuf(iidx:iidx-1+iwords), & dbuf(didx:didx-1+dwords)) iidx = iidx + iwords didx = didx + dwords end do end subroutine vamp_marshal_history @ %def vamp_marshal_history @ <>= pure subroutine vamp_marshal_history_size (h, iwords, dwords) type(vamp_history), intent(in) :: h integer, intent(out) :: iwords, dwords integer :: i, ndim, iw, dw if (h%verbose .and. (associated (h%div))) then ndim = size (h%div) else ndim = 0 end if iwords = 3 dwords = 7 do i = 1, ndim call marshal_div_history_size (h%div(i), iw, dw) iwords = iwords + 2 + iw dwords = dwords + dw end do end subroutine vamp_marshal_history_size @ %def vamp_marshal_history_size @ <>= pure subroutine vamp_unmarshal_history (h, ibuf, dbuf) type(vamp_history), intent(inout) :: h integer, dimension(:), intent(in) :: ibuf real(kind=default), dimension(:), intent(in) :: dbuf integer :: j, ndim, iidx, didx, iwords, dwords ndim = ibuf(1) h%calls = ibuf(2) h%stratified = ibuf(3) /= 0 h%integral = dbuf(1) h%std_dev = dbuf(2) h%avg_integral = dbuf(3) h%avg_std_dev = dbuf(4) h%avg_chi2 = dbuf(5) h%f_min = dbuf(6) h%f_max = dbuf(7) if (ndim > 0) then if (associated (h%div)) then if (size (h%div) /= ndim) then deallocate (h%div) allocate (h%div(ndim)) end if else allocate (h%div(ndim)) end if iidx = 4 didx = 8 do j = 1, ndim iwords = ibuf(iidx) dwords = ibuf(iidx+1) iidx = iidx + 2 call unmarshal_div_history (h%div(j), ibuf(iidx:iidx-1+iwords), & dbuf(didx:didx-1+dwords)) iidx = iidx + iwords didx = didx + dwords end do end if end subroutine vamp_unmarshal_history @ %def vamp_unmarshal_history @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Boring Copying and Deleting of Objects} <>= elemental subroutine vamp_copy_grid (lhs, rhs) type(vamp_grid), intent(inout) :: lhs type(vamp_grid), intent(in) :: rhs integer :: ndim ndim = size (rhs%div) lhs%mu = rhs%mu lhs%mu_plus = rhs%mu_plus lhs%mu_minus = rhs%mu_minus lhs%sum_integral = rhs%sum_integral lhs%sum_weights = rhs%sum_weights lhs%sum_chi2 = rhs%sum_chi2 lhs%calls = rhs%calls lhs%num_calls = rhs%num_calls call copy_array_pointer (lhs%num_div, rhs%num_div) lhs%dv2g = rhs%dv2g lhs%jacobi = rhs%jacobi lhs%f_min = rhs%f_min lhs%f_max = rhs%f_max lhs%mu_gi = rhs%mu_gi lhs%sum_mu_gi = rhs%sum_mu_gi lhs%calls_per_cell = rhs%calls_per_cell lhs%stratified = rhs%stratified lhs%all_stratified = rhs%all_stratified lhs%quadrupole = rhs%quadrupole if (associated (lhs%div)) then if (size (lhs%div) /= ndim) then call delete_division (lhs%div) deallocate (lhs%div) allocate (lhs%div(ndim)) end if else allocate (lhs%div(ndim)) end if call copy_division (lhs%div, rhs%div) if (associated (rhs%map)) then call copy_array_pointer (lhs%map, rhs%map) else if (associated (lhs%map)) then deallocate (lhs%map) end if if (associated (rhs%mu_x)) then call copy_array_pointer (lhs%mu_x, rhs%mu_x) call copy_array_pointer (lhs%mu_xx, rhs%mu_xx) call copy_array_pointer (lhs%sum_mu_x, rhs%sum_mu_x) call copy_array_pointer (lhs%sum_mu_xx, rhs%sum_mu_xx) else if (associated (lhs%mu_x)) then deallocate (lhs%mu_x, lhs%mu_xx, lhs%sum_mu_x, lhs%sum_mu_xx) end if end subroutine vamp_copy_grid @ %def vamp_copy_grid @ <>= elemental subroutine vamp_delete_grid (g) type(vamp_grid), intent(inout) :: g if (associated (g%div)) then call delete_division (g%div) deallocate (g%div, g%num_div) end if if (associated (g%map)) then deallocate (g%map) end if if (associated (g%mu_x)) then deallocate (g%mu_x, g%mu_xx, g%sum_mu_x, g%sum_mu_xx) end if end subroutine vamp_delete_grid @ %def vamp_delete_grid @ <>= elemental subroutine vamp_copy_grids (lhs, rhs) type(vamp_grids), intent(inout) :: lhs type(vamp_grids), intent(in) :: rhs integer :: nch nch = size (rhs%grids) lhs%sum_integral = rhs%sum_integral lhs%sum_chi2 = rhs%sum_chi2 lhs%sum_weights = rhs%sum_weights if (associated (lhs%grids)) then if (size (lhs%grids) /= nch) then deallocate (lhs%grids) allocate (lhs%grids(nch)) call vamp_create_empty_grid (lhs%grids(nch)) end if else allocate (lhs%grids(nch)) call vamp_create_empty_grid (lhs%grids(nch)) end if call vamp_copy_grid (lhs%grids, rhs%grids) call copy_array_pointer (lhs%weights, rhs%weights) call copy_array_pointer (lhs%num_calls, rhs%num_calls) end subroutine vamp_copy_grids @ %def vamp_copy_grids @ <>= elemental subroutine vamp_delete_grids (g) type(vamp_grids), intent(inout) :: g if (associated (g%grids)) then call vamp_delete_grid (g%grids) deallocate (g%weights, g%grids, g%num_calls) end if end subroutine vamp_delete_grids @ %def vamp_delete_grids @ <>= elemental subroutine vamp_copy_history (lhs, rhs) type(vamp_history), intent(inout) :: lhs type(vamp_history), intent(in) :: rhs lhs%calls = rhs%calls lhs%stratified = rhs%stratified lhs%verbose = rhs%verbose lhs%integral = rhs%integral lhs%std_dev = rhs%std_dev lhs%avg_integral = rhs%avg_integral lhs%avg_std_dev = rhs%avg_std_dev lhs%avg_chi2 = rhs%avg_chi2 lhs%f_min = rhs%f_min lhs%f_max = rhs%f_max if (rhs%verbose) then if (associated (lhs%div)) then if (size (lhs%div) /= size (rhs%div)) then deallocate (lhs%div) allocate (lhs%div(size(rhs%div))) end if else allocate (lhs%div(size(rhs%div))) end if call copy_history (lhs%div, rhs%div) end if end subroutine vamp_copy_history @ %def vamp_copy_history @ <>= elemental subroutine vamp_delete_history (h) type(vamp_history), intent(inout) :: h if (associated (h%div)) then deallocate (h%div) end if end subroutine vamp_delete_history @ %def vamp_delete_history @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/application.nw =================================================================== --- trunk/vamp/src/application.nw (revision 8740) +++ trunk/vamp/src/application.nw (revision 8741) @@ -1,1092 +1,1090 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP application code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: application.nw 314 2010-04-17 20:32:33Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Application} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Cross section} <<[[application.f90]]>>= ! application.f90 -- <> module cross_section use kinds use constants use utils use kinematics use tao_random_numbers use products, only: dot use helicity use vamp, only: vamp_grid, vamp_probability implicit none private <> <> <> contains <> end module cross_section @ <>= real(kind=default), private, parameter :: & MA_0 = 0.0, & MB_0 = 0.0, & M1_0 = 0.0, & M2_0 = 0.0, & M3_0 = 0.0, & S_0 = 200.0 ** 2 @ <>= real(kind=default), private, parameter :: & MA_0 = 0.01, & MB_0 = 0.01, & M1_0 = 0.01, & M2_0 = 0.01, & M3_0 = 0.01, & S_0 = 200.0 ** 2 @ <>= real(kind=default), private, parameter :: & S1_MIN_0 = 0.0 ** 2, & S2_MIN_0 = 0.0 ** 2, & S3_MIN_0 = 0.0 ** 2, & T1_MIN_0 = 0.0 ** 2, & T2_MIN_0 = 0.0 ** 2 @ <>= real(kind=default), private, parameter :: & S1_MIN_0 = 1.0 ** 2, & S2_MIN_0 = 1.0 ** 2, & S3_MIN_0 = 1.0 ** 2, & T1_MIN_0 = 10.0 ** 2, & T2_MIN_0 = 10.0 ** 2 @ <>= private :: cuts @ <>= pure function cuts (k1, k2, p1, p2, q) result (inside) real(kind=default), dimension(0:), intent(in) :: k1, k2, p1, p2, q logical :: inside inside = (abs (dot (k1 - q, k1 - q)) >= T1_MIN_0) & .and. (abs (dot (k2 - q, k2 - q)) >= T2_MIN_0) & .and. (abs (dot (p1 + q, p1 + q)) >= S1_MIN_0) & .and. (abs (dot (p2 + q, p2 + q)) >= S2_MIN_0) & .and. (abs (dot (p1 + p2, p1 + p2)) >= S3_MIN_0) end function cuts @ <>= real(kind=default), private, parameter :: & E_MIN = 1.0, & COSTH_SEP_MAX = 0.99, & COSTH_BEAM_MAX = 0.99 @ <>= pure function cuts (k1, k2, p1, p2, q) result (inside) real(kind=default), dimension(0:), intent(in) :: k1, k2, p1, p2, q logical :: inside real(kind=default), dimension(3) :: p1n, p2n, qn inside = .false. if ((p1(0) < E_MIN) .or. (p2(0) < E_MIN) .or. (q(0) < E_MIN)) then return end if p1n = p1(1:3) / sqrt (dot_product (p1(1:3), p1(1:3))) p2n = p2(1:3) / sqrt (dot_product (p2(1:3), p2(1:3))) qn = q(1:3) / sqrt (dot_product (q(1:3), q(1:3))) if ((abs (qn(3)) > COSTH_BEAM_MAX) & .or. (abs (p1n(3)) > COSTH_BEAM_MAX)& .or. (abs (p2n(3)) > COSTH_BEAM_MAX)) then return end if if (dot_product (p1n, qn) > COSTH_SEP_MAX) then return end if if (dot_product (p2n, qn) > COSTH_SEP_MAX) then return end if if (dot_product (p1n, p2n) > COSTH_SEP_MAX) then return end if inside = .true. end function cuts @ <>= function xsect (k1, k2, p1, p2, q) result (xs) real(kind=default), dimension(0:), intent(in) :: k1, k2, p1, p2, q real(kind=default) :: xs complex(kind=default), dimension(-1:1,-1:1,-1:1,-1:1,-1:1) :: amp !!! xs = 1.0_double / phase_space_volume (3, k1(0) + k2(0)) !!! xs = 1.0_double / dot (p1 + q, p1 + q) & !!! + 1.0_double / dot (p2 + q, p2 + q) !!! return amp = nneeg (k1, k2, p1, p2, q) xs = sum (amp(-1:1:2,-1:1:2,-1:1:2,-1:1:2,-1:1:2) & * conjg (amp(-1:1:2,-1:1:2,-1:1:2,-1:1:2,-1:1:2))) end function xsect @ <>= private :: xsect @ \begin{equation} \begin{aligned} \phi: [0,1]^{\otimes5} & \to \begin{aligned}[t] & [(m_2+m_3)^2,(\sqrt{s}-m_1)^2] \otimes [t_1^{\min}(s_2),t_1^{\max}(s_2)] \\ & \;\;\; \otimes [0,2\pi] \otimes [-1,1] \otimes [0,2\pi] \end{aligned} \\ (x_1,\ldots,x_5) &\mapsto \begin{aligned}[t] & (s_2, t_1, \phi, \cos\theta_3, \phi_3) \\ & \;\;\; = (s_2(x_1), x_2 t_1^{\max}(s_2) + (1-x_2) t_1^{\min}(s_2), 2\pi x_3, 2x_4-1, 2\pi x_5) \end{aligned} \end{aligned} \end{equation} where \begin{multline} t_1^{\max/\min}(s_2) \\ = m_a^2 + m_1^2 - \frac{(s + m_a^2 - m_b^2) (s - s_2 + m_1^2) \mp \sqrt{\lambda (s, m_a^2, m_b^2) \lambda (s, s_2, m_1^2)}}% {2s} \end{multline} <>= ! s2_min = S1_MIN_0 s2_min = (m2 + m3)**2 s2_max = (sqrt (s) - m1)**2 s2 = s2_max * x(1) + s2_min * (1 - x(1)) t1_min = ma**2 + m1**2 - ((s + ma**2 - mb**2) * (s - s2 + m1**2) & + sqrt (lambda (s, ma**2, mb**2) * lambda (s, s2, m1**2))) / (2*s) t1_max = ma**2 + m1**2 - ((s + ma**2 - mb**2) * (s - s2 + m1**2) & - sqrt (lambda (s, ma**2, mb**2) * lambda (s, s2, m1**2))) / (2*s) t1 = t1_max * x(2) + t1_min * (1 - x(2)) phi = 2*PI * x(3) cos_theta3 = 2 * x(4) - 1 phi3 = 2*PI * x(5) @ <>= ! s2_min = S1_MIN_0 s2_min = 0 s2_max = s s2 = s2_max * x(1) + s2_min * (1 - x(1)) t1_min = - (s - s2) t1_max = 0 t1 = t1_max * x(2) + t1_min * (1 - x(2)) phi = 2*PI * x(3) cos_theta3 = 2 * x(4) - 1 phi3 = 2*PI * x(5) @ \begin{equation} J_{\phi}(x_1,\ldots,x_5) = \begin{vmatrix} \frac{\partial s_2}{\partial x_1} & \frac{\partial t_1}{\partial x_1} \\ \frac{\partial s_2}{\partial x_2} & \frac{\partial t_1}{\partial x_2} \end{vmatrix} \cdot 8\pi^2 \end{equation} i.e. \begin{equation} J_{\phi}(x_1,\ldots,x_5) = 8\pi^2 \cdot \left| \frac{\mathrm{d} s_2}{\mathrm{d} x_1} \right| \cdot \left( t_1^{\max}(s_2) - t_1^{\min}(s_2) \right) \end{equation} <>= p%jacobian = p%jacobian & * (8.0 * PI**2 * (s2_max - s2_min) * (t1_max - t1_min)) @ <>= pure function phase_space (x, channel) result (p) real(kind=default), dimension(:), intent(in) :: x integer, intent(in) :: channel type(LIPS3) :: p real(kind=default) :: & ma, mb, m1, m2, m3, s, t1, s2, phi, cos_theta3, phi3 real(kind=default) :: s2_min, s2_max, t1_min, t1_max s = S_0 <<$m_a\leftrightarrow m_b$, $m_1\leftrightarrow m_2$ for channel \#1>> <> p = two_to_three (s, t1, s2, phi, cos_theta3, phi3, ma, mb, m1, m2, m3) <> <<$p_1\leftrightarrow p_2$ for channel \#2>> end function phase_space @ <<$m_a\leftrightarrow m_b$, $m_1\leftrightarrow m_2$ for channel \#1>>= select case (channel) case (1) ma = MA_0 mb = MB_0 m1 = M1_0 m2 = M2_0 m3 = M3_0 case (2) ma = MB_0 mb = MA_0 m1 = M2_0 m2 = M1_0 m3 = M3_0 case (3) ma = MA_0 mb = MB_0 m1 = M3_0 m2 = M2_0 m3 = M1_0 case default ma = MA_0 mb = MB_0 m1 = M1_0 m2 = M2_0 m3 = M3_0 end select @ <<$p_1\leftrightarrow p_2$ for channel \#2>>= select case (channel) case (1) ! OK case (2) call swap (p%p(1,:), p%p(2,:)) case (3) call swap (p%p(1,:), p%p(3,:)) case default ! OK end select @ <>= private :: jacobian @ <>= pure function jacobian (k1, k2, p1, p2, q) result (jac) real(kind=default), dimension(0:), intent(in) :: k1, k2, p1, p2, q real(kind=default) :: jac real(kind=default) :: ma_2, mb_2, m1_2, m2_2, m3_2 real(kind=default) :: s, s2, s2_min, s2_max, t1_min, t1_max ma_2 = max (dot (k1, k1), 0.0_double) mb_2 = max (dot (k2, k2), 0.0_double) m1_2 = max (dot (p1, p1), 0.0_double) m2_2 = max (dot (p2, p2), 0.0_double) m3_2 = max (dot (q, q), 0.0_double) s = dot (k1 + k2, k1 + k2) s2 = dot (p2 + q, p2 + q) ! s2_min = S1_MIN_0 s2_min = (sqrt (m2_2) + sqrt (m3_2))**2 s2_max = (sqrt (s) - sqrt (m1_2))**2 t1_min = ma_2 + m1_2 - ((s + ma_2 - mb_2) * (s - s2 + m1_2) & + sqrt (lambda (s, ma_2, mb_2) * lambda (s, s2, m1_2))) / (2*s) t1_max = ma_2 + m1_2 - ((s + ma_2 - mb_2) * (s - s2 + m1_2) & - sqrt (lambda (s, ma_2, mb_2) * lambda (s, s2, m1_2))) / (2*s) jac = 1.0 / ((2*PI)**5 * 32 * s2) & * sqrt (lambda (s2, m2_2, m3_2) / lambda (s, ma_2, mb_2)) & * (8.0 * PI**2 * (s2_max - s2_min) * (t1_max - t1_min)) end function jacobian @ %def jacobian @ <>= private :: phase_space, phase_space_massless @ <>= pure function phase_space_massless (x, channel) result (p) real(kind=default), dimension(:), intent(in) :: x integer, intent(in) :: channel type(LIPS3) :: p real(kind=default) :: s, t1, s2, phi, cos_theta3, phi3 real(kind=default) :: s2_min, s2_max, t1_min, t1_max s = S_0 <> p = two_to_three (s, t1, s2, phi, cos_theta3, phi3) <> <<$p_1\leftrightarrow p_2$ for channel \#2>> end function phase_space_massless @ <>= type, public :: LIPS3_m5i2a3 ! private real(kind=default) :: ma, mb, m1, m2, m3 real(kind=default) :: s, s2, t1 real(kind=default) :: phi, cos_theta3, phi3 real(kind=default) :: jacobian end type LIPS3_m5i2a3 @ %def LIPS3_m5i2a3 @ <>= type, public :: x5 ! private real(kind=default), dimension(5) :: x real(kind=default) :: jacobian end type x5 @ %def x5 @ <>= private :: invariants_from_p, invariants_to_p private :: invariants_from_x, invariants_to_x @ <>= pure function invariants_from_p (p, k1, k2) result (q) type(LIPS3), intent(in) :: p real(kind=default), dimension(0:), intent(in) :: k1, k2 type(LIPS3_m5i2a3) :: q real(kind=default) :: ma_2, mb_2, m1_2, m2_2, m3_2 real(kind=default), dimension(0:3) :: k1k2, p2p3, k1p1, p3_23 k1k2 = k1 + k2 k1p1 = - k1 + p%p(1,:) p2p3 = p%p(2,:) + p%p(3,:) ma_2 = max (dot (k1, k1), 0.0_double) mb_2 = max (dot (k2, k2), 0.0_double) m1_2 = max (dot (p%p(1,:), p%p(1,:)), 0.0_double) m2_2 = max (dot (p%p(2,:), p%p(2,:)), 0.0_double) m3_2 = max (dot (p%p(3,:), p%p(3,:)), 0.0_double) q%ma = sqrt (ma_2) q%mb = sqrt (mb_2) q%m1 = sqrt (m1_2) q%m2 = sqrt (m2_2) q%m3 = sqrt (m3_2) q%s = dot (k1k2, k1k2) q%s2 = dot (p2p3, p2p3) q%t1 = dot (k1p1, k1p1) q%phi = atan2 (p%p(1,2), p%p(1,1)) if (q%phi < 0) then q%phi = q%phi + 2*PI end if p3_23 = boost_momentum (p%p(3,:), p2p3) q%cos_theta3 = p3_23(3) / sqrt (dot_product (p3_23(1:3), p3_23(1:3))) q%phi3 = atan2 (p3_23(2), p3_23(1)) if (q%phi3 < 0) then q%phi3 = q%phi3 + 2*PI end if q%jacobian = 1.0 / ((2*PI)**5 * 32 * q%s2) & * sqrt (lambda (q%s2, m2_2, m3_2) / lambda (q%s, ma_2, mb_2)) end function invariants_from_p @ %def invariants_from_p @ <>= pure function invariants_to_p (p) result (q) type(LIPS3_m5i2a3), intent(in) :: p type(LIPS3) :: q q = two_to_three (p%s, p%t1, p%s2, p%phi, p%cos_theta3, p%phi3) q%jacobian = q%jacobian * p%jacobian end function invariants_to_p @ %def invariants_to_p @ <>= pure function invariants_from_x (x, s, ma, mb, m1, m2, m3) result (p) real(kind=default), dimension(:), intent(in) :: x real(kind=default), intent(in) :: s, ma, mb, m1, m2, m3 type(LIPS3_m5i2a3) :: p real(kind=default) :: s2_min, s2_max, t1_min, t1_max p%ma = ma p%mb = mb p%m1 = m1 p%m2 = m2 p%m3 = m3 p%s = s s2_min = (p%m2 + p%m3)**2 s2_max = (sqrt (p%s) - p%m1)**2 p%s2 = s2_max * x(1) + s2_min * (1 - x(1)) t1_min = p%ma**2 + p%m1**2 & - ((p%s + p%ma**2 - p%mb**2) * (p%s - p%s2 + p%m1**2) & + sqrt (lambda (p%s, p%ma**2, p%mb**2) & * lambda (p%s, p%s2, p%m1**2))) / (2*p%s) t1_max = p%ma**2 + p%m1**2 & - ((p%s + p%ma**2 - p%mb**2) * (p%s - p%s2 + p%m1**2) & - sqrt (lambda (p%s, p%ma**2, p%mb**2) & * lambda (p%s, p%s2, p%m1**2))) / (2*p%s) p%t1 = t1_max * x(2) + t1_min * (1 - x(2)) p%phi = 2*PI * x(3) p%cos_theta3 = 2 * x(4) - 1 p%phi3 = 2*PI * x(5) p%jacobian = 8*PI**2 * (s2_max - s2_min) * (t1_max - t1_min) end function invariants_from_x @ %def invariants_from_x @ <>= pure function invariants_to_x (p) result (x) type(LIPS3_m5i2a3), intent(in) :: p type(x5) :: x real(kind=default) :: s2_min, s2_max, t1_min, t1_max s2_min = (p%m2 + p%m3)**2 s2_max = (sqrt (p%s) - p%m1)**2 t1_min = p%ma**2 + p%m1**2 & - ((p%s + p%ma**2 - p%mb**2) * (p%s - p%s2 + p%m1**2) & + sqrt (lambda (p%s, p%ma**2, p%mb**2) & * lambda (p%s, p%s2, p%m1**2))) / (2*p%s) t1_max = p%ma**2 + p%m1**2 & - ((p%s + p%ma**2 - p%mb**2) * (p%s - p%s2 + p%m1**2) & - sqrt (lambda (p%s, p%ma**2, p%mb**2) & * lambda (p%s, p%s2, p%m1**2))) / (2*p%s) x%x(1) = (p%s2 - s2_min) / (s2_max - s2_min) x%x(2) = (p%t1 - t1_min) / (t1_max - t1_min) x%x(3) = p%phi / (2*PI) x%x(4) = (p%cos_theta3 + 1) / 2 x%x(5) = p%phi3 / (2*PI) x%jacobian = p%jacobian * 8*PI**2 * (s2_max - s2_min) * (t1_max - t1_min) end function invariants_to_x @ %def invariants_to_x @ <>= public :: sigma, sigma_raw, sigma_massless @ <>= function sigma (x, weights, channel, grids) result (xs) real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:), intent(in), optional :: weights integer, intent(in), optional :: channel type(vamp_grid), dimension(:), intent(in), optional :: grids real(kind=default) :: xs real(kind=default), dimension(2,0:3) :: k type(LIPS3) :: p k(1,:) = (/ 100.0_double, 0.0_double, 0.0_double, 100.0_double /) k(2,:) = (/ 100.0_double, 0.0_double, 0.0_double, -100.0_double /) if (present (channel)) then p = phase_space (x, channel) else p = phase_space (x, 0) end if if (cuts (k(1,:), k(2,:), p%p(1,:), p%p(2,:), p%p(3,:))) then xs = xsect (k(1,:), k(2,:), p%p(1,:), p%p(2,:), p%p(3,:)) & * jacobian (k(1,:), k(2,:), p%p(1,:), p%p(2,:), p%p(3,:)) !!! * p%jacobian else xs = 0.0 end if end function sigma @ <>= function sigma_raw (k1, k2, p1, p2, q) result (xs) real(kind=default), dimension(0:), intent(in) :: k1, k2, p1, p2, q real(kind=default) :: xs if (cuts (k1, k2, p1, p2, q)) then xs = xsect (k1, k2, p1, p2, q) else xs = 0.0 end if end function sigma_raw @ %def sigma_raw @ <>= function sigma_massless (x, weights, channel, grids) result (xs) real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:), intent(in), optional :: weights integer, intent(in), optional :: channel type(vamp_grid), dimension(:), intent(in), optional :: grids real(kind=default) :: xs real(kind=default), dimension(2,0:3) :: k type(LIPS3) :: p k(1,:) = (/ 100.0_double, 0.0_double, 0.0_double, 100.0_double /) k(2,:) = (/ 100.0_double, 0.0_double, 0.0_double, -100.0_double /) p = phase_space_massless (x, 0) if (cuts (k(1,:), k(2,:), p%p(1,:), p%p(2,:), p%p(3,:))) then xs = xsect (k(1,:), k(2,:), p%p(1,:), p%p(2,:), p%p(3,:)) & * p%jacobian else xs = 0.0 end if end function sigma_massless @ <>= public :: w @ \begin{center} \hfill\\ \vspace*{\baselineskip} \begin{fmfgraph*}(30,20) \fmfleft{pa,pb} \fmfright{p1,p3,p2} \fmflabel{$p_a$}{pa} \fmflabel{$p_b$}{pb} \fmflabel{$p_1$}{p1} \fmflabel{$p_2$}{p2} \fmflabel{$p_3$}{p3} \fmf{plain}{pa,v,pb} \fmf{plain}{p1,v} \fmf{dbl_plain,label=$s_2$}{v,v3} \fmf{plain}{v3,p2} \fmffreeze \fmf{plain}{v3,p3} \fmfdot{v,v3} \end{fmfgraph*} \qquad \begin{fmfgraph*}(30,20) \fmfleft{pa,pb} \fmfright{p1,p3,p2} \fmflabel{$p_a$}{pa} \fmflabel{$p_b$}{pb} \fmflabel{$p_1$}{p1} \fmflabel{$p_2$}{p2} \fmflabel{$p_3$}{p3} \fmf{plain}{pa,v,pb} \fmf{plain}{p1,v3} \fmf{dbl_plain,label=$s_1$}{v,v3} \fmf{plain}{v,p2} \fmffreeze \fmf{plain}{v3,p3} \fmfdot{v,v3} \end{fmfgraph*} \end{center} <>= function w (x, weights, channel, grids) result (w_x) real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:), intent(in), optional :: weights integer, intent(in), optional :: channel type(vamp_grid), dimension(:), intent(in), optional :: grids real(kind=default) :: w_x real(kind=default), dimension(size(weights)) :: g_x real(kind=default), dimension(2,0:3) :: k type(LIPS3) :: p integer :: ch if (present (channel)) then ch = channel else ch = 0 end if k(1,:) = (/ 100.0_double, 0.0_double, 0.0_double, 100.0_double /) k(2,:) = (/ 100.0_double, 0.0_double, 0.0_double, -100.0_double /) p = phase_space (x, abs (ch)) g_x(1) = 1.0_double / jacobian (k(1,:), k(2,:), p%p(1,:), p%p(2,:), p%p(3,:)) g_x(2) = 1.0_double / jacobian (k(1,:), k(2,:), p%p(2,:), p%p(1,:), p%p(3,:)) g_x(3) = 1.0_double / jacobian (k(1,:), k(2,:), p%p(3,:), p%p(2,:), p%p(1,:)) if (ch > 0) then w_x = sigma_raw (k(1,:), k(2,:), p%p(1,:), p%p(2,:), p%p(3,:)) & / sum (weights * g_x) else if (ch < 0) then w_x = g_x(-ch) / sum (weights * g_x) else w_x = -1 end if end function w @ <>= function sigma_rambo (x, weights, channel, grids) result (xs) real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:), intent(in), optional :: weights integer, intent(in), optional :: channel type(vamp_grid), dimension(:), intent(in), optional :: grids real(kind=default) :: xs real(kind=default), dimension(2,0:3) :: k real(kind=default), dimension(3,0:3) :: p k(1,:) = (/ 100.0_double, 0.0_double, 0.0_double, 100.0_double /) k(2,:) = (/ 100.0_double, 0.0_double, 0.0_double, -100.0_double /) p = massless_isotropic_decay (sum (k(:,0)), reshape (x, (/ 3, 4 /))) if (cuts (k(1,:), k(2,:), p(1,:), p(2,:), p(3,:))) then xs = xsect (k(1,:), k(2,:), p(1,:), p(2,:), p(3,:)) & * phase_space_volume (size (p, dim = 1), sum (k(:,0))) else xs = 0.0 end if end function sigma_rambo @ <>= public :: sigma_rambo @ <>= public :: check_kinematics private :: print_LIPS3_m5i2a3 @ <>= subroutine check_kinematics (rng) type(tao_random_state), intent(inout) :: rng real(kind=default), dimension(5) :: x real(kind=default), dimension(0:3) :: k1, k2 type(x5) :: x1, x2 type(LIPS3) :: p1, p2 type(LIPS3_m5i2a3) :: q, q1, q2 k1 = (/ 100.0_double, 0.0_double, 0.0_double, 100.0_double /) k2 = (/ 100.0_double, 0.0_double, 0.0_double, -100.0_double /) call tao_random_number (rng, x) q = invariants_from_x (x, S_0, MA_0, MB_0, M1_0, M2_0, M3_0) p1 = invariants_to_p (q) q1 = invariants_from_p (p1, k1, k2) p2 = phase_space (x, 1) q2 = invariants_from_p (p2, k1, k2) x1 = invariants_to_x (q1) x2 = invariants_to_x (q2) print *, p1%jacobian, p2%jacobian, x1%jacobian, x2%jacobian call print_lips3_m5i2a3 (q) call print_lips3_m5i2a3 (q1) call print_lips3_m5i2a3 (q2) end subroutine check_kinematics @ %def check_kinematics @ <>= subroutine print_LIPS3_m5i2a3 (p) type(LIPS3_m5i2a3), intent(in) :: p print "(1x,5('m',a1,'=',e9.2,' '))", & 'a', p%ma, 'b', p%mb, '1', p%m1, '2', p%m2, '3', p%m3 print "(1x,'s=',e9.2,' s2=',e9.2,' t1=',e9.2)", & p%s, p%s2, p%t1 print "(1x,'phi=',e9.2,' cos(th3)=',e9.2,' phi2=',e9.2)", & p%phi, p%cos_theta3, p%phi3 print "(1x,'j=',e9.2)", & p%jacobian end subroutine print_LIPS3_m5i2a3 @ %def print_LIPS3_m5i2a3 @ <>= public :: phi12, phi21, phi1, phi2 public :: g12, g21, g1, g2 @ <>= pure function phi12 (x1, dummy) result (x2) real(kind=default), dimension(:), intent(in) :: x1 integer, intent(in) :: dummy real(kind=default), dimension(size(x1)) :: x2 type(LIPS3) :: p1, p2 type(LIPS3_m5i2a3) :: q1, q2 type(x5) :: x52 real(kind=default), dimension(0:3) :: k1, k2 k1 = (/ 100.0_double, 0.0_double, 0.0_double, 100.0_double /) k2 = (/ 100.0_double, 0.0_double, 0.0_double, -100.0_double /) q1 = invariants_from_x (x1, S_0, MA_0, MB_0, M1_0, M2_0, M3_0) p1 = invariants_to_p (q1) p2%p(1,:) = p1%p(2,:) p2%p(2,:) = p1%p(1,:) p2%p(3,:) = p1%p(3,:) if (dummy < 0) then q2 = invariants_from_p (p2, k2, k1) else q2 = invariants_from_p (p2, k1, k2) end if x52 = invariants_to_x (q2) x2 = x52%x end function phi12 @ %def phi12 @ <>= pure function phi21 (x2, dummy) result (x1) real(kind=default), dimension(:), intent(in) :: x2 integer, intent(in) :: dummy real(kind=default), dimension(size(x2)) :: x1 type(LIPS3) :: p1, p2 type(LIPS3_m5i2a3) :: q1, q2 type(x5) :: x51 real(kind=default), dimension(0:3) :: k1, k2 k1 = (/ 100.0_double, 0.0_double, 0.0_double, 100.0_double /) k2 = (/ 100.0_double, 0.0_double, 0.0_double, -100.0_double /) q2 = invariants_from_x (x2, S_0, MA_0, MB_0, M2_0, M1_0, M3_0) p2 = invariants_to_p (q2) p1%p(1,:) = p2%p(2,:) p1%p(2,:) = p2%p(1,:) p1%p(3,:) = p2%p(3,:) if (dummy < 0) then q1 = invariants_from_p (p1, k2, k1) else q1 = invariants_from_p (p1, k1, k2) end if x51 = invariants_to_x (q1) x1 = x51%x end function phi21 @ %def phi21 @ <>= pure function phi1 (x1) result (p1) real(kind=default), dimension(:), intent(in) :: x1 type(LIPS3) :: p1 type(LIPS3_m5i2a3) :: q1 q1 = invariants_from_x (x1, S_0, MA_0, MB_0, M1_0, M2_0, M3_0) p1 = invariants_to_p (q1) end function phi1 @ %def phi1 @ <>= pure function phi2 (x2) result (p2) real(kind=default), dimension(:), intent(in) :: x2 type(LIPS3) :: p2 type(LIPS3_m5i2a3) :: q2 q2 = invariants_from_x (x2, S_0, MA_0, MB_0, M2_0, M1_0, M3_0) p2 = invariants_to_p (q2) end function phi2 @ %def phi2 @ <>= pure function g12 (x1) result (g) real(kind=default), dimension(:), intent(in) :: x1 real(kind=default) :: g type(LIPS3) :: p1, p2 type(LIPS3_m5i2a3) :: q1, q2 type(x5) :: x52 real(kind=default), dimension(0:3) :: k1, k2 k1 = (/ 100.0_double, 0.0_double, 0.0_double, 100.0_double /) k2 = (/ 100.0_double, 0.0_double, 0.0_double, -100.0_double /) q1 = invariants_from_x (x1, S_0, MA_0, MB_0, M1_0, M2_0, M3_0) p1 = invariants_to_p (q1) p2%p(1,:) = p1%p(2,:) p2%p(2,:) = p1%p(1,:) p2%p(3,:) = p1%p(3,:) q2 = invariants_from_p (p2, k2, k1) x52 = invariants_to_x (q2) g = x52%jacobian / p1%jacobian end function g12 @ %def g12 @ <>= pure function g21 (x2) result (g) real(kind=default), dimension(:), intent(in) :: x2 real(kind=default) :: g type(LIPS3) :: p1, p2 type(LIPS3_m5i2a3) :: q1, q2 type(x5) :: x51 real(kind=default), dimension(0:3) :: k1, k2 k1 = (/ 100.0_double, 0.0_double, 0.0_double, 100.0_double /) k2 = (/ 100.0_double, 0.0_double, 0.0_double, -100.0_double /) q2 = invariants_from_x (x2, S_0, MA_0, MB_0, M2_0, M1_0, M3_0) p2 = invariants_to_p (q2) p1%p(1,:) = p2%p(2,:) p1%p(2,:) = p2%p(1,:) p1%p(3,:) = p2%p(3,:) q1 = invariants_from_p (p1, k2, k1) x51 = invariants_to_x (q1) g = x51%jacobian / p2%jacobian end function g21 @ %def g21 @ <>= pure function g1 (x1) result (g) real(kind=default), dimension(:), intent(in) :: x1 real(kind=default) :: g type(LIPS3) :: p1 type(LIPS3_m5i2a3) :: q1 q1 = invariants_from_x (x1, S_0, MA_0, MB_0, M1_0, M2_0, M3_0) p1 = invariants_to_p (q1) g = 1 / p1%jacobian end function g1 @ %def g1 @ <>= pure function g2 (x2) result (g) real(kind=default), dimension(:), intent(in) :: x2 real(kind=default) :: g type(LIPS3) :: p2 type(LIPS3_m5i2a3) :: q2 q2 = invariants_from_x (x2, S_0, MA_0, MB_0, M2_0, M1_0, M3_0) p2 = invariants_to_p (q2) g = 1 / p2%jacobian end function g2 @ %def g2 @ <>= public :: wx @ <>= function wx (x, weights, channel, grids) result (w_x) real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:), intent(in) :: weights integer, intent(in) :: channel type(vamp_grid), dimension(:), intent(in) :: grids real(kind=default) :: w_x real(kind=default), dimension(size(weights)) :: g_x, p_q real(kind=default), dimension(size(x)) :: x1, x2 real(kind=default), dimension(2,0:3) :: k type(LIPS3) :: q k(1,:) = (/ 100.0_double, 0.0_double, 0.0_double, 100.0_double /) k(2,:) = (/ 100.0_double, 0.0_double, 0.0_double, -100.0_double /) select case (abs (channel)) case (1) x1 = x x2 = phi12 (x, 0) q = phi1 (x1) case (2) x1 = phi21 (x, 0) x2 = x q = phi2 (x2) end select p_q(1) = vamp_probability (grids(1), x1) p_q(2) = vamp_probability (grids(2), x2) g_x(1) = p_q(1) * g1 (x1) g_x(2) = p_q(2) * g2 (x2) g_x = g_x / p_q(abs(channel)) if (channel > 0) then w_x = sigma_raw (k(1,:), k(2,:), q%p(1,:), q%p(2,:), q%p(3,:)) & / dot_product (weights, g_x) else if (channel < 0) then w_x = vamp_probability (grids(-channel), x) / dot_product (weights, g_x) else w_x = 0 end if end function wx @ %def wx @ <<[[application.f90]]>>= program application use kinds use utils use vampi use mpi90 use linalg use exceptions use kinematics, only: phase_space_volume use cross_section !NODEP! use tao_random_numbers implicit none type(vamp_grid) :: gr type(vamp_grids) :: grs real(kind=default), dimension(:,:), allocatable :: region real(kind=default) :: integral, standard_dev, chi_squared real(kind=default) :: & single_integral, single_standard_dev, & rambo_integral, rambo_standard_dev real(kind=default), dimension(2) :: weight_vector integer, dimension(2) :: calls, iterations type(vamp_history), dimension(100) :: history type(vamp_history), dimension(100,size(weight_vector)) :: histories type(exception) :: exc type(tao_random_state) :: rng real(kind=default), dimension(5) :: x real(kind=default) :: jac integer :: i integer :: num_proc, proc_id, ticks, ticks0, ticks_per_second, command character(len=72) :: command_line integer, parameter :: & CMD_SINGLE = 1, & CMD_MULTI = 2, & CMD_ROTATING = 3, & CMD_RAMBO = 4, & CMD_COMPARE = 5, & CMD_MASSLESS = 6, & CMD_ERROR = 0 call mpi90_init () call mpi90_size (num_proc) call mpi90_rank (proc_id) call system_clock (ticks0) call tao_random_create (rng, 0) call tao_random_seed (rng, ticks0 + proc_id) !!! call tao_random_seed (rng, proc_id) call vamp_create_history (history, verbose = .true.) call vamp_create_history (histories, verbose = .true.) iterations = (/ 3, 4 /) calls = (/ 10000, 100000 /) if (proc_id == 0) then read *, command_line if (command_line == "single") then command = CMD_SINGLE else if (command_line == "multi") then command = CMD_MULTI else if (command_line == "rotating") then command = CMD_ROTATING else if (command_line == "rambo") then command = CMD_RAMBO else if (command_line == "compare") then command = CMD_COMPARE else if (command_line == "massless") then command = CMD_MASSLESS else command = CMD_ERROR end if end if call mpi90_broadcast (command, 0) call system_clock (ticks0) select case (command) case (CMD_SINGLE) <> case (CMD_MASSLESS) <> case (CMD_MULTI) <> case (CMD_ROTATING) allocate (region(2,5)) region(1,:) = 0.0 region(2,:) = 1.0 if (proc_id == 0) then print *, "rotating N/A yet ..." end if case (CMD_RAMBO) <> case (CMD_COMPARE) <> single_integral = integral single_standard_dev = standard_dev <> if (proc_id == 0) then rambo_integral = integral rambo_standard_dev = standard_dev integral = & (single_integral / single_standard_dev**2 & + rambo_integral / rambo_standard_dev**2) & / (1.0_double / single_standard_dev**2 & + 1.0_double / rambo_standard_dev**2) standard_dev = 1.0_double & / sqrt (1.0_double / single_standard_dev**2 & + 1.0_double / rambo_standard_dev**2) chi_squared = & ((single_integral - integral)**2 / single_standard_dev**2) & + ((rambo_integral - integral)**2 / rambo_standard_dev**2) print *, "S&R: ", integral, standard_dev, chi_squared end if case default if (proc_id == 0) then print *, "???: ", command !!! TO BE REMOVED !!! call check_kinematics (rng) allocate (region(2,5)) region(1,:) = 0 region(2,:) = 1 do i = 1, 10 call tao_random_number (rng, x) call vamp_jacobian (phi12, 0, x, region, jac) print *, "12: ", jac, 1 / g12 (x), jac * g12 (x) - 1 call vamp_jacobian (phi21, 0, x, region, jac) print *, "21: ", jac, 1 / g21 (x), jac * g21 (x) - 1 print *, "1: ", real(x) print *, "2: ", real(phi12(phi21(x,0),0)) print *, "2': ", real(phi12(phi21(x,-1),-1)) print *, "3: ", real(phi21(phi12(x,0),0)) print *, "3': ", real(phi21(phi12(x,-1),-1)) print *, "2-1: ", real(phi12(phi21(x,0),0) - x) print *, "3-1: ", real(phi21(phi12(x,0),0) - x) print *, "a: ", real(phi12(x,0)) print *, "a': ", real(phi12(x,-1)) print *, "b: ", real(phi21(x,0)) print *, "b': ", real(phi21(x,-1)) end do deallocate (region) ! do i = 2, 5 ! print *, i, phase_space_volume (i, 200.0_double) ! end do end if end select if (proc_id == 0) then call system_clock (ticks, ticks_per_second) print "(1X,A,F8.2,A)", & "time = ", real (ticks - ticks0) / ticks_per_second, " secs" end if call mpi90_finalize () end program application @ <>= allocate (region(2,5)) region(1,:) = 0.0 region(2,:) = 1.0 call vamp_create_grid (gr, region, calls(1)) call clear_exception (exc) call vamp_sample_grid & (rng, gr, sigma, iterations(1), history = history, exc = exc) call handle_exception (exc) call vamp_discard_integral (gr, calls(2)) call vamp_sample_grid & (rng, gr, sigma, iterations(2), & integral, standard_dev, chi_squared, & history = history(iterations(1)+1:), exc = exc) call handle_exception (exc) call vamp_print_history (history, "single") if (proc_id == 0) then print *, "SINGLE: ", integral, standard_dev, chi_squared end if call vamp_write_grid (gr, "application.grid") call vamp_delete_grid (gr) deallocate (region) @ <>= allocate (region(2,5)) region(1,:) = 0.0 region(2,:) = 1.0 call vamp_create_grid (gr, region, calls(1)) call clear_exception (exc) call vamp_sample_grid & (rng, gr, sigma_massless, iterations(1), history = history, exc = exc) call handle_exception (exc) call vamp_discard_integral (gr, calls(2)) call vamp_sample_grid & (rng, gr, sigma_massless, iterations(2), & integral, standard_dev, chi_squared, & history = history(iterations(1)+1:), exc = exc) call handle_exception (exc) call vamp_print_history (history, "single") if (proc_id == 0) then print *, "M=0: ", integral, standard_dev, chi_squared end if call vamp_write_grid (gr, "application.grid") call vamp_delete_grid (gr) deallocate (region) @ <>= allocate (region(2,5)) region(1,:) = 0.0 region(2,:) = 1.0 weight_vector = 1.0 if (proc_id == 0) then read *, weight_vector end if call mpi90_broadcast (weight_vector, 0) weight_vector = weight_vector / sum (weight_vector) call vamp_create_grids (grs, region, calls(1), weight_vector) do i = 1, 3 call clear_exception (exc) call vamp_sample_grids & (rng, grs, wx, iterations(1), & history = history(1+(i-1)*iterations(1):), & histories = histories(1+(i-1)*iterations(1):,:), exc = exc) call handle_exception (exc) call vamp_refine_weights (grs) end do call vamp_discard_integrals (grs, calls(2)) call vamp_sample_grids & (rng, grs, wx, iterations(2), & integral, standard_dev, chi_squared, & history = history(3*iterations(1)+1:), & histories = histories(3*iterations(1)+1:,:), exc = exc) call handle_exception (exc) call vamp_print_history (history, "multi") call vamp_print_history (histories, "multi") if (proc_id == 0) then print *, "MULTI: ", integral, standard_dev, chi_squared end if call vamp_write_grids (grs, "application.grids") call vamp_delete_grids (grs) deallocate (region) @ <>= allocate (region(2,12)) region(1,:) = 0.0 region(2,:) = 1.0 call vamp_create_grid (gr, region, calls(1)) call clear_exception (exc) call vamp_sample_grid & (rng, gr, sigma_rambo, iterations(1), history = history, exc = exc) call handle_exception (exc) call vamp_discard_integral (gr, calls(2)) call vamp_sample_grid & (rng, gr, sigma_rambo, iterations(2), & integral, standard_dev, chi_squared, & history = history(iterations(1)+1:), exc = exc) call handle_exception (exc) call vamp_print_history (history, "rambo") if (proc_id == 0) then print *, "RAMBO: ", integral, standard_dev, chi_squared end if call vamp_delete_grid (gr) deallocate (region) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/products.nw =================================================================== --- trunk/vamp/src/products.nw (revision 8740) +++ trunk/vamp/src/products.nw (revision 8741) @@ -1,36 +1,32 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP products code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: products.nw 314 2010-04-17 20:32:33Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Products} <<[[products.f90]]>>= ! products.f90 -- <> module products use kinds implicit none private public :: dot, sp, spc - character(len=*), public, parameter :: PRODUCTS_RCS_ID = & - "$Id: products.nw 314 2010-04-17 20:32:33Z ohl $" contains pure function dot (p, q) result (pq) real(kind=default), dimension(0:), intent(in) :: p, q real(kind=default) :: pq pq = p(0)*q(0) - dot_product (p(1:), q(1:)) end function dot pure function sp (p, q) result (sppq) real(kind=default), dimension(0:), intent(in) :: p, q complex(kind=default) :: sppq sppq = cmplx (p(2), p(3), kind=default) * sqrt ((q(0)-q(1))/(p(0)-p(1))) & - cmplx (q(2), q(3), kind=default) * sqrt ((p(0)-p(1))/(q(0)-q(1))) end function sp pure function spc (p, q) result (spcpq) real(kind=default), dimension(0:), intent(in) :: p, q complex(kind=default) :: spcpq spcpq = conjg (sp (p, q)) end function spc end module products @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/specfun.nw =================================================================== --- trunk/vamp/src/specfun.nw (revision 8740) +++ trunk/vamp/src/specfun.nw (revision 8741) @@ -1,184 +1,179 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP specfun code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: specfun.nw 314 2010-04-17 20:32:33Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Special Functions} <<[[specfun.f90]]>>= ! specfun.f90 -- <> module specfun use kinds ! use constants implicit none private <> - character(len=*), public, parameter :: SPECFUN_RCS_ID = & - "$Id: specfun.nw 314 2010-04-17 20:32:33Z ohl $" - !WK: real(kind=default), public, parameter :: & PI = 3.1415926535897932384626433832795028841972_default contains <> end module specfun @ %def specfun @ The algorithm is stolen from the \texttt{FORTRAN} version in routine C303 of the CERN library~\cite{Luk75}. It has an accuracy which is approximately one digit less than machine precision. <>= public :: gamma @ The so-called reflection formula is used for negative arguments: \begin{equation} \Gamma(x)\Gamma(1-x) = \frac{\pi}{\sin\pi x} \end{equation} Here's the identity transformation that pulls the argument of~$\Gamma$ into~$[3,4]$: \begin{equation} \Gamma(u) = \begin{cases} (u-1)\Gamma(u-1) & \text{ for } u > 4 \\ \frac{1}{u}\Gamma(u+1) & \text{ for } u < 3 \end{cases} \end{equation} @ <>= f = 1 if (u < 3) then do i = 1, int (4 - u) f = f / u u = u + 1 end do else do i = 1, int (u - 3) u = u - 1 f = f * u end do end if @ A Chebyshev approximation for~$\Gamma(x)$ is used after mapping ~$x\in[3,4]$ linearly to~$h\in[-1,1]$. The series is evaluted by Clenshaw's recurrence formula: \begin{equation} \label{eq:Clenshaw} \begin{split} d_m & = d_{m+1} = 0 \\ d_j & = 2xd_{j+1} - d_{j+2} + c_j \text{ for } 0 < j < m-1 \\ f(x) = d_0 & = xd_1 - d_2 + \frac{1}{2}c_0 \end{split} \end{equation} @ <>= alpha = 2*g b1 = 0 b2 = 0 do i = 15, 0, -1 b0 = c(i) + alpha * b1 - b2 b2 = b1 b1 = b0 end do g = f * (b0 - g * b2) @ Note that we're assuming that [[c(0)]] is in fact~$c_0/2$. This is for compatibility with the CERN library routines. <>= pure function gamma (x) result (g) real(kind=default), intent(in) :: x real(kind=default) :: g integer :: i real(kind=default) :: u, f, alpha, b0, b1, b2 real(kind=default), dimension(0:15), parameter :: & c = <<$c_0/2,c_1,c_2,\ldots,c_{15}$ for $\Gamma(x)$>> u = x if (u <= 0.0) then if (u == int (u)) then g = huge (g) return else u = 1 - u end if endif <> g = 2*u - 7 <> if (x < 0) then g = PI / (sin (PI * x) * g) end if end function gamma @ %def gamma @ <<$c_0/2,c_1,c_2,\ldots,c_{15}$ for $\Gamma(x)$>>= (/ 3.65738772508338244_default, & 1.95754345666126827_default, & 0.33829711382616039_default, & 0.04208951276557549_default, & 0.00428765048212909_default, & 0.00036521216929462_default, & 0.00002740064222642_default, & 0.00000181240233365_default, & 0.00000010965775866_default, & 0.00000000598718405_default, & 0.00000000030769081_default, & 0.00000000001431793_default, & 0.00000000000065109_default, & 0.00000000000002596_default, & 0.00000000000000111_default, & 0.00000000000000004_default /) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Test} <<[[stest.f90]]>>= ! stest.f90 -- <> module stest_functions use kinds use constants use specfun private <> contains <> end module stest_functions @ %def stest_functions @ <>= public :: gauss_multiplication @ Gauss' multiplication fomula can serve as a non-trivial test \begin{equation} \Gamma(nx) = (2\pi)^{(1-n)/2} n^{nx-1/2} \prod_{k=0}^{n-1}\Gamma(x+k/n) \end{equation} <>= pure function gauss_multiplication (x, n) result (delta) real(kind=default), intent(in) :: x integer, intent(in) :: n real(kind=default) :: delta real(kind=default) :: gxn integer :: k gxn = (2*PI)**(0.5_double*(1-n)) * n**(n*x-0.5_double) do k = 0, n - 1 gxn = gxn * gamma (x + real (k, kind=default) / n) end do delta = abs ((gamma (n*x) - gxn) / gamma (n*x)) end function gauss_multiplication @ %def gauss_multiplication @ <<[[stest.f90]]>>= program stest use kinds use specfun use stest_functions !NODEP! implicit none integer :: i, steps real(kind=default) :: x, g, xmin, xmax xmin = -4.5 xmax = 4.5 steps = 100 ! 9 do i = 0, steps x = xmin + ((xmax - xmin) / real (steps)) * i print "(f6.3,4(1x,e9.2))", x, & gauss_multiplication (x, 2), & gauss_multiplication (x, 3), & gauss_multiplication (x, 4), & gauss_multiplication (x, 5) end do end program stest @ %def stest @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/linalg.nw =================================================================== --- trunk/vamp/src/linalg.nw (revision 8740) +++ trunk/vamp/src/linalg.nw (revision 8741) @@ -1,470 +1,466 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP linalg code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: linalg.nw 314 2010-04-17 20:32:33Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Linear Algebra} <<[[linalg.f90]]>>= ! linalg.f90 -- <> module linalg use kinds use utils implicit none private <> - character(len=*), public, parameter :: LINALG_RCS_ID = & - "$Id: linalg.nw 314 2010-04-17 20:32:33Z ohl $" contains <> end module linalg @ %def linalg @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{LU Decomposition} <>= public :: lu_decompose @ \begin{subequations} \label{eq:LU} \begin{equation} A = LU \end{equation} In more detail \begin{equation} \begin{pmatrix} a_{11} & a_{12} & \ldots & a_{1n} \\ a_{21} & a_{22} & \ldots & a_{2n} \\ \vdots & \vdots & \vdots & \vdots \\ a_{n1} & a_{n2} & \ldots & a_{nn} \end{pmatrix} = \begin{pmatrix} 1 & 0 & \ldots & 0 \\ l_{21} & 1 & \ldots & 0 \\ \vdots & \vdots & \vdots & \vdots \\ l_{n1} & l_{n2} & \ldots & 1 \end{pmatrix} \begin{pmatrix} u_{11} & u_{12} & \ldots & u_{1n} \\ 0 & u_{22} & \ldots & u_{2n} \\ \vdots & \vdots & \vdots & \vdots \\ 0 & 0 & \ldots & u_{nn} \end{pmatrix} \end{equation} \end{subequations} Rewriting~(\ref{eq:LU}) in block matrix notation \begin{equation} \begin{pmatrix} a_{11} & a_{1\cdot} \\ a_{\cdot1} & A \end{pmatrix} = \begin{pmatrix} 1 & 0 \\ l_{\cdot1} & L \end{pmatrix} \begin{pmatrix} u_{11} & u_{1\cdot} \\ 0 & U \end{pmatrix} = \begin{pmatrix} u_{11} & u_{1\cdot} \\ l_{\cdot1} u_{11} & l_{\cdot1} \otimes u_{1\cdot} + LU \end{pmatrix} \end{equation} we can solve it easily \begin{subequations} \begin{align} u_{11} &= a_{11} \\ u_{1\cdot} &= a_{1\cdot} \\ \label{eq:LU1} l_{\cdot1} &= \frac{a_{\cdot1}}{a_{11}} \\ \label{eq:LU2} LU &= A - \frac{a_{\cdot1} \otimes a_{1\cdot}}{a_{11}} \end{align} \end{subequations} and~(\ref{eq:LU1}) and~(\ref{eq:LU2}) define a simple iterative algorithm if we work from the outside in. It just remains to add pivoting. <>= pure subroutine lu_decompose (a, pivots, eps, l, u) real(kind=default), dimension(:,:), intent(inout) :: a integer, dimension(:), intent(out), optional :: pivots real(kind=default), intent(out), optional :: eps real(kind=default), dimension(:,:), intent(out), optional :: l, u real(kind=default), dimension(size(a,dim=1)) :: vv integer, dimension(size(a,dim=1)) :: p integer :: j, pivot <<[[eps = 1]]>> vv = maxval (abs (a), dim=2) if (any (vv == 0.0)) then a = 0.0 <<[[pivots = 0]] and [[eps = 0]]>> return end if vv = 1.0 / vv do j = 1, size (a, dim=1) pivot = j - 1 + sum (maxloc (vv(j:) * abs (a(j:,j)))) if (j /= pivot) then call swap (a(pivot,:), a(j,:)) <<[[eps = - eps]]>> vv(pivot) = vv(j) end if p(j) = pivot if (a(j,j) == 0.0) then a(j,j) = tiny (a(j,j)) end if a(j+1:,j) = a(j+1:,j) / a(j,j) a(j+1:,j+1:) & = a(j+1:,j+1:) - outer_product (a(j+1:,j), a(j,j+1:)) end do <> end subroutine lu_decompose @ %def lu_decompose @ <<[[eps = 1]]>>= if (present (eps)) then eps = 1.0 end if @ <<[[eps = - eps]]>>= if (present (eps)) then eps = - eps end if @ <<[[pivots = 0]] and [[eps = 0]]>>= if (present (pivots)) then pivots = 0 end if if (present (eps)) then eps = 0 end if @ <>= if (present (pivots)) then pivots = p end if if (present (l)) then do j = 1, size (a, dim=1) l(1:j-1,j) = 0.0 l(j,j) = 1.0 l(j+1:,j) = a(j+1:,j) end do do j = size (a, dim=1), 1, -1 call swap (l(j,:), l(p(j),:)) end do end if if (present (u)) then do j = 1, size (a, dim=1) u(1:j,j) = a(1:j,j) u(j+1:,j) = 0.0 end do end if @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Determinant} <>= public :: determinant @ This is a subroutine to comply with F's rules, otherwise, we would code it as a function. \index{inconvenient F constraints} <>= pure subroutine determinant (a, det) real(kind=default), dimension(:,:), intent(in) :: a real(kind=default), intent(out) :: det real(kind=default), dimension(size(a,dim=1),size(a,dim=2)) :: lu integer :: i lu = a call lu_decompose (lu, eps = det) do i = 1, size (a, dim = 1) det = det * lu(i,i) end do end subroutine determinant @ %def determinant @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Diagonalization} The code is an implementation of the algorithm presented in~\cite{Press/etal:1992:NumRecC,Press/etal:1992:NumRec77}, but independent from the code presented in~\cite{Press/etal:1996:NumRec90} to avoid legal problems.\par A Jacobi rotation around the angle~$\phi$ in row~$p$ and column~$q$ \begin{equation} P(\phi;p,q) = \begin{pmatrix} 1 & & & & & \\ & \ddots & & & & \\ & & \cos\phi & \cdots & \sin\phi & \\ & & \vdots & 1 & \vdots & \\ & & -\sin\phi & \cdots & \cos\phi & \\ & & & & & \ddots \\ & & & & & & 1 \end{pmatrix} \end{equation} results in \begin{equation} A' = P^T(\phi;p,q)\cdot A\cdot P(\phi;p,q) = \begin{pmatrix} & & A'_{1p} & & A'_{1q} & \\ & & \vdots & & \vdots & \\ A'_{p1} & \cdots & A'_{pq} & \cdots & A'_{pq} & \cdots & A'_{pn} \\ & & \vdots & & \vdots & \\ A'_{q1} & \cdots & A'_{qp} & \cdots & A'_{qq} & \cdots & A'_{qn} \\ & & \vdots & & \vdots & \\ & & A'_{np} & & A'_{nq} & \end{pmatrix} \end{equation} <>= public :: diagonalize_real_symmetric @ <>= pure subroutine diagonalize_real_symmetric (a, eval, evec, num_rot) real(kind=default), dimension(:,:), intent(in) :: a real(kind=default), dimension(:), intent(out) :: eval real(kind=default), dimension(:,:), intent(out) :: evec integer, intent(out), optional :: num_rot real(kind=default), dimension(size(a,dim=1),size(a,dim=2)) :: aa real(kind=default) :: off_diagonal_norm, threshold, & c, g, h, s, t, tau, cot_2phi logical, dimension(size(eval),size(eval)) :: upper_triangle integer, dimension(size(eval)) :: one_to_ndim integer :: p, q, ndim, j, sweep integer, parameter :: MAX_SWEEPS = 50 ndim = size (eval) one_to_ndim = (/ (j, j=1,ndim) /) upper_triangle = & spread (one_to_ndim, dim=1, ncopies=ndim) & > spread (one_to_ndim, dim=2, ncopies=ndim) aa = a call unit (evec) <> sweeps: do sweep = 1, MAX_SWEEPS off_diagonal_norm = sum (abs (aa), mask=upper_triangle) if (off_diagonal_norm == 0.0) then eval = diag (aa) return end if if (sweep < 4) then threshold = 0.2 * off_diagonal_norm / ndim**2 else threshold = 0.0 end if do p = 1, ndim - 1 do q = p + 1, ndim <> end do end do end do sweeps if (present (num_rot)) then num_rot = -1 end if !!! print *, "linalg::diagonalize_real_symmetric: exceeded sweep count" end subroutine diagonalize_real_symmetric @ %def diagonalize_real_symmetric @ <>= g = 100 * abs (aa (p,q)) if ((sweep > 4) & .and. (g <= min (spacing (aa(p,p)), spacing (aa(q,q))))) then aa(p,q) = 0.0 else if (abs (aa(p,q)) > threshold) then <> <<$A^\prime = P^T(\phi;p,q)\cdot A\cdot P(\phi;p,q)$>> <<$V^\prime = V\cdot P(\phi;p,q)$>> <> end if @ We want \begin{equation} A^\prime_{pq} = (c^2-s^2)A_{pq}+ sc(A_{pp}-A_{qq}) = 0 \end{equation} and therefore \begin{equation} \cot 2\phi = \frac{1-\tan^2\phi}{2\tan\phi} = \frac{\cos^2\phi-\sin^2\phi}{2\sin\phi\cos\phi} = \frac{A_{pp}-A_{qq}}{2A_{pq}} \end{equation} i.e.~with $t = \tan\phi = s/c$ \begin{equation} t^2 + 2t\cot 2\phi - 1 = 0 \end{equation} This quadratic equation has the roots \begin{equation} t = - \cot 2\phi \pm \sqrt{1 + \cot^2 2\phi} = \frac{\epsilon(\cot 2\phi)}% {|\cot 2\phi| \pm \epsilon(\cot 2\phi) \sqrt{1 + \cot^2 2\phi}} \end{equation} and the smaller in magnitude of these is \begin{equation} t = \frac{\epsilon(\cot 2\phi)}{|\cot 2\phi| + \sqrt{1 + \cot^2 2\phi}} \end{equation} and since~$|t|\le1$, it corresponds to~$|\phi|\le\pi/4$. For very large~$\cot 2\phi$ we will use \begin{equation} t = \frac{1}{2\cot 2\phi} = \frac{A_{pq}}{A_{pp}-A_{qq}} \end{equation} \begin{equation} h = A_{qq} - A_{pp} \end{equation} <>= h = aa(q,q) - aa(p,p) if (g <= spacing (h)) then t = aa(p,q) / h else cot_2phi = 0.5 * h / aa(p,q) t = sign (1.0_default, cot_2phi) & / (abs (cot_2phi) + sqrt (1.0 + cot_2phi**2)) end if @ Trivia \begin{subequations} \begin{align} \cos^2\phi &= \frac{\cos^2\phi}{\cos^2\phi+\sin^2\phi} = \frac{1}{1+\tan^2\phi} \\ \sin\phi &= \tan\phi \cos\phi \\ \label{eq:tau} \tau\sin\phi &= \frac{\sin^2}{1+\cos\phi} = \frac{1-\cos^2}{1+\cos\phi} = 1 - \cos\phi \end{align} \end{subequations} <>= c = 1.0 / sqrt (1.0 + t**2) s = t * c tau = s / (1.0 + c) @ \begin{equation} \begin{aligned} A'_{pp} &= c^2A_{pp}+s^2A_{qq}-2scA_{pq} = A_{pp} - tA_{pq} \\ A'_{qq} &= s^2A_{pp}+c^2A_{qq}+2scA_{pq} = A_{qq} + tA_{pq} \\ A'_{pq} &= (c^2-s^2)A_{pq} + sc(A_{pp}-A_{qq}) \end{aligned} \end{equation} <<$A^\prime = P^T(\phi;p,q)\cdot A\cdot P(\phi;p,q)$>>= aa(p,p) = aa(p,p) - t * aa(p,q) aa(q,q) = aa(q,q) + t * aa(p,q) aa(p,q) = 0.0 @ \begin{equation} \begin{aligned} r \not= p < q \not= r: A'_{rp} &= cA_{rp} - sA_{rq} \\ A'_{rq} &= sA_{rp} + cA_{rq} \end{aligned} \end{equation} Here's how we cover the upper triangular region using array notation: \begin{equation} \begin{pmatrix} & \text{[[a(1:p-1,p)]]} & & \text{[[a(1:p-1,q)]]} & \\ \cdots & A_{pq} & \text{[[a(p,p+1:q-1)]]} & A_{pq} & \text{[[a(p,q+1:ndim)]]} \\ & \vdots & & \text{[[a(p+1:q-1,q)]]} & \\ \cdots & A_{qp} & \cdots & A_{qq} & \text{[[a(q,q+1:ndim)]]} \\ & \vdots & & \vdots & \end{pmatrix} \end{equation} <<$A^\prime = P^T(\phi;p,q)\cdot A\cdot P(\phi;p,q)$>>= call jacobi_rotation (s, tau, aa(1:p-1,p), aa(1:p-1,q)) call jacobi_rotation (s, tau, aa(p,p+1:q-1), aa(p+1:q-1,q)) call jacobi_rotation (s, tau, aa(p,q+1:ndim), aa(q,q+1:ndim)) @ Using~(\ref{eq:tau}), we can write the rotation as a perturbation: \begin{equation} \begin{aligned} V'_p &= cV_p - sV_q = V_p - s(V_q + \tau V_p) \\ V'_q &= sV_p + cV_q = V_q + s(V_p - \tau V_q) \end{aligned} \end{equation} <>= pure subroutine jacobi_rotation (s, tau, vp, vq) real(kind=default), intent(in) :: s, tau real(kind=default), dimension(:), intent(inout) :: vp, vq real(kind=default), dimension(size(vp)) :: vp_tmp vp_tmp = vp vp = vp - s * (vq + tau * vp) vq = vq + s * (vp_tmp - tau * vq) end subroutine jacobi_rotation @ %def jacobi_rotation @ <>= private :: jacobi_rotation @ <<$V^\prime = V\cdot P(\phi;p,q)$>>= call jacobi_rotation (s, tau, evec(:,p), evec(:,q)) @ <>= if (present (num_rot)) then num_rot = 0 end if @ <>= if (present (num_rot)) then num_rot = num_rot + 1 end if @ <>= pure subroutine unit (u) real(kind=default), dimension(:,:), intent(out) :: u integer :: i u = 0.0 do i = 1, min (size (u, dim = 1), size (u, dim = 2)) u(i,i) = 1.0 end do end subroutine unit @ %def unit @ <>= pure function diag (a) result (d) real(kind=default), dimension(:,:), intent(in) :: a real(kind=default), dimension(min(size(a,dim=1),size(a,dim=2))) :: d integer :: i do i = 1, min (size (a, dim = 1), size (a, dim = 2)) d(i) = a(i,i) end do end function diag @ %def diag @ <>= public :: unit, diag @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Test} <<[[la_sample.f90]]>>= ! la_sample.f90 -- <> program la_sample use kinds use utils use tao_random_numbers use linalg implicit none integer, parameter :: N = 200 real(kind=default), dimension(N,N) :: a, evec, a0, l, u, NAG_bug real(kind=default), dimension(N) :: b, eval real(kind=default) :: d integer :: i call system_clock (i) call tao_random_seed (i) print *, i do i = 1, N call tao_random_number (a(:,i)) end do NAG_bug = (a + transpose (a)) / 2 a = NAG_bug a0 = a call lu_decompose (a, l=l, u=u) a = matmul (l, u) print *, maxval (abs(a-a0)) call determinant (a, d) print *, d call diagonalize_real_symmetric (a, eval, evec) print *, product (eval) stop call sort (eval, evec) do i = 1, N b = matmul (a, evec(:,i)) - eval(i) * evec(:,i) write (unit = *, fmt = "(A,I3, 2(A,E11.4))") & "eval #", i, " = ", eval(i), ", |(A-lambda)V|_infty = ", & maxval (abs(b)) / maxval (abs(evec(:,i))) end do end program la_sample @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/divisions.nw =================================================================== --- trunk/vamp/src/divisions.nw (revision 8740) +++ trunk/vamp/src/divisions.nw (revision 8741) @@ -1,1678 +1,1674 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP divisions code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: divisions.nw 314 2010-04-17 20:32:33Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Implementation} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{The Abstract Datatype \texttt{division}} <<[[divisions.f90]]>>= ! divisions.f90 -- <> module divisions use kinds use exceptions use vamp_stat use utils use iso_fortran_env implicit none private <> <> <> <> <> - character(len=*), public, parameter :: DIVISIONS_RCS_ID = & - "$Id: divisions.nw 314 2010-04-17 20:32:33Z ohl $" contains <> end module divisions @ \begin{dubious} [[vamp_apply_equivalences]] from [[vamp]] accesses [[%variance]] \ldots \end{dubious} <>= type, public :: division_t ! private !!! Avoiding a g95 bug real(kind=default), dimension(:), pointer :: x => null () real(kind=default), dimension(:), pointer :: integral => null () real(kind=default), dimension(:), pointer & :: variance => null () ! public :: variance => null () ! real(kind=default), dimension(:), pointer :: efficiency => null () real(kind=default) :: x_min, x_max real(kind=default) :: x_min_true, x_max_true real(kind=default) :: dx, dxg integer :: ng = 0 logical :: stratified = .true. end type division_t @ %def division_t @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Creation, Manipulation \&\ Injection} <>= public :: create_division, create_empty_division public :: copy_division, delete_division public :: set_rigid_division, reshape_division @ <>= elemental subroutine create_division & (d, x_min, x_max, x_min_true, x_max_true) type(division_t), intent(out) :: d real(kind=default), intent(in) :: x_min, x_max real(kind=default), intent(in), optional :: x_min_true, x_max_true allocate (d%x(0:1), d%integral(1), d%variance(1)) ! allocate (d%efficiency(1)) d%x(0) = 0.0 d%x(1) = 1.0 d%x_min = x_min d%x_max = x_max d%dx = d%x_max - d%x_min d%stratified = .false. d%ng = 1 d%dxg = 1.0 / d%ng if (present (x_min_true)) then d%x_min_true = x_min_true else d%x_min_true = x_min end if if (present (x_max_true)) then d%x_max_true = x_max_true else d%x_max_true = x_max end if end subroutine create_division @ %def create_division @ <>= elemental subroutine create_empty_division (d) type(division_t), intent(out) :: d nullify (d%x, d%integral, d%variance) ! nullify (d%efficiency) end subroutine create_empty_division @ %def create_empty_division @ <>= elemental subroutine set_rigid_division (d, ng) type(division_t), intent(inout) :: d integer, intent(in) :: ng d%stratified = ng > 1 d%ng = ng d%dxg = real (ubound (d%x, dim=1), kind=default) / d%ng end subroutine set_rigid_division @ %def set_rigid_division @ \begin{equation} [[dxg]] = \frac{n_{\text{div}}}{n_g} \end{equation} such that $0 < [[cell]]\cdot[[dxg]] < n_{\text{div}}$ <>= elemental subroutine reshape_division (d, max_num_div, ng, use_variance) type(division_t), intent(inout) :: d integer, intent(in) :: max_num_div integer, intent(in), optional :: ng logical, intent(in), optional :: use_variance real(kind=default), dimension(:), allocatable :: old_x, m integer :: num_div, equ_per_adap if (present (ng)) then if (max_num_div > 1) then d%stratified = ng > 1 else d%stratified = .false. end if else d%stratified = .false. end if if (d%stratified) then d%ng = ng <> else num_div = max_num_div d%ng = 1 end if d%dxg = real (num_div, kind=default) / d%ng allocate (old_x(0:ubound(d%x,dim=1)), m(ubound(d%x,dim=1))) old_x = d%x <> <> d%x = rebin (m, old_x, num_div) deallocate (old_x, m) end subroutine reshape_division @ %def reshape_division @ <>= if (present (use_variance)) then if (use_variance) then m = rebinning_weights (d%variance) else m = 1.0 end if else m = 1.0 end if @ %def m @ <>= if (ubound (d%x, dim=1) /= num_div) then deallocate (d%x, d%integral, d%variance) ! deallocate (d%efficiency) allocate (d%x(0:num_div), d%integral(num_div), d%variance(num_div)) ! allocate (d%efficiency(num_div)) end if @ \begin{empcmds} vardef layout = pair ul, ur, ll, lr; ypart (ul) = ypart (ur); ypart (ll) = ypart (lr); xpart (ul) = xpart (ll); xpart (ur) = xpart (lr); numeric weight_width, weight_dist; weight_width = 0.1w; weight_dist = 0.05w; ll = (.1w,.1w); ur = (w-weight_width-weight_dist,h-weight_width-weight_dist); numeric equ_div, adap_div, rx, ry, rxp, rxm, ryp, rym; equ_div = 3; adap_div = 8; rx = 5.2; ry = 3.6; rxp = ceiling rx; rxm = floor rx; ryp = ceiling ry; rym = floor ry; numeric pi; pi = 180; vardef adap_fct_x (expr x) = (x + sind(2*x*pi)/8) enddef; vardef weight_x (expr x) = (1 + 2*sind(1*x*pi)**2) / 3 enddef; vardef adap_fct_y (expr x) = (x + sind(4*x*pi)/16) enddef; vardef weight_y (expr x) = (1 + 2*sind(2*x*pi)**2) / 3 enddef; vardef grid_pos (expr i, j) = (adap_fct_y(j/adap_div))[(adap_fct_x(i/adap_div))[ll,lr], (adap_fct_x(i/adap_div))[ul,ur]] enddef; vardef grid_square (expr i, j) = grid_pos (i,j) -- grid_pos (i+1,j) -- grid_pos (i+1,j+1) -- grid_pos (i,j+1) -- cycle enddef; enddef; vardef decoration = fill (lr shifted (weight_y(0)*(weight_width,0)) for y = .1 step .1 until 1.01: .. y[lr,ur] shifted (weight_y(y)*(weight_width,0)) endfor -- ur -- lr -- cycle) shifted (weight_dist,0) withcolor 0.7white; fill (ul shifted (weight_x(0)*(0,weight_width)) for x = .1 step .1 until 1.01: .. x[ul,ur] shifted (weight_x(x)*(0,weight_width)) endfor -- ur -- ul -- cycle) shifted (0,weight_dist) withcolor 0.7white; picture px, py; px = btex $p_1(x_1)$ etex; py = btex $p_2(x_2)$ etex; label.top (image (unfill bbox px; draw px), .5[ul,ur] shifted (0,weight_dist)); label.rt (image (unfill bbox py; draw py), .75[lr,ur] shifted (weight_dist,0)); label.lrt (btex \texttt{domain(1,1)} etex, ll); label.bot (btex $x_1$ etex, .5[ll,lr]); label.llft (btex \texttt{domain(2,1)} etex, lr); label.ulft (btex \texttt{domain(1,2)} etex, ll); label.lft (btex $x_2$ etex, .5[ll,ul]); label.llft (btex \texttt{domain(2,2)} etex, ul); enddef; \end{empcmds} \begin{figure} \begin{center} \begin{emp}(90,70) layout; fill grid_square (rxm,rym) withcolor 0.7white; pickup pencircle scaled .7pt; for i = 0 upto adap_div: draw grid_pos(i,0) -- grid_pos(i,adap_div); draw grid_pos(0,i) -- grid_pos(adap_div,i); endfor pickup pencircle scaled 2pt; drawdot grid_pos(rx,ry); decoration; \end{emp} \end{center} \caption{\label{fig:nonstrat}% \texttt{vegas} grid structure for non-stratified sampling. N.B.: the grid and the weight functions~$p_{1,2}$ are only in qualitative agreement.} \end{figure} \begin{figure} \begin{center} \begin{emp}(90,70) layout; vardef grid_sub_pos (expr i, di, j, dj) = (dj/equ_div)[(di/equ_div)[grid_pos(i,j),grid_pos(i+1,j)], (di/equ_div)[grid_pos(i,j+1),grid_pos(i+1,j+1)]] enddef; vardef grid_sub_square (expr i, di, j, dj) = grid_sub_pos (i,di,j,dj) -- grid_sub_pos (i,di+1,j,dj) -- grid_sub_pos (i,di+1,j,dj+1) -- grid_sub_pos (i,di,j,dj+1) -- cycle enddef; fill grid_square (rxm,rym) withcolor 0.8white; fill grid_sub_square (rxm,0,rym,1) withcolor 0.6white; pickup pencircle scaled .7pt; for i = 0 upto adap_div: draw grid_pos(i,0) -- grid_pos(i,adap_div); draw grid_pos(0,i) -- grid_pos(adap_div,i); endfor pickup pencircle scaled .5pt; for i = 0 upto (adap_div-1): for j = 1 upto (equ_div-1): draw grid_sub_pos(i,j,0,0) -- grid_sub_pos(i,j,adap_div,0) dashed evenly; draw grid_sub_pos(0,0,i,j) -- grid_sub_pos(adap_div,0,i,j) dashed evenly; endfor endfor pickup pencircle scaled 2pt; drawdot grid_pos(rx,ry); decoration; \end{emp} \end{center} \caption{\label{fig:strat}% \texttt{vegas} grid structure for genuinely stratified sampling, which is used in low dimensions. N.B.: the grid and the weight functions~$p_{1,2}$ are only in qualitative agreement.} \end{figure} Genuinely stratified sampling will superimpose an equidistant grid on the adaptive grid, as shown in figure~\ref{fig:strat}. \begin{table} \begin{center} \begin{tabular}{c|c} $n_{\text{dim}}$ & $N_{\text{calls}}^{\max}(n_g=25)$\\\hline 2 & $1\cdot10^{3}$ \\ 3 & $3\cdot10^{4}$ \\ 4 & $8\cdot10^{5}$ \\ 5 & $2\cdot10^{7}$ \\ 6 & $5\cdot10^{8}$ \end{tabular} \end{center} \caption{\label{tab:dimen}% To stratify or not to stratify.} \end{table} Obviously, this is only possible when the number of cells of the stratification grid is large enough, specifically when $n_g \ge n_{\text{div}}^{\min} = n_{\text{div}}^{\max}/2 = 25$). This condition can be met by a high number of sampling points or by a low dimensionality of the integration region (cf.~table~\ref{tab:dimen}).\par @ For a low number of sampling points and high dimensions, genuinely stratified sampling is impossible, because we would have to reduce the number~$n_{\text{div}}$ of adaptive divisions too far. Instead, we keep [[stratified]] false which will tell the integration routine not to concentrate the grid in the regions where the contribution to the error is largest, but to use importance sampling, i.\,e.~concentrating the grid in the regions where the contribution to the value is largest.\par In this case, the rigid grid is much coarser than the adaptive grid and furthermore, the boundaries of the cells overlap in general. The interplay of the two grids during the sampling process is shown in figure~\ref{fig:grids}.\par @ First we determine the (integer) number~$k$ of equidistant divisions of an adaptive cell for at most~$n_{\text{div}}^{\max}$ divisions of the adaptive grid \begin{subequations} \begin{equation} k = \left\lfloor \frac{n_g}{n_{\text{div}}^{\max}} \right\rfloor + 1 \end{equation} and the corresponding number~$n_{\text{div}}$ of adaptive divisions \begin{equation} n_{\text{div}} = \left\lfloor \frac{n_g}{k} \right\rfloor \end{equation} Finally, adjust~$n_g$ to an exact multiple of~$n_{\text{div}}$ \begin{equation} n_g = k \cdot n_{\text{div}} \end{equation} \end{subequations} <>= if (d%ng >= max_num_div / 2) then d%stratified = .true. equ_per_adap = d%ng / max_num_div + 1 num_div = d%ng / equ_per_adap if (num_div < 2) then d%stratified = .false. num_div = 2 d%ng = 1 else if (mod (num_div,2) == 1) then num_div = num_div - 1 d%ng = equ_per_adap * num_div else d%ng = equ_per_adap * num_div end if else d%stratified = .false. num_div = max_num_div d%ng = 1 end if @ %def num_div ng @ Figure~\ref{fig:grids} on page~\pageref{fig:grids} is a one-dimensional illustration of the sampling algorithm. In each cell of the rigid equidistant grid, two random points are selected (or $N_{\text{calls}}$ in the not stratified case). For each point, the corresponding cell and relative coordinate in the adaptive grid is found, \emph{as if the adaptive grid was equidistant} (upper arrow). Then this point is mapped according to the adapted grid (lower arrow) and the proper Jacobians are applied to the weight. \begin{equation} \prod_{j=1}^n \,(x^j_i-x^j_{i-1}) \cdot N^n = \text{Vol}(\text{cell}') \cdot \frac{1}{\text{Vol}(\text{cell})} = \frac{1}{p(x^j_i)} \end{equation} \begin{figure} \begin{center} \begin{emp}(120,30) pseudo (.3w, .8w, .1h, .8h, 0, 8, 8, 0, 12, 12, 5.2, true, true); \end{emp} \end{center} \caption{\label{fig:grids}% One-dimensional illustration of the \texttt{vegas} grid structure for pseudo stratified sampling, which is used in high dimensions.} \end{figure} <>= public :: inject_division, inject_division_short @ %def inject_division inject_division_short @ <>= elemental subroutine inject_division (d, r, cell, x, x_mid, idx, wgt) type(division_t), intent(in) :: d real(kind=default), intent(in) :: r integer, intent(in) :: cell real(kind=default), intent(out) :: x, x_mid integer, intent(out) :: idx real(kind=default), intent(out) :: wgt real(kind=default) :: delta_x, xi integer :: i xi = (cell - r) * d%dxg + 1.0 <> idx = i x_mid = d%x_min + 0.5 * (d%x(i-1) + d%x(i)) * d%dx end subroutine inject_division @ %def inject_division @ <>= i = max (min (int (xi), ubound (d%x, dim=1)), 1) delta_x = d%x(i) - d%x(i-1) x = d%x_min + (d%x(i-1) + (xi - i) * delta_x) * d%dx wgt = delta_x * ubound (d%x, dim=1) @ <>= elemental subroutine inject_division_short (d, r, x, idx, wgt) type(division_t), intent(in) :: d real(kind=default), intent(in) :: r integer, intent(out) :: idx real(kind=default), intent(out) :: x, wgt real(kind=default) :: delta_x, xi integer :: i xi = r * ubound (d%x, dim=1) + 1.0 <> idx = i end subroutine inject_division_short @ %def inject_division_short @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Grid Refinement} <>= public :: record_integral, record_variance, clear_integral_and_variance ! public :: record_efficiency @ <>= elemental subroutine record_integral (d, i, f) type(division_t), intent(inout) :: d integer, intent(in) :: i real(kind=default), intent(in) :: f d%integral(i) = d%integral(i) + f if (.not. d%stratified) then d%variance(i) = d%variance(i) + f*f end if end subroutine record_integral @ %def record_integral @ <>= elemental subroutine record_variance (d, i, var_f) type(division_t), intent(inout) :: d integer, intent(in) :: i real(kind=default), intent(in) :: var_f if (d%stratified) then d%variance(i) = d%variance(i) + var_f end if end subroutine record_variance @ %def record_variance @ <>= elemental subroutine record_efficiency (d, i, eff) type(division_t), intent(inout) :: d integer, intent(in) :: i real(kind=default), intent(in) :: eff ! d%efficiency(i) = d%efficiency(i) + eff end subroutine record_efficiency @ %def record_efficiency @ <>= elemental subroutine clear_integral_and_variance (d) type(division_t), intent(inout) :: d d%integral = 0.0 d%variance = 0.0 ! d%efficiency = 0.0 end subroutine clear_integral_and_variance @ %def clear_integral_and_variance @ <>= public :: refine_division @ <>= elemental subroutine refine_division (d) type(division_t), intent(inout) :: d character(len=*), parameter :: FN = "refine_division" d%x = rebin (rebinning_weights (d%variance), d%x, size (d%variance)) end subroutine refine_division @ %def refine_division @ Smooth the $d_i = \bar f_i \Delta x_i$ \begin{equation} \begin{aligned} d_1 &\to \frac{1}{2}(d_1+d_2) \\ d_2 &\to \frac{1}{3}(d_1+d_2+d_3) \\ &\ldots\\ d_{n-1} &\to \frac{1}{3}(d_{n-2}+d_{n-1}+d_n) \\ d_n &\to \frac{1}{2}(d_{n-1}+d_n) \end{aligned} \end{equation} As long as the initial $[[num_div]] \ge 6$, we know that $[[num_div]] \ge 3$. @ <>= integer, private, parameter :: MIN_NUM_DIV = 3 @ %def MIN_NUM_DIV @ Here the \texttt{Fortran90} array notation really shines, but we have to handle the cases $\text{[[nd]]}\le2$ specially, because the [[quadrupole]] option can lead to small [[nd]]s. The equivalent \texttt{Fortran77} code~\cite{Lepage:1980:vegas} is orders of magnitude less obvious~\footnote{Some old timers call this a feature, however.} Also protect against vanishing~$d_i$ that will blow up the logarithm. \begin{equation} m_i = \left( \frac{\frac{\bar f_i \Delta x_i}{\sum_j\bar f_j \Delta x_j}-1} {\ln\left(\frac{\bar f_i \Delta x_i}{\sum_j\bar f_j \Delta x_j}\right)} \right)^\alpha \end{equation} <>= pure function rebinning_weights (d) result (m) real(kind=default), dimension(:), intent(in) :: d real(kind=default), dimension(size(d)) :: m real(kind=default), dimension(size(d)) :: smooth_d real(kind=default), parameter :: ALPHA = 1.5 integer :: nd <> nd = size (d) if (nd > 2) then smooth_d(1) = (d(1) + d(2)) / 2.0 smooth_d(2:nd-1) = (d(1:nd-2) + d(2:nd-1) + d(3:nd)) / 3.0 smooth_d(nd) = (d(nd-1) + d(nd)) / 2.0 else smooth_d = d end if if (all (smooth_d < tiny (1.0_default))) then m = 1.0_default else smooth_d = smooth_d / sum (smooth_d) where (smooth_d < tiny (1.0_default)) smooth_d = tiny (1.0_default) end where where (smooth_d /= 1._default) m = ((smooth_d - 1.0) / (log (smooth_d)))**ALPHA elsewhere m = 1.0_default endwhere end if end function rebinning_weights @ %def rebinning_weights @ <>= private :: rebinning_weights @ \begin{dubious} \index{system dependencies} \index{IEEE hacks} The [[NaN]] test is probably not portable: \end{dubious} <>= if (any (d /= d)) then m = 1.0 return end if @ Take a binning~[[x]] and return a new binning with [[num_div]] bins with the [[m]] homogeneously distributed: <>= pure function rebin (m, x, num_div) result (x_new) real(kind=default), dimension(:), intent(in) :: m real(kind=default), dimension(0:), intent(in) :: x integer, intent(in) :: num_div real(kind=default), dimension(0:num_div) :: x_new integer :: i, k real(kind=default) :: step, delta step = sum (m) / num_div k = 0 delta = 0.0 x_new(0) = x(0) do i = 1, num_div - 1 <> <> end do x_new(num_div) = 1.0 end function rebin @ %def rebin @ %def k delta x_new @ <>= private :: rebin @ \begin{figure} \begin{center} \begin{empgraph}(70,30) randomseed := 720.251; pickup pencircle scaled 0.7pt; path m[], g[]; numeric pi; pi = 180; numeric dx; dx = 0.05; numeric dg; dg = -0.04; vardef adap_fct (expr x) = (x + sind(4*x*pi)/16) enddef; autogrid (,); frame.bot; setrange (0, 0, 1, 1.2); for x = 0 step dx until 1+dx/2: numeric r; r = 1 + normaldeviate/10; augment.m[x] (adap_fct (x), r); augment.m[x] (adap_fct (x+dx), r); augment.m[x] (adap_fct (x+dx), 0); augment.m[x] (adap_fct (x), 0); augment.g[x] (adap_fct (x), 0); augment.g[x] (adap_fct (x), dg); endfor for x = 0 step dx until 1-dx/2: gfill m[x] -- cycle withcolor 0.7white; gdraw m[x] -- cycle; endfor for x = 0 step dx until 1+dx/2: gdraw g[x]; endfor glabel.bot (btex $x_0$ etex, (adap_fct (0*dx), dg)); glabel.bot (btex $x_1$ etex, (adap_fct (1*dx), dg)); glabel.bot (btex $x_2$ etex, (adap_fct (2*dx), dg)); glabel.bot (btex $x_{n-1}$ etex, (adap_fct (1-dx), dg)); glabel.bot (btex $x_n$ etex, (adap_fct (1), dg)); glabel.lft (btex $\displaystyle \bar f_i\approx\frac{m_i}{\Delta x_i}$ etex, OUT); \end{empgraph} \end{center} \caption{\label{fig:rebin}% Typical weights used in the rebinning algorithm.} \end{figure} We increment~$k$ until another $\Delta$ (a.\,k.\,a.~[[step]]) of the integral has been accumulated (cf.~figure~\ref{fig:rebin}). The mismatch will be corrected below. <>= do if (step <= delta) then exit end if k = k + 1 delta = delta + m(k) end do delta = delta - step @ %def k delta @ <>= x_new(i) = x(k) - (x(k) - x(k-1)) * delta / m(k) @ %def x_new @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Probability Density} <>= public :: probability @ \begin{equation} \xi = \frac{x-x_{\min}}{x_{\max}-x_{\min}} \in [0,1] \end{equation} and \begin{equation} \int_{x_{\min}}^{x_{\max}}\!\textrm{d}x\; p(x) = 1 \end{equation} <>= elemental function probability (d, x) result (p) type(division_t), intent(in) :: d real(kind=default), intent(in) :: x real(kind=default) :: p real(kind=default) :: xi integer :: hi, mid, lo xi = (x - d%x_min) / d%dx if ((xi >= 0) .and. (xi <= 1)) then lo = lbound (d%x, dim=1) hi = ubound (d%x, dim=1) bracket: do if (lo >= hi - 1) then p = 1.0 / (ubound (d%x, dim=1) * d%dx * (d%x(hi) - d%x(hi-1))) return end if mid = (hi + lo) / 2 if (xi > d%x(mid)) then lo = mid else hi = mid end if end do bracket else p = 0 end if end function probability @ %def probability @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Quadrupole} <>= public :: quadrupole_division @ <>= elemental function quadrupole_division (d) result (q) type(division_t), intent(in) :: d real(kind=default) :: q !!! q = value_spread_percent (rebinning_weights (d%variance)) q = standard_deviation_percent (rebinning_weights (d%variance)) end function quadrupole_division @ %def quadrupole_division @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Forking and Joining} The goal is to split a division in such a way, that we can later sample the pieces separately and combine the results. <>= public :: fork_division, join_division, sum_division @ \begin{dubious} Caveat emptor: splitting divisions can lead to $[[num_div]]<3$ and the application \emph{must not} try to refine such grids before merging them again! \end{dubious} <>= pure subroutine fork_division (d, ds, sum_calls, num_calls, exc) type(division_t), intent(in) :: d type(division_t), dimension(:), intent(inout) :: ds integer, intent(in) :: sum_calls integer, dimension(:), intent(inout) :: num_calls type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "fork_division" integer, dimension(size(ds)) :: n0, n1 integer, dimension(0:size(ds)) :: n, ds_ng integer :: i, j, num_div, num_forks, nx real(kind=default), dimension(:), allocatable :: d_x, d_integral, d_variance ! real(kind=default), dimension(:), allocatable :: d_efficiency num_div = ubound (d%x, dim=1) num_forks = size (ds) if (d%ng == 1) then <> else if (num_div >= num_forks) then if (modulo (d%ng, num_div) == 0) then <> else <> end if else if (present (exc)) then call raise_exception (exc, EXC_FATAL, FN, "internal error") end if num_calls = 0 end if end subroutine fork_division @ %def fork_division @ <>= pure subroutine join_division (d, ds, exc) type(division_t), intent(inout) :: d type(division_t), dimension(:), intent(in) :: ds type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "join_division" integer, dimension(size(ds)) :: n0, n1 integer, dimension(0:size(ds)) :: n, ds_ng integer :: i, j, num_div, num_forks, nx real(kind=default), dimension(:), allocatable :: d_x, d_integral, d_variance ! real(kind=default), dimension(:), allocatable :: d_efficiency num_div = ubound (d%x, dim=1) num_forks = size (ds) if (d%ng == 1) then <> else if (num_div >= num_forks) then if (modulo (d%ng, num_div) == 0) then <> else <> end if else if (present (exc)) then call raise_exception (exc, EXC_FATAL, FN, "internal error") end if end if end subroutine join_division @ %def join_division @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Importance Sampling} Importance sampling ([[d%ng == 1]]) is trivial, since we can just sample [[size(ds)]] copies of the same grid with (almost) the same number of points <>= if (d%stratified) then call raise_exception (exc, EXC_FATAL, FN, & "ng == 1 incompatiple w/ stratification") else call copy_division (ds, d) num_calls(2:) = ceiling (real (sum_calls) / num_forks) num_calls(1) = sum_calls - sum (num_calls(2:)) end if @ and sum up the results in the end: <>= call sum_division (d, ds) @ Note, however, that this is only legitimate as long as [[d%ng == 1]] implies [[d%stratified == .false.]], because otherwise the sampling code would be incorrect (cf.~[[var_f]] on page~\pageref{pg:var_f}). @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Stratified Sampling} For stratified sampling, we have to work a little harder, because there are just two points per cell and we have to slice along the lines of the stratification grid. Actually, we are slicing along the adaptive grid, since it has a reasonable size. Slicing along the stratification grid could be done using the method below. However, in this case \emph{very} large adaptive grids would be shipped from one process to the other and the comunication costs will outweigh the gains fom paralell processing. <>= n = (num_div * (/ (j, j=0,num_forks) /)) / num_forks n0(1:num_forks) = n(0:num_forks-1) n1(1:num_forks) = n(1:num_forks) @ <>= <> do i = 1, num_forks call copy_array_pointer (ds(i)%x, d%x(n0(i):n1(i)), lb = 0) call copy_array_pointer (ds(i)%integral, d%integral(n0(i)+1:n1(i))) call copy_array_pointer (ds(i)%variance, d%variance(n0(i)+1:n1(i))) ! call copy_array_pointer (ds(i)%efficiency, d%efficiency(n0(i)+1:n1(i))) ds(i)%x = (ds(i)%x - ds(i)%x(0)) / (d%x(n1(i)) - d%x(n0(i))) end do ds%x_min = d%x_min + d%dx * d%x(n0) ds%x_max = d%x_min + d%dx * d%x(n1) ds%dx = ds%x_max - ds%x_min ds%x_min_true = d%x_min_true ds%x_max_true = d%x_max_true ds%stratified = d%stratified ds%ng = (d%ng * (n1 - n0)) / num_div num_calls = sum_calls !: this is a misnomer, it remains ``calls per cell'' here ds%dxg = real (n1 - n0, kind=default) / ds%ng @ Joining is the exact inverse, but we're only interested in [[d%integral]] and [[d%variance]] for the grid refinement: <>= <> do i = 1, num_forks d%integral(n0(i)+1:n1(i)) = ds(i)%integral d%variance(n0(i)+1:n1(i)) = ds(i)%variance ! d%efficiency(n0(i)+1:n1(i)) = ds(i)%efficiency end do @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Pseudo Stratified Sampling} \begin{figure} \begin{center} \begin{emp}(120,90) pseudo (.3w, .8w, .7h, .9h, 0, 8, 8, 0, 12, 12, 5.2, true, true); % lcm (lcm (3, 8) / 3, 12) pseudo (.3w, .8w, .4h, .6h, 0, 8, 8, 0, 24, 24, 5.2*2, false, true); % forks pseudo (.2w, .7w, .1h, .3h, 0, 2, 8, 0, 6, 24, 5.2*2, false, false); pseudo (.3w, .8w, .1h, .3h, 2, 5, 8, 6, 15, 24, 5.2*2, false, true); pseudo (.4w, .9w, .1h, .3h, 5, 8, 8, 15, 24, 24, 5.2*2, false, false); label.urt (btex \texttt{ds(1)} etex, (.2w, 0)); label.top (btex \texttt{ds(2)} etex, (.5w, 0)); label.ulft (btex \texttt{ds(3)} etex, (.9w, 0)); \end{emp} \end{center} \caption{\label{fig:grids-split}% Forking one dimension~\texttt{d} of a grid into three parts \texttt{ds(1)}, \texttt{ds(2)}, and~\texttt{ds(3)}. The picture illustrates the most complex case of pseudo stratified sampling (cf.~fig.~\ref{fig:grids}).} \end{figure} The coarsest grid covering the division of~$n_g$ bins into~$n_f$ forks has $n_g / \mathop{\textrm{gcd}}(n_f,n_g) = \mathop{\textrm{lcm}}(n_f,n_g) / n_f$ bins per fork. Therefore, we need \begin{equation} \mathop{\textrm{lcm}} \left( \frac{\mathop{\textrm{lcm}}(n_f,n_g)}{n_f}, n_x \right) \end{equation} divisions of the adaptive grid (if~$n_x$ is the number of bins in the original adaptive grid).\par @ Life would be much easier, if we knew that~$n_f$ divides~$n_g$. However, this is hard to maintain in real life applications. We can try to achieve this if possible, but the algorithms must be prepared to handle the general case. <>= nx = lcm (d%ng / gcd (num_forks, d%ng), num_div) ds_ng = (d%ng * (/ (j, j=0,num_forks) /)) / num_forks n = (nx * ds_ng) / d%ng n0(1:num_forks) = n(0:num_forks-1) n1(1:num_forks) = n(1:num_forks) @ <>= <> allocate (d_x(0:nx), d_integral(nx), d_variance(nx)) ! allocate (d_efficiency(nx)) call subdivide (d_x, d%x) call distribute (d_integral, d%integral) call distribute (d_variance, d%variance) ! call distribute (d_efficiency, d%efficiency) do i = 1, num_forks call copy_array_pointer (ds(i)%x, d_x(n0(i):n1(i)), lb = 0) call copy_array_pointer (ds(i)%integral, d_integral(n0(i)+1:n1(i))) call copy_array_pointer (ds(i)%variance, d_variance(n0(i)+1:n1(i))) ! call copy_array_pointer (ds(i)%efficiency, d_efficiency(n0(i)+1:n1(i))) ds(i)%x = (ds(i)%x - ds(i)%x(0)) / (d_x(n1(i)) - d_x(n0(i))) end do ds%x_min = d%x_min + d%dx * d_x(n0) ds%x_max = d%x_min + d%dx * d_x(n1) ds%dx = ds%x_max - ds%x_min ds%x_min_true = d%x_min_true ds%x_max_true = d%x_max_true ds%stratified = d%stratified ds%ng = ds_ng(1:num_forks) - ds_ng(0:num_forks-1) num_calls = sum_calls !: this is a misnomer, it remains ``calls per cell'' here ds%dxg = real (n1 - n0, kind=default) / ds%ng deallocate (d_x, d_integral, d_variance) ! deallocate (d_efficiency) @ <>= <> allocate (d_x(0:nx), d_integral(nx), d_variance(nx)) ! allocate (d_efficiency(nx)) do i = 1, num_forks d_integral(n0(i)+1:n1(i)) = ds(i)%integral d_variance(n0(i)+1:n1(i)) = ds(i)%variance ! d_efficiency(n0(i)+1:n1(i)) = ds(i)%efficiency end do call collect (d%integral, d_integral) call collect (d%variance, d_variance) ! call collect (d%efficiency, d_efficiency) deallocate (d_x, d_integral, d_variance) ! deallocate (d_efficiency) @ <>= private :: subdivide private :: distribute private :: collect @ <>= pure subroutine subdivide (x, x0) real(kind=default), dimension(0:), intent(inout) :: x real(kind=default), dimension(0:), intent(in) :: x0 integer :: i, n, n0 n0 = ubound (x0, dim=1) n = ubound (x, dim=1) / n0 x(0) = x0(0) do i = 1, n x(i::n) = x0(0:n0-1) * real (n - i) / n + x0(1:n0) * real (i) / n end do end subroutine subdivide @ %def subdivide @ <>= pure subroutine distribute (x, x0) real(kind=default), dimension(:), intent(inout) :: x real(kind=default), dimension(:), intent(in) :: x0 integer :: i, n n = ubound (x, dim=1) / ubound (x0, dim=1) do i = 1, n x(i::n) = x0 / n end do end subroutine distribute @ %def distribute @ <>= pure subroutine collect (x0, x) real(kind=default), dimension(:), intent(inout) :: x0 real(kind=default), dimension(:), intent(in) :: x integer :: i, n, n0 n0 = ubound (x0, dim=1) n = ubound (x, dim=1) / n0 do i = 1, n0 x0(i) = sum (x((i-1)*n+1:i*n)) end do end subroutine collect @ %def collect @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Trivia} <>= pure subroutine sum_division (d, ds) type(division_t), intent(inout) :: d type(division_t), dimension(:), intent(in) :: ds integer :: i d%integral = 0.0 d%variance = 0.0 ! d%efficiency = 0.0 do i = 1, size (ds) d%integral = d%integral + ds(i)%integral d%variance = d%variance + ds(i)%variance ! d%efficiency = d%efficiency + ds(i)%efficiency end do end subroutine sum_division @ %def sum_division @ <>= public :: debug_division public :: dump_division @ <>= subroutine debug_division (d, prefix) type(division_t), intent(in) :: d character(len=*), intent(in) :: prefix print "(1x,a,2(a,1x,i3,1x,f10.7))", prefix, ": d%x: ", & lbound(d%x,dim=1), d%x(lbound(d%x,dim=1)), & " ... ", & ubound(d%x,dim=1), d%x(ubound(d%x,dim=1)) print "(1x,a,2(a,1x,i3,1x,f10.7))", prefix, ": d%i: ", & lbound(d%integral,dim=1), d%integral(lbound(d%integral,dim=1)), & " ... ", & ubound(d%integral,dim=1), d%integral(ubound(d%integral,dim=1)) print "(1x,a,2(a,1x,i3,1x,f10.7))", prefix, ": d%v: ", & lbound(d%variance,dim=1), d%variance(lbound(d%variance,dim=1)), & " ... ", & ubound(d%variance,dim=1), d%variance(ubound(d%variance,dim=1)) ! print "(1x,a,2(a,1x,i3,1x,f10.7))", prefix, ": d%e: ", & ! lbound(d%efficiency,dim=1), d%efficiency(lbound(d%efficiency,dim=1)), & ! " ... ", & ! ubound(d%efficiency,dim=1), d%efficiency(ubound(d%efficiency,dim=1)) end subroutine debug_division @ %def debug_division @ <>= subroutine dump_division (d, prefix) type(division_t), intent(in) :: d character(len=*), intent(in) :: prefix ! print "(2(1x,a),100(1x,f10.7))", prefix, ":x: ", d%x print "(2(1x,a),100(1x,f10.7))", prefix, ":x: ", d%x(1:) print "(2(1x,a),100(1x,e10.3))", prefix, ":i: ", d%integral print "(2(1x,a),100(1x,e10.3))", prefix, ":v: ", d%variance ! print "(2(1x,a),100(1x,e10.3))", prefix, ":e: ", d%efficiency end subroutine dump_division @ %def dump_division @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Inquiry} Trivial, but necessary for making [[divisions]] an abstract data type: <>= public :: inside_division, stratified_division public :: volume_division, rigid_division, adaptive_division @ <>= elemental function inside_division (d, x) result (theta) type(division_t), intent(in) :: d real(kind=default), intent(in) :: x logical :: theta theta = (x >= d%x_min_true) .and. (x <= d%x_max_true) end function inside_division @ %def inside_division @ <>= elemental function stratified_division (d) result (yorn) type(division_t), intent(in) :: d logical :: yorn yorn = d%stratified end function stratified_division @ %def stratified_division @ <>= elemental function volume_division (d) result (vol) type(division_t), intent(in) :: d real(kind=default) :: vol vol = d%dx end function volume_division @ %def volume_division @ <>= elemental function rigid_division (d) result (n) type(division_t), intent(in) :: d integer :: n n = d%ng end function rigid_division @ %def rigid_division @ <>= elemental function adaptive_division (d) result (n) type(division_t), intent(in) :: d integer :: n n = ubound (d%x, dim=1) end function adaptive_division @ %def adaptive_division @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Diagnostics} <>= type, public :: div_history private logical :: stratified integer :: ng, num_div real(kind=default) :: x_min, x_max, x_min_true, x_max_true real(kind=default) :: & spread_f_p, stddev_f_p, spread_p, stddev_p, spread_m, stddev_m end type div_history @ %def div_history @ <>= public :: copy_history, summarize_division @ <>= elemental function summarize_division (d) result (s) type(division_t), intent(in) :: d type(div_history) :: s real(kind=default), dimension(:), allocatable :: p, m allocate (p(ubound(d%x,dim=1)), m(ubound(d%x,dim=1))) p = probabilities (d%x) m = rebinning_weights (d%variance) s%ng = d%ng s%num_div = ubound (d%x, dim=1) s%stratified = d%stratified s%x_min = d%x_min s%x_max = d%x_max s%x_min_true = d%x_min_true s%x_max_true = d%x_max_true s%spread_f_p = value_spread_percent (d%integral) s%stddev_f_p = standard_deviation_percent (d%integral) s%spread_p = value_spread_percent (p) s%stddev_p = standard_deviation_percent (p) s%spread_m = value_spread_percent (m) s%stddev_m = standard_deviation_percent (m) deallocate (p, m) end function summarize_division @ %def summarize_division @ <>= private :: probabilities @ <>= pure function probabilities (x) result (p) real(kind=default), dimension(0:), intent(in) :: x real(kind=default), dimension(ubound(x,dim=1)) :: p integer :: num_div num_div = ubound (x, dim=1) p = 1.0 / (x(1:num_div) - x(0:num_div-1)) p = p / sum(p) end function probabilities @ %def probabilities @ <>= subroutine print_history (h, tag) type(div_history), dimension(:), intent(in) :: h character(len=*), intent(in), optional :: tag call write_history (output_unit, h, tag) flush (output_unit) end subroutine print_history @ <>= subroutine write_history (u, h, tag) integer, intent(in) :: u type(div_history), dimension(:), intent(in) :: h character(len=*), intent(in), optional :: tag character(len=BUFFER_SIZE) :: pfx character(len=1) :: s integer :: i if (present (tag)) then pfx = tag else pfx = "[vamp]" end if if ((minval (h%x_min) == maxval (h%x_min)) & .and. (minval (h%x_max) == maxval (h%x_max))) then write (u, "(1X,A11,1X,2X,1X,2(ES10.3,A4,ES10.3,A7))") pfx, & h(1)%x_min, " <= ", h(1)%x_min_true, & " < x < ", h(1)%x_max_true, " <= ", h(1)%x_max else do i = 1, size (h) write (u, "(1X,A11,1X,I2,1X,2(ES10.3,A4,ES10.3,A7))") pfx, & i, h(i)%x_min, " <= ", h(i)%x_min_true, & " < x < ", h(i)%x_max_true, " <= ", h(i)%x_max end do end if write (u, "(1X,A11,1X,A2,2(1X,A3),A1,6(1X,A8))") pfx, & "it", "nd", "ng", "", & "spr(f/p)", "dev(f/p)", "spr(m)", "dev(m)", "spr(p)", "dev(p)" iterations: do i = 1, size (h) if (h(i)%stratified) then s = "*" else s = "" end if write (u, "(1X,A11,1X,I2,2(1X,I3),A1,6(1X,F7.2,A1))") pfx, & i, h(i)%num_div, h(i)%ng, s, & h(i)%spread_f_p, "%", h(i)%stddev_f_p, "%", & h(i)%spread_m, "%", h(i)%stddev_m, "%", & h(i)%spread_p, "%", h(i)%stddev_p, "%" end do iterations flush (u) end subroutine write_history @ %def print_history @ <>= integer, private, parameter :: BUFFER_SIZE = 50 @ %def BUFFER_SIZE @ <>= public :: print_history, write_history @ %def print_history, write_history @ <>= public :: division_x, division_integral public :: division_variance, division_efficiency @ <>= pure subroutine division_x (x, d) real(kind=default), dimension(:), pointer :: x type(division_t), intent(in) :: d call copy_array_pointer (x, d%x, 0) end subroutine division_x @ %def division_x @ <>= pure subroutine division_integral (integral, d) real(kind=default), dimension(:), pointer :: integral type(division_t), intent(in) :: d call copy_array_pointer (integral, d%integral) end subroutine division_integral @ %def division_integral @ <>= pure subroutine division_variance (variance, d) real(kind=default), dimension(:), pointer :: variance type(division_t), intent(in) :: d call copy_array_pointer (variance, d%variance, 0) end subroutine division_variance @ %def division_variance @ <>= pure subroutine division_efficiency (eff, d) real(kind=default), dimension(:), pointer :: eff type(division_t), intent(in) :: d call copy_array_pointer (eff, d%efficiency, 0) end subroutine division_efficiency @ %def division_efficiency @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{I/O} <>= public :: write_division private :: write_division_unit, write_division_name public :: read_division private :: read_division_unit, read_division_name public :: write_division_raw private :: write_division_raw_unit, write_division_raw_name public :: read_division_raw private :: read_division_raw_unit, read_division_raw_name @ <>= interface write_division module procedure write_division_unit, write_division_name end interface interface read_division module procedure read_division_unit, read_division_name end interface interface write_division_raw module procedure write_division_raw_unit, write_division_raw_name end interface interface read_division_raw module procedure read_division_raw_unit, read_division_raw_name end interface @ %def write_division write_division_raw @ %def read_division read_division_raw @ It makes no sense to read or write [[d%integral]], [[d%variance]], and [[d%efficiency]], because they are only used during sampling. <>= subroutine write_division_unit (d, unit, write_integrals) type(division_t), intent(in) :: d integer, intent(in) :: unit logical, intent(in), optional :: write_integrals logical :: write_integrals0 integer :: i write_integrals0 = .false. if (present(write_integrals)) write_integrals0 = write_integrals write (unit = unit, fmt = descr_fmt) "begin type(division_t) :: d" write (unit = unit, fmt = integer_fmt) "ubound(d%x,1) = ", ubound (d%x, dim=1) write (unit = unit, fmt = integer_fmt) "d%ng = ", d%ng write (unit = unit, fmt = logical_fmt) "d%stratified = ", d%stratified write (unit = unit, fmt = double_fmt) "d%dx = ", d%dx write (unit = unit, fmt = double_fmt) "d%dxg = ", d%dxg write (unit = unit, fmt = double_fmt) "d%x_min = ", d%x_min write (unit = unit, fmt = double_fmt) "d%x_max = ", d%x_max write (unit = unit, fmt = double_fmt) "d%x_min_true = ", d%x_min_true write (unit = unit, fmt = double_fmt) "d%x_max_true = ", d%x_max_true write (unit = unit, fmt = descr_fmt) "begin d%x" do i = 0, ubound (d%x, dim=1) if (write_integrals0 .and. i/=0) then write (unit = unit, fmt = double_array_fmt) & i, d%x(i), d%integral(i), d%variance(i) else write (unit = unit, fmt = double_array_fmt) i, d%x(i) end if end do write (unit = unit, fmt = descr_fmt) "end d%x" write (unit = unit, fmt = descr_fmt) "end type(division_t)" end subroutine write_division_unit @ %def write_division_unit @ <>= character(len=*), parameter, private :: & descr_fmt = "(1x,a)", & integer_fmt = "(1x,a15,1x,i15)", & logical_fmt = "(1x,a15,1x,l1)", & double_fmt = "(1x,a15,1x,e30.22)", & double_array_fmt = "(1x,i15,1x,3(e30.22))" @ %def descr_fmt integer_fmt logical_fmt double_fmt double_array_fmt @ <>= subroutine read_division_unit (d, unit, read_integrals) type(division_t), intent(inout) :: d integer, intent(in) :: unit logical, intent(in), optional :: read_integrals logical :: read_integrals0 integer :: i, idum, num_div character(len=80) :: chdum read_integrals0 = .false. if (present(read_integrals)) read_integrals0 = read_integrals read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = integer_fmt) chdum, num_div <> read (unit = unit, fmt = integer_fmt) chdum, d%ng read (unit = unit, fmt = logical_fmt) chdum, d%stratified read (unit = unit, fmt = double_fmt) chdum, d%dx read (unit = unit, fmt = double_fmt) chdum, d%dxg read (unit = unit, fmt = double_fmt) chdum, d%x_min read (unit = unit, fmt = double_fmt) chdum, d%x_max read (unit = unit, fmt = double_fmt) chdum, d%x_min_true read (unit = unit, fmt = double_fmt) chdum, d%x_max_true read (unit = unit, fmt = descr_fmt) chdum do i = 0, ubound (d%x, dim=1) if (read_integrals0 .and. i/=0) then read (unit = unit, fmt = double_array_fmt) & & idum, d%x(i), d%integral(i), d%variance(i) else read (unit = unit, fmt = double_array_fmt) idum, d%x(i) end if end do read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = descr_fmt) chdum if (.not.read_integrals0) then d%integral = 0.0 d%variance = 0.0 ! d%efficiency = 0.0 end if end subroutine read_division_unit @ %def read_division_unit @ \begin{dubious} What happened to [[d%efficiency]]? \end{dubious} <>= if (associated (d%x)) then if (ubound (d%x, dim=1) /= num_div) then deallocate (d%x, d%integral, d%variance) ! deallocate (d%efficiency) allocate (d%x(0:num_div), d%integral(num_div), d%variance(num_div)) ! allocate (d%efficiency(num_div)) end if else allocate (d%x(0:num_div), d%integral(num_div), d%variance(num_div)) ! allocate (d%efficiency(num_div)) end if @ <>= subroutine write_division_name (d, name, write_integrals) type(division_t), intent(in) :: d character(len=*), intent(in) :: name logical, intent(in), optional :: write_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "write", status = "replace", file = name) call write_division_unit (d, unit, write_integrals) close (unit = unit) end subroutine write_division_name @ %def write_division_name @ <>= subroutine read_division_name (d, name, read_integrals) type(division_t), intent(inout) :: d character(len=*), intent(in) :: name logical, intent(in), optional :: read_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "read", status = "old", file = name) call read_division_unit (d, unit, read_integrals) close (unit = unit) end subroutine read_division_name @ %def read_division_name @ <>= subroutine write_division_raw_unit (d, unit, write_integrals) type(division_t), intent(in) :: d integer, intent(in) :: unit logical, intent(in), optional :: write_integrals logical :: write_integrals0 integer :: i write_integrals0 = .false. if (present(write_integrals)) write_integrals0 = write_integrals write (unit = unit) MAGIC_DIVISION_BEGIN write (unit = unit) ubound (d%x, dim=1) write (unit = unit) d%ng write (unit = unit) d%stratified write (unit = unit) d%dx write (unit = unit) d%dxg write (unit = unit) d%x_min write (unit = unit) d%x_max write (unit = unit) d%x_min_true write (unit = unit) d%x_max_true do i = 0, ubound (d%x, dim=1) if (write_integrals0 .and. i/=0) then write (unit = unit) d%x(i), d%integral(i), d%variance(i) else write (unit = unit) d%x(i) end if end do write (unit = unit) MAGIC_DIVISION_END end subroutine write_division_raw_unit @ %def write_division_raw_unit @ <>= integer, parameter, private :: MAGIC_DIVISION = 11111111 integer, parameter, private :: MAGIC_DIVISION_BEGIN = MAGIC_DIVISION + 1 integer, parameter, private :: MAGIC_DIVISION_END = MAGIC_DIVISION + 2 @ <>= subroutine read_division_raw_unit (d, unit, read_integrals) type(division_t), intent(inout) :: d integer, intent(in) :: unit logical, intent(in), optional :: read_integrals logical :: read_integrals0 integer :: i, num_div, magic character(len=*), parameter :: FN = "read_division_raw_unit" read_integrals0 = .false. if (present(read_integrals)) read_integrals0 = read_integrals read (unit = unit) magic if (magic /= MAGIC_DIVISION_BEGIN) then print *, FN, " fatal: expecting magic ", MAGIC_DIVISION_BEGIN, & ", found ", magic stop end if read (unit = unit) num_div <> read (unit = unit) d%ng read (unit = unit) d%stratified read (unit = unit) d%dx read (unit = unit) d%dxg read (unit = unit) d%x_min read (unit = unit) d%x_max read (unit = unit) d%x_min_true read (unit = unit) d%x_max_true do i = 0, ubound (d%x, dim=1) if (read_integrals0 .and. i/=0) then read (unit = unit) d%x(i), d%integral(i), d%variance(i) else read (unit = unit) d%x(i) end if end do if (.not.read_integrals0) then d%integral = 0.0 d%variance = 0.0 ! d%efficiency = 0.0 end if read (unit = unit) magic if (magic /= MAGIC_DIVISION_END) then print *, FN, " fatal: expecting magic ", MAGIC_DIVISION_END, & ", found ", magic stop end if end subroutine read_division_raw_unit @ %def read_division_raw_unit @ <>= subroutine write_division_raw_name (d, name, write_integrals) type(division_t), intent(in) :: d character(len=*), intent(in) :: name logical, intent(in), optional :: write_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "write", status = "replace", & form = "unformatted", file = name) call write_division_unit (d, unit, write_integrals) close (unit = unit) end subroutine write_division_raw_name @ %def write_division_raw_name @ <>= subroutine read_division_raw_name (d, name, read_integrals) type(division_t), intent(inout) :: d character(len=*), intent(in) :: name logical, intent(in), optional :: read_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "read", status = "old", & form = "unformatted", file = name) call read_division_unit (d, unit, read_integrals) close (unit = unit) end subroutine read_division_raw_name @ %def read_division_raw_name @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Marshaling} Note that we can not use the~[[transfer]] intrinsic function for marshalling types that contain pointers that substitute for allocatable array components. [[transfer]] will copy the pointers in this case and not where they point to! <>= public :: marshal_division_size, marshal_division, unmarshal_division @ <>= pure subroutine marshal_division (d, ibuf, dbuf) type(division_t), intent(in) :: d integer, dimension(:), intent(inout) :: ibuf real(kind=default), dimension(:), intent(inout) :: dbuf integer :: num_div num_div = ubound (d%x, dim=1) ibuf(1) = d%ng ibuf(2) = num_div if (d%stratified) then ibuf(3) = 1 else ibuf(3) = 0 end if dbuf(1) = d%x_min dbuf(2) = d%x_max dbuf(3) = d%x_min_true dbuf(4) = d%x_max_true dbuf(5) = d%dx dbuf(6) = d%dxg dbuf(7:7+num_div) = d%x dbuf(8+ num_div:7+2*num_div) = d%integral dbuf(8+2*num_div:7+3*num_div) = d%variance ! dbuf(8+3*num_div:7+4*num_div) = d%efficiency end subroutine marshal_division @ %def marshal_division @ <>= pure subroutine marshal_division_size (d, iwords, dwords) type(division_t), intent(in) :: d integer, intent(out) :: iwords, dwords iwords = 3 dwords = 7 + 3 * ubound (d%x, dim=1) ! dwords = 7 + 4 * ubound (d%x, dim=1) end subroutine marshal_division_size @ %def marshal_division_size @ <>= pure subroutine unmarshal_division (d, ibuf, dbuf) type(division_t), intent(inout) :: d integer, dimension(:), intent(in) :: ibuf real(kind=default), dimension(:), intent(in) :: dbuf integer :: num_div d%ng = ibuf(1) num_div = ibuf(2) d%stratified = ibuf(3) /= 0 d%x_min = dbuf(1) d%x_max = dbuf(2) d%x_min_true = dbuf(3) d%x_max_true = dbuf(4) d%dx = dbuf(5) d%dxg = dbuf(6) <> d%x = dbuf(7:7+num_div) d%integral = dbuf(8+ num_div:7+2*num_div) d%variance = dbuf(8+2*num_div:7+3*num_div) ! d%efficiency = dbuf(8+3*num_div:7+4*num_div) end subroutine unmarshal_division @ %def unmarshal_division @ <>= public :: marshal_div_history_size, marshal_div_history, unmarshal_div_history @ <>= pure subroutine marshal_div_history (h, ibuf, dbuf) type(div_history), intent(in) :: h integer, dimension(:), intent(inout) :: ibuf real(kind=default), dimension(:), intent(inout) :: dbuf ibuf(1) = h%ng ibuf(2) = h%num_div if (h%stratified) then ibuf(3) = 1 else ibuf(3) = 0 end if dbuf(1) = h%x_min dbuf(2) = h%x_max dbuf(3) = h%x_min_true dbuf(4) = h%x_max_true dbuf(5) = h%spread_f_p dbuf(6) = h%stddev_f_p dbuf(7) = h%spread_p dbuf(8) = h%stddev_p dbuf(9) = h%spread_m dbuf(10) = h%stddev_m end subroutine marshal_div_history @ %def marshal_div_history @ <>= pure subroutine marshal_div_history_size (h, iwords, dwords) type(div_history), intent(in) :: h integer, intent(out) :: iwords, dwords iwords = 3 dwords = 10 end subroutine marshal_div_history_size @ %def marshal_div_history_size @ <>= pure subroutine unmarshal_div_history (h, ibuf, dbuf) type(div_history), intent(inout) :: h integer, dimension(:), intent(in) :: ibuf real(kind=default), dimension(:), intent(in) :: dbuf h%ng = ibuf(1) h%num_div = ibuf(2) h%stratified = ibuf(3) /= 0 h%x_min = dbuf(1) h%x_max = dbuf(2) h%x_min_true = dbuf(3) h%x_max_true = dbuf(4) h%spread_f_p = dbuf(5) h%stddev_f_p = dbuf(6) h%spread_p = dbuf(7) h%stddev_p = dbuf(8) h%spread_m = dbuf(9) h%stddev_m = dbuf(10) end subroutine unmarshal_div_history @ %def unmarshal_div_history @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Boring Copying and Deleting of Objects} <>= elemental subroutine copy_division (lhs, rhs) type(division_t), intent(inout) :: lhs type(division_t), intent(in) :: rhs if (associated (rhs%x)) then call copy_array_pointer (lhs%x, rhs%x, lb = 0) else if (associated (lhs%x)) then deallocate (lhs%x) end if if (associated (rhs%integral)) then call copy_array_pointer (lhs%integral, rhs%integral) else if (associated (lhs%integral)) then deallocate (lhs%integral) end if if (associated (rhs%variance)) then call copy_array_pointer (lhs%variance, rhs%variance) else if (associated (lhs%variance)) then deallocate (lhs%variance) end if ! if (associated (rhs%efficiency)) then ! call copy_array_pointer (lhs%efficiency, rhs%efficiency) ! else if (associated (lhs%efficiency)) then ! deallocate (lhs%efficiency) ! end if lhs%dx = rhs%dx lhs%dxg = rhs%dxg lhs%x_min = rhs%x_min lhs%x_max = rhs%x_max lhs%x_min_true = rhs%x_min_true lhs%x_max_true = rhs%x_max_true lhs%ng = rhs%ng lhs%stratified = rhs%stratified end subroutine copy_division @ %def copy_division @ <>= elemental subroutine delete_division (d) type(division_t), intent(inout) :: d if (associated (d%x)) then deallocate (d%x, d%integral, d%variance) ! deallocate (d%efficiency) end if end subroutine delete_division @ %def delete_division @ <>= elemental subroutine copy_history (lhs, rhs) type(div_history), intent(out) :: lhs type(div_history), intent(in) :: rhs lhs%stratified = rhs%stratified lhs%ng = rhs%ng lhs%num_div = rhs%num_div lhs%x_min = rhs%x_min lhs%x_max = rhs%x_max lhs%x_min_true = rhs%x_min_true lhs%x_max_true = rhs%x_max_true lhs%spread_f_p = rhs%spread_f_p lhs%stddev_f_p = rhs%stddev_f_p lhs%spread_p = rhs%spread_p lhs%stddev_p = rhs%stddev_p lhs%spread_m = rhs%spread_m lhs%stddev_m = rhs%stddev_m end subroutine copy_history @ %def copy_history @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/coordinates.nw =================================================================== --- trunk/vamp/src/coordinates.nw (revision 8740) +++ trunk/vamp/src/coordinates.nw (revision 8741) @@ -1,344 +1,342 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP coordinates code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: coordinates.nw 314 2010-04-17 20:32:33Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Coordinates} \label{sec:coordinates} <<[[coordinates.f90]]>>= ! coordinates.f90 -- <> module coordinates use kinds use constants, only: PI use specfun, only: gamma implicit none private <> contains <> end module coordinates @ %def coordinates @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Angular Spherical Coordinates} \begin{equation} \begin{aligned} x_n &= r \cos\theta_{n-2} \\ x_{n-1} &= r \sin\theta_{n-2}\cos\theta_{n-3} \\ &\cdots \\ x_3 &= r \sin\theta_{n-2}\sin\theta_{n-3} \cdots \cos\theta_1 \\ x_2 &= r \sin\theta_{n-2}\sin\theta_{n-3} \cdots \sin\theta_1\cos\phi \\ x_1 &= r \sin\theta_{n-2}\sin\theta_{n-3} \cdots \sin\theta_1\sin\phi \end{aligned} \end{equation} and \begin{equation} J = r^{n-1} \prod_{i=1}^{n-2}\left(\sin\theta_i\right)^i \end{equation} We can minimize the number of multiplications by computing the products \begin{equation} P_j = \prod_{i=j}^{n-2}\sin\theta_i \end{equation} Then \begin{equation} \begin{aligned} x_n &= r \cos\theta_{n-2} \\ x_{n-1} &= r P_{n-2}\cos\theta_{n-3} \\ &\cdots \\ x_3 &= r P_2 \cos\theta_1 \\ x_2 &= r P_1 \cos\phi \\ x_1 &= r P_1\sin\phi \end{aligned} \end{equation} and \begin{equation} J = r^{n-1} \prod_{i=1}^{n-2}P_i \end{equation} Note that~$\theta_i\in[0,\pi]$ and~$\phi\in[0,2\pi]$ or~$\phi\in[-\pi,\pi]$. Therefore~$\sin\theta_i\ge0$ and \begin{equation} \label{eq:sin(theta)} \sin\theta_i = \sqrt{1-\cos^2\theta_i} \end{equation} which is not true for~$\phi$. Since [[sqrt]] is typically much faster than [[sin]] and [[cos]], we use~(\ref{eq:sin(theta)}) where ever possible. @ <>= public :: spherical_to_cartesian_2, & spherical_to_cartesian, spherical_to_cartesian_j @ <>= pure subroutine spherical_to_cartesian_2 (r, phi, theta, x, jacobian) real(kind=default), intent(in) :: r, phi real(kind=default), dimension(:), intent(in) :: theta real(kind=default), dimension(:), intent(out), optional :: x real(kind=default), intent(out), optional :: jacobian real(kind=default), dimension(size(theta)) :: cos_theta real(kind=default), dimension(size(theta)+1) :: product_sin_theta integer :: n, i n = size (theta) + 2 cos_theta = cos (theta) product_sin_theta(n-1) = 1.0_default do i = n - 2, 1, -1 product_sin_theta(i) = & product_sin_theta(i+1) * sqrt (1 - cos_theta(i)**2) end do if (present (x)) then x(1) = r * product_sin_theta(1) * sin (phi) x(2) = r * product_sin_theta(1) * cos (phi) x(3:) = r * product_sin_theta(2:n-1) * cos_theta end if if (present (jacobian)) then jacobian = r**(n-1) * product (product_sin_theta) end if end subroutine spherical_to_cartesian_2 @ %def spherical_to_cartesian_2 @ \begin{dubious} Note that~[[call]] inside of a function breaks [[F]]-compatibility. Here it would be easy to fix, but the inverse can not be coded as a function, unless a type for spherical coordinates is introduced, where [[theta]] could not be assumed shape \ldots \end{dubious} <>= pure function spherical_to_cartesian (r, phi, theta) result (x) real(kind=default), intent(in) :: r, phi real(kind=default), dimension(:), intent(in) :: theta real(kind=default), dimension(size(theta)+2) :: x call spherical_to_cartesian_2 (r, phi, theta, x = x) end function spherical_to_cartesian @ %def spherical_to_cartesian @ <>= pure function spherical_to_cartesian_j (r, phi, theta) & result (jacobian) real(kind=default), intent(in) :: r, phi real(kind=default), dimension(:), intent(in) :: theta real(kind=default) :: jacobian call spherical_to_cartesian_2 (r, phi, theta, jacobian = jacobian) end function spherical_to_cartesian_j @ %def spherical_to_cartesian_j @ <>= public :: cartesian_to_spherical_2, & cartesian_to_spherical, cartesian_to_spherical_j @ <>= pure subroutine cartesian_to_spherical_2 (x, r, phi, theta, jacobian) real(kind=default), dimension(:), intent(in) :: x real(kind=default), intent(out), optional :: r, phi real(kind=default), dimension(:), intent(out), optional :: theta real(kind=default), intent(out), optional :: jacobian real(kind=default) :: local_r real(kind=default), dimension(size(x)-2) :: cos_theta real(kind=default), dimension(size(x)-1) :: product_sin_theta integer :: n, i n = size (x) local_r = sqrt (dot_product (x, x)) if (local_r == 0) then if (present (r)) then r = 0 end if if (present (phi)) then phi = 0 end if if (present (theta)) then theta = 0 end if if (present (jacobian)) then jacobian = 1 end if else product_sin_theta(n-1) = 1 do i = n, 3, -1 if (product_sin_theta(i-1) == 0) then cos_theta(i-2) = 0 else cos_theta(i-2) = x(i) / product_sin_theta(i-1) / local_r end if product_sin_theta(i-2) = & product_sin_theta(i-1) * sqrt (1 - cos_theta(i-2)**2) end do if (present (r)) then r = local_r end if if (present (phi)) then ! Set phi = 0 for vanishing vector if (x(1) == 0 .and. x(2)==0) then phi = 0 else phi = atan2 (x(1), x(2)) end if end if if (present (theta)) then theta = acos (cos_theta) end if if (present (jacobian)) then jacobian = local_r**(1-n) / product (product_sin_theta) end if end if end subroutine cartesian_to_spherical_2 @ %def cartesian_to_spherical_2 @ <>= pure subroutine cartesian_to_spherical (x, r, phi, theta) real(kind=default), dimension(:), intent(in) :: x real(kind=default), intent(out) :: r, phi real(kind=default), dimension(:), intent(out) :: theta call cartesian_to_spherical_2 (x, r, phi, theta) end subroutine cartesian_to_spherical @ %def cartesian_to_spherical @ <>= pure function cartesian_to_spherical_j (x) result (jacobian) real(kind=default), dimension(:), intent(in) :: x real(kind=default) :: jacobian call cartesian_to_spherical_2 (x, jacobian = jacobian) end function cartesian_to_spherical_j @ %def cartesian_to_spherical_j @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Trigonometric Spherical Coordinates} <>= public :: spherical_cos_to_cartesian_2, & spherical_cos_to_cartesian, spherical_cos_to_cartesian_j @ Using the cosine, we have to drop~$P_1$ from the Jacobian <>= pure subroutine spherical_cos_to_cartesian_2 (r, phi, cos_theta, x, jacobian) real(kind=default), intent(in) :: r, phi real(kind=default), dimension(:), intent(in) :: cos_theta real(kind=default), dimension(:), intent(out), optional :: x real(kind=default), intent(out), optional :: jacobian real(kind=default), dimension(size(cos_theta)+1) :: product_sin_theta integer :: n, i n = size (cos_theta) + 2 product_sin_theta(n-1) = 1.0_default do i = n - 2, 1, -1 product_sin_theta(i) = & product_sin_theta(i+1) * sqrt (1 - cos_theta(i)**2) end do if (present (x)) then x(1) = r * product_sin_theta(1) * sin (phi) x(2) = r * product_sin_theta(1) * cos (phi) x(3:) = r * product_sin_theta(2:n-1) * cos_theta end if if (present (jacobian)) then jacobian = r**(n-1) * product (product_sin_theta(2:)) end if end subroutine spherical_cos_to_cartesian_2 @ %def spherical_cos_to_cartesian_2 @ <>= pure function spherical_cos_to_cartesian (r, phi, theta) result (x) real(kind=default), intent(in) :: r, phi real(kind=default), dimension(:), intent(in) :: theta real(kind=default), dimension(size(theta)+2) :: x call spherical_cos_to_cartesian_2 (r, phi, theta, x = x) end function spherical_cos_to_cartesian @ %def spherical_cos_to_cartesian @ <>= pure function spherical_cos_to_cartesian_j (r, phi, theta) & result (jacobian) real(kind=default), intent(in) :: r, phi real(kind=default), dimension(:), intent(in) :: theta real(kind=default) :: jacobian call spherical_cos_to_cartesian_2 (r, phi, theta, jacobian = jacobian) end function spherical_cos_to_cartesian_j @ %def spherical_cos_to_cartesian_j @ <>= public :: cartesian_to_spherical_cos_2, & cartesian_to_spherical_cos, cartesian_to_spherical_cos_j @ <>= pure subroutine cartesian_to_spherical_cos_2 (x, r, phi, cos_theta, jacobian) real(kind=default), dimension(:), intent(in) :: x real(kind=default), intent(out), optional :: r, phi real(kind=default), dimension(:), intent(out), optional :: cos_theta real(kind=default), intent(out), optional :: jacobian real(kind=default) :: local_r real(kind=default), dimension(size(x)-2) :: local_cos_theta real(kind=default), dimension(size(x)-1) :: product_sin_theta integer :: n, i n = size (x) local_r = sqrt (dot_product (x, x)) if (local_r == 0) then if (present (r)) then r = 0 end if if (present (phi)) then phi = 0 end if if (present (cos_theta)) then cos_theta = 0 end if if (present (jacobian)) then jacobian = 1 end if else product_sin_theta(n-1) = 1 do i = n, 3, -1 if (product_sin_theta(i-1) == 0) then local_cos_theta(i-2) = 0 else local_cos_theta(i-2) = x(i) / product_sin_theta(i-1) / local_r end if product_sin_theta(i-2) = & product_sin_theta(i-1) * sqrt (1 - local_cos_theta(i-2)**2) end do if (present (r)) then r = local_r end if if (present (phi)) then ! Set phi = 0 for vanishing vector if (x(1) == 0 .and. x(2)==0) then phi = 0 else phi = atan2 (x(1), x(2)) end if end if if (present (cos_theta)) then cos_theta = local_cos_theta end if if (present (jacobian)) then jacobian = local_r**(1-n) / product (product_sin_theta(2:)) end if end if end subroutine cartesian_to_spherical_cos_2 @ %def cartesian_to_spherical_cos_2 @ <>= pure subroutine cartesian_to_spherical_cos (x, r, phi, cos_theta) real(kind=default), dimension(:), intent(in) :: x real(kind=default), intent(out) :: r, phi real(kind=default), dimension(:), intent(out), optional :: cos_theta call cartesian_to_spherical_cos_2 (x, r, phi, cos_theta) end subroutine cartesian_to_spherical_cos @ %def cartesian_to_spherical_cos @ <>= pure function cartesian_to_spherical_cos_j (x) result (jacobian) real(kind=default), dimension(:), intent(in) :: x real(kind=default) :: jacobian call cartesian_to_spherical_cos_2 (x, jacobian = jacobian) end function cartesian_to_spherical_cos_j @ %def cartesian_to_spherical_cos_j @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Surface of a Sphere} <>= public :: surface @ \begin{equation} \int\mathrm{d}\Omega_n = \frac{2\pi^{n/2}}{\Gamma(n/2)} = S_n \end{equation} <>= pure function surface (n) result (vol) integer, intent(in) :: n real(kind=default) :: vol real(kind=default) :: n_by_2 n_by_2 = 0.5_default * n vol = 2 * PI**n_by_2 / gamma (n_by_2) end function surface @ %def surface @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/vampi.nw =================================================================== --- trunk/vamp/src/vampi.nw (revision 8740) +++ trunk/vamp/src/vampi.nw (revision 8741) @@ -1,1148 +1,1143 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP vampi code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: vampi.nw 314 2010-04-17 20:32:33Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Interface to MPI} The module [[vamp]] makes no specific assumptions about the hardware and software supporting parallel execution. In this section, we present a specific example of a parallel implementation of multi channel sampling using the message passing paradigm.\par The modules [[vamp_serial_mpi]] and [[vamp_parallel_mpi]] are not intended to be [[use]]d directly by application programs. For this purpose, the module [[vampi]] is provided. [[vamp_serial_mpi]] is identical to [[vamp]], but some types, procedures and variables are renamed so that [[vamp_parallel_mpi]] can redefine them: <<[[vampi.f90]]>>= ! vampi.f90 -- <> module vamp_serial_mpi use vamp, & <<[[vamp0_* => vamp_*]]>> - VAMP0_RCS_ID => VAMP_RCS_ID public end module vamp_serial_mpi @ %def vamp_serial_mpi @ [[vamp_parallel_mpi]] contains the non trival MPI code and will be discussed in detail below. <<[[vampi.f90]]>>= module vamp_parallel_mpi use kinds use utils use tao_random_numbers use exceptions use mpi90 use divisions use vamp_serial_mpi !NODEP! use iso_fortran_env implicit none private <> <> <> <> - character(len=*), public, parameter :: VAMPI_RCS_ID = & - "$Id: vampi.nw 314 2010-04-17 20:32:33Z ohl $" contains <> end module vamp_parallel_mpi @ %def vamp_parallel_mpi @ [[vampi]] is now a plug-in replacement for [[vamp]] and \emph{must not} be [[use]]d together with [[vamp]]: <<[[vampi.f90]]>>= module vampi use vamp_serial_mpi !NODEP! use vamp_parallel_mpi !NODEP! public end module vampi @ %def vampi @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Parallel Execution} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Single Channel} <>= public :: vamp_create_grid public :: vamp_discard_integral public :: vamp_reshape_grid public :: vamp_sample_grid public :: vamp_delete_grid @ <<[[vamp0_* => vamp_*]]>>= vamp0_create_grid => vamp_create_grid, & vamp0_discard_integral => vamp_discard_integral, & vamp0_reshape_grid => vamp_reshape_grid, & vamp0_sample_grid => vamp_sample_grid, & vamp0_delete_grid => vamp_delete_grid, & @ <>= subroutine vamp_create_grid & (g, domain, num_calls, num_div, & stratified, quadrupole, covariance, map, exc) type(vamp_grid), intent(inout) :: g real(kind=default), dimension(:,:), intent(in) :: domain integer, intent(in) :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole, covariance real(kind=default), dimension(:,:), intent(in), optional :: map type(exception), intent(inout), optional :: exc integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_create_grid & (g, domain, num_calls, num_div, & stratified, quadrupole, covariance, map, exc) else call vamp_create_empty_grid (g) end if end subroutine vamp_create_grid @ %def vamp_create_grid @ <>= integer, public, parameter :: VAMP_ROOT = 0 @ %def VAMP_ROOT @ <>= subroutine vamp_discard_integral & (g, num_calls, num_div, stratified, quadrupole, covariance, exc) type(vamp_grid), intent(inout) :: g integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole, covariance type(exception), intent(inout), optional :: exc integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_discard_integral & (g, num_calls, num_div, stratified, quadrupole, covariance, exc) end if end subroutine vamp_discard_integral @ %def vamp_discard_integral @ <>= subroutine vamp_reshape_grid & (g, num_calls, num_div, stratified, quadrupole, covariance, exc) type(vamp_grid), intent(inout) :: g integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole, covariance type(exception), intent(inout), optional :: exc integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_reshape_grid & (g, num_calls, num_div, stratified, quadrupole, covariance, exc) end if end subroutine vamp_reshape_grid @ %def vamp_reshape_grid @ NB: [[grids]] has to have [[intent(inout)]] because we will call [[vamp_broadcast_grid]] on it. <>= subroutine vamp_sample_grid & (rng, g, func, iterations, integral, std_dev, avg_chi2, accuracy, & channel, weights, grids, exc, history) type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g integer, intent(in) :: iterations real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 real(kind=default), intent(in), optional :: accuracy integer, intent(in), optional :: channel real(kind=default), dimension(:), intent(in), optional :: weights type(vamp_grid), dimension(:), intent(inout), optional :: grids type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> character(len=*), parameter :: FN = "vamp_sample_grid" real(kind=default) :: local_integral, local_std_dev, local_avg_chi2 type(vamp_grid), dimension(:), allocatable :: gs, gx integer, dimension(:,:), pointer :: d integer :: iteration, i integer :: num_proc, proc_id, num_workers nullify (d) call mpi90_size (num_proc) call mpi90_rank (proc_id) iterate: do iteration = 1, iterations if (proc_id == VAMP_ROOT) then call vamp_distribute_work (num_proc, vamp_rigid_divisions (g), d) num_workers = max (1, product (d(2,:))) end if call mpi90_broadcast (num_workers, VAMP_ROOT) if ((present (grids)) .and. (num_workers > 1)) then call vamp_broadcast_grid (grids, VAMP_ROOT) end if if (proc_id == VAMP_ROOT) then allocate (gs(num_workers), gx(vamp_fork_grid_joints (d))) call vamp_create_empty_grid (gs) call vamp_fork_grid (g, gs, gx, d, exc) do i = 2, num_workers call vamp_send_grid (gs(i), i-1, 0) end do else if (proc_id < num_workers) then call vamp_receive_grid (g, VAMP_ROOT, 0) end if if (proc_id == VAMP_ROOT) then if (num_workers > 1) then call vamp_sample_grid0 & (rng, gs(1), func, channel, weights, grids, exc) else call vamp_sample_grid0 & (rng, g, func, channel, weights, grids, exc) end if else if (proc_id < num_workers) then call vamp_sample_grid0 & (rng, g, func, channel, weights, grids, exc) end if if (proc_id == VAMP_ROOT) then do i = 2, num_workers call vamp_receive_grid (gs(i), i-1, 0) end do call vamp_join_grid (g, gs, gx, d, exc) call vamp0_delete_grid (gs) deallocate (gs, gx) call vamp_refine_grid (g) call vamp_average_iterations & (g, iteration, local_integral, local_std_dev, local_avg_chi2) if (present (history)) then if (iteration <= size (history)) then call vamp_get_history & (history(iteration), g, & local_integral, local_std_dev, local_avg_chi2) else call raise_exception (exc, EXC_WARN, FN, "history too short") end if call vamp_terminate_history (history(iteration+1:)) end if if (present (accuracy)) then if (local_std_dev <= accuracy * local_integral) then call raise_exception (exc, EXC_INFO, FN, & "requested accuracy reached") exit iterate end if end if else if (proc_id < num_workers) then call vamp_send_grid (g, VAMP_ROOT, 0) end if end do iterate if (proc_id == VAMP_ROOT) then deallocate (d) if (present (integral)) then integral = local_integral end if if (present (std_dev)) then std_dev = local_std_dev end if if (present (avg_chi2)) then avg_chi2 = local_avg_chi2 end if end if end subroutine vamp_sample_grid @ %def vamp_sample_grid @ <>= subroutine vamp_delete_grid (g) type(vamp_grid), intent(inout) :: g integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_reshape_grid (g) end if end subroutine vamp_delete_grid @ %def vamp_delete_grid @ <>= public :: vamp_print_history private :: vamp_print_one_history, vamp_print_histories @ <<[[vamp0_* => vamp_*]]>>= vamp0_print_history => vamp_print_history, & @ <>= interface vamp_print_history module procedure vamp_print_one_history, vamp_print_histories end interface @ %def vamp_print_history @ <>= subroutine vamp_print_one_history (h, tag) type(vamp_history), dimension(:), intent(in) :: h character(len=*), intent(in), optional :: tag integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_print_history (h, tag) end if end subroutine vamp_print_one_history @ %def vamp_print_one_history @ <>= subroutine vamp_print_histories (h, tag) type(vamp_history), dimension(:,:), intent(in) :: h character(len=*), intent(in), optional :: tag integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_print_history (h, tag) end if end subroutine vamp_print_histories @ %def vamp_print_histories @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Multi Channel} <>= type, public :: vamp_grids !!! private type(vamp0_grids) :: g0 logical, dimension(:), pointer :: active integer, dimension(:), pointer :: proc real(kind=default), dimension(:), pointer :: integrals, std_devs end type vamp_grids @ %def vamp_grids @ <<[[vamp0_* => vamp_*]]>>= vamp0_grids => vamp_grids, & @ Partially duplicate the API of [[vamp]]: <>= public :: vamp_create_grids public :: vamp_discard_integrals public :: vamp_update_weights public :: vamp_refine_weights public :: vamp_delete_grids public :: vamp_sample_grids @ <<[[vamp0_* => vamp_*]]>>= vamp0_create_grids => vamp_create_grids, & vamp0_discard_integrals => vamp_discard_integrals, & vamp0_update_weights => vamp_update_weights, & vamp0_refine_weights => vamp_refine_weights, & vamp0_delete_grids => vamp_delete_grids, & vamp0_sample_grids => vamp_sample_grids, & @ Call [[vamp_create_grids]] just like the serial version. It will create the actual grids on the root processor and create stubs on the other processors <>= subroutine vamp_create_grids (g, domain, num_calls, weights, maps, & num_div, stratified, quadrupole, exc) type(vamp_grids), intent(inout) :: g real(kind=default), dimension(:,:), intent(in) :: domain integer, intent(in) :: num_calls real(kind=default), dimension(:), intent(in) :: weights real(kind=default), dimension(:,:,:), intent(in), optional :: maps integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole type(exception), intent(inout), optional :: exc integer :: proc_id, nch call mpi90_rank (proc_id) nch = size (weights) allocate (g%active(nch), g%proc(nch), g%integrals(nch), g%std_devs(nch)) if (proc_id == VAMP_ROOT) then call vamp0_create_grids (g%g0, domain, num_calls, weights, maps, & num_div, stratified, quadrupole, exc) else allocate (g%g0%grids(nch), g%g0%weights(nch), g%g0%num_calls(nch)) call vamp_create_empty_grid (g%g0%grids) end if end subroutine vamp_create_grids @ %def vamp_create_grids @ <>= subroutine vamp_discard_integrals & (g, num_calls, num_div, stratified, quadrupole, exc) type(vamp_grids), intent(inout) :: g integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole type(exception), intent(inout), optional :: exc integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_discard_integrals & (g%g0, num_calls, num_div, stratified, quadrupole, exc) end if end subroutine vamp_discard_integrals @ %def vamp_discard_integrals @ <>= subroutine vamp_update_weights & (g, weights, num_calls, num_div, stratified, quadrupole, exc) type(vamp_grids), intent(inout) :: g real(kind=default), dimension(:), intent(in) :: weights integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole type(exception), intent(inout), optional :: exc integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_update_weights & (g%g0, weights, num_calls, num_div, stratified, quadrupole, exc) end if end subroutine vamp_update_weights @ %def vamp_update_weights @ <>= subroutine vamp_refine_weights (g, power) type(vamp_grids), intent(inout) :: g real(kind=default), intent(in), optional :: power integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_refine_weights (g%g0, power) end if end subroutine vamp_refine_weights @ %def vamp_refine_weights @ <>= subroutine vamp_delete_grids (g) type(vamp_grids), intent(inout) :: g character(len=*), parameter :: FN = "vamp_delete_grids" deallocate (g%active, g%proc, g%integrals, g%std_devs) call vamp0_delete_grids (g%g0) end subroutine vamp_delete_grids @ %def vamp_delete_grids @ Call [[vamp_sample_grids]] just like [[vamp0_sample_grids]]. <>= subroutine vamp_sample_grids & (rng, g, func, iterations, integral, std_dev, avg_chi2, & accuracy, history, histories, exc) type(tao_random_state), intent(inout) :: rng type(vamp_grids), intent(inout) :: g integer, intent(in) :: iterations real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 real(kind=default), intent(in), optional :: accuracy type(vamp_history), dimension(:), intent(inout), optional :: history type(vamp_history), dimension(:,:), intent(inout), optional :: histories type(exception), intent(inout), optional :: exc <> character(len=*), parameter :: FN = "vamp_sample_grids" integer :: num_proc, proc_id, nch, ch, iteration real(kind=default), dimension(size(g%g0%weights)) :: weights real(kind=default) :: local_integral, local_std_dev, local_avg_chi2 real(kind=default) :: current_accuracy, waste logical :: distribute_complete_grids call mpi90_size (num_proc) call mpi90_rank (proc_id) nch = size (g%g0%weights) if (proc_id == VAMP_ROOT) then g%active = (g%g0%num_calls >= 2) where (g%active) weights = g%g0%num_calls elsewhere weights = 0.0 endwhere weights = weights / sum (weights) call schedule (weights, num_proc, g%proc, waste) distribute_complete_grids = (waste <= VAMP_MAX_WASTE) end if call mpi90_broadcast (weights, VAMP_ROOT) call mpi90_broadcast (g%active, VAMP_ROOT) call mpi90_broadcast (distribute_complete_grids, VAMP_ROOT) if (distribute_complete_grids) then call mpi90_broadcast (g%proc, VAMP_ROOT) end if iterate: do iteration = 1, iterations if (distribute_complete_grids) then call vamp_broadcast_grid (g%g0%grids, VAMP_ROOT) <> else <> end if <> end do iterate <> end subroutine vamp_sample_grids @ %def vamp_sample_grids @ Setting [[VAMP_MAX_WASTE]] to~$1$ disables the splitting of grids, which doesn't work yet. <>= real(kind=default), private, parameter :: VAMP_MAX_WASTE = 1.0 ! real(kind=default), private, parameter :: VAMP_MAX_WASTE = 0.3 @ %def VAMP_MAX_WASTE @ <>= do ch = 1, nch if (g%active(ch)) then if (proc_id == g%proc(ch)) then call vamp0_discard_integral (g%g0%grids(ch)) <> end if else call vamp_nullify_variance (g%g0%grids(ch)) call vamp_nullify_covariance (g%g0%grids(ch)) end if end do @ Refine the grids after \emph{all} grids have been sampled: <>= do ch = 1, nch if (g%active(ch) .and. (proc_id == g%proc(ch))) then call vamp_refine_grid (g%g0%grids(ch)) if (proc_id /= VAMP_ROOT) then <> end if end if end do @ therefore we use [[vamp_sample_grid0]] instead of [[vamp0_sample_grid]]: <>= call vamp_sample_grid0 & (rng, g%g0%grids(ch), func, ch, weights, g%g0%grids, exc) call vamp_average_iterations & (g%g0%grids(ch), iteration, g%integrals(ch), g%std_devs(ch), local_avg_chi2) if (present (histories)) then if (iteration <= ubound (histories, dim=1)) then call vamp_get_history & (histories(iteration,ch), g%g0%grids(ch), & g%integrals(ch), g%std_devs(ch), local_avg_chi2) else call raise_exception (exc, EXC_WARN, FN, "history too short") end if call vamp`'_terminate_history (histories(iteration+1:,ch)) end if @ <>= if (proc_id == VAMP_ROOT) then do ch = 1, nch if (g%active(ch) .and. (g%proc(ch) /= proc_id)) then <> end if end do call vamp_reduce_channels (g%g0, g%integrals, g%std_devs, g%active) call vamp_average_iterations & (g%g0, iteration, local_integral, local_std_dev, local_avg_chi2) if (present (history)) then if (iteration <= size (history)) then call vamp_get_history & (history(iteration), g%g0, local_integral, local_std_dev, & local_avg_chi2) else call raise_exception (exc, EXC_WARN, FN, "history too short") end if call vamp_terminate_history (history(iteration+1:)) end if end if @ This would be cheaper than [[vamp_broadcast_grid]], but we need the latter to support the adaptive multi channel sampling: <>= do ch = 1, nch if (g%active(ch) .and. (g%proc(ch) /= VAMP_ROOT)) then if (proc_id == VAMP_ROOT) then call vamp_send_grid & (g%g0%grids(ch), g%proc(ch), object (ch, TAG_GRID)) else if (proc_id == g%proc(ch)) then call vamp_receive_grid & (g%g0%grids(ch), VAMP_ROOT, object (ch, TAG_GRID)) end if end if end do @ <>= call mpi90_send (g%integrals(ch), VAMP_ROOT, object (ch, TAG_INTEGRAL)) call mpi90_send (g%std_devs(ch), VAMP_ROOT, object (ch, TAG_STD_DEV)) call vamp_send_grid (g%g0%grids(ch), VAMP_ROOT, object (ch, TAG_GRID)) if (present (histories)) then call vamp_send_history & (histories(iteration,ch), VAMP_ROOT, object (ch, TAG_HISTORY)) end if @ <>= call mpi90_receive (g%integrals(ch), g%proc(ch), object (ch, TAG_INTEGRAL)) call mpi90_receive (g%std_devs(ch), g%proc(ch), object (ch, TAG_STD_DEV)) call vamp_receive_grid (g%g0%grids(ch), g%proc(ch), object (ch, TAG_GRID)) if (present (histories)) then call vamp_receive_history & (histories(iteration,ch), g%proc(ch), object (ch, TAG_HISTORY)) end if @ <>= private :: object @ <>= pure function object (ch, obj) result (tag) integer, intent(in) :: ch, obj integer :: tag tag = 100 * ch + obj end function object @ %def object @ <>= integer, public, parameter :: & TAG_INTEGRAL = 1, & TAG_STD_DEV = 2, & TAG_GRID = 3, & TAG_HISTORY = 6, & TAG_NEXT_FREE = 9 @ %def TAG_INTEGRAL TAG_STD_DEFS TAG_GRID TAG_HISTORY TAG_NEXT_FREE @ <>= if (present (integral)) then call mpi90_broadcast (local_integral, VAMP_ROOT) integral = local_integral end if if (present (std_dev)) then call mpi90_broadcast (local_std_dev, VAMP_ROOT) std_dev = local_std_dev end if if (present (avg_chi2)) then call mpi90_broadcast (local_avg_chi2, VAMP_ROOT) avg_chi2 = local_avg_chi2 end if @ %def integral std_dev avg_chi2 @ <>= if (present (accuracy)) then if (proc_id == VAMP_ROOT) then current_accuracy = local_std_dev / local_integral end if call mpi90_broadcast (current_accuracy, VAMP_ROOT) if (current_accuracy <= accuracy) then call raise_exception (exc, EXC_INFO, FN, & "requested accuracy reached") exit iterate end if end if @ A very simple minded scheduler: maximizes processor utilization and, does not pay attention to communication costs. <>= private :: schedule @ We disfavor the root process a little bit (by starting up with a fake filling ratio of~10\%) so that it is likely to be ready to answer all communication requests. <>= pure subroutine schedule (jobs, num_procs, assign, waste) real(kind=default), dimension(:), intent(in) :: jobs integer, intent(in) :: num_procs integer, dimension(:), intent(out) :: assign real(kind=default), intent(out), optional :: waste integer, dimension(size(jobs)) :: idx real(kind=default), dimension(size(jobs)) :: sjobs real(kind=default), dimension(num_procs) :: fill integer :: job, proc sjobs = jobs / sum (jobs) * num_procs idx = (/ (job, job = 1, size(jobs)) /) call sort (sjobs, idx, reverse = .true.) fill = 0.0 fill(VAMP_ROOT+1) = 0.1 do job = 1, size (sjobs) proc = sum (minloc (fill)) fill(proc) = fill(proc) + sjobs(job) assign(idx(job)) = proc - 1 end do <> end subroutine schedule @ %def schedule @ Assuming equivalent processors and uniform computation costs, the waste is given by the fraction of the time that it spent by the other processors waiting for the processor with the biggest assigment: <>= if (present (waste)) then waste = 1.0 - sum (fill) / (num_procs * maxval (fill)) end if @ Accordingly, if the waste caused by distributing only complete grids, we switch to splitting the grids, just like in single channel sampling. This is \emph{not} the default, because the communication costs are measurably higher for many grids and many processors. \begin{dubious} This version is broken! \end{dubious} <>= do ch = 1, size (g%g0%grids) if (g%active(ch)) then call vamp_discard_integral (g%g0%grids(ch)) if (present (histories)) then call vamp_sample_grid & (rng, g%g0%grids(ch), func, 1, g%integrals(ch), g%std_devs(ch), & channel = ch, weights = weights, grids = g%g0%grids, & history = histories(iteration:iteration,ch)) else call vamp_sample_grid & (rng, g%g0%grids(ch), func, 1, g%integrals(ch), g%std_devs(ch), & channel = ch, weights = weights, grids = g%g0%grids) end if else if (proc_id == VAMP_ROOT) then call vamp_nullify_variance (g%g0%grids(ch)) call vamp_nullify_covariance (g%g0%grids(ch)) end if end if end do if (proc_id == VAMP_ROOT) then call vamp_reduce_channels (g%g0, g%integrals, g%std_devs, g%active) call vamp_average_iterations & (g%g0, iteration, local_integral, local_std_dev, local_avg_chi2) if (present (history)) then if (iteration <= size (history)) then call vamp_get_history & (history(iteration), g%g0, local_integral, local_std_dev, & local_avg_chi2) else call raise_exception (exc, EXC_WARN, FN, "history too short") end if call vamp`'_terminate_history (history(iteration+1:)) end if end if @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Event Generation} This is currently only a syntacical translation \ldots <>= public :: vamp_warmup_grid public :: vamp_warmup_grids public :: vamp_next_event private :: vamp_next_event_single, vamp_next_event_multi @ <<[[vamp0_* => vamp_*]]>>= vamp0_warmup_grid => vamp_warmup_grid, & vamp0_warmup_grids => vamp_warmup_grids, & vamp0_next_event => vamp_next_event, & @ <>= interface vamp_next_event module procedure vamp_next_event_single, vamp_next_event_multi end interface @ <>= subroutine vamp_next_event_single & (x, rng, g, func, weight, channel, weights, grids, exc) real(kind=default), dimension(:), intent(out) :: x type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g real(kind=default), intent(out), optional :: weight integer, intent(in), optional :: channel real(kind=default), dimension(:), intent(in), optional :: weights type(vamp_grid), dimension(:), intent(in), optional :: grids type(exception), intent(inout), optional :: exc <> integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_next_event & (x, rng, g, func, weight, channel, weights, grids, exc) end if end subroutine vamp_next_event_single @ %def vamp_next_event_single @ <>= subroutine vamp_next_event_multi (x, rng, g, func, phi, weight, exc) real(kind=default), dimension(:), intent(out) :: x type(tao_random_state), intent(inout) :: rng type(vamp_grids), intent(inout) :: g real(kind=default), intent(out), optional :: weight type(exception), intent(inout), optional :: exc <> <> integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_next_event (x, rng, g%g0, func, phi, weight, exc) end if end subroutine vamp_next_event_multi @ %def vamp_next_event_multi @ <>= subroutine vamp_warmup_grid (rng, g, func, iterations, exc, history) type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g integer, intent(in) :: iterations type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> call vamp_sample_grid & (rng, g, func, iterations - 1, exc = exc, history = history) call vamp_sample_grid0 (rng, g, func, exc = exc) end subroutine vamp_warmup_grid @ %def vamp_warmup_grid @ <>= subroutine vamp_warmup_grids & (rng, g, func, iterations, history, histories, exc) type(tao_random_state), intent(inout) :: rng type(vamp_grids), intent(inout) :: g integer, intent(in) :: iterations type(vamp_history), dimension(:), intent(inout), optional :: history type(vamp_history), dimension(:,:), intent(inout), optional :: histories type(exception), intent(inout), optional :: exc <> integer :: ch call vamp0_sample_grids (rng, g%g0, func, iterations - 1, exc = exc, & history = history, histories = histories) do ch = 1, size (g%g0%grids) ! if (g%g0%grids(ch)%num_calls >= 2) then call vamp_sample_grid0 (rng, g%g0%grids(ch), func, exc = exc) ! end if end do end subroutine vamp_warmup_grids @ %def vamp_warmup_grids @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{I/O} <>= public :: vamp_write_grid, vamp_read_grid private :: write_grid_unit, write_grid_name private :: read_grid_unit, read_grid_name @ <<[[vamp0_* => vamp_*]]>>= vamp0_write_grid => vamp_write_grid, & vamp0_read_grid => vamp_read_grid, & @ <>= interface vamp_write_grid module procedure write_grid_unit, write_grid_name end interface interface vamp_read_grid module procedure read_grid_unit, read_grid_name end interface @ %def vamp_write_grid @ %def vamp_read_grid @ <>= subroutine write_grid_unit (g, unit) type(vamp_grid), intent(in) :: g integer, intent(in) :: unit integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_write_grid (g, unit) end if end subroutine write_grid_unit @ %def write_grid_unit @ <>= subroutine read_grid_unit (g, unit) type(vamp_grid), intent(inout) :: g integer, intent(in) :: unit integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_read_grid (g, unit) end if end subroutine read_grid_unit @ %def read_grid_unit @ <>= subroutine write_grid_name (g, name) type(vamp_grid), intent(inout) :: g character(len=*), intent(in) :: name integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_write_grid (g, name) end if end subroutine write_grid_name @ %def write_grid_name @ <>= subroutine read_grid_name (g, name) type(vamp_grid), intent(inout) :: g character(len=*), intent(in) :: name integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_read_grid (g, name) end if end subroutine read_grid_name @ %def read_grid_name @ <>= public :: vamp_write_grids, vamp_read_grids private :: write_grids_unit, write_grids_name private :: read_grids_unit, read_grids_name @ <<[[vamp0_* => vamp_*]]>>= vamp0_write_grids => vamp_write_grids, & vamp0_read_grids => vamp_read_grids, & @ <>= interface vamp_write_grids module procedure write_grids_unit, write_grids_name end interface interface vamp_read_grids module procedure read_grids_unit, read_grids_name end interface @ %def vamp_write_grids @ %def vamp_read_grids @ <>= subroutine write_grids_unit (g, unit) type(vamp_grids), intent(in) :: g integer, intent(in) :: unit integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_write_grids (g%g0, unit) end if end subroutine write_grids_unit @ %def write_grids_unit @ <>= subroutine read_grids_unit (g, unit) type(vamp_grids), intent(inout) :: g integer, intent(in) :: unit integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_read_grids (g%g0, unit) end if end subroutine read_grids_unit @ %def read_grids_unit @ <>= subroutine write_grids_name (g, name) type(vamp_grids), intent(inout) :: g character(len=*), intent(in) :: name integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_write_grids (g%g0, name) end if end subroutine write_grids_name @ %def write_grids_name @ <>= subroutine read_grids_name (g, name) type(vamp_grids), intent(inout) :: g character(len=*), intent(in) :: name integer :: proc_id call mpi90_rank (proc_id) if (proc_id == VAMP_ROOT) then call vamp0_read_grids (g%g0, name) end if end subroutine read_grids_name @ %def read_grids_name @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Communicating Grids} <>= public :: vamp_send_grid public :: vamp_receive_grid public :: vamp_broadcast_grid public :: vamp_broadcast_grids @ \begin{dubious} \index{Problems with MPICH} The next two are still kludged. Nicer implementations with one message less per call below, but MPICH does funny things during [[mpi_get_count]], which is called by [[mpi90_receive_pointer]]. \end{dubious} Caveat: this [[vamp_send_grid]] uses \emph{three} tags: [[tag]], [[tag+1]] and [[tag+2]]: <>= subroutine vamp_send_grid (g, target, tag, domain, error) type(vamp_grid), intent(in) :: g integer, intent(in) :: target, tag integer, intent(in), optional :: domain integer, intent(out), optional :: error integer, dimension(2) :: words integer, dimension(:), allocatable :: ibuf real(kind=default), dimension(:), allocatable :: dbuf call vamp_marshal_grid_size (g, words(1), words(2)) allocate (ibuf(words(1)), dbuf(words(2))) call vamp_marshal_grid (g, ibuf, dbuf) call mpi90_send (words, target, tag, domain, error) call mpi90_send (ibuf, target, tag+1, domain, error) call mpi90_send (dbuf, target, tag+2, domain, error) deallocate (ibuf, dbuf) end subroutine vamp_send_grid @ %def vamp_send_grid @ <>= subroutine vamp_receive_grid (g, source, tag, domain, status, error) type(vamp_grid), intent(inout) :: g integer, intent(in) :: source, tag integer, intent(in), optional :: domain type(mpi90_status), intent(out), optional :: status integer, intent(out), optional :: error integer, dimension(2) :: words integer, dimension(:), allocatable :: ibuf real(kind=default), dimension(:), allocatable :: dbuf call mpi90_receive (words, source, tag, domain, status, error) allocate (ibuf(words(1)), dbuf(words(2))) call mpi90_receive (ibuf, source, tag+1, domain, status, error) call mpi90_receive (dbuf, source, tag+2, domain, status, error) call vamp_unmarshal_grid (g, ibuf, dbuf) deallocate (ibuf, dbuf) end subroutine vamp_receive_grid @ %def vamp_receive_grid @ Caveat: the real [[vamp_send_grid]] uses \emph{two} tags: [[tag]] and [[tag+1]]: <>= subroutine vamp_send_grid (g, target, tag, domain, error) type(vamp_grid), intent(in) :: g integer, intent(in) :: target, tag integer, intent(in), optional :: domain integer, intent(out), optional :: error integer :: iwords, dwords integer, dimension(:), allocatable :: ibuf real(kind=default), dimension(:), allocatable :: dbuf call vamp_marshal_grid_size (g, iwords, dwords) allocate (ibuf(iwords), dbuf(dwords)) call vamp_marshal_grid (g, ibuf, dbuf) call mpi90_send (ibuf, target, tag, domain, error) call mpi90_send (dbuf, target, tag+1, domain, error) deallocate (ibuf, dbuf) end subroutine vamp_send_grid @ %def vamp_send_grid @ \begin{dubious} \index{Problems with MPICH} There's something wrone with MPICH: if I call [[mpi90_receive_pointer]] in the opposite order, the low level call to [[mpi_get_count]] bombs for no apparent reason! \end{dubious} \begin{dubious} \index{Problems with MPICH} There are also funky things going on with [[tag]]: [[mpi90_receive_pointer]] should leave it alone, but \ldots \end{dubious} <>= subroutine vamp_receive_grid (g, source, tag, domain, status, error) type(vamp_grid), intent(inout) :: g integer, intent(in) :: source, tag integer, intent(in), optional :: domain type(mpi90_status), intent(out), optional :: status integer, intent(out), optional :: error integer, dimension(:), pointer :: ibuf real(kind=default), dimension(:), pointer :: dbuf nullify (ibuf, dbuf) call mpi90_receive_pointer (dbuf, source, tag+1, domain, status, error) call mpi90_receive_pointer (ibuf, source, tag, domain, status, error) call vamp_unmarshal_grid (g, ibuf, dbuf) deallocate (ibuf, dbuf) end subroutine vamp_receive_grid @ %def vamp_receive_grid @ This if not a good idea, with respect to communication costs. For SMP machines, it appears to be negligible however. <>= interface vamp_broadcast_grid module procedure & vamp_broadcast_one_grid, vamp_broadcast_many_grids end interface @ <>= subroutine vamp_broadcast_one_grid (g, root, domain, error) type(vamp_grid), intent(inout) :: g integer, intent(in) :: root integer, intent(in), optional :: domain integer, intent(out), optional :: error integer, dimension(:), allocatable :: ibuf real(kind=default), dimension(:), allocatable :: dbuf integer :: iwords, dwords, me call mpi90_rank (me) if (me == root) then call vamp_marshal_grid_size (g, iwords, dwords) end if call mpi90_broadcast (iwords, root, domain, error) call mpi90_broadcast (dwords, root, domain, error) allocate (ibuf(iwords), dbuf(dwords)) if (me == root) then call vamp_marshal_grid (g, ibuf, dbuf) end if call mpi90_broadcast (ibuf, root, domain, error) call mpi90_broadcast (dbuf, root, domain, error) if (me /= root) then call vamp_unmarshal_grid (g, ibuf, dbuf) end if deallocate (ibuf, dbuf) end subroutine vamp_broadcast_one_grid @ %def vamp_broadcast_one_grid @ <>= subroutine vamp_broadcast_many_grids (g, root, domain, error) type(vamp_grid), dimension(:), intent(inout) :: g integer, intent(in) :: root integer, intent(in), optional :: domain integer, intent(out), optional :: error integer :: i do i = 1, size(g) call vamp_broadcast_one_grid (g(i), root, domain, error) end do end subroutine vamp_broadcast_many_grids @ %def vamp_broadcast_many_grids @ <>= subroutine vamp_broadcast_grids (g, root, domain, error) type(vamp0_grids), intent(inout) :: g integer, intent(in) :: root integer, intent(in), optional :: domain integer, intent(out), optional :: error integer :: nch, me call mpi90_broadcast (g%sum_chi2, root, domain, error) call mpi90_broadcast (g%sum_integral, root, domain, error) call mpi90_broadcast (g%sum_weights, root, domain, error) call mpi90_rank (me) if (me == root) then nch = size (g%grids) end if call mpi90_broadcast (nch, root, domain, error) if (me /= root) then if (associated (g%grids)) then if (size (g%grids) /= nch) then call vamp0_delete_grid (g%grids) deallocate (g%grids, g%weights, g%num_calls) allocate (g%grids(nch), g%weights(nch), g%num_calls(nch)) call vamp_create_empty_grid (g%grids) end if else allocate (g%grids(nch), g%weights(nch), g%num_calls(nch)) call vamp_create_empty_grid (g%grids) end if end if call vamp_broadcast_grid (g%grids, root, domain, error) call mpi90_broadcast (g%weights, root, domain, error) call mpi90_broadcast (g%num_calls, root, domain, error) end subroutine vamp_broadcast_grids @ %def vamp_broadcast_grids @ <>= public :: vamp_send_history public :: vamp_receive_history <>= subroutine vamp_send_history (g, target, tag, domain, error) type(vamp_history), intent(in) :: g integer, intent(in) :: target, tag integer, intent(in), optional :: domain integer, intent(out), optional :: error integer, dimension(2) :: words integer, dimension(:), allocatable :: ibuf real(kind=default), dimension(:), allocatable :: dbuf call vamp_marshal_history_size (g, words(1), words(2)) allocate (ibuf(words(1)), dbuf(words(2))) call vamp_marshal_history (g, ibuf, dbuf) call mpi90_send (words, target, tag, domain, error) call mpi90_send (ibuf, target, tag+1, domain, error) call mpi90_send (dbuf, target, tag+2, domain, error) deallocate (ibuf, dbuf) end subroutine vamp_send_history @ %def vamp_send_history @ <>= subroutine vamp_receive_history (g, source, tag, domain, status, error) type(vamp_history), intent(inout) :: g integer, intent(in) :: source, tag integer, intent(in), optional :: domain type(mpi90_status), intent(out), optional :: status integer, intent(out), optional :: error integer, dimension(2) :: words integer, dimension(:), allocatable :: ibuf real(kind=default), dimension(:), allocatable :: dbuf call mpi90_receive (words, source, tag, domain, status, error) allocate (ibuf(words(1)), dbuf(words(2))) call mpi90_receive (ibuf, source, tag+1, domain, status, error) call mpi90_receive (dbuf, source, tag+2, domain, status, error) call vamp_unmarshal_history (g, ibuf, dbuf) deallocate (ibuf, dbuf) end subroutine vamp_receive_history @ %def vamp_receive_history @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/constants.nw =================================================================== --- trunk/vamp/src/constants.nw (revision 8740) +++ trunk/vamp/src/constants.nw (revision 8741) @@ -1,21 +1,17 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP constants code as NOWEB source -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: constants.nw 314 2010-04-17 20:32:33Z ohl $ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Mathematical and Physical Constants} <<[[constants.f90]]>>= ! constants.f90 -- <> module constants use kinds implicit none private real(kind=default), public, parameter :: & PI = 3.1415926535897932384626433832795028841972_default - character(len=*), public, parameter :: CONSTANTS_RCS_ID = & - "$Id: constants.nw 314 2010-04-17 20:32:33Z ohl $" end module constants @ %def constants PI @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/tao_random_numbers.nw =================================================================== --- trunk/vamp/src/tao_random_numbers.nw (revision 8740) +++ trunk/vamp/src/tao_random_numbers.nw (revision 8741) @@ -1,1668 +1,1661 @@ -% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- +% tao_random_numbers.nw -- -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP tao_random_numbers code as NOWEB source -% $Id: tao_random_numbers.nw 314 2010-04-17 20:32:33Z ohl $ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \newcommand{\modpoly}{% \;(\text{modulo } z^K+z^L+1)} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{The Art Of Random Numbers} Volume two of Donald E.~Knuth' \textit{The Art of Computer Programming}~\cite{Knuth:1997:TAOCP2} has always been celebrated as a prime reference for random number generation. Recently, the third edition has been published and it contains a gem of a \emph{portable} random number generator. It generates 30-bit integers with the following desirable properties \begin{itemize} \item they pass all the tests from George Marsaglia's ``diehard'' suite of tests for random number generators~\cite{Marsaglia:1996:CD} (but see~\cite{Knuth:1997:TAOCP2} for a caveat regarding the ``birthday-spacing'' test) \item they can be generated with portable signed 32-bit arithmetic (Fortran can't do unsigned arithmetic) \item it is faster than other lagged Fibonacci generators \item it can create at least $2^{30}-2$ independent sequences \end{itemize} We implement the improved versions available as FORTRAN77 code from \begin{verbatim} http://www-cs-faculty.stanford.edu/~uno/programs.html#rng \end{verbatim} that contain a streamlined seeding alorithm with better independence of substreams. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Application Program Interface} A function returning single reals and integers. Note that the static version without the [[tao_random_state]] argument does not require initialization. It will behave as if [[call tao_random_seed(0)]] had been executed. On the other hand, the parallelizable version with the explicit [[tao_random_state]] will fail if none of the [[tao_random_create]] have been called for the state. (This is a deficiency of Fortran90 that can be fixed in Fortran95). \index{deficiencies of Fortran90 that have been fixed in Fortran95} <>= call tao_random_number (r) call tao_random_number (s, r) @ The state of the random number generator comes in two variaties: buffered and raw. The former is much more efficient, but it can be beneficial to flush the buffers and to pass only the raw state in order to save of interprocess communication~(IPC) costs. <>= type(tao_random_state) :: s type(tao_random_raw_state) :: rs @ Subroutines filling arrays of reals and integers: <>= call tao_random_number (a, num = n) call tao_random_number (s, a, num = n) @ Subroutine for changing the seed: <>= call tao_random_seed (seed = seed) call tao_random_seed (s, seed = seed) @ Subroutine for changing the luxury. Per default, use all random numbers: <>= call tao_random_luxury () call tao_random_luxury (s) @ With an integer argument, use the first~[[n]] of each fill of the buffer: <>= call tao_random_luxury (n) call tao_random_luxury (s, n) @ With a floating point argument, use that fraction of each fill of the buffer: <>= call tao_random_luxury (x) call tao_random_luxury (s, x) @ Create a [[tao_random_state]] <>= call tao_random_create (s, seed, buffer_size = buffer_size) call tao_random_create (s, raw_state, buffer_size = buffer_size) call tao_random_create (s, state) @ Create a [[tao_random_raw_state]] <>= call tao_random_create (rs, seed) call tao_random_create (rs, raw_state) call tao_random_create (rs, state) @ Destroy a [[tao_random_state]] or [[tao_random_raw_state]] <>= call tao_random_destroy (s) @ Copy [[tao_random_state]] and [[tao_random_raw_state]] in all four combinations <>= call tao_random_copy (lhs, rhs) lhs = rhs @ <>= call tao_random_flush (s) @ <>= call tao_random_read (s, unit) call tao_random_write (s, unit) @ <>= call tao_random_test (name = name) @ Here is a sample application of random number states: <>= subroutine threads (args, y, state) real, dimension(:), intent(in) :: args real, dimension(:), intent(out) :: y type(tao_random_state) :: state integer :: seed type(tao_random_raw_state), dimension(size(y)) :: states integer :: s call tao_random_number (state, seed) call tao_random_create (states, (/ (s, s=seed,size(y)-1) /)) y = thread (args, states) end function thread @ In this example, we could equivalently pass an integer seed, instead of [[raw_state]]. But in more complicated cases it can be beneficial to have the option of reusing [[raw_state]] in the calling routine. <>= elemental function thread (arg, raw_state) result (y) real, dimension, intent(in) :: arg type(tao_random_raw_state) :: raw_state real :: y type(tao_random_state) :: state real :: r call tao_random_create (state, raw_state) do ... call tao_random_number (state, r) ... end do end function thread @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Low Level Routines} Here the low level routines are \emph{much} more interesting than the high level routines. The latter contain a lot of duplication (made necessary by Fortran's lack of parametric polymorphism) and consist mostly of bookkeeping. We wil therefore start with the former. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Generation of 30-bit Random Numbers} The generator is a subtractive lagged Fibonacci \begin{equation} \label{eq:tao30} X_j = (X_{j-K} - X_{j-L}) \mod 2^{30} \end{equation} with lags~$K=100$ and~$L=37$. <>= integer, parameter, private :: K = 100, L = 37 @ %def K L @ Other good choices for~$K$ and~$L$ are (cf.~\cite{Knuth:1997:TAOCP2}, table~1 in section~3.2.2, p.~29) <>= integer, parameter, private :: K = 55, L = 24 integer, parameter, private :: K = 89, L = 38 integer, parameter, private :: K = 100, L = 37 integer, parameter, private :: K = 127, L = 30 integer, parameter, private :: K = 258, L = 83 integer, parameter, private :: K = 378, L = 107 integer, parameter, private :: K = 607, L = 273 @ A modulus of $2^{30}$ is the largest we can handle in \emph{portable} (i.e.~\emph{signed}) 32-bit arithmetic <>= integer(kind=tao_i32), parameter, private :: M = 2**30 @ %def M @ [[generate]] fills the array $a_1,\ldots,a_n$ with random integers $0 \le a_i < 2^{30}$. We \emph{must} have at least~$n \ge K$. Higher values don't change the results, but make [[generate]] more efficient (about a factor of two, asymptotically). For~$K=100$, DEK recommends~$n \ge 1000$. Best results are obtained using the first~100 random numbers out of~1009. Let's therefore use~1009 as a default buffer size. The user can [[call tao_random_luxury (100)]] him/herself: <>= integer, parameter, private :: DEFAULT_BUFFER_SIZE = 1009 @ %def DEFAULT_BUFFER_SIZE @ Since users are not expected to call [[generate]] directly, we do \emph{not} check for $n \ge K$ and assume that the caller knows what (s)he's doing \ldots <>= pure subroutine generate (a, state) integer(kind=tao_i32), dimension(:), intent(inout) :: a, state integer :: j, n n = size (a) <> end subroutine generate @ %def generate @ <>= private :: generate @ [[state(1:K)]] is already set up properly: <>= a(1:K) = state(1:K) @ The remaining $n-K$ random numbers can be gotten directly from the recursion~(\ref{eq:tao30}). Note that Fortran90's [[modulo]] intrinsic does the right thing, since it guarantees (unlike Fortran77's [[mod]]) that~$0\le[[modulo]](a,m)0$). <>= do j = K+1, n a(j) = modulo (a(j-K) - a(j-L), M) end do @ Do the recursion~(\ref{eq:tao30}) $K$ more times to prepare [[state(1:K)]] for the next invokation of [[generate]]. <>= 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 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Initialization of 30-bit Random Numbers} The non-trivial and most beautiful part is the algorithm to initialize the random number generator state [[state]] with the first $K$~numbers. I haven't studied algebra over finite fields in sufficient depth to consider the mathematics behind it straightforward. The commentary below is rather verbose and reflects my understanding of DEK's rather terse remarks (solution to exercise~3.6-9~\cite{Knuth:1997:TAOCP2}). <>= 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 @ %def seed_static s_last s_virginal @ The static version of [[tao_random_raw_state]]: <>= integer(kind=tao_i32), dimension(K), save, private :: s_state logical, save, private :: s_virginal = .true. @ %def s_state s_virginal @ <>= 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 @ %def 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 @ %def seed_state @ This incarnation of the procedure is [[pure]]. <>= pure subroutine seed_stateless (state, seed) integer(kind=tao_i32), dimension(:), intent(out) :: state integer, optional, intent(in) :: seed <> integer :: seed_value, j, s, t integer(kind=tao_i32), dimension(2*K-1) :: x <> <> <> do <<$p(z)\to p(z)^2 \modpoly$>> <<$p(z)\to zp(z) \modpoly$>> <> end do <> <> end subroutine seed_stateless @ %def seed_stateless @ Any default will do <>= integer, parameter :: DEFAULT_SEED = 0 @ %def DEFAULT_SEED @ These must not be changed: <>= integer, parameter :: MAX_SEED = 2**30 - 3 integer, parameter :: TT = 70 @ %def MAX_SEED TT @ <>= if (present (seed)) then seed_value = modulo (seed, MAX_SEED + 1) else seed_value = DEFAULT_SEED end if @ %def seed_value @ Fill the array $x_1,\ldots,x_K$ with even integers, shifted cyclically by 29 bits. <>= 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 @ Make $x_2$ (and only $x_2$) odd: <>= x(2) = x(2) + 1 @ <>= s = seed_value t = TT - 1 @ Consider the polynomial \begin{equation} p(z) = \sum_{n=1}^K x_n z^{n-1} = x_Kz^{K-1} + \ldots + x_2 z + x_1 \end{equation} We have $p(z)^2 = p(z^2) \mod 2$ because cross terms have an even coefficient and $x_n^2 = x_n \mod 2$. Therefore we can square the polynomial by shifting the coefficients. The coefficients for $n>K$ will be reduced. <<$p(z)\to p(z)^2 \modpoly$>>= x(3:2*K-1:2) = x(2:K) x(2:2*K-2:2) = 0 @ Let's return to the coefficients for $n>K$ generated by the shifting above. Subtract $z^n(z^K + z^L + 1)=z^nz^K(1 + z^{-(K-L)} + z^{-K})$. The coefficient of $z^nz^K$ is left alone, because it doesn't belong to $p(z)$ anyway. <<$p(z)\to p(z)^2 \modpoly$>>= do j = 2*K-1, K+1, -1 x(j-(K-L)) = modulo (x(j-(K-L))-x(j), M) x(j-K)=modulo (x(j-K)-x(j), M) end do @ <<$p(z)\to zp(z) \modpoly$>>= if (modulo (s, 2) == 1) then x(2:K+1) = x(1:K) x(1) = x(K+1) x(L+1) = modulo (x(L+1) - x(K+1), M) end if @ <>= if (s /= 0) then s = s / 2 else t = t - 1 end if if (t <= 0) then exit end if @ <>= state(1:K-L) = x(L+1:K) state(K-L+1:K) = x(1:L) @ <>= do j = 1, 10 call generate (x, state) end do @ <>= interface tao_random_seed module procedure <> end interface @ %def tao_random_seed @ <>= private :: <> @ <>= seed_static, seed_state, seed_raw_state @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Generation of 52-bit Random Numbers} \begin{equation} \label{eq:tao52} X_j = (X_{j-K} + X_{j-L}) \mod 1 \end{equation} <>= real(kind=tao_r64), parameter, private :: M = 1.0_tao_r64 @ %def M @ The state of the internal routines <>= real(kind=tao_r64), dimension(K), save, private :: s_state logical, save, private :: s_virginal = .true. @ %def s_state s_virginal @ <>= pure subroutine generate (a, state) real(kind=tao_r64), dimension(:), intent(inout) :: a real(kind=tao_r64), dimension(:), intent(inout) :: state integer :: j, n n = size (a) <> end subroutine generate @ %def generate @ That's almost identical to the 30-bit version, except that the relative sign is flipped: <>= 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 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Initialization of 52-bit Random Numbers} This incarnation of the procedure is [[pure]]. <>= pure subroutine seed_stateless (state, seed) real(kind=tao_r64), dimension(:), intent(out) :: state integer, optional, intent(in) :: seed <> <> <> <> <> do <<52-bit $p(z)\to p(z)^2 \modpoly$>> <<52-bit $p(z)\to zp(z) \modpoly$>> <> end do <> <> end subroutine seed_stateless @ %def seed_stateless @ <>= private :: seed_stateless @ <>= real(kind=tao_r64), parameter :: ULP = 2.0_tao_r64**(-52) @ %def ULP @ <>= real(kind=tao_r64), dimension(2*K-1) :: x real(kind=tao_r64) :: ss integer :: seed_value, t, s, j @ %def x ss seed_value t s j @ <>= ss = 2*ULP * (seed_value + 2) do j = 1, K x(j) = ss ss = 2*ss if (ss >= 1) then ss = ss - 1 + 2*ULP end if end do x(K+1:2*K-1) = 0.0 @ <>= x(2) = x(2) + ULP @ <<52-bit $p(z)\to p(z)^2 \modpoly$>>= x(3:2*K-1:2) = x(2:K) x(2:2*K-2:2) = 0 @ This works because [[2*K-1]] is odd <<52-bit $p(z)\to p(z)^2 \modpoly$>>= do j = 2*K-1, K+1, -1 x(j-(K-L)) = modulo (x(j-(K-L)) + x(j), M) x(j-K) = modulo (x(j-K) + x(j), M) end do @ <<52-bit $p(z)\to zp(z) \modpoly$>>= if (modulo (s, 2) == 1) THEN x(2:K+1) = x(1:K) x(1) = x(K+1) x(L+1) = modulo (x(L+1) + x(K+1), M) end if @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{The State} <>= type, public :: tao_random_raw_state private integer(kind=tao_i32), dimension(K) :: x end type tao_random_raw_state @ %def tao_random_raw_state @ <>= type, public :: tao_random_state private type(tao_random_raw_state) :: state integer(kind=tao_i32), dimension(:), pointer :: buffer => null () integer :: buffer_end, last end type tao_random_state @ %def tao_random_state @ <>= type, public :: tao_random_raw_state private real(kind=tao_r64), dimension(K) :: x end type tao_random_raw_state @ %def tao_random_raw_state @ <>= type, public :: tao_random_state private type(tao_random_raw_state) :: state real(kind=tao_r64), dimension(:), pointer :: buffer => null () integer :: buffer_end, last end type tao_random_state @ %def tao_random_state @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Creation} <>= interface tao_random_create module procedure <> end interface @ %def tao_random_create @ <>= 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 @ There are no procedures for copying the state of the static generator to or from an explicit [[tao_random_state]]. Users needing this functionality can be expected to handle explicit states anyway. Since the direction of the copying can not be obvious from the type of the argument, such functions would spoil the simplicity of the generic procedure interface. <>= 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 @ %def 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 @ %def 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 @ %def 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 @ %def 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 @ %def 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 @ %def create_raw_state_from_raw_st @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Destruction} @ <>= interface tao_random_destroy module procedure destroy_state, destroy_raw_state end interface @ %def tao_random_destroy @ <>= private :: destroy_state, destroy_raw_state @ <>= elemental subroutine destroy_state (s) type(tao_random_state), intent(inout) :: s deallocate (s%buffer) end subroutine destroy_state @ %def destroy_state @ Currently, this is a no-op, but we might need a non-trivial destruction method in the future <>= elemental subroutine destroy_raw_state (s) type(tao_random_raw_state), intent(inout) :: s end subroutine destroy_raw_state @ %def destroy_raw_state @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Copying} <>= interface tao_random_copy module procedure <> end interface @ %def tao_random_copy @ <>= interface assignment(=) module procedure <> end interface @ <>= public :: assignment(=) private :: <> @ <>= copy_state, copy_raw_state, & copy_raw_state_to_state, copy_state_to_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 @ %def 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 @ %def 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 @ %def 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 @ %def copy_state_to_raw_state @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Flushing} <>= elemental subroutine tao_random_flush (s) type(tao_random_state), intent(inout) :: s s%last = size (s%buffer) end subroutine tao_random_flush @ %def tao_random_flush @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Input and Output} <>= interface tao_random_write module procedure & write_state_unit, write_state_name, & write_raw_state_unit, write_raw_state_name end interface @ %def tao_random_write @ <>= private :: write_state_unit, write_state_name private :: write_raw_state_unit, write_raw_state_name @ <>= interface tao_random_read module procedure & read_state_unit, read_state_name, & read_raw_state_unit, read_raw_state_name end interface @ %def tao_random_read @ <>= private :: read_state_unit, read_state_name private :: read_raw_state_unit, read_raw_state_name @ <>= 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 @ %def 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 @ %def 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 @ %def 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 @ %def read_raw_state_unit @ <>= subroutine write_state_array (a, unit) integer(kind=tao_i32), 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 @ %def write_state_array @ <>= private :: write_state_array @ <>= subroutine read_state_array (a, unit) integer(kind=tao_i32), 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 @ %def read_state_array @ <>= private :: read_state_array @ Reading and writing 52-bit floating point numbers accurately is beyond most Fortran runtime libraries. Their job is simplified considerably if we rescale by~$2^{52}$ before writing. Then the temptation to truncate will not be as overwhelming as before \ldots <>= subroutine write_state_array (a, unit) real(kind=tao_r64), dimension(:), intent(in) :: a integer, intent(in) :: unit integer :: i do i = 1, size (a) write (unit = unit, fmt = "(1x,i10,1x,f30.0)") i, 2.0_tao_r64**52 * a(i) end do end subroutine write_state_array @ %def write_state_array @ <>= private :: write_state_array @ <>= subroutine read_state_array (a, unit) real(kind=tao_r64), dimension(:), intent(inout) :: a integer, intent(in) :: unit real(kind=tao_r64) :: x integer :: i, idum do i = 1, size (a) read (unit = unit, fmt = *) idum, x a(i) = 2.0_tao_r64**(-52) * x end do end subroutine read_state_array @ %def read_state_array @ <>= private :: read_state_array @ <>= 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 @ \index{system dependencies} <>= integer, parameter, private :: MIN_UNIT = 11, MAX_UNIT = 99 @ %def MIN_UNIT MAX_UNIT @ <>= private :: 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 @ %def 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 @ %def 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 @ %def 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 @ %def read_raw_state_name @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Marshaling and Unmarshaling} Note that we can not use the~[[transfer]] intrinsic function for marshalling types that contain pointers that substitute for allocatable array components. [[transfer]] will copy the pointers in this case and not where they point to! <>= 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 @ %def tao_random_marshal_size @ %def tao_random_marshal @ %def tao_random_unmarshal @ <>= 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 @ <>= pure subroutine marshal_state (s, ibuf, dbuf) type(tao_random_state), intent(in) :: s integer, dimension(:), intent(inout) :: ibuf real(kind=tao_r64), 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 @ %def 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 @ %def marshal_state_size @ <>= pure subroutine unmarshal_state (s, ibuf, dbuf) type(tao_random_state), intent(inout) :: s integer, dimension(:), intent(in) :: ibuf real(kind=tao_r64), 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 @ %def marshal_state @ <>= pure subroutine marshal_raw_state (s, ibuf, dbuf) type(tao_random_raw_state), intent(in) :: s integer, dimension(:), intent(inout) :: ibuf real(kind=tao_r64), dimension(:), intent(inout) :: dbuf ibuf(1) = size (s%x) ibuf(2:1+size(s%x)) = s%x end subroutine marshal_raw_state @ %def 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 @ %def 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=tao_r64), dimension(:), intent(in) :: dbuf integer :: buf_size buf_size = ibuf(1) s%x = ibuf(2:1+buf_size) end subroutine unmarshal_raw_state @ %def marshal_raw_state @ <>= pure subroutine marshal_state (s, ibuf, dbuf) type(tao_random_state), intent(in) :: s integer, dimension(:), intent(inout) :: ibuf real(kind=tao_r64), 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 dbuf(1:buf_size) = s%buffer call marshal_raw_state (s%state, ibuf(4:), dbuf(buf_size+1:)) end subroutine marshal_state @ %def 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 dwords = dwords + size(s%buffer) end subroutine marshal_state_size @ %def marshal_state_size @ <>= pure subroutine unmarshal_state (s, ibuf, dbuf) type(tao_random_state), intent(inout) :: s integer, dimension(:), intent(in) :: ibuf real(kind=tao_r64), dimension(:), intent(in) :: dbuf integer :: buf_size s%buffer_end = ibuf(1) s%last = ibuf(2) buf_size = ibuf(3) s%buffer = dbuf(1:buf_size) call unmarshal_raw_state (s%state, ibuf(4:), dbuf(buf_size+1:)) end subroutine unmarshal_state @ %def 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=tao_r64), dimension(:), intent(inout) :: dbuf ibuf(1) = size (s%x) dbuf(1:size(s%x)) = s%x end subroutine marshal_raw_state @ %def 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 dwords = size (s%x) end subroutine marshal_raw_state_size @ %def 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=tao_r64), dimension(:), intent(in) :: dbuf integer :: buf_size buf_size = ibuf(1) s%x = dbuf(1:buf_size) end subroutine unmarshal_raw_state @ %def unmarshal_raw_state @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{High Level Routines} <<[[tao_random_numbers.f90]]>>= ! tao_random_numbers.f90 -- <> module tao_random_numbers use kinds implicit none integer, parameter, private :: tao_i32 = selected_int_kind (9) integer, parameter, private :: tao_r64 = selected_real_kind (15) <> <> <> <> <> <> <> <> - character(len=*), public, parameter :: TAO_RANDOM_NUMBERS_RCS_ID = & - "$Id: tao_random_numbers.nw 314 2010-04-17 20:32:33Z ohl $" contains <> <> end module tao_random_numbers @ %def tao_random_numbers @ <<[[tao52_random_numbers.f90]]>>= ! tao52_random_numbers.f90 -- <> module tao52_random_numbers use kinds implicit none integer, parameter, private :: tao_i32 = selected_int_kind (9) integer, parameter, private :: tao_r64 = selected_real_kind (15) <> <> <> <> <> <> <> <> - character(len=*), public, parameter :: TAO52_RANDOM_NUMBERS_RCS_ID = & - "$Id: tao_random_numbers.nw 314 2010-04-17 20:32:33Z ohl $" contains <> <> end module tao52_random_numbers @ %def tao52_random_numbers @ Ten functions are exported <>= 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 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Single Random Numbers} A random integer $r$ with $0 \le r < 2^{30} = 1073741824$: <>= pure subroutine integer_stateless & (state, buffer, buffer_end, last, r) integer(kind=tao_i32), dimension(:), intent(inout) :: state, buffer integer, intent(in) :: buffer_end integer, intent(inout) :: last integer, intent(out) :: r integer, parameter :: NORM = 1 <> end subroutine integer_stateless @ %def integer_stateless @ <>= <> r = NORM * buffer(last) @ The low level routine [[generate]] will fill an array $a_1,\ldots,a_n$, which will be consumed and refilled like an input buffer. We need at least $n \ge K$ for the call to [[generate]]. <>= integer(kind=tao_i32), 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) @ %def s_buffer s_buffer_end s_last @ Increment the index [[last]] and reload the array [[buffer]], iff this buffer is exhausted. Throughout these routines, [[last]] will point to random number that has just been consumed. For the array filling routines below, this is simpler than pointing to the next waiting number. <>= last = last + 1 if (last > buffer_end) then call generate (buffer, state) last = 1 end if @ A random real $r \in [0,1)$. This is almost identical to [[tao_random_integer]], but we duplicate the code to avoid the function call overhead for speed. <>= pure subroutine real_stateless (state, buffer, buffer_end, last, r) integer(kind=tao_i32), dimension(:), intent(inout) :: state, buffer integer, intent(in) :: buffer_end integer, intent(inout) :: last real(kind=default), intent(out) :: r real(kind=default), parameter :: NORM = 1.0_default / M <> end subroutine real_stateless @ %def real_stateless @ A random real $r \in [0,1)$. <>= pure subroutine real_stateless (state, buffer, buffer_end, last, r) real(kind=tao_r64), dimension(:), intent(inout) :: state, buffer integer, intent(in) :: buffer_end integer, intent(inout) :: last real(kind=default), intent(out) :: r integer, parameter :: NORM = 1 <> end subroutine real_stateless @ %def real_stateless @ The low level routine [[generate]] will fill an array $a_1,\ldots,a_N$, which will be consumed and refilled like an input buffer. <>= real(kind=tao_r64), 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) @ %def s_buffer buffer_end last @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Arrays of Random Numbers} Fill the array $j_1,\ldots,j_\nu$ with random integers $0 \le j_i < 2^{30} = 1073741824$. This has to be done such that the underlying array length in [[generate]] is transparent to the user. At the same time we want to avoid the overhead of calling [[tao_random_real]] $\nu$ times. <>= pure subroutine integer_array_stateless & (state, buffer, buffer_end, last, v, num) integer(kind=tao_i32), 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 <> end subroutine integer_array_stateless @ %def integer_array_stateless @ <>= integer :: nu, done, todo, chunk <> <> v(1:chunk) = NORM * buffer(last+1:last+chunk) do <> <> v(done+1:done+chunk) = NORM * buffer(1:chunk) end do @ <>= if (present (num)) then nu = num else nu = size (v) end if @ [[last]] is used as an offset into the buffer [[buffer]], as usual. [[done]] is an offset into the target. We still have to process all [[nu]] numbers. The first chunk can only use what's left in the buffer. <>= if (last >= buffer_end) then call generate (buffer, state) last = 0 end if done = 0 todo = nu chunk = min (todo, buffer_end - last) @ This logic is a bit weird, but after the first chunk, [[todo]] will either vanish (in which case we're done) or we have consumed all of the buffer and must reload. In any case we can pretend that the next chunk can use the whole buffer. <>= 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 @ <>= pure subroutine real_array_stateless & (state, buffer, buffer_end, last, v, num) integer(kind=tao_i32), dimension(:), intent(inout) :: state, buffer integer, intent(in) :: buffer_end integer, intent(inout) :: last real(kind=default), dimension(:), intent(out) :: v integer, optional, intent(in) :: num real(kind=default), parameter :: NORM = 1.0_default / M <> end subroutine real_array_stateless @ %def real_array_stateless @ Fill the array $v_1,\ldots,v_\nu$ with uniform deviates $v_i \in [0,1)$. <>= pure subroutine real_array_stateless & (state, buffer, buffer_end, last, v, num) real(kind=tao_r64), dimension(:), intent(inout) :: state, buffer integer, intent(in) :: buffer_end integer, intent(inout) :: last real(kind=default), dimension(:), intent(out) :: v integer, optional, intent(in) :: num integer, parameter :: NORM = 1 <> end subroutine real_array_stateless @ %def real_array_stateless @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Procedures With Explicit \texttt{tao\_random\_state}} Unfortunately, this is very boring, but Fortran's lack of parametric polymorphism forces this duplication on us: <>= 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 @ %def integer_state @ <>= elemental subroutine real_state (s, r) type(tao_random_state), intent(inout) :: s real(kind=default), intent(out) :: r call real_stateless (s%state%x, s%buffer, s%buffer_end, s%last, r) end subroutine real_state @ %def real_state @ <>= elemental subroutine real_state (s, r) type(tao_random_state), intent(inout) :: s real(kind=default), intent(out) :: r call real_stateless (s%state%x, s%buffer, s%buffer_end, s%last, r) end subroutine real_state @ %def 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 @ %def integer_array_state @ <>= pure subroutine real_array_state (s, v, num) type(tao_random_state), intent(inout) :: s real(kind=default), 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 @ %def real_array_state @ <>= pure subroutine real_array_state (s, v, num) type(tao_random_state), intent(inout) :: s real(kind=default), 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 @ %def real_array_state @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Static Procedures} First make sure that [[tao_random_seed]] has been called to initialize the generator state: <>= if (s_virginal) then call tao_random_seed () end if @ <>= subroutine integer_static (r) integer, intent(out) :: r <> call integer_stateless (s_state, s_buffer, s_buffer_end, s_last, r) end subroutine integer_static @ %def integer_static @ <>= subroutine real_static (r) real(kind=default), intent(out) :: r <> call real_stateless (s_state, s_buffer, s_buffer_end, s_last, r) end subroutine real_static @ %def real_static @ <>= subroutine real_static (r) real(kind=default), intent(out) :: r <> call real_stateless (s_state, s_buffer, s_buffer_end, s_last, r) end subroutine real_static @ %def real_static @ <>= subroutine integer_array_static (v, num) integer, dimension(:), intent(out) :: v integer, optional, intent(in) :: num <> call integer_array_stateless & (s_state, s_buffer, s_buffer_end, s_last, v, num) end subroutine integer_array_static @ %def integer_array_static @ <>= subroutine real_array_static (v, num) real(kind=default), dimension(:), intent(out) :: v integer, optional, intent(in) :: num <> call real_array_stateless & (s_state, s_buffer, s_buffer_end, s_last, v, num) end subroutine real_array_static @ %def real_array_static @ <>= subroutine real_array_static (v, num) real(kind=default), dimension(:), intent(out) :: v integer, optional, intent(in) :: num <> call real_array_stateless & (s_state, s_buffer, s_buffer_end, s_last, v, num) end subroutine real_array_static @ %def real_array_static @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Generic Procedures} <>= interface tao_random_number module procedure <> end interface @ %def tao_random_number @ <>= integer_static, integer_state, & integer_array_static, integer_array_state, & real_static, real_state, real_array_static, real_array_state @ These are not exported <>= private :: & integer_stateless, integer_array_stateless, & real_stateless, real_array_stateless @ <>= private :: <> @ <>= interface tao_random_number module procedure <> end interface @ <>= real_static, real_state, real_array_static, real_array_state @ Thes are not exported <>= private :: real_stateless, real_array_stateless @ <>= private :: <> @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Luxury} <>= 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 @ %def 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 @ %def 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 @ %def luxury_state_integer @ <>= elemental subroutine luxury_state_real (s, consumption) type(tao_random_state), intent(inout) :: s real(kind=default), intent(in) :: consumption call luxury_state_integer (s, int (consumption * size (s%buffer))) end subroutine luxury_state_real @ %def luxury_state_real @ <>= subroutine luxury_static () <> call luxury_static_integer (size (s_buffer)) end subroutine luxury_static @ %def luxury_static @ <>= subroutine luxury_static_integer (consumption) integer, intent(in) :: consumption <> call luxury_stateless (size (s_buffer), s_buffer_end, s_last, consumption) end subroutine luxury_static_integer @ %def luxury_static_integer @ <>= subroutine luxury_static_real (consumption) real(kind=default), intent(in) :: consumption <> call luxury_static_integer (int (consumption * size (s_buffer))) end subroutine luxury_static_real @ %def luxury_static_real @ <>= interface tao_random_luxury module procedure <> end interface @ %def tao_random_luxury @ <>= private :: luxury_stateless @ <>= private :: <> @ <>= luxury_static, luxury_state, & luxury_static_integer, luxury_state_integer, & luxury_static_real, luxury_state_real @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Testing} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{30-bit} <>= 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 :: & A_2027082 = 995235265 integer, dimension(N) :: a type(tao_random_state) :: s, t integer, dimension(:), allocatable :: ibuf real(kind=tao_r64), dimension(:), allocatable :: dbuf integer :: i, ibuf_size, dbuf_size - print *, TAO_RANDOM_NUMBERS_RCS_ID print *, "testing the 30-bit tao_random_numbers ..." <> <> end subroutine tao_random_test @ %def tao_random_test @ <>= integer, parameter :: & SEED = 310952, & N = 2009, M = 1009, & N_SHORT = 1984 @ DEK's ``official'' test expects~$a_{1009\cdot2009+1}=a_{2027082}=995235265$: <>= ! 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 stop 1 end if @ Deja vu all over again, but 2027081 is factored the other way around this time <>= call tao_random_seed (SEED) do i = 1, M+1 call tao_random_number (a) end do <> @ Now checkpoint the random number generator after~$N_{\text{short}}\cdot M$ numbers <>= 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 <> @ and restart the saved generator <>= do i = 1, N+1 - N_SHORT call tao_random_number (t, a, M) end do <> @ The same story again, but this time saving the copy to a file <>= 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 <> call tao_random_read (s, name) do i = 1, N+1 - N_SHORT call tao_random_number (s, a, M) end do <> end if @ And finally using marshaling/unmarshaling: <>= 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 <> call tao_random_unmarshal (s, ibuf, dbuf) do i = 1, N+1 - N_SHORT call tao_random_number (s, a, M) end do <> @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{52-bit} DEK's ``official'' test expects~$x_{1009\cdot2009+1}=x_{2027082}=0.36410514377569680455$: <>= subroutine tao_random_test (name) character(len=*), optional, intent(in) :: name character(len=*), parameter :: & OK = "(1x,f22.20,' is ok.')", & NOT_OK = "(1x,f22.20,' is not ok, (A_2027082 ',f22.20,')!')" <> real(kind=default), parameter :: & A_2027082 = 0.36410514377569680455_tao_r64 real(kind=default), dimension(N) :: a type(tao_random_state) :: s, t integer, dimension(:), allocatable :: ibuf real(kind=tao_r64), dimension(:), allocatable :: dbuf integer :: i, ibuf_size, dbuf_size - print *, TAO52_RANDOM_NUMBERS_RCS_ID print *, "testing the 52-bit tao_random_numbers ..." <> <> end subroutine tao_random_test @ %def tao_random_test @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Test Program} <<[[tao_test.f90]]>>= program tao_test use tao_random_numbers, only: test30 => tao_random_test use tao52_random_numbers, only: test52 => tao_random_test implicit none call test30 ("tmp.tao") call test52 ("tmp.tao") stop 0 end program tao_test @ %def tao_test @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/histograms.nw =================================================================== --- trunk/vamp/src/histograms.nw (revision 8740) +++ trunk/vamp/src/histograms.nw (revision 8741) @@ -1,432 +1,428 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP histograms code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: histograms.nw 314 2010-04-17 20:32:33Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Histogramming} \begin{dubious} Merged WK's improvements for WHIZARD. TODO \emph{after} merging: \begin{enumerate} \item [[bins3]] is a bad undescriptive name \item [[bins3]] should be added to [[histogram2]] \item [[write_histogram2_unit]] for symmetry. \end{enumerate} \end{dubious} \begin{dubious} There's almost no sanity checking. If you call one of these functions on a histogram that has not been initialized, you loose. --- \emph{Big time}. \end{dubious} <<[[histograms.f90]]>>= ! histograms.f90 -- <> module histograms use kinds use utils, only: find_free_unit implicit none private <> <> <> <> - character(len=*), public, parameter :: HISTOGRAMS_RCS_ID = & - "$Id: histograms.nw 314 2010-04-17 20:32:33Z ohl $" contains <> end module histograms @ %def histograms @ <>= type, public :: histogram private integer :: n_bins real(kind=default) :: x_min, x_max real(kind=default), dimension(:), pointer :: bins => null () real(kind=default), dimension(:), pointer :: bins2 => null () real(kind=default), dimension(:), pointer :: bins3 => null () end type histogram @ %def histogram @ <>= type, public :: histogram2 private integer, dimension(2) :: n_bins real(kind=default), dimension(2) :: x_min, x_max real(kind=default), dimension(:,:), pointer :: bins => null () real(kind=default), dimension(:,:), pointer :: bins2 => null () end type histogram2 @ %def histogram2 @ <>= public :: create_histogram public :: fill_histogram public :: delete_histogram public :: write_histogram @ <>= interface create_histogram module procedure create_histogram1, create_histogram2 end interface interface fill_histogram module procedure fill_histogram1, fill_histogram2s, fill_histogram2v end interface interface delete_histogram module procedure delete_histogram1, delete_histogram2 end interface interface write_histogram module procedure write_histogram1, write_histogram2 module procedure write_histogram1_unit end interface @ %def create_histogram @ %def fill_histogram @ %def delete_histogram @ %def write_histogram @ <>= private :: create_histogram1, create_histogram2 private :: fill_histogram1, fill_histogram2s, fill_histogram2v private :: delete_histogram1, delete_histogram2 private :: write_histogram1, write_histogram2 @ <>= integer, parameter, private :: N_BINS_DEFAULT = 10 @ <>= elemental subroutine create_histogram1 (h, x_min, x_max, nb) type(histogram), intent(out) :: h real(kind=default), intent(in) :: x_min, x_max integer, intent(in), optional :: nb if (present (nb)) then h%n_bins = nb else h%n_bins = N_BINS_DEFAULT end if h%x_min = x_min h%x_max = x_max allocate (h%bins(0:h%n_bins+1), h%bins2(0:h%n_bins+1)) h%bins = 0 h%bins2 = 0 allocate (h%bins3(0:h%n_bins+1)) h%bins3 = 0 end subroutine create_histogram1 @ %def create_histogram1 @ <>= pure subroutine create_histogram2 (h, x_min, x_max, nb) type(histogram2), intent(out) :: h real(kind=default), dimension(:), intent(in) :: x_min, x_max integer, intent(in), dimension(:), optional :: nb if (present (nb)) then h%n_bins = nb else h%n_bins = N_BINS_DEFAULT end if h%x_min = x_min h%x_max = x_max allocate (h%bins(0:h%n_bins(1)+1,0:h%n_bins(1)+1), & h%bins2(0:h%n_bins(2)+1,0:h%n_bins(2)+1)) h%bins = 0 h%bins2 = 0 end subroutine create_histogram2 @ %def create_histogram2 @ <>= elemental subroutine fill_histogram1 (h, x, weight, excess) type(histogram), intent(inout) :: h real(kind=default), intent(in) :: x real(kind=default), intent(in), optional :: weight real(kind=default), intent(in), optional :: excess integer :: i if (x < h%x_min) then i = 0 else if (x > h%x_max) then i = h%n_bins + 1 else i = 1 + h%n_bins * (x - h%x_min) / (h%x_max - h%x_min) !WK! i = min (max (i, 0), h%n_bins + 1) end if if (present (weight)) then h%bins(i) = h%bins(i) + weight h%bins2(i) = h%bins2(i) + weight*weight else h%bins(i) = h%bins(i) + 1 h%bins2(i) = h%bins2(i) + 1 end if if (present (excess)) h%bins3(i) = h%bins3(i) + excess end subroutine fill_histogram1 @ %def fill_histogram1 @ <>= elemental subroutine fill_histogram2s (h, x1, x2, weight) type(histogram2), intent(inout) :: h real(kind=default), intent(in) :: x1, x2 real(kind=default), intent(in), optional :: weight call fill_histogram2v (h, (/ x1, x2 /), weight) end subroutine fill_histogram2s @ %def fill_histogram2s @ <>= pure subroutine fill_histogram2v (h, x, weight) type(histogram2), intent(inout) :: h real(kind=default), dimension(:), intent(in) :: x real(kind=default), intent(in), optional :: weight integer, dimension(2) :: i i = 1 + h%n_bins * (x - h%x_min) / (h%x_max - h%x_min) i = min (max (i, 0), h%n_bins + 1) if (present (weight)) then h%bins(i(1),i(2)) = h%bins(i(1),i(2)) + weight h%bins2(i(1),i(2)) = h%bins2(i(1),i(2)) + weight*weight else h%bins(i(1),i(2)) = h%bins(i(1),i(2)) + 1 h%bins2(i(1),i(2)) = h%bins2(i(1),i(2)) + 1 end if end subroutine fill_histogram2v @ %def fill_histogram2v @ <>= elemental subroutine delete_histogram1 (h) type(histogram), intent(inout) :: h deallocate (h%bins, h%bins2) deallocate (h%bins3) end subroutine delete_histogram1 @ %def delete_histogram1 @ <>= elemental subroutine delete_histogram2 (h) type(histogram2), intent(inout) :: h deallocate (h%bins, h%bins2) end subroutine delete_histogram2 @ %def delete_histogram2 @ <>= subroutine write_histogram1 (h, name, over) type(histogram), intent(in) :: h character(len=*), intent(in), optional :: name logical, intent(in), optional :: over integer :: i, iounit if (present (name)) then call find_free_unit (iounit) if (iounit > 0) then open (unit = iounit, action = "write", status = "replace", & file = name) if (present (over)) then if (over) then write (unit = iounit, fmt = *) & "underflow", h%bins(0), sqrt (h%bins2(0)) end if end if do i = 1, h%n_bins write (unit = iounit, fmt = *) & midpoint (h, i), h%bins(i), sqrt (h%bins2(i)) end do if (present (over)) then if (over) then write (unit = iounit, fmt = *) & "overflow", h%bins(h%n_bins+1), & sqrt (h%bins2(h%n_bins+1)) end if end if close (unit = iounit) else print *, "write_histogram: Can't find a free unit!" end if else if (present (over)) then if (over) then print *, "underflow", h%bins(0), sqrt (h%bins2(0)) end if end if do i = 1, h%n_bins print *, midpoint (h, i), h%bins(i), sqrt (h%bins2(i)) end do if (present (over)) then if (over) then print *, "overflow", h%bins(h%n_bins+1), & sqrt (h%bins2(h%n_bins+1)) end if end if end if end subroutine write_histogram1 @ %def write_histogram1 @ <>= !WK! public :: write_histogram1_unit @ \begin{dubious} I don't like the [[format]] statement with the line number. Use a character constant instead (after we have merged with WHIZARD's branch). \end{dubious} <>= subroutine write_histogram1_unit (h, iounit, over, show_excess) type(histogram), intent(in) :: h integer, intent(in) :: iounit logical, intent(in), optional :: over, show_excess integer :: i logical :: show_exc show_exc = .false.; if (present(show_excess)) show_exc = show_excess if (present (over)) then if (over) then if (show_exc) then write (unit = iounit, fmt = 1) & "underflow", h%bins(0), sqrt (h%bins2(0)), h%bins3(0) else write (unit = iounit, fmt = 1) & "underflow", h%bins(0), sqrt (h%bins2(0)) end if end if end if do i = 1, h%n_bins if (show_exc) then write (unit = iounit, fmt = 1) & midpoint (h, i), h%bins(i), sqrt (h%bins2(i)), h%bins3(i) else write (unit = iounit, fmt = 1) & midpoint (h, i), h%bins(i), sqrt (h%bins2(i)) end if end do if (present (over)) then if (over) then if (show_exc) then write (unit = iounit, fmt = 1) & "overflow", h%bins(h%n_bins+1), & sqrt (h%bins2(h%n_bins+1)), & h%bins3(h%n_bins+1) else write (unit = iounit, fmt = 1) & "overflow", h%bins(h%n_bins+1), & sqrt (h%bins2(h%n_bins+1)) end if end if end if 1 format (1x,4(G16.9,2x)) end subroutine write_histogram1_unit @ %def write_histogram1_unit @ <>= private :: midpoint @ <>= interface midpoint module procedure midpoint1, midpoint2 end interface @ %def midpoint @ <>= private :: midpoint1, midpoint2 @ <>= elemental function midpoint1 (h, bin) result (x) type(histogram), intent(in) :: h integer, intent(in) :: bin real(kind=default) :: x x = h%x_min + (h%x_max - h%x_min) * (bin - 0.5) / h%n_bins end function midpoint1 @ %def midpoint1 @ <>= elemental function midpoint2 (h, bin, d) result (x) type(histogram2), intent(in) :: h integer, intent(in) :: bin, d real(kind=default) :: x x = h%x_min(d) + (h%x_max(d) - h%x_min(d)) * (bin - 0.5) / h%n_bins(d) end function midpoint2 @ %def midpoint2 @ <>= subroutine write_histogram2 (h, name, over) type(histogram2), intent(in) :: h character(len=*), intent(in), optional :: name logical, intent(in), optional :: over integer :: i1, i2, iounit if (present (name)) then call find_free_unit (iounit) if (iounit > 0) then open (unit = iounit, action = "write", status = "replace", & file = name) if (present (over)) then if (over) then write (unit = iounit, fmt = *) & "double underflow", h%bins(0,0), sqrt (h%bins2(0,0)) do i2 = 1, h%n_bins(2) write (unit = iounit, fmt = *) & "x1 underflow", midpoint (h, i2, 2), & h%bins(0,i2), sqrt (h%bins2(0,i2)) end do do i1 = 1, h%n_bins(1) write (unit = iounit, fmt = *) & "x2 underflow", midpoint (h, i1, 1), & h%bins(i1,0), sqrt (h%bins2(i1,0)) end do end if end if do i1 = 1, h%n_bins(1) do i2 = 1, h%n_bins(2) write (unit = iounit, fmt = *) & midpoint (h, i1, 1), midpoint (h, i2, 2), & h%bins(i1,i2), sqrt (h%bins2(i1,i2)) end do end do if (present (over)) then if (over) then do i2 = 1, h%n_bins(2) write (unit = iounit, fmt = *) & "x1 overflow", midpoint (h, i2, 2), & h%bins(h%n_bins(1)+1,i2), & sqrt (h%bins2(h%n_bins(1)+1,i2)) end do do i1 = 1, h%n_bins(1) write (unit = iounit, fmt = *) & "x2 overflow", midpoint (h, i1, 1), & h%bins(i1,h%n_bins(2)+1), & sqrt (h%bins2(i1,h%n_bins(2)+1)) end do write (unit = iounit, fmt = *) "double overflow", & h%bins(h%n_bins(1)+1,h%n_bins(2)+1), & sqrt (h%bins2(h%n_bins(1)+1,h%n_bins(2)+1)) end if end if close (unit = iounit) else print *, "write_histogram: Can't find a free unit!" end if else if (present (over)) then if (over) then print *, "double underflow", h%bins(0,0), sqrt (h%bins2(0,0)) do i2 = 1, h%n_bins(2) print *, "x1 underflow", midpoint (h, i2, 2), & h%bins(0,i2), sqrt (h%bins2(0,i2)) end do do i1 = 1, h%n_bins(1) print *, "x2 underflow", midpoint (h, i1, 1), & h%bins(i1,0), sqrt (h%bins2(i1,0)) end do end if end if do i1 = 1, h%n_bins(1) do i2 = 1, h%n_bins(2) print *, midpoint (h, i1, 1), midpoint (h, i2, 2), & h%bins(i1,i2), sqrt (h%bins2(i1,i2)) end do end do if (present (over)) then if (over) then do i2 = 1, h%n_bins(2) print *, "x1 overflow", midpoint (h, i2, 2), & h%bins(h%n_bins(1)+1,i2), & sqrt (h%bins2(h%n_bins(1)+1,i2)) end do do i1 = 1, h%n_bins(1) print *, "x2 overflow", midpoint (h, i1, 1), & h%bins(i1,h%n_bins(2)+1), & sqrt (h%bins2(i1,h%n_bins(2)+1)) end do print *, "double overflow", & h%bins(h%n_bins(1)+1,h%n_bins(2)+1), & sqrt (h%bins2(h%n_bins(1)+1,h%n_bins(2)+1)) end if end if end if end subroutine write_histogram2 @ %def write_histogram2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/sample.nw =================================================================== --- trunk/vamp/src/sample.nw (revision 8740) +++ trunk/vamp/src/sample.nw (revision 8741) @@ -1,283 +1,281 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP sample code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: sample.nw 314 2010-04-17 20:32:33Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Example} \label{sec:sample} <<[[sample.f90]]>>= ! sample.f90 -- <> module sample_functions use kinds use vamp, only: vamp_sum_channels private <> <> contains <> end module sample_functions @ \begin{equation} \begin{aligned} \psi_i: [0,1]^{\otimes N} &\to [0,1]^{\otimes N} \\ (\ldots,x_i,\ldots) &\mapsto (\ldots, x^0_i + a_i\cdot\tan\left( x_i\cdot\atan\frac{1-x^0_i}{a_i} - (1-x_i)\cdot\atan\frac{x^0_i}{a_i} \right),\ldots) \end{aligned} \end{equation} <>= _elemental_(function psi) (x, x0, a) result (psi_x) real(kind=default), intent(in) :: x, x0, a real(kind=default) :: psi_x psi_x = x0 & + a * tan (x * atan ((1 - x0) / a) - (1 - x) * atan (x0 / a)) end function psi @ %def psi @ <>= private :: psi @ %def psi @ \begin{subequations} their compositions \begin{equation} \phi_i = \psi_{k^i_1} \circ \ldots \circ \psi_{k^i_j} \end{equation} and \begin{equation} \begin{aligned} \phi_{n+1}: [0,1]^{\otimes N} &\to [0,1]^{\otimes N} \\ x &\mapsto x \end{aligned} \end{equation} \end{subequations} <>= _pure(function phi) (x, channel) result (phi_x) real(kind=default), dimension(:), intent(in) :: x integer, intent(in) :: channel real(kind=default), dimension(size(x)) :: phi_x integer :: i if (channel >= 1 .and. channel <= size (C)) then do i = 1, size (x) if (A(i,channel) >= 0) then phi_x(i) = psi (x(i), X0(i,channel), A(i,channel)) else phi_x(i) = x(i) end if end do else if (channel == size (C) + 1) then phi_x = x end if end function phi @ %def phi @ <>= integer, private, parameter :: ND = 5, NC = 10 real(kind=default), dimension(ND,NC), public :: A, X0 real(kind=default), dimension(NC), public :: C @ <>= A = 0.001 X0(4:,:) = 0.0 do i = 1, size (C) X0(1:3,i) = 0.25 + 0.5 * real (i) / size (C) C(i) = real (i) end do @ <>= public :: phi @ %def phi @ The inverse mappings are simply \begin{subequations} \begin{equation} \begin{aligned} \psi_i^{-1}: [0,1]^{\otimes N} &\to [0,1]^{\otimes N} \\ (\ldots,\xi_i,\ldots) &\mapsto (\ldots, \frac{\atan\frac{\xi_i-x^0_i}{a_i} + \atan\frac{x^0_i}{a_i}}% {\atan\frac{1-x^0_i}{a_i} + \atan\frac{x^0_i}{a_i}}, \ldots) \end{aligned} \end{equation} and \begin{equation} \begin{aligned} \phi_{n+1}^{-1}: [0,1]^{\otimes N} &\to [0,1]^{\otimes N} \\ \xi &\mapsto \xi \end{aligned} \end{equation} \end{subequations} Using \begin{equation} J_{\psi_i^{-1}}(\xi) = \frac{\partial\psi_i^{-1}(\xi)}{\partial(\xi)} = \frac{1}{J_{\psi_i}(\phi^{-1}(\xi))} \end{equation} i.e. \begin{subequations} \begin{align} J_{\phi_i^{-1}}(\xi) &= \frac{a_i}{\atan\frac{1-x^0_i}{a_i} + \atan\frac{x^0_i}{a_i}} \,\frac{1}{(\xi-x^0_i)^2 + a_i^2} \\ J_{\phi_{n+1}^{-1}}(\xi) &= 1 \end{align} \end{subequations} <>= _elemental_(function g0) (x, x0, a) result (g0_x) real(kind=default), intent(in) :: x, x0, a real(kind=default) :: g0_x g0_x = a / (atan ((1 - x0) / a) + atan (x0 / a)) & / ((x - x0)**2 + a**2) end function g0 @ %def g0 @ <>= private :: g0 @ <>= _pure(recursive function g) (x, weights, channel) result (g_x) real(kind=default), dimension(:), intent(in) :: x, weights integer, intent(in) :: channel real(kind=default) :: g_x integer :: i, ch if (channel == 0) then <<$[[g_x]] = \sum_i\alpha_ig_i(x)$>> else if (channel >= 1 .and. channel <= size (C)) then g_x = 1.0 do i = 1, size (x) if (A(i,channel) >= 0) then g_x = g_x * g0 (x(i), X0(i,channel), A(i,channel)) end if end do else if (channel == size (C) + 1) then g_x = 1.0 end if end function g @ %def g @ <>= public :: g @ <<$[[g_x]] = \sum_i\alpha_ig_i(x)$ (defensive programming)>>= g_x = 0.0 do ch = 1, size (weights) g_x = g_x + weights(ch) * g (x, weights, ch) end do @ More elegant, but an error in the Fortran standard caused some implementations to forbid it: <<$[[g_x]] = \sum_i\alpha_ig_i(x)$>>= g_x = vamp_sum_channels (x, weights, g) @ \begin{equation} f(x) = \sum_i\, \frac{a_i}{\atan\frac{1-x^0_i}{a_i} + \atan\frac{x^0_i}{a_i}} \,\frac{c_i}{(x_i-x^0_i)^2 + a_i^2} \end{equation} <>= _pure(function f) (x, weights, channel) result (f_x) real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:), intent(in), optional :: weights integer, intent(in), optional :: channel real(kind=default) :: f_x integer :: i f_x = 0.0 do i = 1, size (C) f_x = f_x + C(i) * g (x, (/ 0.0_double /), i) end do end function f @ %def f @ <>= public :: f @ %def f @ <>= _pure(function w) (x, weights, channel) result (w_x) real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:), intent(in), optional :: weights integer, intent(in), optional :: channel real(kind=default) :: w_x real(kind=default), dimension(size(x)) :: x_prime integer :: ch if (present (channel)) then ch = channel else ch = 0 end if if (ch > 0) then x_prime = phi (x, ch) w_x = f (x_prime) / g (x_prime, weights, 0) else if (ch < 0) then x_prime = phi (x, -ch) w_x = g (x_prime, weights, -ch) / g (x_prime, weights, 0) else w_x = f (x) end if end function w @ %def w @ <>= public :: w @ %def w @ <<[[sample.f90]]>>= program sample use kinds use sample_functions !NODEP! use vamp use tao_random_numbers logical :: mc, quadrupole real(kind=default), dimension(2,size(A,dim=1)) :: region real(kind=default) :: integral, standard_dev, chi_squared integer :: i, it integer, dimension(2,2) :: calls integer, dimension(2,2,3) :: callsx real(kind=default), dimension(size(C)+1) :: weight_vector type(vamp_grids) :: gr type(tao_random_state) :: rng call tao_random_create (rng, 0) read *, mc, quadrupole region(1,:) = 0.0 region(2,:) = 1.0 <> weight_vector = 1.0 if (mc) then print *, "going multi channel ..." call vamp_create_grids (gr, region, 10000, weight_vector, quadrupole = quadrupole) call vamp_sample_grids (rng, gr, w, 4) call vamp_discard_integrals (gr, 100000) do it = 1, 3 call vamp_sample_grids (rng, gr, w, 1, integral, standard_dev) print *, integral, standard_dev call vamp_refine_weights (gr) end do call vamp_discard_integrals (gr, 500000) call vamp_sample_grids (rng, gr, w, 2, integral, standard_dev) print *, integral, standard_dev else print *, "going single channel ..." calls(:,1) = (/ 4, 100000 /) calls(:,2) = (/ 6, 100000 /) call vamp_integrate (rng, region, f, calls, integral, & standard_dev, chi_squared, quadrupole = quadrupole) print *, integral, standard_dev, chi_squared if (.true.) then print *, "revolving ..." callsx(:,1,1:2) = spread ((/ 4, 10000 /), dim = 2, ncopies = 2) callsx(:,2,1:2) = spread ((/ 1, 100000 /), dim = 2, ncopies = 2) callsx(:,:,3) = calls call vamp_integratex (rng, region, f, callsx, integral, & standard_dev, chi_squared, quadrupole = quadrupole) print *, integral, standard_dev, chi_squared end if endif print *, "expected: ", sum (C) end program sample @ <>= @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/exceptions.nw =================================================================== --- trunk/vamp/src/exceptions.nw (revision 8740) +++ trunk/vamp/src/exceptions.nw (revision 8741) @@ -1,148 +1,144 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP exceptions code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: exceptions.nw 314 2010-04-17 20:32:33Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Errors and Exceptions} \label{sec:exceptions} Fortran95 does not allow \emph{any} I/O in [[pure]] and [[elemental]] procedures, not even output to the unit~[[*]]. A [[stop]] statement is verboten as well. Therefore we have to use condition codes <<[[exceptions.f90]]>>= ! exceptions.f90 -- <> module exceptions use kinds implicit none private <> <> <> <> - character(len=*), public, parameter :: EXCEPTIONS_RCS_ID = & - "$Id: exceptions.nw 314 2010-04-17 20:32:33Z ohl $" contains <> end module exceptions @ %def exceptions @ <>= type, public :: exception integer :: level = EXC_NONE character(len=NAME_LENGTH) :: message = "" character(len=NAME_LENGTH) :: origin = "" end type exception @ %def exception @ <>= integer, public, parameter :: & EXC_NONE = 0, & EXC_INFO = 1, & EXC_WARN = 2, & EXC_ERROR = 3, & EXC_FATAL = 4 @ %def EXC_NONE EXC_INFO EXC_WARN EXC_ERROR EXC_FATAL @ <>= integer, private, parameter :: EXC_DEFAULT = EXC_ERROR integer, private, parameter :: NAME_LENGTH = 64 @ %def EXC_DEFAULT NAME_LENGTH @ <>= public :: handle_exception @ <>= subroutine handle_exception (exc) type(exception), intent(inout) :: exc character(len=10) :: name if (exc%level > 0) then select case (exc%level) case (EXC_NONE) name = "(none)" case (EXC_INFO) name = "info" case (EXC_WARN) name = "warning" case (EXC_ERROR) name = "error" case (EXC_FATAL) name = "fatal" case default name = "invalid" end select print *, trim (exc%origin), ": ", trim(name), ": ", trim (exc%message) if (exc%level >= EXC_FATAL) then print *, "terminated." stop end if end if end subroutine handle_exception @ %def handle_exception @ <>= public :: raise_exception, clear_exception, gather_exceptions @ Raise an exception, but don't overwrite the messages in [[exc]] if it holds a more severe exception. This way we can accumulate error codes across procedure calls. We have [[exc]] optional to simplify life for the cslling procedures, which might have it optional themselves. <>= elemental subroutine raise_exception (exc, level, origin, message) type(exception), intent(inout), optional :: exc integer, intent(in), optional :: level character(len=*), intent(in), optional :: origin, message integer :: local_level if (present (exc)) then if (present (level)) then local_level = level else local_level = EXC_DEFAULT end if if (exc%level < local_level) then exc%level = local_level if (present (origin)) then exc%origin = origin else exc%origin = "[vamp]" end if if (present (message)) then exc%message = message else exc%message = "[vamp]" end if end if end if end subroutine raise_exception @ %def raise_exception @ <>= elemental subroutine clear_exception (exc) type(exception), intent(inout) :: exc exc%level = 0 exc%message = "" exc%origin = "" end subroutine clear_exception @ %def clear_exception @ <>= pure subroutine gather_exceptions (exc, excs) type(exception), intent(inout) :: exc type(exception), dimension(:), intent(in) :: excs integer :: i i = sum (maxloc (excs%level)) if (exc%level < excs(i)%level) then call raise_exception (exc, excs(i)%level, excs(i)%origin, & excs(i)%message) end if end subroutine gather_exceptions @ %def gather_exceptions @ Here's how to use [[gather_exceptions]]. [[elemental_procedure]] <>= call clear_exception (excs) call elemental_procedure_1 (y, x, excs) call elemental_procedure_2 (b, a, excs) if (any (excs%level > 0)) then call gather_exceptions (exc, excs) return end if @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/vamp_test0.nw =================================================================== --- trunk/vamp/src/vamp_test0.nw (revision 8740) +++ trunk/vamp/src/vamp_test0.nw (revision 8741) @@ -1,793 +1,783 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP vamp_test0 code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: vamp_test0.nw 314 2010-04-17 20:32:33Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Mapped Mode} In this chapter we perfom a test of the major features of Vamp. A function with many peaks is integrated with the traditional Vegas algorithm, using a multi-channel approach and in parallel. The function is constructed to have a known analytical integral (which is chosen to be one) in order to be able to gauge the accuracy of the reselt and error estimate. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Serial Test} <<[[vamp_test0.f90]]>>= ! vamp_test0.f90 -- <> <> @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Single Channel} The functions to be integrated are shared by the serial and the parallel incarnation of the code. <>= module vamp_test0_functions use kinds use vamp, only: vamp_grid, vamp_multi_channel0 use vamp, only: vamp_data_t implicit none private public :: f, g, phi, w public :: create_sample, delete_sample private :: f0, psi, g0, f_norm real(kind=default), dimension(:), allocatable, private :: c, x_min, x_max real(kind=default), dimension(:,:,:), allocatable, public :: x0, gamma contains <> end module vamp_test0_functions @ %def vamp_test0_functions @ We start from a model of~$n_p$ interfering resonances in one variable (cf.~section~\ref{sec:MC/vegas}) \begin{equation} f_0(x|x_{\min},x_{\max},x_0,\gamma) = \frac{1}{N(x_{\min},x_{\max},x_0,\gamma)} \left|\sum_{p=1}^{n_p}\frac{1}{x-x_{0,p}+i\gamma_p}\right|^2 \end{equation} where \begin{equation} N(x_{\min},x_{\max},x_0,\gamma) = \int\limits_{x_{\min}}^{x_{\max}}\!\mathrm{d}x\, \left|\sum_{p=1}^{n_p}\frac{1}{x-x_{0,p}+i\gamma_p}\right|^2 \end{equation} such that \begin{equation} \int\limits_{x_{\min}}^{x_{\max}}\!\mathrm{d}x\, f_0(x|x_{\min},x_{\max},x_0,\gamma) = 1 \end{equation} NB: the~$N(x_{\min},x_{\max},x_0,\gamma)$ should be calculated once and tabulated to save processing time, but we are lazy here. \begin{multline} N(x_{\min},x_{\max},x_0,\gamma) = \sum_{p=1}^{n_p} \int\limits_{x_{\min}}^{x_{\max}}\!\mathrm{d}x\, \left|\frac{1}{x-x_{0,p}+i\gamma_p}\right|^2 \\ + 2 \mathop{\textrm{Re}} \sum_{p=1}^{n_p}\sum_{q=1}^{n_p} \int\limits_{x_{\min}}^{x_{\max}}\!\mathrm{d}x\, \frac{1}{x-x_{0,p}+i\gamma_p}\,\frac{1}{x-x_{0,q}-i\gamma_q} \end{multline} <>= pure function f0 (x, x_min, x_max, x0, g) result (f_x) real(kind=default), intent(in) :: x, x_min, x_max real(kind=default), dimension(:), intent(in) :: x0, g real(kind=default) :: f_x complex(kind=default) :: amp real(kind=default) :: norm integer :: i, j amp = sum (1.0 / cmplx (x - x0, g, kind=default)) norm = 0 do i = 1, size (x0) norm = norm + f_norm (x_min, x_max, x0(i), g(i), x0(i), g(i)) do j = i + 1, size (x0) norm = norm + 2 * f_norm (x_min, x_max, x0(i), g(i), x0(j), g(j)) end do end do f_x = amp * conjg (amp) / norm end function f0 @ %def f0 @ \begin{multline} \int\limits_{x_{\min}}^{x_{\max}}\!\mathrm{d}x\, \frac{1}{x-x_{0,p}+i\gamma_p}\,\frac{1}{x-x_{0,q}-i\gamma_q} = \\ \frac{1}{x_{0,p} - x_{0,q} - i\gamma_p - i\gamma_q} \left( \ln\left(\frac{x_{\max} - x_{0,p} + i\gamma_p}% {x_{\min} - x_{0,p} + i\gamma_p}\right) - \ln\left(\frac{x_{\max} - x_{0,q} - i\gamma_q}% {x_{\min} - x_{0,q} - i\gamma_q}\right) \right) \end{multline} Don't even think of merging the logarithms: it will screw up the Riemann sheet. <>= pure function f_norm (x_min, x_max, x0p, gp, x0q, gq) & result (norm) real(kind=default), intent(in) :: x_min, x_max, x0p, gp, x0q, gq real(kind=default) :: norm norm = real (( log ( cmplx (x_max - x0p, gp, kind=default) & / cmplx (x_min - x0p, gp, kind=default)) & - log ( cmplx (x_max - x0q, - gq, kind=default) & / cmplx (x_min - x0q, - gq, kind=default))) & / cmplx (x0p - x0q, - gp - gq, kind=default), & kind=default) end function f_norm @ %def f_norm @ Since we want to be able to do the integral of~$f$ analytically, it is most convenient to take a weighted sum of products: \begin{multline} f(x_1,\ldots,x_{n_d}|x_{\min},x_{\max},x_0,\gamma) = \\ \frac{1}{\sum_{i=1}^{n_c} c_i} \sum_{i=1}^{n_c} c_i \prod_{j=1}^{n_d} f_0(x_j|x_{\min,j},x_{\max,j},x_{0,ij},\gamma_{ij}) \end{multline} Each summand is factorized and therefore very easily integrated by Vegas. A non-trivial sum is more realistic in this respect. <>= pure function f (x, data, weights, channel, grids) result (f_x) real(kind=default), dimension(:), intent(in) :: x class(vamp_data_t), intent(in) :: data real(kind=default), dimension(:), intent(in), optional :: weights integer, intent(in), optional :: channel type(vamp_grid), dimension(:), intent(in), optional :: grids real(kind=default) :: f_x real(kind=default) :: fi_x integer :: i, j f_x = 0.0 do i = 1, size (c) fi_x = 1.0 do j = 1, size (x) if (all (gamma(:,i,j) > 0)) then fi_x = fi_x * f0 (x(j), x_min(j), x_max(j), & x0(:,i,j), gamma(:,i,j)) else fi_x = fi_x / (x_max(j) - x_min(j)) end if end do f_x = f_x + c(i) * fi_x end do f_x = f_x / sum (c) end function f @ %def f @ <>= subroutine delete_sample () deallocate (c, x_min, x_max, x0, gamma) end subroutine delete_sample @ %def delete_sample @ <>= subroutine create_sample (num_poles, weights, region) integer, intent(in) :: num_poles real(kind=default), dimension(:), intent(in) :: weights real(kind=default), dimension(:,:), intent(in) :: region integer :: nd, nc nd = size (region, dim=2) nc = size (weights) allocate (c(nc), x_min(nd), x_max(nd)) allocate (x0(num_poles,nc,nd), gamma(num_poles,nc,nd)) x_min = region(1,:) x_max = region(2,:) c = weights end subroutine create_sample @ %def create_sample @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Multi Channel} We start from the usual mapping for Lorentzian peaks \begin{equation} \begin{aligned} \psi(x_{\min},x_{\max},x_0,\gamma): [x_{\min},x_{\max}] &\to [x_{\min},x_{\max}] \\ \xi &\mapsto x = \psi(\xi|x_{\min},x_{\max},x_0,\gamma) \end{aligned} \end{equation} where \begin{multline} \psi(\xi|x_{\min},x_{\max},x_0,\gamma) = x_0 + \\ \gamma\cdot\tan\left( \frac{\xi-x_{\min}}{x_{\max}-x_{\min}}\cdot \atan\frac{x_{\max}-x_0}{\gamma} - \frac{x_{\max}-\xi}{x_{\max}-x_{\min}}\cdot \atan\frac{x_0-x_{\min}}{\gamma} \right) \end{multline} <>= pure function psi (xi, x_min, x_max, x0, gamma) result (x) real(kind=default), intent(in) :: xi, x_min, x_max, x0, gamma real(kind=default) :: x x = x0 + gamma & * tan (((xi - x_min) * atan ((x_max - x0) / gamma) & - (x_max - xi) * atan ((x0 - x_min) / gamma)) & / (x_max - x_min)) end function psi @ %def psi @ The inverse mapping is \begin{equation} \begin{aligned} \psi^{-1}(x_{\min},x_{\max},x_0,\gamma): [x_{\min},x_{\max}] &\to [x_{\min},x_{\max}] \\ x &\mapsto \xi = \psi^{-1}(x|x_{\min},x_{\max},x_0,\gamma) \end{aligned} \end{equation} with \begin{multline} \psi^{-1}(x|x_{\min},x_{\max},x_0,\gamma) = \\ \frac{ x_{\max}(\atan\frac{x_0-x_{\min}}{\gamma} + \atan\frac{x-x_0}{\gamma}) + x_{\min}(\atan\frac{x_{\max}-x_0}{\gamma} + \atan\frac{x_0-x}{\gamma})}% { \atan\frac{x_{\max}-x_0}{\gamma} + \atan\frac{x_0-x_{\min}}{\gamma}} \end{multline} with Jacobian \begin{equation} \frac{\textrm{d}(\psi^{-1}(x|x_{\min},x_{\max},x_0,\gamma))}% {\textrm{d}x} = \frac{x_{\max}-x_{\min}}% {\atan\frac{x_{\max}-x_0}{\gamma} + \atan\frac{x_0-x_{\min}}{\gamma}} \frac{\gamma}{(x-x_0)^2 + \gamma^2} \end{equation} <>= pure function g0 (x, x_min, x_max, x0, gamma) result (g_x) real(kind=default), intent(in) :: x, x_min, x_max, x0, gamma real(kind=default) :: g_x g_x = gamma / (atan ((x_max - x0) / gamma) - atan ((x_min - x0) / gamma)) & * (x_max - x_min) / ((x - x0)**2 + gamma**2) end function g0 @ %def g0 @ The function~$f$ has~$n_c^{\vphantom{n_d}}n_p^{n_d}$ peaks and we need a channel for each one, plus a constant function for the background. We encode the position on the grid linearly: <>= ch = channel - 1 do j = 1, size (x) p(j) = 1 + modulo (ch, np) ch = ch / np end do ch = ch + 1 @ The map~$\phi$ is the direct product of~$\psi$s: <>= pure function phi (xi, channel) result (x) real(kind=default), dimension(:), intent(in) :: xi integer, intent(in) :: channel real(kind=default), dimension(size(xi)) :: x integer, dimension(size(xi)) :: p integer :: j, ch, np, nch, nd, channels np = size (x0, dim = 1) nch = size (x0, dim = 2) nd = size (x0, dim = 3) channels = nch * np**nd if (channel >= 1 .and. channel <= channels) then <> do j = 1, size (xi) if (all (gamma(:,ch,j) > 0)) then x(j) = psi (xi(j), x_min(j), x_max(j), & x0(p(j),ch,j), gamma(p(j),ch,j)) else x = xi end if end do else if (channel == channels + 1) then x = xi else x = 0 end if end function phi @ %def phi @ similarly for the Jacobians: <>= pure recursive function g (x, data, channel) result (g_x) real(kind=default), dimension(:), intent(in) :: x class(vamp_data_t), intent(in) :: data integer, intent(in) :: channel real(kind=default) :: g_x integer, dimension(size(x)) :: p integer :: j, ch, np, nch, nd, channels np = size (x0, dim = 1) nch = size (x0, dim = 2) nd = size (x0, dim = 3) channels = nch * np**nd if (channel >= 1 .and. channel <= channels) then <> g_x = 1.0 do j = 1, size (x) if (all (gamma(:,ch,j) > 0)) then g_x = g_x * g0 (x(j), x_min(j), x_max(j), & x0(p(j),ch,j), gamma(p(j),ch,j)) end if end do else if (channel == channels + 1) then g_x = 1.0 else g_x = 0 end if end function g @ %def g @ <>= function w (x, data, weights, channel, grids) result (w_x) real(kind=default), dimension(:), intent(in) :: x class(vamp_data_t), intent(in) :: data real(kind=default), dimension(:), intent(in), optional :: weights integer, intent(in), optional :: channel type(vamp_grid), dimension(:), intent(in), optional :: grids real(kind=default) :: w_x w_x = vamp_multi_channel0 (f, data, phi, g, x, weights, channel) end function w @ %def w @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Driver Routines} <<[[vamp_test0.f90]]>>= module vamp_tests0 <> use vamp implicit none private <> contains <> end module vamp_tests0 @ %def vamp_tests0 @ <>= use kinds use exceptions use histograms use tao_random_numbers use vamp_test0_functions !NODEP! @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \paragraph{Verification} <>= public :: check_jacobians @ <>= subroutine check_jacobians (do_print, region, samples, rng) logical, intent(in) :: do_print real(kind=default), dimension(:,:), intent(in) :: region integer, dimension(:), intent(in) :: samples type(tao_random_state), intent(inout) :: rng real(kind=default), dimension(size(region,dim=2)) :: x real(kind=default) :: d integer :: ch do ch = 1, size(x0,dim=2) * size(x0,dim=1)**size(x0,dim=3) + 1 call vamp_check_jacobian (rng, samples(1), g, phi, ch, region, d, x) if (do_print) then print *, ch, ": ", d, ", x = ", real (x) end if end do end subroutine check_jacobians @ %def check_jacobians @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \paragraph{Integration} <>= public :: single_channel, multi_channel @ <>= subroutine single_channel (do_print, region, iterations, samples, rng, & acceptable, failures) logical, intent(in) :: do_print real(kind=default), dimension(:,:), intent(in) :: region integer, dimension(:), intent(in) :: iterations, samples type(tao_random_state), intent(inout) :: rng real(kind=default), intent(in) :: acceptable integer, intent(inout) :: failures type(vamp_grid) :: gr type(vamp_history), dimension(iterations(1)+iterations(2)) :: history real(kind=default) :: integral, standard_dev, chi_squared, pull call vamp_create_history (history) call vamp_create_grid (gr, region, samples(1)) call vamp_sample_grid (rng, gr, f, NO_DATA, iterations(1), history = history) call vamp_discard_integral (gr, samples(2)) call vamp_sample_grid & (rng, gr, f, NO_DATA, iterations(2), & integral, standard_dev, chi_squared, & history = history(iterations(1)+1:)) call vamp_write_grid (gr, "vamp_test0.grid") call vamp_delete_grid (gr) call vamp_print_history (history, "single") call vamp_delete_history (history) pull = (integral - 1) / standard_dev if (do_print) then print *, " int, err, chi2:", integral, standard_dev, chi_squared end if if (abs (pull) > acceptable) then failures = failures + 1 print *, " unacceptable pull:", pull else print *, " acceptable pull:", pull end if end subroutine single_channel @ %def single_channel @ <>= subroutine multi_channel (do_print, region, iterations, samples, rng, & acceptable, failures) logical, intent(in) :: do_print real(kind=default), dimension(:,:), intent(in) :: region integer, dimension(:), intent(in) :: iterations, samples type(tao_random_state), intent(inout) :: rng real(kind=default), intent(in) :: acceptable type(vamp_grids) :: grs integer, intent(inout) :: failures <> end subroutine multi_channel @ %def multi_channel @ <>= real(kind=default), & dimension(size(x0,dim=2)*size(x0,dim=1)**size(x0,dim=3)+1) :: & weight_vector type(vamp_history), dimension(iterations(1)+iterations(2)+4) :: history type(vamp_history), dimension(size(history),size(weight_vector)) :: histories real(kind=default) :: integral, standard_dev, chi_squared, pull integer :: it weight_vector = 1.0 call vamp_create_history (history) call vamp_create_history (histories) call vamp_create_grids (grs, region, samples(1), weight_vector) call vamp_sample_grids (rng, grs, w, NO_DATA, iterations(1) - 1, & history = history, histories = histories) do it = 1, 5 call vamp_sample_grids (rng, grs, w, NO_DATA, 1, & history = history(iterations(1)+it-1:), & histories = histories(iterations(1)+it-1:,:)) call vamp_refine_weights (grs) end do call vamp_discard_integrals (grs, samples(2)) call vamp_sample_grids & (rng, grs, w, NO_DATA, iterations(2), & integral, standard_dev, chi_squared, & history = history(iterations(1)+5:), & histories = histories(iterations(1)+5:,:)) call vamp_write_grids (grs, "vamp_test0.grids") call vamp_delete_grids (grs) call vamp_print_history (history, "multi") call vamp_print_history (histories, "multi") call vamp_delete_history (history) call vamp_delete_history (histories) if (do_print) then print *, integral, standard_dev, chi_squared end if pull = (integral - 1) / standard_dev if (abs (pull) > acceptable) then failures = failures + 1 print *, " unacceptable pull:", pull else print *, " acceptable pull:", pull end if @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \paragraph{Event Generation} @ <>= public :: single_channel_generator, multi_channel_generator @ <>= subroutine single_channel_generator (do_print, region, iterations, samples, rng) logical, intent(in) :: do_print real(kind=default), dimension(:,:), intent(in) :: region integer, dimension(:), intent(in) :: iterations, samples type(tao_random_state), intent(inout) :: rng type(vamp_grid) :: gr type(vamp_history), dimension(iterations(1)+iterations(2)) :: history type(histogram) :: unweighted, reweighted, weighted, weights type(exception) :: exc real(kind=default) :: weight, integral, standard_dev integer :: i real(kind=default), dimension(size(region,dim=2)) :: x call vamp_create_grid (gr, region, samples(1)) call vamp_sample_grid (rng, gr, f, NO_DATA, iterations(1), history = history) call vamp_discard_integral (gr, samples(2)) call vamp_warmup_grid & (rng, gr, f, NO_DATA, iterations(2), history = history(iterations(1)+1:)) call vamp_print_history (history, "single") call vamp_delete_history (history) call create_histogram (unweighted, region(1,1), region(2,1), 100) call create_histogram (reweighted, region(1,1), region(2,1), 100) call create_histogram (weighted, region(1,1), region(2,1), 100) call create_histogram (weights, 0.0_default, 10.0_default, 100) ! do i = 1, 1000000 do i = 1, 100 call clear_exception (exc) call vamp_next_event (x, rng, gr, f, NO_DATA, exc = exc) call handle_exception (exc) call fill_histogram (unweighted, x(1)) call fill_histogram (reweighted, x(1), 1.0_default / f (x, NO_DATA)) end do integral = 0.0 standard_dev = 0.0 do i = 1, 10000 call clear_exception (exc) call vamp_next_event (x, rng, gr, f, NO_DATA, weight, exc = exc) call handle_exception (exc) call fill_histogram (weighted, x(1), weight / f (x, NO_DATA)) call fill_histogram (weights, x(1), weight) integral = integral + weight standard_dev = standard_dev + weight**2 end do if (do_print) then print *, integral / (i-1), sqrt (standard_dev) / (i-1) call write_histogram (unweighted, "u_s.d") call write_histogram (reweighted, "r_s.d") call write_histogram (weighted, "w_s.d") call write_histogram (weights, "ws_s.d") end if call delete_histogram (unweighted) call delete_histogram (reweighted) call delete_histogram (weighted) call delete_histogram (weights) call vamp_delete_grid (gr) end subroutine single_channel_generator @ %def single_channel_generator @ <>= subroutine multi_channel_generator (do_print, region, iterations, samples, rng) logical, intent(in) :: do_print real(kind=default), dimension(:,:), intent(in) :: region integer, dimension(:), intent(in) :: iterations, samples type(tao_random_state), intent(inout) :: rng type(vamp_grids) :: grs real(kind=default), & dimension(size(x0,dim=2)*size(x0,dim=1)**size(x0,dim=3)+1) :: & weight_vector type(vamp_history), dimension(iterations(1)+iterations(2)+4) :: history type(vamp_history), dimension(size(history),size(weight_vector)) :: histories type(histogram) :: unweighted, reweighted, weighted, weights type(exception) :: exc real(kind=default) :: weight, integral, standard_dev real(kind=default), dimension(size(region,dim=2)) :: x character(len=5) :: pfx integer :: it, i, j weight_vector = 1.0 call vamp_create_history (history) call vamp_create_history (histories) call vamp_create_grids (grs, region, samples(1), weight_vector) call vamp_sample_grids (rng, grs, w, NO_DATA, iterations(1) - 1, & history = history, histories = histories) do it = 1, 5 call vamp_sample_grids (rng, grs, w, NO_DATA, 1, & history = history(iterations(1)+it-1:), & histories = histories(iterations(1)+it-1:,:)) call vamp_refine_weights (grs) end do call vamp_discard_integrals (grs, samples(2)) call vamp_warmup_grids & (rng, grs, w, NO_DATA, iterations(2), & history = history(iterations(1)+5:), & histories = histories(iterations(1)+5:,:)) call vamp_print_history (history, "multi") call vamp_print_history (histories, "multi") call vamp_delete_history (history) call vamp_delete_history (histories) !!! do i = 1, size (grs%grids) !!! do j = 1, size (grs%grids(i)%div) !!! write (pfx, "(I2.2,'/',I2.2)") i, j !!! call dump_division (grs%grids(i)%div(j), pfx) !!! end do !!! end do call create_histogram (unweighted, region(1,1), region(2,1), 100) call create_histogram (reweighted, region(1,1), region(2,1), 100) call create_histogram (weighted, region(1,1), region(2,1), 100) call create_histogram (weights, 0.0_default, 10.0_default, 100) ! do i = 1, 1000000 do i = 1, 100 call clear_exception (exc) call vamp_next_event (x, rng, grs, f, NO_DATA, phi, exc = exc) call handle_exception (exc) call fill_histogram (unweighted, x(1)) call fill_histogram (reweighted, x(1), 1.0_default / f (x, NO_DATA)) end do integral = 0.0 standard_dev = 0.0 do i = 1, 10000 call clear_exception (exc) call vamp_next_event (x, rng, grs, f, NO_DATA, phi, weight, exc = exc) call handle_exception (exc) call fill_histogram (weighted, x(1), weight / f (x, NO_DATA)) call fill_histogram (weights, x(1), weight) integral = integral + weight standard_dev = standard_dev + weight**2 end do if (do_print) then print *, integral / (i-1), sqrt (standard_dev) / (i-1) call write_histogram (unweighted, "u_m.d") call write_histogram (reweighted, "r_m.d") call write_histogram (weighted, "w_m.d") call write_histogram (weights, "ws_m.d") end if call delete_histogram (unweighted) call delete_histogram (reweighted) call delete_histogram (weighted) call delete_histogram (weights) call vamp_delete_grids (grs) end subroutine multi_channel_generator @ %def multi_channel_generator @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Main Program} <<[[vamp_test0.f90]]>>= program vamp_test0 <> implicit none <> do_print = .true. print *, "Starting VAMP 1.0 self test..." print *, "serial code" - print *, VAMP_RCS_ID - print *, DIVISIONS_RCS_ID call tao_random_create (rng, 0) call get_environment_variable (name="VAMP_RANDOM_TESTS", status=status) if (status == 0) then call system_clock (ticks0) else ticks0 = 42 end if call tao_random_seed (rng, ticks0) <> <> <> if (failures == 0) then stop 0 else if (failures == 1) then stop 1 else stop 2 end if end program vamp_test0 @ %def vamp_test0 @ <>= failures = 0 call system_clock (ticks0) call single_channel (do_print, region, iterations, samples, rng, 10*ACCEPTABLE, failures) call system_clock (ticks, ticks_per_second) print "(1X,A,F6.2,A)", & "time = ", real (ticks - ticks0) / ticks_per_second, " secs" @ <>= call system_clock (ticks0) call single_channel_generator & (do_print, region, iterations, samples, rng) call system_clock (ticks, ticks_per_second) print "(1X,A,F6.2,A)", & "time = ", real (ticks - ticks0) / ticks_per_second, " secs" @ <>= call system_clock (ticks0) call multi_channel (do_print, region, iterations, samples, rng, ACCEPTABLE, failures) call system_clock (ticks, ticks_per_second) print "(1X,A,F6.2,A)", & "time = ", real (ticks - ticks0) / ticks_per_second, " secs" @ <>= call system_clock (ticks0) call multi_channel_generator & (do_print, region, iterations, samples, rng) call system_clock (ticks, ticks_per_second) print "(1X,A,F6.2,A)", & "time = ", real (ticks - ticks0) / ticks_per_second, " secs" @ <>= call system_clock (ticks0) ! call check_jacobians (do_print, region, samples, rng) call system_clock (ticks, ticks_per_second) print "(1X,A,F6.2,A)", & "time = ", real (ticks - ticks0) / ticks_per_second, " secs" @ <>= logical :: do_print @ <>= @ <>= use kinds use tao_random_numbers -use divisions, only: DIVISIONS_RCS_ID -use vamp, only: VAMP_RCS_ID use vamp_test0_functions !NODEP! use vamp_tests0 !NODEP! @ <>= integer :: i, j, ticks, ticks_per_second, ticks0, status integer, dimension(2) :: iterations, samples real(kind=default), dimension(:,:), allocatable :: region type(tao_random_state) :: rng real(kind=default), parameter :: ACCEPTABLE = 4 integer :: failures @ <>= iterations = (/ 4, 3 /) samples = (/ 10000, 50000 /) allocate (region(2,2)) region(1,:) = -1.0 region(2,:) = 2.0 call create_sample & (num_poles = 2, weights = (/ 1.0_default, 2.0_default /), region = region) do i = 1, size (x0, dim=2) do j = 1, size (x0, dim=3) call tao_random_number (rng, x0(:,i,j)) end do end do gamma = 0.001 x0(1,:,:) = 0.2 x0(2:,:,:) = 0.8 @ <>= call delete_sample () deallocate (region) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Parallel Test} <<[[vampi_test0.f90]]>>= ! vampi_test0.f90 -- <> <> module vamp_tests0 <> use vampi use mpi90 implicit none private <> contains <> end module vamp_tests0 @ %def vamp_tests0 @ <<[[vampi_test0.f90]]>>= program vampi_test0 <> use mpi90 - use vampi, only: VAMPI_RCS_ID implicit none <> integer :: num_proc, proc_id call mpi90_init () call mpi90_size (num_proc) call mpi90_rank (proc_id) if (proc_id == 0) then do_print = .true. print *, "Starting VAMP 1.0 self test..." if (num_proc > 1) then print *, "parallel code running on ", num_proc, " processors" else print *, "parallel code running serially" end if - print *, VAMP_RCS_ID - print *, VAMPI_RCS_ID - print *, DIVISIONS_RCS_ID else do_print = .false. end if call tao_random_create (rng, 0) call system_clock (ticks0) call tao_random_seed (rng, ticks0 + proc_id) <> call mpi90_broadcast (x0, 0) call mpi90_broadcast (gamma, 0) command_loop: do if (proc_id == 0) then <> end if call mpi90_broadcast (command, 0) call system_clock (ticks0) <> call system_clock (ticks, ticks_per_second) if (proc_id == 0) then print "(1X,A,F6.2,A)", & "time = ", real (ticks - ticks0) / ticks_per_second, " secs" end if end do command_loop <> call mpi90_finalize () if (proc_id == 0) then print *, "bye." end if end program vampi_test0 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Output} <<[[vamp_test0.out]]>>= @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/kinematics.nw =================================================================== --- trunk/vamp/src/kinematics.nw (revision 8740) +++ trunk/vamp/src/kinematics.nw (revision 8741) @@ -1,566 +1,560 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP kinematics code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: kinematics.nw 314 2010-04-17 20:32:33Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Kinematics} <<[[kinematics.f90]]>>= ! kinematics.f90 -- <> module kinematics use kinds use constants use products, only: dot use specfun, only: gamma implicit none private <> <> <> - character(len=*), public, parameter :: KINEMATICS_RCS_ID = & - "$Id: kinematics.nw 314 2010-04-17 20:32:33Z ohl $" contains <> end module kinematics @ %def kinematics @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Lorentz Transformations} <>= public :: boost_velocity private :: boost_one_velocity, boost_many_velocity public :: boost_momentum private :: boost_one_momentum, boost_many_momentum @ <>= interface boost_velocity module procedure boost_one_velocity, boost_many_velocity end interface interface boost_momentum module procedure boost_one_momentum, boost_many_momentum end interface @ %def boost_velocity boost_momentum @ Boost a four vector~$p$ to the inertial frame moving with the velocity~$\beta$: \begin{subequations} \begin{align} p'_0 &= \gamma \left( p_0 - \vec\beta\vec p \right) \\ \vec p' &= \gamma \left( \vec p_{\parallel} - \vec\beta p_0 \right) + \vec p_{\perp} \end{align} \end{subequations} with~$\gamma=1/\sqrt{1-{\vec\beta}^2}$, $\vec p_{\parallel} = \vec\beta (\vec\beta\vec p) / {\vec\beta}^2$ and~$\vec p_{\perp} = \vec p - \vec p_{\parallel}$. Using~$1/{\vec\beta}^2 = \gamma^2/(\gamma+1) \cdot 1/(\gamma-1)$ and~$\vec b=\gamma\vec\beta$ this can be rewritten as \begin{subequations} \begin{align} p'_0 &= \gamma p_0 - \vec b\vec p \\ \vec p' &= \vec p + \left( \frac{\vec b\vec p}{\gamma+1} - p_0 \right) \vec b \end{align} \end{subequations} <>= pure function boost_one_velocity (p, beta) result (p_prime) real(kind=default), dimension(0:), intent(in) :: p real(kind=default), dimension(1:), intent(in) :: beta real(kind=default), dimension(0:3) :: p_prime real(kind=default), dimension(1:3) :: b real(kind=default) :: gamma, b_dot_p gamma = 1.0 / sqrt (1.0 - dot_product (beta, beta)) b = gamma * beta b_dot_p = dot_product (b, p(1:3)) p_prime(0) = gamma * p(0) - b_dot_p p_prime(1:3) = p(1:3) + (b_dot_p / (1.0 + gamma) - p(0)) * b end function boost_one_velocity @ %def boost_one_velocity @ <>= pure function boost_many_velocity (p, beta) result (p_prime) real(kind=default), dimension(:,0:), intent(in) :: p real(kind=default), dimension(1:), intent(in) :: beta real(kind=default), dimension(size(p,dim=1),0:3) :: p_prime integer :: i do i = 1, size (p, dim=1) p_prime(i,:) = boost_one_velocity (p(i,:), beta) end do end function boost_many_velocity @ %def boost_many_velocity @ Boost a four vector~$p$ to the rest frame of the four vector~$q$. The velocity is~$\vec\beta=\vec q/|q_0|$: <>= pure function boost_one_momentum (p, q) result (p_prime) real(kind=default), dimension(0:), intent(in) :: p, q real(kind=default), dimension(0:3) :: p_prime p_prime = boost_velocity (p, q(1:3) / abs (q(0))) end function boost_one_momentum @ %def boost_one_momentum @ <>= pure function boost_many_momentum (p, q) result (p_prime) real(kind=default), dimension(:,0:), intent(in) :: p real(kind=default), dimension(0:), intent(in) :: q real(kind=default), dimension(size(p,dim=1),0:3) :: p_prime p_prime = boost_many_velocity (p, q(1:3) / abs (q(0))) end function boost_many_momentum @ %def boost_many_momentum @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Massive Phase Space} \begin{equation} \lambda(a,b,c) = a^2 + b^2 + c^2 - 2ab - 2bc - 2ca = (a-b-c)^2 - 4bc \end{equation} and permutations <>= pure function lambda (a, b, c) result (lam) real(kind=default), intent(in) :: a, b, c real(kind=default) :: lam lam = a**2 + b**2 + c**2 - 2*(a*b + b*c + c*a) end function lambda @ %def lambda @ <>= public :: lambda @ <>= public :: two_to_three private :: two_to_three_massive, two_to_three_massless @ <>= interface two_to_three module procedure two_to_three_massive, two_to_three_massless end interface @ <>= type, public :: LIPS3 real(kind=default), dimension(3,0:3) :: p real(kind=default) :: jacobian end type LIPS3 @ %def LIPS3 @ \begin{equation} \mathrm{d}\text{LIPS}_3 = \int\!\frac{\textrm{d}^3\vec p_1}{(2\pi)^3 2E_1} \frac{\textrm{d}^3\vec p_2}{(2\pi)^3 2E_2} \frac{\textrm{d}^3\vec p_3}{(2\pi)^3 2E_3}\, (2\pi)^4 \delta^4(p_1 + p_2 + p_3 - p_a - p_b) \end{equation} The jacobian is given by \begin{equation} \mathrm{d}\text{LIPS}_3 = \frac{1}{(2\pi)^5} \int\!\mathrm{d}\phi\mathrm{d}t_1 \mathrm{d}s_2\mathrm{d}\Omega_3^{[23]} \frac{1}{32\sqrt{ss_2}} \frac{|\vec p_3^{[23]}|}{|\vec p_a^{[ab]}|} \end{equation} where~$\vec p_i^{[jk]}$ denotes the momentum of particle~$i$ in the center of mass system of particles~$j$ and~$k$. <>= pure function two_to_three_massive & (s, t1, s2, phi, cos_theta3, phi3, ma, mb, m1, m2, m3) result (p) real(kind=default), intent(in) :: & s, t1, s2, phi, cos_theta3, phi3, ma, mb, m1, m2, m3 type(LIPS3) :: p real(kind=default), dimension(0:3) :: p23 real(kind=default) :: Ea, pa_abs, E1, p1_abs, p3_abs, cos_theta pa_abs = sqrt (lambda (s, ma**2, mb**2) / (4 * s)) Ea = sqrt (ma**2 + pa_abs**2) p1_abs = sqrt (lambda (s, m1**2, s2) / (4 * s)) E1 = sqrt (m1**2 + p1_abs**2) p3_abs = sqrt (lambda (s2, m2**2, m3**2) / (4 * s2)) p%jacobian = & 1.0 / (2*PI)**5 * (p3_abs / pa_abs) / (32 * sqrt (s * s2)) cos_theta = (t1 - ma**2 - m1**2 + 2*Ea*E1) / (2*pa_abs*p1_abs) p%p(1,1:3) = polar_to_cartesian (p1_abs, cos_theta, phi) p%p(1,0) = on_shell (p%p(1,:), m1) p23(1:3) = - p%p(1,1:3) p23(0) = on_shell (p23, sqrt (s2)) p%p(3:2:-1,:) = one_to_two (p23, cos_theta3, phi3, m3, m2) end function two_to_three_massive @ A specialized version for massless particles can be faster, because the kinematics is simpler: <>= pure function two_to_three_massless (s, t1, s2, phi, cos_theta3, phi3) & result (p) real(kind=default), intent(in) :: s, t1, s2, phi, cos_theta3, phi3 type(LIPS3) :: p real(kind=default), dimension(0:3) :: p23 real(kind=default) :: pa_abs, p1_abs, p3_abs, cos_theta pa_abs = sqrt (s) / 2 p1_abs = (s - s2) / (2 * sqrt (s)) p3_abs = sqrt (s2) / 2 p%jacobian = 1.0 / ((2*PI)**5 * 32 * s) cos_theta = 1 + t1 / (2*pa_abs*p1_abs) p%p(1,0) = p1_abs p%p(1,1:3) = polar_to_cartesian (p1_abs, cos_theta, phi) p23(1:3) = - p%p(1,1:3) p23(0) = on_shell (p23, sqrt (s2)) p%p(3:2:-1,:) = one_to_two (p23, cos_theta3, phi3) end function two_to_three_massless @ %def two_to_three_massless @ <>= public :: one_to_two private :: one_to_two_massive, one_to_two_massless @ <>= interface one_to_two module procedure one_to_two_massive, one_to_two_massless end interface @ <>= pure function one_to_two_massive (p12, cos_theta, phi, m1, m2) result (p) real(kind=default), dimension(0:), intent(in) :: p12 real(kind=default), intent(in) :: cos_theta, phi, m1, m2 real(kind=default), dimension(2,0:3) :: p real(kind=default) :: s, p1_abs s = dot (p12, p12) p1_abs = sqrt (lambda (s, m1**2, m2**2) / (4 * s)) p(1,1:3) = polar_to_cartesian (p1_abs, cos_theta, phi) p(2,1:3) = - p(1,1:3) p(1,0) = on_shell (p(1,:), m1) p(2,0) = on_shell (p(2,:), m2) p = boost_momentum (p, - p12) end function one_to_two_massive @ %def one_to_two_massive @ <>= pure function one_to_two_massless (p12, cos_theta, phi) result (p) real(kind=default), dimension(0:), intent(in) :: p12 real(kind=default), intent(in) :: cos_theta, phi real(kind=default), dimension(2,0:3) :: p real(kind=default) :: p1_abs p1_abs = sqrt (dot (p12, p12)) / 2 p(1,0) = p1_abs p(1,1:3) = polar_to_cartesian (p1_abs, cos_theta, phi) p(2,0) = p1_abs p(2,1:3) = - p(1,1:3) p = boost_momentum (p, - p12) end function one_to_two_massless @ %def one_to_two_massless @ <>= public :: polar_to_cartesian, on_shell @ <>= pure function polar_to_cartesian (v_abs, cos_theta, phi) result (v) real(kind=default), intent(in) :: v_abs, cos_theta, phi real(kind=default), dimension(3) :: v real(kind=default) :: sin_phi, cos_phi, sin_theta sin_theta = sqrt (1.0 - cos_theta**2) cos_phi = cos (phi) sin_phi = sin (phi) v = (/ sin_theta * cos_phi, sin_theta * sin_phi, cos_theta /) * v_abs end function polar_to_cartesian @ <>= pure function on_shell (p, m) result (E) real(kind=default), dimension(0:), intent(in) :: p real(kind=default), intent(in) :: m real(kind=default) :: E E = sqrt (m**2 + dot_product (p(1:3), p(1:3))) end function on_shell @ %def on_shell @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Massive 3-Particle Phase Space Revisited} \begin{equation} \begin{CD} U_1 @>{\xi_1}>> P_1 @>{\phi_1}>> M \\ @V{\pi_U}VV @VV{\pi_P}V @| \\ U_2 @>{\xi_2}>> P_2 @>{\phi_2}>> M \end{CD} \end{equation} \begin{equation} \begin{CD} U_1 @>{\xi}>> P_1 @>{\phi}>> M \\ @V{\pi_U}VV @VV{\pi_P}V @VV{\pi}V \\ U_2 @>{\xi}>> P_2 @>{\phi}>> M \end{CD} \end{equation} <<[[kinematics.f90]]>>= module phase_space use kinds use constants use kinematics !NODEP! use tao_random_numbers implicit none private <> <> <> - character(len=*), public, parameter :: PHASE_SPACE_RCS_ID = & - "$Id: kinematics.nw 314 2010-04-17 20:32:33Z ohl $" contains <> end module phase_space @ %def phase_space @ \begin{equation} \text{\texttt{LIPS3\_unit}}: [0,1]^5 \end{equation} <>= type, public :: LIPS3_unit real(kind=default), dimension(5) :: x real(kind=default) :: s real(kind=default), dimension(2) :: mass_in real(kind=default), dimension(3) :: mass_out real(kind=default) :: jacobian end type LIPS3_unit @ %def LIPS3_unit @ <>= type, public :: LIPS3_unit_massless real(kind=default), dimension(5) :: x real(kind=default) :: s real(kind=default) :: jacobian end type LIPS3_unit_massless @ %def LIPS3_unit_massless @ \begin{equation} \text{\texttt{LIPS3\_s2\_t1\_angles}}: (s_2, t_1, \phi, \cos\theta_3, \phi_3) \end{equation} <>= type, public :: LIPS3_s2_t1_angles real(kind=default) :: s2, t1, phi, cos_theta3, phi3 real(kind=default) :: s real(kind=default), dimension(2) :: mass_in real(kind=default), dimension(3) :: mass_out real(kind=default) :: jacobian end type LIPS3_s2_t1_angles @ %def LIPS3_s2_t1_angles @ <>= type, public :: LIPS3_s2_t1_angles_massless real(kind=default) :: s2, t1, phi, cos_theta3, phi3 real(kind=default) :: s real(kind=default) :: jacobian end type LIPS3_s2_t1_angles_massless @ %def LIPS3_s2_t1_angles_massless @ \begin{equation} \text{\texttt{LIPS3\_momenta}}: (p_1, p_2, p_3) \end{equation} <>= type, public :: LIPS3_momenta real(kind=default), dimension(0:3,3) :: p real(kind=default) :: s real(kind=default), dimension(2) :: mass_in real(kind=default), dimension(3) :: mass_out real(kind=default) :: jacobian end type LIPS3_momenta @ %def LIPS3_momenta @ <>= type, public :: LIPS3_momenta_massless real(kind=default), dimension(0:3,3) :: p real(kind=default) :: s real(kind=default) :: jacobian end type LIPS3_momenta_massless @ %def LIPS3_momenta_massless @ <>= public :: random_LIPS3 private :: random_LIPS3_unit, random_LIPS3_unit_massless @ <>= interface random_LIPS3 module procedure random_LIPS3_unit, random_LIPS3_unit_massless end interface @ %def random_LIPS3 @ <>= pure subroutine random_LIPS3_unit (rng, lips) type(tao_random_state), intent(inout) :: rng type(LIPS3_unit), intent(inout) :: lips call tao_random_number (rng, lips%x) lips%jacobian = 1 end subroutine random_LIPS3_unit @ %def subroutine random_LIPS3_unit @ <>= pure subroutine random_LIPS3_unit_massless (rng, lips) type(tao_random_state), intent(inout) :: rng type(LIPS3_unit_massless), intent(inout) :: lips call tao_random_number (rng, lips%x) lips%jacobian = 1 end subroutine random_LIPS3_unit_massless @ %def subroutine random_LIPS3_unit_massless @ <>= private :: LIPS3_unit_to_s2_t1_angles, LIPS3_unit_to_s2_t1_angles_m0 @ <<(Unused) Interfaces of [[phase_space]] procedures>>= interface assignment(=) module procedure & LIPS3_unit_to_s2_t1_angles, LIPS3_unit_to_s2_t1_angles_m0 end interface @ <>= pure subroutine LIPS3_unit_to_s2_t1_angles (s2_t1_angles, unit) type(LIPS3_s2_t1_angles), intent(out) :: s2_t1_angles type(LIPS3_unit), intent(in) :: unit end subroutine LIPS3_unit_to_s2_t1_angles @ %def subroutine LIPS3_unit_to_s2_t1_angles @ <>= pure subroutine LIPS3_unit_to_s2_t1_angles_m0 (s2_t1_angles, unit) type(LIPS3_s2_t1_angles_massless), intent(out) :: s2_t1_angles type(LIPS3_unit_massless), intent(in) :: unit end subroutine LIPS3_unit_to_s2_t1_angles_m0 @ %def subroutine LIPS3_unit_to_s2_t1_angles_m0 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Massless $n$-Particle Phase Space: \texttt{RAMBO}} <>= public :: massless_isotropic_decay @ The massless \texttt{RAMBO} algorithm~\cite{Kleiss/Stirling/Ellis:1986:RAMBO}: <>= pure function massless_isotropic_decay (roots, ran) result (p) real (kind=default), intent(in) :: roots real (kind=default), dimension(:,:), intent(in) :: ran real (kind=default), dimension(size(ran,dim=1),0:3) :: p real (kind=default), dimension(size(ran,dim=1),0:3) :: q real (kind=default), dimension(0:3) :: qsum real (kind=default) :: cos_theta, sin_theta, phi, qabs, x, r, z integer :: k <> <> end function massless_isotropic_decay @ %def massless_isotropic_decay @ Generate a $xe^{-x}$ distribution for [[q(k,0)]] <>= do k = 1, size (p, dim = 1) q(k,0) = - log (ran(k,1) * ran(k,2)) cos_theta = 2 * ran(k,3) - 1 sin_theta = sqrt (1 - cos_theta**2) phi = 2 * PI * ran(k,4) q(k,1) = q(k,0) * sin_theta * cos (phi) q(k,2) = q(k,0) * sin_theta * sin (phi) q(k,3) = q(k,0) * cos_theta enddo @ The proof that the Jacobian of the transformation vanishes can be found in~\cite{Kleiss/Stirling/Ellis:1986:RAMBO}. The transformation is really a Lorentz boost (as can be seen easily). <>= qsum = sum (q, dim = 1) qabs = sqrt (dot (qsum, qsum)) x = roots / qabs do k = 1, size (p, dim = 1) r = dot (q(k,:), qsum) / qabs z = (q(k,0) + r) / (qsum(0) + qabs) p(k,1:3) = x * (q(k,1:3) - qsum(1:3) * z) p(k,0) = x * r enddo @ <>= public :: phase_space_volume @ \begin{equation} V_n(s) = \frac{1}{8\pi} \frac{n-1}{\left(\Gamma(n)\right)^2} \left(\frac{s}{16\pi^2}\right)^{n-2} \end{equation} <>= pure function phase_space_volume (n, roots) result (volume) integer, intent(in) :: n real (kind=default), intent(in) :: roots real (kind=default) :: volume real (kind=default) :: nd nd = n volume = (nd - 1) / (8*PI * (gamma (nd))**2) * (roots / (4*PI))**(2*n-4) end function phase_space_volume @ %def phase_space_volume @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Tests} <<[[ktest.f90]]>>= program ktest use kinds use constants use products use kinematics use tao_random_numbers implicit none real(kind=default) :: & ma, mb, m1, m2, m3, s, t1, s2, phi, cos_theta3, phi3 real(kind=default) :: t1_min, t1_max real(kind=default), dimension(5) :: r type(LIPS3) :: p integer :: i character(len=*), parameter :: fmt = "(A,4(1X,E12.5))" ma = 1.0 mb = 1.0 m1 = 10.0 m2 = 20.0 m3 = 30.0 s = 100.0 ** 2 do i = 1, 10 call tao_random_number (r) s2 = (r(1) * (sqrt (s) - m1) + (1 - r(1)) * (m2 + m3)) ** 2 t1_max = ma**2 + m1**2 - ((s + ma**2 - mb**2) * (s - s2 + m1**2) & + sqrt (lambda (s, ma**2, mb**2) * lambda (s, s2, m1**2))) / (2*s) t1_min = ma**2 + m1**2 - ((s + ma**2 - mb**2) * (s - s2 + m1**2) & - sqrt (lambda (s, ma**2, mb**2) * lambda (s, s2, m1**2))) / (2*s) t1 = r(2) * t1_max + (1 - r(2)) * t1_min phi = 2*PI * r(3) cos_theta3 = 2 * r(4) - 1 phi3 = 2*PI * r(5) p = two_to_three (s, t1, s2, phi, cos_theta3, phi3, ma, mb, m1, m2, m3) print fmt, "p1 = ", p%p(1,:) print fmt, "p2 = ", p%p(2,:) print fmt, "p3 = ", p%p(3,:) print fmt, "p1,2,3^2 = ", dot (p%p(1,:), p%p(1,:)), & dot (p%p(2,:), p%p(2,:)), dot (p%p(3,:), p%p(3,:)) print fmt, "sum(p) = ", p%p(1,:) + p%p(2,:) + p%p(3,:) print fmt, "|J| = ", p%jacobian end do end program ktest @ \begin{dubious} \index{remove from finalized program} Trivial check for typos, should be removed from the finalized program! \end{dubious} <>= program ktest use kinds use constants use products use kinematics use tao_random_numbers implicit none real(kind=default), dimension(0:3) :: p, q, p_prime, p0 real(kind=default) :: m character(len=*), parameter :: fmt = "(A,4(1X,E12.5))" integer :: i do i = 1, 5 if (i == 1) then p = (/ 1.0_double, 0.0_double, 0.0_double, 0.0_double /) m = 1.0 else call tao_random_number (p) m = sqrt (PI) end if call tao_random_number (q(1:3)) q(0) = sqrt (m**2 + dot_product (q(1:3), q(1:3))) p_prime = boost_momentum (p, q) print fmt, "p = ", p print fmt, "q = ", q print fmt, "p' = ", p_prime print fmt, "p^2 = ", dot (p, p) print fmt, "p'^2 = ", dot (p_prime, p_prime) if (dot (p, p) > 0.0) then p0 = boost_momentum (p, p) print fmt, "p0 = ", p0 print fmt, "p0^2 = ", dot (p0, p0) end if end do end program ktest @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/vamp_kinds.nw =================================================================== --- trunk/vamp/src/vamp_kinds.nw (revision 8740) +++ trunk/vamp/src/vamp_kinds.nw (revision 8741) @@ -1,33 +1,29 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP kinds code as NOWEB source (superseded by WHIZARD kinds code) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: kinds.nw 314 2010-04-17 20:32:33Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \appendix \chapter{Constants} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Kinds} \label{sec:kinds} This borders on overkill, but it is the most portable way to get double precision in standard Fortran without relying on [[kind (1.0D0)]] Currently, it is possible to change [[double]] to any other supported real kind. The MPI interface is a potential trouble source for such things, however. <<[[vamp_kinds.f90]]>>= ! vamp_kinds.f90 -- <> module kinds implicit none integer, parameter, private :: single = & & selected_real_kind (precision(1.0), range(1.0)) integer, parameter, private :: double = & & selected_real_kind (precision(1.0_single) + 1, range(1.0_single) + 1) integer, parameter, private :: extended = & & selected_real_kind (precision (1.0_double) + 1, range (1.0_double)) integer, parameter, public :: default = double - character(len=*), public, parameter :: KINDS_RCS_ID = & - "$Id: kinds.nw 314 2010-04-17 20:32:33Z ohl $" end module kinds @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/mpi90.nw =================================================================== --- trunk/vamp/src/mpi90.nw (revision 8740) +++ trunk/vamp/src/mpi90.nw (revision 8741) @@ -1,640 +1,636 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP mpi90 code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: mpi90.nw 314 2010-04-17 20:32:33Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Idiomatic Fortran90 Interface for MPI} <<[[mpi90.f90]]>>= ! mpi90.f90 -- <> module mpi90 use kinds use mpi implicit none private <> <> <> <> <> - character(len=*), public, parameter :: MPI90_RCS_ID = & - "$Id: mpi90.nw 314 2010-04-17 20:32:33Z ohl $" contains <> end module mpi90 @ %def mpi90 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Basics} <>= public :: mpi90_init public :: mpi90_finalize public :: mpi90_abort public :: mpi90_print_error public :: mpi90_size public :: mpi90_rank @ <>= subroutine mpi90_init (error) integer, intent(out), optional :: error integer :: local_error character(len=*), parameter :: FN = "mpi90_init" external mpi_init call mpi_init (local_error) <> end subroutine mpi90_init @ %def mpi90_init @ <>= if (present (error)) then error = local_error else if (local_error /= MPI_SUCCESS) then call mpi90_print_error (local_error, FN) stop end if end if @ <>= if (present (error)) then error = local_error else if (local_error /= MPI_SUCCESS) then call mpi90_print_error (local_error, FN) call mpi90_abort (local_error) stop end if end if @ <>= subroutine mpi90_finalize (error) integer, intent(out), optional :: error integer :: local_error character(len=*), parameter :: FN = "mpi90_finalize" external mpi_finalize call mpi_finalize (local_error) <> end subroutine mpi90_finalize @ %def mpi90_finalize @ <>= subroutine mpi90_abort (code, domain, error) integer, intent(in), optional :: code, domain integer, intent(out), optional :: error character(len=*), parameter :: FN = "mpi90_abort" integer :: local_domain, local_code, local_error external mpi_abort if (present (code)) then local_code = code else local_code = MPI_ERR_UNKNOWN end if <> call mpi_abort (local_domain, local_code, local_error) <> end subroutine mpi90_abort @ %def mpi90_abort @ <>= subroutine mpi90_print_error (error, msg) integer, intent(in) :: error character(len=*), optional :: msg character(len=*), parameter :: FN = "mpi90_print_error" integer :: msg_len, local_error external mpi_error_string call mpi_error_string (error, msg, msg_len, local_error) if (local_error /= MPI_SUCCESS) then print *, "PANIC: even MPI_ERROR_STRING() failed!!!" call mpi90_abort (local_error) else if (present (msg)) then print *, trim (msg), ": ", trim (msg(msg_len+1:)) else print *, "mpi90: ", trim (msg(msg_len+1:)) end if end subroutine mpi90_print_error @ %def mpi90_print_error @ <>= if (present (domain)) then local_domain = domain else local_domain = MPI_COMM_WORLD end if @ <>= subroutine mpi90_size (sz, domain, error) integer, intent(out) :: sz integer, intent(in), optional :: domain integer, intent(out), optional :: error character(len=*), parameter :: FN = "mpi90_size" integer :: local_domain, local_error external mpi_comm_size <> call mpi_comm_size (local_domain, sz, local_error) <> end subroutine mpi90_size @ %def mpi90_size @ <>= subroutine mpi90_rank (rank, domain, error) integer, intent(out) :: rank integer, intent(in), optional :: domain integer, intent(out), optional :: error character(len=*), parameter :: FN = "mpi90_rank" integer :: local_domain, local_error external mpi_comm_rank <> call mpi_comm_rank (local_domain, rank, local_error) <> end subroutine mpi90_rank @ %def mpi90_rank @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Point to Point} <>= public :: mpi90_send public :: mpi90_receive public :: mpi90_receive_pointer @ <>= interface mpi90_send module procedure & mpi90_send_integer, mpi90_send_double, & mpi90_send_integer_array, mpi90_send_double_array, & mpi90_send_integer_array2, mpi90_send_double_array2 end interface @ %def mpi90_send @ <>= subroutine mpi90_send_integer (value, target, tag, domain, error) integer, intent(in) :: value integer, intent(in) :: target, tag integer, intent(in), optional :: domain integer, intent(out), optional :: error call mpi90_send_integer_array ((/ value /), target, tag, domain, error) end subroutine mpi90_send_integer @ %def mpi90_send_integer @ <>= subroutine mpi90_send_double (value, target, tag, domain, error) real(kind=default), intent(in) :: value integer, intent(in) :: target, tag integer, intent(in), optional :: domain integer, intent(out), optional :: error call mpi90_send_double_array ((/ value /), target, tag, domain, error) end subroutine mpi90_send_double @ %def mpi90_send_double @ <>= subroutine mpi90_send_integer_array (buffer, target, tag, domain, error) integer, dimension(:), intent(in) :: buffer integer, intent(in) :: target, tag integer, intent(in), optional :: domain integer, intent(out), optional :: error character(len=*), parameter :: FN = "mpi90_send_integer_array" integer, parameter :: datatype = MPI_INTEGER <> end subroutine mpi90_send_integer_array @ %def mpi90_send_integer_array @ <>= integer :: local_domain, local_error external mpi_send <> call mpi_send (buffer, size (buffer), datatype, target, tag, & local_domain, local_error) <> @ <>= subroutine mpi90_send_double_array (buffer, target, tag, domain, error) real(kind=default), dimension(:), intent(in) :: buffer integer, intent(in) :: target, tag integer, intent(in), optional :: domain integer, intent(out), optional :: error character(len=*), parameter :: FN = "mpi90_send_double_array" integer, parameter :: datatype = MPI_DOUBLE_PRECISION <> end subroutine mpi90_send_double_array @ %def mpi90_send_double_array @ <>= subroutine mpi90_send_integer_array2 (value, target, tag, domain, error) integer, dimension(:,:), intent(in) :: value integer, intent(in) :: target, tag integer, intent(in), optional :: domain integer, intent(out), optional :: error integer, dimension(size(value)) :: buffer buffer = reshape (value, shape(buffer)) call mpi90_send_integer_array (buffer, target, tag, domain, error) end subroutine mpi90_send_integer_array2 @ %def mpi90_send_integer_array2 @ <>= subroutine mpi90_send_double_array2 (value, target, tag, domain, error) real(kind=default), dimension(:,:), intent(in) :: value integer, intent(in) :: target, tag integer, intent(in), optional :: domain integer, intent(out), optional :: error real(kind=default), dimension(size(value)) :: buffer buffer = reshape (value, shape(buffer)) call mpi90_send_double_array (buffer, target, tag, domain, error) end subroutine mpi90_send_double_array2 @ %def mpi90_send_double_array2 @ <>= type, public :: mpi90_status integer :: count, source, tag, error end type mpi90_status @ %def mpi90_status @ <>= subroutine mpi90_receive_integer (value, source, tag, domain, status, error) integer, intent(out) :: value integer, intent(in), optional :: source, tag, domain type(mpi90_status), intent(out), optional :: status integer, intent(out), optional :: error integer, dimension(1) :: buffer call mpi90_receive_integer_array (buffer, source, tag, domain, status, error) value = buffer(1) end subroutine mpi90_receive_integer @ %def mpi90_receive_integer @ <>= interface mpi90_receive module procedure & mpi90_receive_integer, mpi90_receive_double, & mpi90_receive_integer_array, mpi90_receive_double_array, & mpi90_receive_integer_array2, mpi90_receive_double_array2 end interface @ %def mpi90_receive @ <>= if (present (source)) then local_source = source else local_source = MPI_ANY_SOURCE end if if (present (tag)) then local_tag = tag else local_tag = MPI_ANY_TAG end if <> @ <>= subroutine mpi90_receive_double (value, source, tag, domain, status, error) real(kind=default), intent(out) :: value integer, intent(in), optional :: source, tag, domain type(mpi90_status), intent(out), optional :: status integer, intent(out), optional :: error real(kind=default), dimension(1) :: buffer call mpi90_receive_double_array (buffer, source, tag, domain, status, error) value = buffer(1) end subroutine mpi90_receive_double @ %def mpi90_receive_double @ <>= subroutine mpi90_receive_integer_array & (buffer, source, tag, domain, status, error) integer, dimension(:), intent(out) :: buffer integer, intent(in), optional :: source, tag, domain type(mpi90_status), intent(out), optional :: status integer, intent(out), optional :: error character(len=*), parameter :: FN = "mpi90_receive_integer_array" integer, parameter :: datatype = MPI_INTEGER <> end subroutine mpi90_receive_integer_array @ %def mpi90_receive_integer_array @ <>= integer :: local_source, local_tag, local_domain, local_error integer, dimension(MPI_STATUS_SIZE) :: local_status external mpi_receive, mpi_get_count <> call mpi_recv (buffer, size (buffer), datatype, local_source, local_tag, & local_domain, local_status, local_error) <> if (present (status)) then call decode_status (status, local_status, datatype) end if @ <>= private :: decode_status @ \begin{dubious} Can we ignore [[ierror]]??? \end{dubious} <>= subroutine decode_status (status, mpi_status, datatype) type(mpi90_status), intent(out) :: status integer, dimension(:), intent(in) :: mpi_status integer, intent(in), optional :: datatype integer :: ierror if (present (datatype)) then call mpi_get_count (mpi_status, datatype, status%count, ierror) else status%count = 0 end if status%source = mpi_status(MPI_SOURCE) status%tag = mpi_status(MPI_TAG) status%error = mpi_status(MPI_ERROR) end subroutine decode_status @ %def decode_status @ <>= subroutine mpi90_receive_double_array & (buffer, source, tag, domain, status, error) real(kind=default), dimension(:), intent(out) :: buffer integer, intent(in), optional :: source, tag, domain type(mpi90_status), intent(out), optional :: status integer, intent(out), optional :: error character(len=*), parameter :: FN = "mpi90_receive_double_array" integer, parameter :: datatype = MPI_DOUBLE_PRECISION <> end subroutine mpi90_receive_double_array @ %def mpi90_receive_double_array @ <>= subroutine mpi90_receive_integer_array2 & (value, source, tag, domain, status, error) integer, dimension(:,:), intent(out) :: value integer, intent(in), optional :: source, tag, domain type(mpi90_status), intent(out), optional :: status integer, intent(out), optional :: error integer, dimension(size(value)) :: buffer call mpi90_receive_integer_array & (buffer, source, tag, domain, status, error) value = reshape (buffer, shape(value)) end subroutine mpi90_receive_integer_array2 @ %def mpi90_receive_integer_array2 @ <>= subroutine mpi90_receive_double_array2 & (value, source, tag, domain, status, error) real(kind=default), dimension(:,:), intent(out) :: value integer, intent(in), optional :: source, tag, domain type(mpi90_status), intent(out), optional :: status integer, intent(out), optional :: error real(kind=default), dimension(size(value)) :: buffer call mpi90_receive_double_array & (buffer, source, tag, domain, status, error) value = reshape (buffer, shape(value)) end subroutine mpi90_receive_double_array2 @ %def mpi90_receive_double_array2 @ <>= interface mpi90_receive_pointer module procedure & mpi90_receive_integer_pointer, mpi90_receive_double_pointer end interface @ %def mpi90_receive_pointer @ <>= subroutine mpi90_receive_integer_pointer & (buffer, source, tag, domain, status, error) integer, dimension(:), pointer :: buffer integer, intent(in), optional :: source, tag, domain type(mpi90_status), intent(out), optional :: status integer, intent(out), optional :: error character(len=*), parameter :: FN = "mpi90_receive_integer_pointer" integer, parameter :: datatype = MPI_INTEGER <> end subroutine mpi90_receive_integer_pointer @ %def mpi90_receive_integer_pointer @ <>= integer :: local_source, local_tag, local_domain, local_error, buffer_size integer, dimension(MPI_STATUS_SIZE) :: local_status integer :: ierror external mpi_receive, mpi_get_count <> @ <>= call mpi_probe (local_source, local_tag, local_domain, & local_status, local_error) <> @ \begin{dubious} Can we ignore [[ierror]]??? \end{dubious} <>= call mpi_get_count (local_status, datatype, buffer_size, ierror) if (associated (buffer)) then if (size (buffer) /= buffer_size) then deallocate (buffer) allocate (buffer(buffer_size)) end if else allocate (buffer(buffer_size)) end if @ <>= call mpi_recv (buffer, size (buffer), datatype, local_source, local_tag, & local_domain, local_status, local_error) @ <>= <> if (present (status)) then call decode_status (status, local_status, datatype) end if @ <>= subroutine mpi90_receive_double_pointer & (buffer, source, tag, domain, status, error) real(kind=default), dimension(:), pointer :: buffer integer, intent(in), optional :: source, tag, domain type(mpi90_status), intent(out), optional :: status integer, intent(out), optional :: error character(len=*), parameter :: FN = "mpi90_receive_double_pointer" integer, parameter :: datatype = MPI_DOUBLE_PRECISION <> end subroutine mpi90_receive_double_pointer @ %def mpi90_receive_double_pointer @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Collective Communication} <>= public :: mpi90_broadcast @ <>= interface mpi90_broadcast module procedure & mpi90_broadcast_integer, mpi90_broadcast_integer_array, & mpi90_broadcast_integer_array2, mpi90_broadcast_integer_array3, & mpi90_broadcast_double, mpi90_broadcast_double_array, & mpi90_broadcast_double_array2, mpi90_broadcast_double_array3, & mpi90_broadcast_logical, mpi90_broadcast_logical_array, & mpi90_broadcast_logical_array2, mpi90_broadcast_logical_array3 end interface @ %def mpi90_broadcast @ <>= if (present (domain)) then local_domain = domain else local_domain = MPI_COMM_WORLD end if @ <>= subroutine mpi90_broadcast_integer (value, root, domain, error) integer, intent(inout) :: value integer, intent(in) :: root integer, intent(in), optional :: domain integer, intent(out), optional :: error integer, dimension(1) :: buffer buffer(1) = value call mpi90_broadcast_integer_array (buffer, root, domain, error) value = buffer(1) end subroutine mpi90_broadcast_integer @ %def mpi90_broadcast_integer @ <>= subroutine mpi90_broadcast_double (value, root, domain, error) real(kind=default), intent(inout) :: value integer, intent(in) :: root integer, intent(in), optional :: domain integer, intent(out), optional :: error real(kind=default), dimension(1) :: buffer buffer(1) = value call mpi90_broadcast_double_array (buffer, root, domain, error) value = buffer(1) end subroutine mpi90_broadcast_double @ %def mpi90_broadcast_double @ <>= subroutine mpi90_broadcast_logical (value, root, domain, error) logical, intent(inout) :: value integer, intent(in) :: root integer, intent(in), optional :: domain integer, intent(out), optional :: error logical, dimension(1) :: buffer buffer(1) = value call mpi90_broadcast_logical_array (buffer, root, domain, error) value = buffer(1) end subroutine mpi90_broadcast_logical @ %def mpi90_broadcast_logical @ <>= subroutine mpi90_broadcast_integer_array (buffer, root, domain, error) integer, dimension(:), intent(inout) :: buffer integer, intent(in) :: root integer, intent(in), optional :: domain integer, intent(out), optional :: error character(len=*), parameter :: FN = "mpi90_broadcast_integer_array" integer, parameter :: datatype = MPI_INTEGER <> end subroutine mpi90_broadcast_integer_array @ %def mpi90_broadcast_integer_array @ <>= integer :: local_domain, local_error external mpi_bcast <> call mpi_bcast (buffer, size (buffer), datatype, root, & local_domain, local_error) <> @ <>= subroutine mpi90_broadcast_double_array (buffer, root, domain, error) real(kind=default), dimension(:), intent(inout) :: buffer integer, intent(in) :: root integer, intent(in), optional :: domain integer, intent(out), optional :: error integer, parameter :: datatype = MPI_DOUBLE_PRECISION character(len=*), parameter :: FN = "mpi90_broadcast_double_array" <> end subroutine mpi90_broadcast_double_array @ %def mpi90_broadcast_double_array @ <>= subroutine mpi90_broadcast_logical_array (buffer, root, domain, error) logical, dimension(:), intent(inout) :: buffer integer, intent(in) :: root integer, intent(in), optional :: domain integer, intent(out), optional :: error integer, parameter :: datatype = MPI_LOGICAL character(len=*), parameter :: FN = "mpi90_broadcast_logical_array" <> end subroutine mpi90_broadcast_logical_array @ %def mpi90_broadcast_logical_array @ <>= subroutine mpi90_broadcast_integer_array2 (value, root, domain, error) integer, dimension(:,:), intent(inout) :: value integer, intent(in) :: root integer, intent(in), optional :: domain integer, intent(out), optional :: error integer, dimension(size(value)) :: buffer buffer = reshape (value, shape(buffer)) call mpi90_broadcast_integer_array (buffer, root, domain, error) value = reshape (buffer, shape(value)) end subroutine mpi90_broadcast_integer_array2 @ %def mpi90_broadcast_integer_array2 @ <>= subroutine mpi90_broadcast_double_array2 (value, root, domain, error) real(kind=default), dimension(:,:), intent(inout) :: value integer, intent(in) :: root integer, intent(in), optional :: domain integer, intent(out), optional :: error real(kind=default), dimension(size(value)) :: buffer buffer = reshape (value, shape(buffer)) call mpi90_broadcast_double_array (buffer, root, domain, error) value = reshape (buffer, shape(value)) end subroutine mpi90_broadcast_double_array2 @ %def mpi90_broadcast_double_array2 @ <>= subroutine mpi90_broadcast_logical_array2 (value, root, domain, error) logical, dimension(:,:), intent(inout) :: value integer, intent(in) :: root integer, intent(in), optional :: domain integer, intent(out), optional :: error logical, dimension(size(value)) :: buffer buffer = reshape (value, shape(buffer)) call mpi90_broadcast_logical_array (buffer, root, domain, error) value = reshape (buffer, shape(value)) end subroutine mpi90_broadcast_logical_array2 @ %def mpi90_broadcast_logical_array2 @ <>= subroutine mpi90_broadcast_integer_array3 (value, root, domain, error) integer, dimension(:,:,:), intent(inout) :: value integer, intent(in) :: root integer, intent(in), optional :: domain integer, intent(out), optional :: error integer, dimension(size(value)) :: buffer buffer = reshape (value, shape(buffer)) call mpi90_broadcast_integer_array (buffer, root, domain, error) value = reshape (buffer, shape(value)) end subroutine mpi90_broadcast_integer_array3 @ %def mpi90_broadcast_integer_array3 @ <>= subroutine mpi90_broadcast_double_array3 (value, root, domain, error) real(kind=default), dimension(:,:,:), intent(inout) :: value integer, intent(in) :: root integer, intent(in), optional :: domain integer, intent(out), optional :: error real(kind=default), dimension(size(value)) :: buffer buffer = reshape (value, shape(buffer)) call mpi90_broadcast_double_array (buffer, root, domain, error) value = reshape (buffer, shape(value)) end subroutine mpi90_broadcast_double_array3 @ %def mpi90_broadcast_double_array3 @ <>= subroutine mpi90_broadcast_logical_array3 (value, root, domain, error) logical, dimension(:,:,:), intent(inout) :: value integer, intent(in) :: root integer, intent(in), optional :: domain integer, intent(out), optional :: error logical, dimension(size(value)) :: buffer buffer = reshape (value, shape(buffer)) call mpi90_broadcast_logical_array (buffer, root, domain, error) value = reshape (buffer, shape(value)) end subroutine mpi90_broadcast_logical_array3 @ %def mpi90_broadcast_logical_array3 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/vamp_stat.nw =================================================================== --- trunk/vamp/src/vamp_stat.nw (revision 8740) +++ trunk/vamp/src/vamp_stat.nw (revision 8741) @@ -1,108 +1,104 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP vamp_stat code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: vamp_stat.nw 314 2010-04-17 20:32:33Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Statistics} <<[[vamp_stat.f90]]>>= ! vamp_stat.f90 -- <> module vamp_stat use kinds implicit none private <> - character(len=*), public, parameter :: VAMP_STAT_RCS_ID = & - "$Id: vamp_stat.nw 314 2010-04-17 20:32:33Z ohl $" contains <> end module vamp_stat @ %def vamp_stat @ <>= public :: average, standard_deviation, value_spread @ \begin{equation} \mathop{\textrm{avg}} (X) = \frac{1}{|X|} \sum_{x\in X} x \end{equation} <>= pure function average (x) result (a) real(kind=default), dimension(:), intent(in) :: x real(kind=default) :: a integer :: n n = size (x) if (n == 0) then a = 0.0 else a = sum (x) / n end if end function average @ %def average @ \begin{equation} \mathop{\textrm{stddev}} (X) = \frac{1}{|X|-1} \sum_{x\in X} (x - \mathop{\textrm{avg}}(X))^2 = \frac{1}{|X|-1} \left( \frac{1}{|X|} \sum_{x\in X} x^2 - \left(\mathop{\textrm{avg}}(X)\right)^2 \right) \end{equation} <>= pure function standard_deviation (x) result (s) real(kind=default), dimension(:), intent(in) :: x real(kind=default) :: s integer :: n n = size (x) if (n < 2) then s = huge (s) else s = sqrt (max ((sum (x**2) / n - (average (x))**2) / (n - 1), & 0.0_default)) end if end function standard_deviation @ %def standard_deviation @ \begin{equation} \mathop{\textrm{spread}} (X) = \max_{x\in X}(x) - \min_{x\in X}(x) \end{equation} <>= pure function value_spread (x) result (s) real(kind=default), dimension(:), intent(in) :: x real(kind=default) :: s s = maxval(x) - minval(x) end function value_spread @ %def value_spread @ <>= public :: standard_deviation_percent, value_spread_percent @ <>= pure function standard_deviation_percent (x) result (s) real(kind=default), dimension(:), intent(in) :: x real(kind=default) :: s real(kind=default) :: abs_avg abs_avg = abs (average (x)) if (abs_avg <= tiny (abs_avg)) then s = huge (s) else s = 100.0 * standard_deviation (x) / abs_avg end if end function standard_deviation_percent @ %def standard_deviation_percent @ <>= pure function value_spread_percent (x) result (s) real(kind=default), dimension(:), intent(in) :: x real(kind=default) :: s real(kind=default) :: abs_avg abs_avg = abs (average (x)) if (abs_avg <= tiny (abs_avg)) then s = huge (s) else s = 100.0 * value_spread (x) / abs_avg end if end function value_spread_percent @ %def value_spread_percent @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/postlude.nw =================================================================== --- trunk/vamp/src/postlude.nw (revision 8740) +++ trunk/vamp/src/postlude.nw (revision 8741) @@ -1,193 +1,190 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\RCSId$Id: postlude.nw 314 2010-04-17 20:32:33Z ohl $ -@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Ideas} \section{Toolbox for Interactive Optimization} \paragraph{Idea:} Provide a OpenGL interface to visualize the grid optimization. \paragraph{Motivation:} Would help multi channel developers. \paragraph{Implementation:} Coding is straightforward, but interface design is hard. \section{Partially Non-Factorized Importance Sampling} \paragraph{Idea:} Allow non-factorized grid optimization in two- or three-dimensional subspaces. \paragraph{Motivation:} Handle nastiest subspaces. Non-factorized approaches are impossible in higher than three dimensions (and probably only realistic in two dimensions), but there are cases that are best handled by including non-factorized optimization in two dimensions. \paragraph{Implementation:} The problem is that the present [[vamp_sample_grid0]] can't accomodate this, because other auxiliary information has to be collected, but a generalization is straightforward. Work has to start from an extended [[divisions]] module. \section{Correlated Importance Sampling (?)} \paragraph{Idea:} Is it possible to include \emph{some} correlations in a mainly factorized context? \paragraph{Motivation:} Would be nice \ldots \paragraph{Implementation:} First, I have to think about the maths \ldots \section{Align Coordinate System (i.e.~the grid) with Singularities (or the hot region)} \paragraph{Idea:} Solve \texttt{vegas}' nastiest problem by finding the direction(s) along which singularities are aligned. \paragraph{Motivation:} Automatically choose proper coordinate system in generator generators and separate wild and smooth directions. \paragraph{Implementation:} Diagonalize the covariance matrix~$\mathop{\textrm{cov}}(x_ix_j)$ to find better axes. Caveats: \begin{itemize} \item damp rotations (rotate only if eigenvalues are spread out sufficiently). \item be careful about blow up of the integration volume, which is $V' = Vd^{d/2}$ in the worst case for hypercubes and can be even worse for stretched cubes. (An adaptive grid can help, since we will have more smooth directions!) \end{itemize} \emph{Maybe} try non-linear transformations as well. \section{Automagic Multi Channel} \paragraph{Idea:} Find and extract one singularity after the other. \paragraph{Motivation:} Obvious. \paragraph{Implementation:} Either use multiple of \texttt{vegas}' $p(x)$ for importance sampling. Or find hot region(s) and split the integration region (\'a la signal/background). @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Cross References} \section{Identifiers} \nowebindex \section{Refinements} \nowebchunks \InputIfFileExists{\jobname.ind}{}{} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section*{Acknowledgements} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% \bibliography{jpsi} \begin{thebibliography}{10} \bibitem{Lepage:1978:vegas} G.~P.~Lepage, J.~Comp.\ Phys.\ \textbf{27}, 192 (1978). \bibitem{Lepage:1980:vegas} G.~P.~Lepage, \textit{\texttt{VEGAS} -- An Adaptive Multi-dimensional Integration Program}, Cornell preprint, CLNS-80/447, March 1980. \bibitem{Ohl:1998:VAMP-preview} T.~Ohl, \textit{Vegas Revisited: Adaptive Monte Carlo Integration Beyond Factorization}, hep-ph/9806432, Preprint IKDA 98/15, Darmstadt University of Technology, 1998. \bibitem{Knuth:1991:literate_programming} D.~E.~Knuth, \textit{Literate Programming}, Vol.~27 of \textit{{CSLI} Lecture Notes} (Center for the Study of Language and Information, Leland Stanford Junior University, Stanford, CA, 1991). \bibitem{Ramsey:1994:noweb} N.~Ramsey, IEEE Software \textbf{11}, 97 (1994). \bibitem{FORTRAN77} American National Standards Institute, \textit{American National Standard Programming Languages FORTRAN, ANSI X3.9-1978,} New York, 1978. \bibitem{Fortran90} International Standards Organization, \textit{ISO/IEC 1539:1991, Information technology --- Programming Languages --- Fortran,} Geneva, 1991. \bibitem{Fortran03} International Standards Organization, \textit{ISO/IEC 1539-1:2004, Information technology --- Programming Languages --- Fortran,} Geneva, 2004. \bibitem{Fortran95} International Standards Organization, \textit{ISO/IEC 1539:1997, Information technology --- Programming Languages --- Fortran,} Geneva, 1997. \bibitem{HPF1.1} High Performance Fortran Forum, \textit{High Performance Fortran Language Specification, Version 1.1}, Rice University, Houston, Texas, 1994. \bibitem{HPF2.0} High Performance Fortran Forum, \textit{High Performance Fortran Language Specification, Version 2.0}, Rice University, Houston, Texas, 1997. \bibitem{MPI} Message Passing Interface Forum, \textit{MPI: A Message Passing Interface Standard}, Technical Report CS-94230, University of Tennessee, Knoxville, Tennessee, 1994. \bibitem{Adams/etal:1997:Fortran95} J.~C.~Adams, W.~S.~Brainerd, J.~T.~Martin, B.~T.~Smith, and J.~L.~Wagener, \textit{Fortran 95 Handbook,} The MIT Press, Cambridge, MA, 1997. \bibitem{Metcalf/Reid:1996:F} Michael Metcalf and John Reid, \textit{The F Programming Language}, (Oxford University Press, 1996). \bibitem{Koelbel/etal:1994:HPF} C.~H.~Koelbel, D.~B.~Loveman, R.~S.~Schreiber, G.~L.~Steele Jr., and M.~E.~Zosel, \textit{The High Performance Fortran Handbook,} The MIT Press, Cambridge, MA, 1994. \bibitem{Knuth:1997:TAOCP2} D.~E. Knuth, \textit{Seminumerical Algorithms} (third edition), Vol.~2 of \textit{The Art of Computer Programming}, (Addison-Wesley, 1997). \bibitem{Press/etal:1992:NumRecC} W.~H.~Press, S.~A.~Teukolsky, W.~T.~Vetterling, B.~P.Flannery, \textit{Numerical Recipies in C: The Art of Scientific Computing}, 2nd edition, (Cambridge University Press, 1992) \bibitem{Press/etal:1992:NumRec77} W.~H.~Press, S.~A.~Teukolsky, W.~T.~Vetterling, B.~P.Flannery, \textit{Numerical Recipies in Fortran77: The Art of Scientific Computing}, Volume~1 of \textit{Fortran Numerical Recipies}, 2nd edition, (Cambridge University Press, 1992) \bibitem{Press/etal:1996:NumRec90} W.~H.~Press, S.~A.~Teukolsky, W.~T.~Vetterling, B.~P.Flannery, \textit{Numerical Recipies in Fortran90: The Art of Parallel Scientific Computing}, Volume~2 of \textit{Fortran Numerical Recipies}, (Cambridge University Press, 1992) \bibitem{Kawabata:1986:Bases/Spring} S.~Kawabata, Comp.\ Phys.\ Comm.\ \textbf{41}, 127 (1986). \bibitem{GRACE:1993:Manual} MINAMI-TATEYA Group, \textit{GRACE Manual}, KEK Report 92-19. \bibitem{Veseli:1998:Parallel-Vegas} S.~Veseli, Comp.\ Phys.\ Comm.\ \textbf{108}, 9 (1998). \bibitem{Kleiss/Pittau:1994:multichannel} R.~Kleiss, R.~Pittau, \textit{Weight Optimization in Multichannel Monte Carlo,} Comp.\ Phys.\ Comm.\ \textbf{83}, 141 (1994). \bibitem{Marsaglia:1996:CD} George Marsaglia, \textit{The Marsaglia Random Number CD-ROM}, FSU, Dept.~of Statistics and SCRI, 1996. \bibitem{Luk75} Y. L. Luke, \textit{Mathematical Functions and their Approximations}, Academic Press, New York, 1975. \bibitem{Kleiss/Stirling/Ellis:1986:RAMBO} R. Kleiss, W. J. Stirling, S. D. Ellis, \textit{A New Monte Carlo Treatment of Multiparticle Phase Space at High Energies}, Comp.\ Phys.\ Comm.\ \textbf{40}, 359 (1986). \end{thebibliography} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \end{fmffile} \end{empfile} -\end{RCS} \end{document}