Related
I am using a simple 'leapfrog algorithm I am aiming to simulate the orbits of the earth a Jupiter around the sun. I am unable to get them to orbit despite being fairly sure the maths is correct. It appears that gravity is acting too weekly and the planet merely floats away from the sun, interestingly if I adjust the Newtonian acceleration due to gravity term by multiplying it by rad2 I find that the system does indeed produce fairly stable orbits but at much much too large radii.
program physim
Implicit none
integer :: i,j,n,day ! Integer variables
doubleprecision :: G , r(1:3,1:10) , a(1:3, 1:10) , v(1:3, 1:10) , m(1:3), dt, Au, dr(1:3),
rad2(1:3), t, tcount, tend, tout
! constants
day = 86400
tout = 10*day
tend = 20*day
Au = 15e11
n = 3
G = 6.67e-11
!n = 2
dt = 100
!sun
r(1,1) = 0.
r(2,1) = 0.
r(3,1) = 0.
v(1,1) = 0.
v(2,1) = 0.
v(3,1) = 0.
m(1) = 1.9898e30
!earth
r(1,2) = Au
r(2,2) = 0.
r(3,2) = 0.
v(1,2) = 0.
v(2,2) = 30000
v(3,2) = 0.
m(2) = 6e24
!jupiter
r(1,3) = 5.2*Au
r(2,3) = 0.
r(3,3) = 0.
v(1,3) = 0.
v(2,3) = 13070
v(3,3) = 0.
m(3) = 2e27
do
a = 0
tcount = 0
do i = 1, n
do j = 1, n
!calculating acceleration
if (i==j)cycle
dr(1:3) = r(1:3, j) - r(1:3, i)
rad2 = dr(1)**2 + dr(2)**2 + dr(3)**2
a(1:3, i) = a(1:3, i) + G*m(j)*dr(1:3)/(rad2*sqrt(rad2))
end do
end do
do i = 1, n
r(1:3 ,i) = r(1:3, i) + v(1:3, i)*dt
v(1:3, i) = v(1:3, i) + a(1:3, i)*dt
end do
t = t + dt
tcount = t + dt
if(tcount>tout) then
!write(6,*) a(1,2)
!write(6,*) rad2
write(6,*) a(1,1) , a(2,1), a(3, 2)
end if
end do
end program
Your most fundamental problem was that 1 A.U. = 1.5e11 m, not 15e11. Then you were doing stuff like resetting tcount every trip through the loop. Set it before the start of the main loop and then only reset when you print out a line of output. It should be updated as tcount=tcount+dt and then you probably want to print out r(1,2) , r(2,2), r(1,3) , r(2,3) so you can plot the positions of jupiter and earth. Also you should maybe go for more time so you can see a few full orbits of earth, and finally put a test at the bottom of the loop so it will exit when t>tend. Making these changes I got output that looked like this:
I have a program to draw a grid of ellipses with a uniform phase distribution. However, it is very slow.
I'd like my code to be faster, so that I can use, for example, N = 150, M = 150.
How can I speed up this code?
N = 10;
M = 10;
y = 1;
x = 1;
a = 1;
b = 2;
for k = 1:N
for m = 1:N
w = rand(1,1);
for l = 1:N
for s = 1:N
if(((l-x)*cos(w*pi)+(s-y)*sin(w*pi)).^2/a^2 + (-(l-x)*sin(w*pi) + (s-y)*cos(w*pi)).^2/b.^2 <= 1)
f(l,s) = 1*(cos(0.001)+i*sin(0.001));
end
end
end
y = y+4;
end
y = 1;
x = x+5;
end
image(arg(f),'CDataMapping','scaled');
This is what the code produces:
Updated:
N = 10;
M = 10;
y = 1;
x = 1;
a = 1;
b = 2;
for x = 1:5:N
for y = 1:4:N
w = rand(1);
for l = 1:N
for s = 1:N
if(((l-x).*cos(w.*pi)+(s-y).*sin(w.*pi)).^2/a.^2 + (-(l-x).*sin(w.*pi) + (s-y).*cos(w.*pi)).^2/b.^2 <= 1)
f(l,s) = cos(0.001)+i.*sin(0.001);
end
end
end
end
y = 1;
end
image(arg(f),'CDataMapping','scaled');
There are many things you can do to speed up the computation. One important one is to remove loops and replace them with vectorized code. Octave works much faster when doing many computations as once, as opposed to one at a time.
For example, instead of
for l = 1:N
for s = 1:N
if(((l-x).*cos(w.*pi)+(s-y).*sin(w.*pi)).^2/a.^2 + (-(l-x).*sin(w.*pi) + (s-y).*cos(w.*pi)).^2/b.^2 <= 1)
f(l,s) = cos(0.001)+i.*sin(0.001);
end
end
end
one can write
l = 1:N;
s = (1:N).';
index = ((l-x).*cos(w.*pi)+(s-y).*sin(w.*pi)).^2/a.^2 + (-(l-x).*sin(w.*pi) + (s-y).*cos(w.*pi)).^2/b.^2 <= 1;
f(index) = cos(0.001)+i.*sin(0.001);
However, here we still do too much work because we compute index at locations that we know will be outside the extend of the ellipse. Ideally we'd find a smaller region around each point (x,y) that we know the ellipse fits into.
Another important thing to do is preallocate the array. f grows within the loop iterations. Instead, one should create f with its final size before the loop starts.
There are also many redundant computations being made. For example w.*pi is computed multiple times, and the cos and sin of it too. You also assign cos(0.001)+i.*sin(0.001) to output pixels over and over again, this could be a constant computed once.
The following code runs in MATLAB in a tiny fraction of a second (though Octave will be a lot slower). I've also separated N and M properly (so the output is not always square) and made the step sizes a variable for improved understanding of the code. I'm assigning 1 to the ellipse elements, you can replace them by your constant by multiplying f = f * (cos(0.001)+i*sin(0.001)).
N = 150;
M = 200;
a = 5;
b = 10;
x_step = 25;
y_step = 25;
f = zeros(N,M);
for x = x_step/2:x_step:M
for y = y_step/2:y_step:N
phi = rand(1)*pi;
cosphi = cos(phi);
sinphi = sin(phi);
l = (1:M)-x;
s = (1:N).'-y;
index = (l*cosphi+s*sinphi).^2/a.^2 + (-l*sinphi + s*cosphi).^2/b.^2 <= 1;
f(index) = 1;
end
end
I'm not 100% sure what you're trying to do. See the code below and let me know. It took me about 30 s to run the 150 x 150 case. Not sure if that's fast enough
[h,k] = meshgrid(0:150, 0:150);
a = 0.25;
b = 0.5;
phi = reshape( linspace( 0 , 2*pi , numel(h) ), size(h));
theta = linspace(0,2*pi,50)';
x = a*cos(theta);
y = b*sin(theta);
h = h(:);
k = k(:);
phi = phi(:);
ellipseX = arrayfun(#(H,K,F) x*cos(F)-y*sin(F) + H , h,k,phi, 'uni', 0);
ellipseY = arrayfun(#(H,K,F) x*sin(F)+y*cos(F) + K , h,k,phi, 'uni', 0);
ellipse = [ellipseX, ellipseY, repmat({'r'}, size(ellipseX))]';
fill(ellipse{:})
I need help calculating fiber length. I found all the coordinate values of center line of fiber by using regional maximal of euclidean distance. Here is the image that I got after applying regional maximal of euclidean distance. Now I want to draw a line on each fiber by using these points how can I do that so that I can extract each fiber length automatically. I tried to do it by using spline curve fitting. But the problem is I was not able to initiate the starting and ending point of fiber. How can I calculate each fiber length?
close all;
clear all;
clc
ima=imread('ecm61.png');
ima=bwareaopen(ima,50);
[rowsInImage,columnImage]=size(ima);
skel= bwmorph(ima,'skel',Inf);
figure
imshow(skel)
B = bwmorph(skel, 'branchpoints');
E = bwmorph(skel, 'endpoints');
[x,y] = find(E);
%plot(x,y,'+')
B_loc = find(B);
Dmask = false(size(skel));
for k = 1:numel(y)
D = bwdistgeodesic(skel,y(k),x(k));
distanceToBranchPt = min(D(B_loc));
Dmask(D < distanceToBranchPt) =true;
end
skelD = skel - Dmask;
figure
imshow(skelD);
hold all;
[x,y] = find(B); plot(y,x,'ro')
numberOfEndpoints=length(y);
% Label the image. Gives each separate segment a unique ID label number.
[labeledImage, numberOfSegments] = bwlabel(skelD);
fprintf('There are %d endpoints on %d segments.\n', numberOfEndpoints, numberOfSegments);
% Get the label numbers (segment numbers) of every endpoint.
for k = 1 : numberOfEndpoints
thisRow = x(k);
thisColumn = y(k);
%line([endPointRows(k),endPointColumns(k)],[endPointRows(k+1),endPointColumns(k+1)])
% Get the label number of this segment
theLabels(k) = labeledImage(thisRow, thisColumn);
fprintf('Endpoint #%d at (%d, %d) is in segment #%d.\n', k, thisRow, thisColumn, theLabels(k));
end
% For each endpoint, find the closest other endpoint
% that is not in the same segment
for k = 1 : numberOfEndpoints
thisRow = x(k);
thisColumn =y(k);
% Get the label number of this segment
thisLabel = theLabels(k);
otherEndpointIndexes = setdiff(1:numberOfEndpoints, k);
%if mustBeDifferent
% If they want to consider joining only end points that reside on different segments
% then we need to remove the end points on the same segment from the "other" list.
% Get the label numbers of the other end points.
%otherLabels = theLabels(otherEndpointIndexes);
%onSameSegment = (otherLabels == thisLabel); % List of what segments are the same as this segment
%otherEndpointIndexes(onSameSegment) = []; % Remove if on the same segment
%end
% Now get a list of only those end points that are on a different segment.
otherCols = y(otherEndpointIndexes);
otherRows = x(otherEndpointIndexes);
% Compute distances
distances = sqrt((thisColumn - otherCols).^2 + (thisRow - otherRows).^2);
% Find the min
[minDistance, indexOfMin] = min(distances);
nearestX = otherCols(indexOfMin);
nearestY = otherRows(indexOfMin);
%if minDistance < longestGapToClose;
if minDistance < rowsInImage
% Draw line from this endpoint to the other endpoint.
line([thisColumn, nearestX], [thisRow, nearestY], 'Color', 'g', 'LineWidth', 2);
fprintf('Drawing line #%d, %.1f pixels long, from (%d, %d) on segment #%d to (%d, %d) on segment #%d.\n', ...
k, minDistance, thisColumn, thisRow, theLabels(k), nearestX, nearestY, theLabels(indexOfMin));
end
end
title('Endpoints Linked by Green Lines', 'FontSize', 12, 'Interpreter', 'None');
after using edge linking
I would do this:
Skeletonize
Pruning
Find the different path at each intersection. It will give you the different segments, and you can reconnect them using the orientation.
I am searching for an algorithm or C++/Matlab library that can be used to separate two images multiplied together. A visual example of this problem is given below.
Image 1 can be anything (such as a relatively complicated scene). Image 2 is very simple, and can be mathematically generated. Image 2 always has similar morphology (i.e. downward trend). By multiplying Image 1 by Image 2 (using point-by-point multiplication), we get a transformed image.
Given only the transformed image, I would like to estimate Image 1 or Image 2. Is there an algorithm that can do this?
Here are the Matlab code and images:
load('trans.mat');
imageA = imread('room.jpg');
imageB = abs(response); % loaded from MAT file
[m,n] = size(imageA);
image1 = rgb2gray( imresize(im2double(imageA), [m n]) );
image2 = imresize(im2double(imageB), [m n]);
figure; imagesc(image1); colormap gray; title('Image 1 of Room')
colorbar
figure; imagesc(image2); colormap gray; title('Image 2 of Response')
colorbar
% This is image1 and image2 multiplied together (point-by-point)
trans = image1 .* image2;
figure; imagesc(trans); colormap gray; title('Transformed Image')
colorbar
UPDATE
There are a number of ways to approach this problem. Here are the results of my experiments. Thank you to all who responded to my question!
1. Low-pass filtering of image
As noted by duskwuff, taking the low-pass filter of the transformed image returns an approximation of Image 2. In this case, the low-pass filter has been Gaussian. You can see that it is possible to identify multiplicative noise in the image using the low-pass filter.
2. Homomorphic Filtering
As suggested by EitenT I examined homomorphic filtering. Knowing the name of this type of image filtering, I managed to find a number of references that I think would be useful in solving similar problems.
S. P. Banks, Signal processing, image processing, and pattern recognition. New York: Prentice Hall, 1990.
A. Oppenheim, R. Schafer, and J. Stockham, T., “Nonlinear filtering of multiplied and convolved signals,” IEEE Transactions on Audio and Electroacoustics, vol. 16, no. 3, pp. 437 – 466, Sep. 1968.
Blind image Deconvolution: theory and applications. Boca Raton: CRC Press, 2007.
Chapter 5 of the Blind image deconvolution book is particularly good, and contains many references to homomorphic filtering. This is perhaps the most generalized approach that will work well in many different applications.
3. Optimization using fminsearch
As suggested by Serg, I used an objective function with fminsearch. Since I know the mathematical model of the noise, I was able to use this as input to an optimization algorithm. This approach is entirely problem-specific, and may not be always useful in all situations.
Here is a reconstruction of Image 2:
Here is a reconstruction of Image 1, formed by dividing by the reconstruction of Image 2:
Here is the image containing the noise:
Source code
Here is the source code for my problem. As shown by the code, this is a very specific application, and will not work well in all situations.
N = 1001;
q = zeros(N, 1);
q(1:200) = 55;
q(201:300) = 120;
q(301:400) = 70;
q(401:600) = 40;
q(601:800) = 100;
q(801:1001) = 70;
dt = 0.0042;
fs = 1 / dt;
wSize = 101;
Glim = 20;
ginv = 0;
[R, ~, ~] = get_response(N, q, dt, wSize, Glim, ginv);
rows = wSize;
cols = N;
cut_val = 200;
figure; imagesc(abs(R)); title('Matrix output of algorithm')
colorbar
figure;
imagesc(abs(R)); title('abs(response)')
figure;
imagesc(imag(R)); title('imag(response)')
imageA = imread('room.jpg');
% images should be of the same size
[m,n] = size(R);
image1 = rgb2gray( imresize(im2double(imageA), [m n]) );
% here is the multiplication (with the image in complex space)
trans = ((image1.*1i)) .* (R(end:-1:1, :));
figure;
imagesc(abs(trans)); colormap(gray);
% take the imaginary part of the response
imagLogR = imag(log(trans));
% The beginning and end points are not usable
Mderiv = zeros(rows, cols-2);
for k = 1:rows
val = deriv_3pt(imagLogR(k,:), dt);
val(val > cut_val) = 0;
Mderiv(k,:) = val(1:end-1);
end
% This is the derivative of the imaginary part of R
% d/dtau(imag((log(R)))
% Do we need to remove spurious values from the matrix?
figure;
imagesc(abs(log(Mderiv)));
disp('Running iteration');
% Apply curve-fitting to get back the values
% by cycling over the cols
q0 = 10;
q1 = 500;
NN = cols - 2;
qout = zeros(NN, 1);
for k = 1:NN
data = Mderiv(:,k);
qout(k) = fminbnd(#(q) curve_fit_to_get_q(q, dt, rows, data),q0,q1);
end
figure; plot(q); title('q value input as vector');
ylim([0 200]); xlim([0 1001])
figure;
plot(qout); title('Reconstructed q')
ylim([0 200]); xlim([0 1001])
% make the vector the same size as the other
qout2 = [qout(1); qout; qout(end)];
% get the reconstructed response
[RR, ~, ~] = get_response(N, qout2, dt, wSize, Glim, ginv);
RR = RR(end:-1:1,:);
figure; imagesc(abs(RR)); colormap gray
title('Reconstructed Image 2')
colorbar;
% here is the reconstructed image of the room
% NOTE the division in the imagesc function
check0 = image1 .* abs(R(end:-1:1, :));
figure; imagesc(check0./abs(RR)); colormap gray
title('Reconstructed Image 1')
colorbar;
figure; imagesc(check0); colormap gray
title('Original image with noise pattern')
colorbar;
function [response, L, inte] = get_response(N, Q, dt, wSize, Glim, ginv)
fs = 1 / dt;
Npad = wSize - 1;
N1 = wSize + Npad;
N2 = floor(N1 / 2 + 1);
f = (fs/2)*linspace(0,1,N2);
omega = 2 * pi .* f';
omegah = 2 * pi * f(end);
sigma2 = exp(-(0.23*Glim + 1.63));
sign = 1;
if(ginv == 1)
sign = -1;
end
ratio = omega ./ omegah;
rs_r = zeros(N2, 1);
rs_i = zeros(N2, 1);
termr = zeros(N2, 1);
termi = zeros(N2, 1);
termr_sub1 = zeros(N2, 1);
termi_sub1 = zeros(N2, 1);
response = zeros(N2, N);
L = zeros(N2, N);
inte = zeros(N2, N);
% cycle over cols of matrix
for ti = 1:N
term0 = omega ./ (2 .* Q(ti));
gamma = 1 / (pi * Q(ti));
% calculate for the real part
if(ti == 1)
Lambda = ones(N2, 1);
termr_sub1(1) = 0;
termr_sub1(2:end) = term0(2:end) .* (ratio(2:end).^-gamma);
else
termr(1) = 0;
termr(2:end) = term0(2:end) .* (ratio(2:end).^-gamma);
rs_r = rs_r - dt.*(termr + termr_sub1);
termr_sub1 = termr;
Beta = exp( -1 .* -0.5 .* rs_r );
Lambda = (Beta + sigma2) ./ (Beta.^2 + sigma2); % vector
end
% calculate for the complex part
if(ginv == 1)
termi(1) = 0;
termi(2:end) = (ratio(2:end).^(sign .* gamma) - 1) .* omega(2:end);
else
termi = (ratio.^(sign .* gamma) - 1) .* omega;
end
rs_i = rs_i - dt.*(termi + termi_sub1);
termi_sub1 = termi;
integrand = exp( 1i .* -0.5 .* rs_i );
L(:,ti) = Lambda;
inte(:,ti) = integrand;
if(ginv == 1)
response(:,ti) = Lambda .* integrand;
else
response(:,ti) = (1 ./ Lambda) .* integrand;
end
end % ti loop
function sse = curve_fit_to_get_q(q, dt, rows, data)
% q = trial q value
% dt = timestep
% rows = number of rows
% data = actual dataset
fs = 1 / dt;
N2 = rows;
f = (fs/2)*linspace(0,1,N2); % vector for frequency along cols
omega = 2 * pi .* f';
omegah = 2 * pi * f(end);
ratio = omega ./ omegah;
gamma = 1 / (pi * q);
% calculate for the complex part
termi = ((ratio.^(gamma)) - 1) .* omega;
% for now, just reverse termi
termi = termi(end:-1:1);
%
% Do non-linear curve-fitting
% termi is a column-vector with the generated noise pattern
% data is the log-transformed image
% sse is the value that is returned to fminsearchbnd
Error_Vector = termi - data;
sse = sum(Error_Vector.^2);
function output = deriv_3pt(x, dt)
N = length(x);
N0 = N - 1;
output = zeros(N0, 1);
denom = 2 * dt;
for k = 2:N0
output(k - 1) = (x(k+1) - x(k-1)) / denom;
end
This is going to be a difficult, unreliable process, as you're fundamentally trying to extract information (the separation of the two images) which has been destroyed. Bringing it back perfectly is impossible; the best you can do is guess.
If the second image is always going to be relatively "smooth", you may be able to reconstruct it (or, at least, an approximation of it) by applying a strong low-pass filter to the transformed image. With that in hand, you can invert the multiplication, or equivalently use a complementary high-pass filter to get the first image. It won't be quite the same, but it'll at least be something.
I would try constrained optimization (fmincon in Matlab).
If you understand the source / nature of the 2-nd image, you probably can define a multivariate function that generates similar noise patterns. The objective function can be the correlation between the generated noise image, and the last image.
I need to calculate six dimensional integrals using Trapezoid in Fortran 90 in an efficient way. Here is an example of what I need to do:
Where F is a numerical (e.g. not analytical) function which is to be integrated over x1 to x6, variables. I have initially coded a one dimension subroutine:
SUBROUTINE trapzd(f,mass,x,nstep,deltam)
INTEGER nstep,i
DOUBLE PRECISION mass(nstep+1),f(nstep+1),x,deltam
x=0.d0
do i=1,nstep
x=x+deltam*(f(i)+f(i+1))/2.d0
end do
return
END
Which seems to work fine with one dimension, however, I don't know how to scale this up to six dimensions. Can I re-use this six times, once for every dimension or shall I write a new subroutine?
If you have a fully coded (no library/API use) version of this in another language like Python, MATLAB or Java, I'd be very glad to have a look and get some ideas.
P.S. This is not school homework. I am a PhD student in Biomedicine and this is part of my research in modeling stem cell activities. I do not have a deep background of coding and mathematics.
Thank you in advance.
You could look at the Monte Carlo Integration chapter of the GNU Scientific Library (GSL). Which is both a library, and, since it is open source, source code that you can study.
Look at section 4.6 of numerical recipes for C.
Step one is to reduce the problem using, symmetry and analytical dependencies.
Step two is to chain the solution like this:
f2(x2,x3,..,x6) = Integrate(f(x,x2,x3..,x6),x,1,x1end)
f3(x3,x4,..,x6) = Integrate(f2(x,x3,..,x6),x,1,x2end)
f4(x4,..,x6) = ...
f6(x6) = Integrate(I4(x,x6),x,1,x5end)
result = Integrate(f6(x),x,1,x6end)
Direct evaluation of multiple integrals is computationally challenging. It might be better to use Monte Carlo, perhaps using importance sampling. However brute force direct integration is sometimes of interest for validation of methods.
The integration routine I use is "QuadMo" written by Luke Mo about 1970. I made it recursive and put it in a module. QuadMo refines the mesh were needed to get the requested integration accuracy. Here is a program that does an n-dimensional integral using QuadMo.
Here is the validation of the program using a Gaussian centered at 0.5 with SD 0.1 in all dimensions for nDim up to 6, using a G95 compile. It runs in a couple of seconds.
nDim ans expected nlvl
1 0.249 0.251 2
2 6.185E-02 6.283E-02 2 2
3 1.538E-02 1.575E-02 2 2 2
4 3.826E-03 3.948E-03 2 2 2 2
5 9.514E-04 9.896E-04 2 2 2 2 2
6 2.366E-04 2.481E-04 2 2 2 2 2 2
Here is the code:
!=======================================================================
module QuadMo_MOD
implicit none
integer::QuadMo_MinLvl=6,QuadMo_MaxLvl=24
integer,dimension(:),allocatable::QuadMo_nlvlk
real*8::QuadMo_Tol=1d-5
real*8,save,dimension(:),allocatable::thet
integer,save::nDim
abstract interface
function QuadMoFunct_interface(thet,k)
real*8::QuadMoFunct_interface
real*8,intent(in)::thet
integer,intent(in),optional::k
end function
end interface
abstract interface
function MultIntFunc_interface(thet)
real*8::MultIntFunc_interface
real*8,dimension(:),intent(in)::thet
end function
end interface
procedure(MultIntFunc_interface),pointer :: stored_func => null()
contains
!----------------------------------------------------------------------
recursive function quadMoMult(funct,lower,upper,k) result(ans)
! very powerful integration routine written by Luke Mo
! then at the Stanford Linear Accelerator Center circa 1970
! QuadMo_Eps is error tolerance
! QuadMo_MinLvl determines initial grid of 2**(MinLvl+1) + 1 points
! to avoid missing a narrow peak, this may need to be increased.
! QuadMo_Nlvl returns number of subinterval refinements required beyond
! QuadMo_MaxLvl
! Modified by making recursive and adding argument k
! for multiple integrals (GuthrieMiller#gmail.com)
real*8::ans
procedure(QuadMoFunct_interface) :: funct
real*8,intent(in)::lower,upper
integer,intent(in),optional::k
real*8::Middle,Left,Right,eps,est,fLeft,fMiddle,fRight
& ,fml,fmr,rombrg,coef,estl,estr,estint,area,abarea
real*8::valint(50,2), Middlex(50), Rightx(50), fmx(50), frx(50)
& ,fmrx(50), estrx(50), epsx(50)
integer retrn(50),i,level
level = 0
QuadMo_nlvlk(k) = 0
abarea = 0
Left = lower
Right = upper
if(present(k))then
fLeft = funct(Left,k)
fMiddle = funct((Left+Right)/2,k)
fRight = funct(Right,k)
else
fLeft = funct(Left)
fMiddle = funct((Left+Right)/2)
fRight = funct(Right)
endif
est = 0
eps = QuadMo_Tol
100 level = level+1
Middle = (Left+Right)/2
coef = Right-Left
if(coef.ne.0) go to 150
rombrg = est
go to 300
150 continue
if(present(k))then
fml = funct((Left+Middle)/2,k)
fmr = funct((Middle+Right)/2,k)
else
fml = funct((Left+Middle)/2)
fmr = funct((Middle+Right)/2)
endif
estl = (fLeft+4*fml+fMiddle)*coef
estr = (fMiddle+4*fmr+fRight)*coef
estint = estl+estr
area= abs(estl)+ abs(estr)
abarea=area+abarea- abs(est)
if(level.ne.QuadMo_MaxLvl) go to 200
QuadMo_nlvlk(k) = QuadMo_nlvlk(k)+1
rombrg = estint
go to 300
200 if(( abs(est-estint).gt.(eps*abarea)).or.
1(level.lt.QuadMo_MinLvl)) go to 400
rombrg = (16*estint-est)/15
300 level = level-1
i = retrn(level)
valint(level, i) = rombrg
go to (500, 600), i
400 retrn(level) = 1
Middlex(level) = Middle
Rightx(level) = Right
fmx(level) = fMiddle
fmrx(level) = fmr
frx(level) = fRight
estrx(level) = estr
epsx(level) = eps
eps = eps/1.4d0
Right = Middle
fRight = fMiddle
fMiddle = fml
est = estl
go to 100
500 retrn(level) = 2
Left = Middlex(level)
Right = Rightx(level)
fLeft = fmx(level)
fMiddle = fmrx(level)
fRight = frx(level)
est = estrx(level)
eps = epsx(level)
go to 100
600 rombrg = valint(level,1)+valint(level,2)
if(level.gt.1) go to 300
ans = rombrg /12
end function quadMoMult
!-----------------------------------------------------------------------
recursive function MultInt(k,func) result(ans)
! MultInt(nDim,func) returns multi-dimensional integral from 0 to 1
! in all dimensions of function func
! variable QuadMo_Mod: nDim needs to be set initially to number of dimensions
procedure(MultIntFunc_interface) :: func
real*8::ans
integer,intent(in)::k
stored_func => func
if(k.eq.nDim)then
if(allocated(thet))deallocate(thet)
allocate (thet(nDim))
if(allocated(QuadMo_nlvlk))deallocate(QuadMo_nlvlk)
allocate(QuadMo_nlvlk(nDim))
endif
if(k.eq.0)then
ans=func(thet)
return
else
ans=QuadMoMult(MultIntegrand,0d0,1d0,k)
endif
end function MultInt
!-----------------------------------------------------------------------
recursive function MultIntegrand(thetARG,k) result(ans)
real*8::ans
real*8,intent(in)::thetARG
integer,optional,intent(in)::k
if(present(k))then
thet(k)=thetARG
else
write(*,*)'MultIntegrand: not expected, k not present!'
stop
endif
ans=MultInt(k-1,stored_func)
end function MultIntegrand
!-----------------------------------------------------------------------
end module QuadMo_MOD
!=======================================================================
module test_MOD
use QuadMo_MOD
implicit none
contains
!-----------------------------------------------------------------------
real*8 function func(thet) ! multidimensional function
! this is the function defined in nDim dimensions
! in this case a Gaussian centered at 0.5 with SD 0.1
real*8,intent(in),dimension(:)::thet
func=exp(-sum(((thet-5d-1)/1d-1)
& *((thet-5d-1)/1d-1))/2)
end function func
!-----------------------------------------------------------------------
end module test_MOD
!=======================================================================
! test program to evaluate multiple integrals
use test_MOD
implicit none
real*8::ans
! these values are set for speed, not accuracy
QuadMo_MinLvl=2
QuadMo_MaxLvl=3
QuadMo_Tol=1d-1
write(*,*)' nDim ans expected nlvl'
do nDim=1,6
! expected answer is (0.1 sqrt(2pi))**nDim
ans=MultInt(nDim,func)
write(*,'(i10,2(1pg10.3),999(i3))')nDim,ans,(0.250663)**nDim
& ,QuadMo_nlvlk
enddo
end
!-----------------------------------------------------------------------
double MultInt(int k);
double MultIntegrand(double thetARG, int k);
double quadMoMult(double(*funct)(double, int), double lower, double upper, int k);
double funkn(double *thet);
int QuadMo_MinLvl = 2;
int QuadMo_MaxLvl = 3;
double QuadMo_Tol = 0.1;
int *QuadMo_nlvlk;
double *thet;
int nDim;
//double MultInt(int k, double(*func)(double *))
double MultInt(int k)
{
//MultInt(nDim, func) returns multi - dimensional integral from 0 to 1
//in all dimensions of function func
double ans;
if (k == 0)
{
ans = funkn(thet);
}
else
{
ans = quadMoMult(MultIntegrand, 0.0, 1.0, k); //limits hardcoded here
}
return ans;
}
double MultIntegrand(double thetARG, int k)
{
double ans;
if (k > 0)
thet[k] = thetARG;
else
printf("\n***MultIntegrand: not expected, k not present!***\n");
//Recursive call
//ans = MultInt(k - 1, func);
ans = MultInt(k - 1);
return ans;
}
double quadMoMult(double(*funct)(double, int), double lower, double upper, int k)
{
//Integration routine written by Luke Mo
//Stanford Linear Accelerator Center circa 1970
//QuadMo_Eps is error tolerance
//QuadMo_MinLvl determines initial grid of 2 * *(MinLvl + 1) + 1 points
//to avoid missing a narrow peak, this may need to be increased.
//QuadMo_Nlvl returns number of subinterval refinements required beyond
//QuadMo_MaxLvl
//Modified by making recursive and adding argument k
//for multiple integrals(GuthrieMiller#gmail.com)
double ans;
double Middle, Left, Right, eps, est, fLeft, fMiddle, fRight;
double fml, fmr, rombrg, coef, estl, estr, estint, area, abarea;
double valint[51][3], Middlex[51], Rightx[51], fmx[51], frx[51]; //Jack up arrays
double fmrx[51], estrx[51], epsx[51];
int retrn[51];
int i, level;
level = 0;
QuadMo_nlvlk[k] = 0;
abarea = 0.0;
Left = lower;
Right = upper;
if (k > 0)
{
fLeft = funct(Left, k);
fMiddle = funct((Left + Right) / 2, k);
fRight = funct(Right, k);
}
else
{
fLeft = funct(Left,0);
fMiddle = funct((Left + Right) / 2,0);
fRight = funct(Right,0);
}
est = 0.0;
eps = QuadMo_Tol;
l100:
level = level + 1;
Middle = (Left + Right) / 2;
coef = Right - Left;
if (coef != 0.0)
goto l150;
rombrg = est;
goto l300;
l150:
if (k > 0)
{
fml = funct((Left + Middle) / 2.0, k);
fmr = funct((Middle + Right) / 2.0, k);
}
else
{
fml = funct((Left + Middle) / 2.0, 0);
fmr = funct((Middle + Right) / 2.0, 0);
}
estl = (fLeft + 4 * fml + fMiddle)*coef;
estr = (fMiddle + 4 * fmr + fRight)*coef;
estint = estl + estr;
area = abs(estl) + abs(estr);
abarea = area + abarea - abs(est);
if (level != QuadMo_MaxLvl)
goto l200;
QuadMo_nlvlk[k] = QuadMo_nlvlk[k] + 1;
rombrg = estint;
goto l300;
l200:
if ((abs(est - estint) > (eps*abarea)) || (level < QuadMo_MinLvl))
goto l400;
rombrg = (16 * estint - est) / 15;
l300:
level = level - 1;
i = retrn[level];
valint[level][i] = rombrg;
if (i == 1)
goto l500;
if (i == 2)
goto l600;
l400:
retrn[level] = 1;
Middlex[level] = Middle;
Rightx[level] = Right;
fmx[level] = fMiddle;
fmrx[level] = fmr;
frx[level] = fRight;
estrx[level] = estr;
epsx[level] = eps;
eps = eps / 1.4;
Right = Middle;
fRight = fMiddle;
fMiddle = fml;
est = estl;
goto l100;
l500:
retrn[level] = 2;
Left = Middlex[level];
Right = Rightx[level];
fLeft = fmx[level];
fMiddle = fmrx[level];
fRight = frx[level];
est = estrx[level];
eps = epsx[level];
goto l100;
l600:
rombrg = valint[level][1] + valint[level][2];
if (level > 1)
goto l300;
ans = rombrg / 12.0;
return ans;
}
double funkn(double *thet)
{
//in this case a Gaussian centered at 0.5 with SD 0.1
double *sm;
double sum;
sm = new double[nDim];
sum = 0.0;
for (int i = 1; i <= nDim; i++)
{
sm[i] = (thet[i] - 0.5) / 0.1;
sm[i] *= sm[i];
sum = sum + sm[i];
}
return exp(-sum / 2.0);
}
int main() {
double ans;
printf("\nnDim ans expected nlvl\n");
for (nDim = 1; nDim <= 6; nDim++)
{
//expected answer is(0.1 sqrt(2pi))**nDim
QuadMo_nlvlk = new int[nDim + 1]; //array for x values
thet = new double[nDim + 1]; //array for x values
ans = MultInt(nDim);
printf("\n %d %f %f ", nDim, ans, pow((0.250663),nDim));
for (int j=1; j<=nDim; j++)
printf(" %d ", QuadMo_nlvlk[nDim]);
printf("\n");
}
return 0;
}
Declare relevant parameters globally
int QuadMo_MinLvl = 2;
int QuadMo_MaxLvl = 3;
double QuadMo_Tol = 0.1;
int *QuadMo_nlvlk;
double *thet;
int nDim;
This coding is much clearer than the obfuscated antiquated fortran coding, with some tweaking the integral limits and tolerances could be parameterised!!
There are better algorithms to use with adaptive techniques and which handle singularities on the surfaces etc....