diff --git a/Dependencies.txt b/Dependencies.txt new file mode 100644 index 0000000..bc9de80 --- /dev/null +++ b/Dependencies.txt @@ -0,0 +1,34 @@ +This code relies on several external libraries. Some are already included in the repository and some have to be downloaded and compiled then linked at compile time. + +Fortran libraries included in the repository and statically linked during compilation: +- Routines to compute elliptic integrals in elliptic_mod.f90 + by John Burkardt, Bille Carlson, Elaine Notis, Roland Bulirsch + Downloaded from: https://people.sc.fsu.edu/~jburkardt/f_src/elliptic_integral/elliptic_integral.html +- Routines to compute incomplete gamma functions in incomplete_gamma_mod.f90 + by John Burkardt, Allan Macleod, G Bhattacharjee + Downloaded from: https://people.sc.fsu.edu/~jburkardt/f_src/asa032/asa032.html +- Random number generator in random.f random.h random_mod.f90 + by Charles Karney + Downloaded from: https://w3.pppl.gov/ntcc/RNG/ + +Matlab libraries included in the repository: +- C2xyz_v2 to extract the points of a contour plot + by Chad Greene + Downloaded from: https://ch.mathworks.com/matlabcentral/fileexchange/43162-c2xyz-contour-matrix-to-coordinates +- export_fig to save matlab figures to eps,png,pdf + by Yair Altman + Downloaded from: https://ch.mathworks.com/matlabcentral/fileexchange/23629-export_fig?s_tid=srchtitle + +External Fortran libraries statically linked during compilation: +- spclib library to solve PDE with FEM + by the Swiss Plasma Center + Downloaded from: https://c4science.ch/source/spclibs/ +- futils library to facilitate reading and saving datasets to hdf5 files + by the Swiss Plasma Center + Downloaded from: https://c4science.ch/diffusion/FUTILS/ +- SISL library to evaluate b-spline curves and surfaces and compute the smallest distance from a point to a curve/surface + by SINTEF company + Downloaded from: https://github.com/SINTEF-Geometry/SISL +- forSISL wrapper to facilitate the use of SISL from fortran as it is written in c + by Richard Weed + Downloaded from: https://github.com/rweed/forSISL \ No newline at end of file diff --git a/geometries/experiment_upper/exp_outer_withvessel.m b/geometries/experiment_upper/exp_outer_withvessel.m index 88e2f68..8ca38af 100644 --- a/geometries/experiment_upper/exp_outer_withvessel.m +++ b/geometries/experiment_upper/exp_outer_withvessel.m @@ -1,170 +1,170 @@ %% Create the geometry 1 for the T-REX experiment % uses the upper ellipse and constant radius center column. % bottom axial position zbottom=305; % mm radialindent=8; %mm % Outer vacuum vessel splid=1; geomcells(splid).Dval=0; % V geomcells(splid).order=3; geomcells(splid).dim=2; geomcells(splid).name='vacuum vessel'; geomcells(splid).type=0; geomcells(splid).periodic=0; rmax=50; %mm lw=linspace(40,rmax,8); rw=linspace(zbottom,480,20); uw=flip(linspace(0,rmax,30)); geomcells(splid).points=flip([zbottom*ones(size(lw')) lw'; rw' rmax*ones(size(rw')); 480*ones(size(uw')) uw']/1e3); % Central electrode splid=2; geomcells(splid).Dval=-20000; % V geomcells(splid).order=3; geomcells(splid).dim=2; %splines(1).epsge=1e-6; %splines(1).epsce=1e-6; geomcells(splid).name='central electrode'; geomcells(splid).type=0; geomcells(splid).periodic=0; lw=linspace(10-radialindent,10,10); rw=linspace(zbottom+30.5,429.5,60); uw=flip(linspace(0,10,10)); %ellipse= lowerring=linspace(zbottom,zbottom+29.5,40); geomcells(splid).points=[ lowerring' (10-radialindent)*ones(size(lowerring')); (zbottom+30)*ones(size(lw')) lw'; rw' 10*ones(size(rw')); 430*ones(size(uw')) uw']/1e3; % Bottom plate splid=3; geomcells(splid).Dval=0; % V geomcells(splid).order=3; geomcells(splid).dim=2; %splines(1).epsge=1e-6; %splines(1).epsce=1e-6; geomcells(splid).name='vacuum vessel'; geomcells(splid).type=0; geomcells(splid).periodic=0; lw=linspace(10-radialindent,24+radialindent,50); geomcells(splid).points=flip([ zbottom*ones(size(lw')) lw';]/1e3); % Outer electrode splid=4; geomcells(splid).Dval=0; % V geomcells(splid).order=3; geomcells(splid).dim=2; %splines(1).epsge=1e-6; %splines(1).epsce=1e-6; geomcells(splid).name='outer electrode'; geomcells(splid).type=0; geomcells(splid).periodic=0; lbaser=linspace(24+radialindent,24,20); base=linspace(zbottom+30.5,349,80); lowerbase=linspace(zbottom,zbottom+29.5,50); %tiltedwall alpha=0.1745; tiltedz=linspace(350,180+250,500); tiltedr=(tiltedz-tiltedz(1))*tan(alpha)+24; %tilted ellipse cosa=cos(alpha); sina=sin(alpha); r_c=28; z_c=375; Lz=25; Lr=5; deltar=(tiltedr-r_c); deltaz=(tiltedz-z_c); D=((deltaz*cosa+deltar*sina)/Lz).^2+((deltaz*sina-deltar*cosa)/Lr).^2; w=1-D; ellipsez=tiltedz(w>=0); deltaz=ellipsez-z_c; a=(Lr^2*sina^2+Lz^2*cosa^2); b=2*deltaz*sina*cosa*(Lr^2-Lz^2); c=-Lr^2*Lz^2 +deltaz.^2*(Lr^2*cosa^2+Lz^2*sina^2); tiltedr(w>=0)=r_c+(-b-sqrt(b.^2-4*a.*c))/2/a; axialend=linspace(tiltedr(end)+0.5,39.5,15); upperend=flip(linspace(zbottom,180+250,60)); geomcells(splid).points=flip([lowerbase' (24+radialindent)*ones(size(lowerbase')); zbottom+30*ones(size(lbaser')) lbaser'; base' 24*ones(size(base))'; tiltedz' tiltedr'; (180+250)*ones(size(axialend')) axialend'; upperend' 40*ones(size(upperend'))]/1e3); % Dielectric ring splid=5; geomcells(splid).Dval=0; % V geomcells(splid).order=3; geomcells(splid).dim=2; %splines(1).epsge=1e-6; %splines(1).epsce=1e-6; geomcells(splid).name='dielectric rings'; geomcells(splid).type=2; geomcells(splid).periodic=0; ow=flip(linspace(zbottom,zbottom+30,130)); -lw=flip(linspace(10.1,23.5,10)); +lw=flip(linspace(10.1,23.5,30)); rw=linspace(zbottom,429.5,60); uw=flip(linspace(0,10,10)); geomcells(splid).points=[flip([upperend', 40*ones(size(upperend'))]); flip([(180+250)*ones(size(axialend')) axialend']); flip([tiltedz' tiltedr']); flip([base' 24*ones(size(base))']); ow' 24*ones(size(ow')); zbottom*ones(size(lw')) lw'; rw' 10*ones(size(rw')); 430*ones(size(uw')) uw']/1e3; %% Plots f=figure; for k=1:length(geomcells) plothandle=plot(geomcells(k).points(:,1), geomcells(k).points(:,2),'k-x','linewidth',1.5); hold on %geomcells(k).points=[geomcells(k).Z; geomcells(k).R]; order=geomcells(k).order; knots=linspace(0,1,size(geomcells(k).points,1)-(order-2)); knots=augknt(knots, order); sizec=size(geomcells(k).points,1); order=length(knots)-sizec(end); coeffs=geomcells(k).points'; pp=spmak(knots,coeffs); s=linspace(0,1,1000); fittedpos=fnval(pp,s); plot(fittedpos(1,:),fittedpos(2,:),'x-') end legend(plothandle,{'Gun geometry'},'location','southwest') f.PaperUnits='centimeters'; f.PaperSize=[12,8]; xlabel('z [m]') ylabel('r [m]') axis equal savegeomtoh5('exp_outer_with_vessel_geom.h5',geomcells,1e-2,true); % print(f,name,'-dpdf','-fillpage') % savefig(f,name) % set(f, 'Color', 'w'); % export_fig(f,name,'-eps') hold off \ No newline at end of file diff --git a/geometries/gt170_proto/Draw_B_Ellip_170_geom_proto.m b/geometries/gt170_proto/Draw_B_Ellip_170_geom_proto.m index 612ceac..7e5f738 100644 --- a/geometries/gt170_proto/Draw_B_Ellip_170_geom_proto.m +++ b/geometries/gt170_proto/Draw_B_Ellip_170_geom_proto.m @@ -1,170 +1,202 @@ % Display the geometry of the gt170 gyrotron gun for the first prototype. % The magnetic field is the one of the asg magnet % This also creates the h5 files of the geometry and of the magnetic field % to be used in FENNECS % %% Define and calculate the magnetic field % z=linspace(-0.05,0.2,100); % r=linspace(0.02,0.09,100); % [Z,R] = meshgrid(z,r); % % % I = [ 9.7 7.7 96.2499 91.0124 87.4723]; % % I = [0 0 6.79541 1.967 88.2799]; % % I = [0 0 5 1.967 88.2799]; % % Current in coils % I = 0.6*[61.56 66.45 113.43 108.09 ]; % res=zeros([size(Z),3]); % % % for i=1:size(R,1) % res(i,:,:) = B_Ellip_Cryogenic_170({'aphi','bz','br'},'cryogenic',I,R(i,:),Z(i,:)); % end % Aphi=res(:,:,1); % Bz=res(:,:,2); % Br=res(:,:,3); %% Define the individual boundaries %read from input file geom=importproto('geometry_proto_modif.data',[2,Inf]); geomcells={}; j=1; i=1; n=1; % clean and separate the curves while i<=size(geom.Z,1) if isnan(geom.Z(i)) j=j+1; while isnan(geom.Z(i)) i=i+1; end n=1; end geomcells{j}.Z(n)=geom.Z(i); geomcells{j}.R(n)=geom.R(i); i=i+1; n=n+1; end geo_old = geomcells{2}; %% Correcting the corners % Body ----------------------------------------- N = 30; % First corner (lone corner) start1 = 32; -end1 = 37; +end1 = 36; R_corner = cat(2,linspace(geomcells{2}.R(start1),0.0869994,30),linspace(0.0869994,geomcells{2}.R(end1),30)); Z_corner = cat(2,linspace(geomcells{2}.Z(start1),0.104844,30),linspace(0.104844,geomcells{2}.Z(end1),30)); % Incomplete square start2 =510; -R_square = cat(2,linspace(geomcells{2}.R(start2),0.0819994,N),linspace(0.0819994,0.0899991,N),linspace(0.08999911,0.0900011,N),linspace(0.0899911,0.085,N)); -Z_square = cat(2,linspace(geomcells{2}.Z(start2),0.0143061,N),linspace(0.0143061,0.0143061,N),linspace(0.0143061,0.00316498,N),linspace(0.00316498,0.00330665,N)); + +R_square = cat(2,linspace(geomcells{2}.R(start2),0.0819994,N),linspace(0.0819994,0.0899991,N),linspace(0.08999911,0.0900011,N),linspace(0.0899911,0.085,N),0.085*ones(1,10),linspace(0.08505,0.0899911,N)); +Z_square = cat(2,linspace(geomcells{2}.Z(start2),0.0143061,N),linspace(0.0143061,0.0143061,N),linspace(0.0143061,0.00316498,N),0.003165*ones(1,N),linspace(0.003165,0.0029,10),0.0029*ones(1,N)); geomcells{2}.R = cat(2,geomcells{2}.R(1:start1),R_corner,geomcells{2}.R(end1:start2),R_square); geomcells{2}.Z = cat(2,geomcells{2}.Z(1:start1),Z_corner,geomcells{2}.Z(end1:start2),Z_square); +geomcells{2}.R(284)=[]; +geomcells{2}.Z(284)=[]; +geomcells{2}.R(32)=[]; +geomcells{2}.Z(32)=[]; +geomcells{2}.Z(605)=geomcells{2}.Z(606); +geomcells{2}.R(606)=[]; +geomcells{2}.Z(606)=[]; + + + + % Cathode -------------------------------------- %Incomplete square end1 = 320; -R_square = cat(2,linspace(0.085,0.0900011,N),linspace(0.0900011,0.0899991,N),linspace(0.089991,0.08,N)); -Z_square = cat(2,linspace(-0.0829438,-0.0829483,N),linspace(-0.0829483,-0.0939433,N),linspace(-0.0939433,-0.094,N)); +R_square = cat(2,linspace(0.090,0.08505,N),0.085*ones(1,10),linspace(0.085,0.0900011,N),linspace(0.0900011,0.0899991,N),linspace(0.089991,0.08,N)); +Z_square = cat(2,-0.082*ones(1,N),linspace(-0.082,-0.0829,10),-0.0829438*ones(1,N),linspace(-0.0829483,-0.0939433,N),linspace(-0.0939433,-0.094,N)); geomcells{1}.R = cat(2,R_square,geomcells{1}.R(end1:end)); geomcells{1}.Z = cat(2,Z_square,geomcells{1}.Z(end1:end)); +% adapt body + +geomcells{3}.R(2:4)=0.085; +geomcells{3}.R=[geomcells{3}.R(1:4) 0.0875 geomcells{3}.R(5:end)]; +geomcells{3}.Z=[geomcells{3}.Z(1:4) geomcells{3}.Z(4) geomcells{3}.Z(5:end)]; +geomcells{3}.Z(1:2)=-0.271; + %% Define the ceramic boundaries -geomcells{4}.Z = cat(2,geomcells{2}.Z,linspace(geomcells{2}.Z(end),-0.08294,50),geomcells{1}.Z(1:668),linspace(geomcells{1}.Z(668),geomcells{3}.Z(4),50),geomcells{3}.Z(4:end)); -geomcells{4}.R = cat(2,geomcells{2}.R,0.085*ones(1,50),geomcells{1}.R(1:668),0.085*ones(1,50),geomcells{3}.R(4:end)); +geomcells{4}.Z = cat(2,geomcells{2}.Z(1:end-10-N),linspace(geomcells{2}.Z(end-10-N),-0.08294,50),geomcells{1}.Z((1:668)+N+10),linspace(geomcells{1}.Z(668),geomcells{3}.Z(2),50),geomcells{3}.Z(3:end)); +geomcells{4}.R = cat(2,geomcells{2}.R(1:end-10-N),0.085*ones(1,50),geomcells{1}.R((1:668)+N+10),0.085*ones(1,50),geomcells{3}.R(3:end)); % create the geometry structure geomcells{1}.name='Cathode'; geomcells{1}.Dval=-30000; geomcells{2}.name='Body'; geomcells{2}.Dval=0; geomcells{3}.name='Coaxial insert'; geomcells{3}.Dval=0; geomcells{4}.name='Ceramics'; geomcells{4}.Dval=0; % geomcells{4}.name='insulator left'; % geomcells{4}.Dval=0; % geomcells{5}.name='insulator right'; % geomcells{5}.Dval=0; for k=1:(length(geomcells)-1) geomcells{k}.order=2; geomcells{k}.dim=2; geomcells{k}.epsce=1e-9; geomcells{k}.epsge=1e-9; geomcells{k}.type=0; geomcells{k}.periodic=0; dist{k}=sqrt(diff(geomcells{k}.Z).^2+diff(geomcells{k}.R).^2); +% remove the problematic points too close to each other +geomcells{k}.Z(dist{k}<1e-5)=[]; +geomcells{k}.R(dist{k}<1e-5)=[]; end % geomcells{end-1}.type=2; % geomcells{end}.type=2; k = length(geomcells); geomcells{k}.order=2; geomcells{k}.dim=2; geomcells{k}.epsce=1e-9; geomcells{k}.epsge=1e-9; geomcells{k}.type=2; geomcells{k}.periodic=0; +dist{k}=sqrt(diff(geomcells{k}.Z).^2+diff(geomcells{k}.R).^2); +% remove the problematic points too close to each other +geomcells{k}.Z(dist{k}<1e-5)=[]; +geomcells{k}.R(dist{k}<1e-5)=[]; %% Plots f=figure; +markers=true; for k=1:length(geomcells) plothandle=plot(geomcells{k}.Z, geomcells{k}.R,'k-','linewidth',1.5); hold on + if markers && k>3 + for j=1:length(geomcells{k}.Z) + text(geomcells{k}.Z(j),geomcells{k}.R(j),sprintf('%i',j),'fontsize',14) + end + end geomcells{k}.points=[geomcells{k}.Z; geomcells{k}.R]; order=geomcells{k}.order; knots=linspace(0,1,length(geomcells{k}.Z)-(order-2)); knots=augknt(knots, order); sizec=size(geomcells{k}.Z); order=length(knots)-sizec(end); coeffs=[geomcells{k}.Z; geomcells{k}.R]; pp=spmak(knots,coeffs); - s=linspace(0,1,10000); + s=linspace(0,1,100000); fittedpos=fnval(pp,s); plot(fittedpos(1,:),fittedpos(2,:),'x-') end hold on %end %axis equal %Plot the magnetic field lines %[~,cont1]=contour(Z,R,R.*Aphi,15,'r:','linewidth',3); % legend([plothandle,cont1],{'Gun geometry', 'Magnetic field lines','Wall approximation'},'location','southwest') f.PaperUnits='centimeters'; f.PaperSize=[12,8]; xlabel('z [m]') ylabel('r [m]') print(f,'phiBprofile_protoasg','-dpdf','-fillpage') savefig(f,'phiBprofile_protoasg') hold off %% Save magnetic field and geometry to disk save=true; overwrite=true; if save % idr=1:1:length(magnet.r); % idz=1:1:length(magnet.z); % Aphi=zeros(length(idr),length(idz)); % Bz=zeros(length(idr),length(idz)); % Br=zeros(length(idr),length(idz)); % % for i=1:size(magnet.subcoils,1) % Aphi=Aphi+Icoil(i)*magnet.subcoils{i,1}(idr,idz); % Bz=Bz+Icoil(i)*magnet.subcoils{i,2}(idr,idz); % Br=Br+Icoil(i)*magnet.subcoils{i,3}(idr,idz); % end % savemagtoh5([name,'.h5'],magnet.r,magnet.z,Aphi,Br,Bz,overwrite); savegeomtoh5('geom_crmcs.h5',geomcells,1e-2,overwrite); end diff --git a/magnet/Cryogenic/Draw_B_Ellip_170_geom_refurb.m b/magnet/Cryogenic/Draw_B_Ellip_170_geom_refurb.m index 92d0c74..4b78737 100644 --- a/magnet/Cryogenic/Draw_B_Ellip_170_geom_refurb.m +++ b/magnet/Cryogenic/Draw_B_Ellip_170_geom_refurb.m @@ -1,244 +1,142 @@ % creates the magnetic field h5 file necessary for fennecs % This uses the geometry of the refurbished 170GHz coaxial gyrotron gun % The magnetic field is the one created by the asg magnet % Both the magnet and geometry are definde in the Final report of the % Development of the european gyrotron CCCGDS6 %% Import and calculate the magnetic field -magnet=load('asg_magnet_ceramics.mat'); +magnet=load('asg_magnet_red.mat'); %% calculate magnetic field and magnetic vector idr=1:10:length(magnet.r); idz=1:10:length(magnet.z); % Define the coils currents %I = [ 9.7 7.7 96.2499 91.0124 87.4723]; % I = [0 0 4.5 1.967 88.2799]; % name='phiBprofile_refurbasg_4_5_red'; % I = [0 0 4.8 1.967 88.2799]; % name='phiBprofile_refurbasg_well_red'; % I = [0 0 5 1.967 88.2799]; % name='phiBprofile_refurbasg_5_red'; % I = [0 0 5.15 1.967 88.2799]; % name='phiBprofile_refurbasg_limdwn_red'; %I = [0 0 5.35 1.967 88.2799]; %name='phiBprofile_refurbasg_limup_red'; % I = [0 0 5.5 1.967 88.2799]; % name='phiBprofile_refurbasg_5_5_red'; %I = [0 0 5.6 1.967 88.2799]; %name='phiBprofile_refurbasg_5_6_red'; %I = [0 0 5.7 1.967 88.2799]; %name='phiBprofile_refurbasg_5_7_red'; % I = [0 0 5.75 1.967 88.2799]; % name='phiBprofile_refurbasg_5_75_red'; % I = [0 0 5.8 1.967 88.2799]; % name='phiBprofile_refurbasg_5_8_red'; % I = [0 0 5.85 1.967 88.2799]; % name='phiBprofile_refurbasg_5_85_red'; % I = [0 0 5.9 1.967 88.2799]; % name='phiBprofile_refurbasg_5_9_red'; % I = [0 0 6 1.967 88.2799]; % name='phiBprofile_refurbasg_6_red'; % I = [0 0 6.4 1.967 88.2799]; % name='phiBprofile_refurbasg_6_4_red'; % I = [0 0 6.79541 1.967 88.2799]; % name='phiBprofile_refurbasg_nominal_red'; % for Ib=linspace(4.6,6.8,12) %Ib=4.4; %I = [0 0 Ib 1.967 88.2799]; %name=sprintf('phiBprofile_refurbasg_%2d_red',floor(Ib*10)); +% +%I = 0.6*[0 0 6.79541 1.967 88.2799]; +%name='phiBprofile_refurbasg_nominal_0_6'; -I = 0.6*[0 0 6.79541 1.967 88.2799]; -name='phiBprofile_refurbasg_nominal_0_6'; +I = 0.6*[8.037 7.030 8.154 3.485 86.706]; +name='phiBprofile_refurbasg_nominal2_0_6'; Icoil=[I(1) I(2) -I(3)-I(5) -I(3)-I(5) I(4)+I(5) I(4)+I(5) I(5) I(5)]; rmin = [0.13958 0.13958 0.13710 0.16952 0.13670 0.19101 0.13458 0.17197 ]; rmax = [0.142694 0.142694 0.16733 0.20005 0.18941 0.23666 0.16972 0.20412 ]; zmin = [0.07854 0.13854 0.18200 0.18200 0.31778 0.31748 0.50685 0.50685 ]; zmax = [0.09846 0.15846 0.28350 0.28350 0.48977 0.49017 0.71128 0.71128 ]; % Nturn = [ 218 218 2528.5 2626 7689 11517.5 6110 9656.5 ]; % na = 2. *[ 10 10 10 10 10 10 10 10 ]; % Number of subcoils (radial direction % nb = 2. *[ 10 10 10 10 10 10 10 10 ]; % Number of subcoils in longitudinal direction % Icoil=Icoil.*Nturn./(na.*nb); [Z,R] = meshgrid(magnet.z(idz),magnet.r(idr)); Aphi=zeros(length(idr),length(idz)); Bz=zeros(length(idr),length(idz)); Br=zeros(length(idr),length(idz)); for i=1:size(magnet.subcoils,1) Aphi=Aphi+Icoil(i)*magnet.subcoils{i,1}(idr,idz); Bz=Bz+Icoil(i)*magnet.subcoils{i,2}(idr,idz); Br=Br+Icoil(i)*magnet.subcoils{i,3}(idr,idz); end -%% Define the individual boundaries -geom=importrefurb('Magnetic_Field_GLS_2020/refurb_modif_improv.data'); -geomcells={}; -j=1; -i=1; -n=1; -while i<=size(geom.Z,1) - if isnan(geom.Z(i)) - j=j+1; - while isnan(geom.Z(i)) - i=i+1; - end - n=1; - end - geomcells{j}.Z(n)=geom.Z(i)/1e3; - geomcells{j}.R(n)=geom.R(i)/1e3; - i=i+1; - n=n+1; -end -geomcells{4}.Z = cat(2,geomcells{2}.Z,geomcells{1}.Z,geomcells{3}.Z); -geomcells{4}.R = cat(2,geomcells{2}.R,geomcells{1}.R,geomcells{3}.R); - -geomcells{1}.name='Cathode'; -geomcells{1}.Dval=-30000; -geomcells{2}.name='Body'; -geomcells{2}.Dval=0; -geomcells{3}.name='Coaxial insert'; -geomcells{3}.Dval=0; -geomcells{4}.name='Ceramics'; -geomcells{4}.Dval=0; - -for k=1:(length(geomcells)-1) -geomcells{k}.order=3; -geomcells{k}.dim=2; -geomcells{k}.epsce=1e-9; -geomcells{k}.epsge=1e-9; -geomcells{k}.type=0; -geomcells{k}.periodic=0; -end - -k = length(geomcells); -geomcells{k}.order=3; -geomcells{k}.dim=2; -geomcells{k}.epsce=1e-9; -geomcells{k}.epsge=1e-9; -geomcells{k}.type=2; -geomcells{k}.periodic=0; - - -%% Load the original boundary -geomorig=importrefurb('Magnetic_Field_GLS_2020/refurb.data'); -geomcellsorig={}; -j=1; -i=1; -n=1; -while i<=size(geomorig.Z,1) - if isnan(geomorig.Z(i)) - j=j+1; - while isnan(geomorig.Z(i)) - i=i+1; - end - n=1; - end - geomcellsorig{j}.Z(n)=geomorig.Z(i)/1e3; - geomcellsorig{j}.R(n)=geomorig.R(i)/1e3; - i=i+1; - n=n+1; -end - -geomcellsorig{4}.Z = cat(2,geomcells{2}.Z,geomcells{1}.Z,geomcells{3}.Z); -geomcellsorig{4}.R = cat(2,geomcells{2}.R,geomcells{1}.R,geomcells{3}.R); - -geomcellsorig{1}.name='Cathode'; -geomcellsorig{1}.Dval=-30000; -geomcellsorig{2}.name='Body'; -geomcellsorig{2}.Dval=0; -geomcellsorig{3}.name='Coaxial insert'; -geomcellsorig{3}.Dval=0; -geomcellsorig{4}.name='Ceramics'; -geomcellsorig{4}.Dval=0; - -for k=1:length(geomcellsorig) -geomcellsorig{k}.order=3; -geomcellsorig{k}.dim=2; -geomcellsorig{k}.epsce=1e-9; -geomcellsorig{k}.epsge=1e-9; -end %% Plots f=figure; -for k=1:length(geomcellsorig) - plothandleorig=plot(geomcellsorig{k}.Z*1e3, geomcellsorig{k}.R*1e3,'r-','linewidth',2); - hold on -end -for k=1:length(geomcells) - %plothandle=plot(geomcells{k}.Z, geomcells{k}.R,'k-','linewidth',1.5); - hold on - geomcells{k}.points=[geomcells{k}.Z; geomcells{k}.R]; - order=geomcells{k}.order; - knots=linspace(0,1,length(geomcells{k}.Z)-(order-2)); - knots=augknt(knots, order); - sizec=size(geomcells{k}.Z); - order=length(knots)-sizec(end); - coeffs=[geomcells{k}.Z; geomcells{k}.R]; - pp=spmak(knots,coeffs); - s=linspace(0,1,500); - fittedpos=fnval(pp,s); - plot(fittedpos(1,:)*1e3,fittedpos(2,:)*1e3,'--','linewidth',2.2) -end + %% %axis equal raphi=R.*Aphi; lvls=logspace(-4,log10(max(raphi(:))),50); -%[~,cont1]=contour(Z*1e3,R*1e3,raphi,lvls,'b:','linewidth',1.5); +[~,cont1]=contour(Z*1e3,R*1e3,raphi,lvls,'b:','linewidth',1.5); %xlim([min(magnet.z) max(magnet.z)]*1e3) %ylim([min(magnet.r) max(magnet.r)]*1e3) %[~,cont2]=contour(Zphi,Rphi,Phi,20,'b'); rectangle('Position',[-0.1, 0.045, 0.292, 0.092-0.045]*1e3,'EdgeColor','black','Linestyle','--','linewidth',2) %legend([plothandle,cont1],{'Gun geometry', 'Magnetic field lines'},'location','southwest') %f.PaperUnits='centimeters'; %f.PaperSize=[12,8]; xlabel('z [mm]') ylabel('r [mm]') axis equal grid on ylim([0,inf]) xlim([-300 750]) for i=1:length(rmin) rectangle('Position',[zmin(i) rmin(i) zmax(i)-zmin(i) rmax(i)-rmin(i)]*1e3,'edgecolor','r') text(zmin(i)*1e3-10,(rmin(i)+rmax(i))/2*1e3,sprintf('S%i',i),'fontsize',10,'color','r') end print(f,name,'-dpdf','-fillpage') savefig(f,name) set(f, 'Color', 'w'); export_fig(f,name,'-eps') hold off %% Save magnetic field and geometry to disk save=true; overwrite=true; if save idr=1:1:length(magnet.r); idz=1:1:length(magnet.z); Aphi=zeros(length(idr),length(idz)); Bz=zeros(length(idr),length(idz)); Br=zeros(length(idr),length(idz)); for i=1:size(magnet.subcoils,1) Aphi=Aphi+Icoil(i)*magnet.subcoils{i,1}(idr,idz); Bz=Bz+Icoil(i)*magnet.subcoils{i,2}(idr,idz); Br=Br+Icoil(i)*magnet.subcoils{i,3}(idr,idz); end savemagtoh5([name,'.h5'],magnet.r,magnet.z,Aphi,Br,Bz,overwrite); - savegeomtoh5('geom_ceramics.h5',geomcells,1e-2,overwrite); + %savegeomtoh5('geom_ceramics.h5',geomcells,1e-2,overwrite); end % end diff --git a/matlab/@fennecshdf5/display2Dpotentialwell.m b/matlab/@fennecshdf5/display2Dpotentialwell.m index e122bb6..4a91b6f 100644 --- a/matlab/@fennecshdf5/display2Dpotentialwell.m +++ b/matlab/@fennecshdf5/display2Dpotentialwell.m @@ -1,196 +1,236 @@ function f=display2Dpotentialwell(obj,timestep,rcoord,clims,rescale, mag,nblv) % Display the 2D potential well at time obj.t2d(timestep) % if rcoord is true, the potential is evaluated at grid points in r,z coordinates % if false, the potential is evaluated at grid points in magnetic field line coordinates % clims are the values limits in eV for the color coding of the % potential well if iscell(timestep) timestep=cell2mat(timestep); end if nargin <3 rcoord=true; end if nargin<4 clims=[-inf inf]; end if nargin<5 rescale=false; end if nargin<6 mag=[]; end if nargin<7 nblv=500; end f=figure('Name',sprintf('%s Potential well',obj.name)); ax1=gca; model=obj.potentialwellmodel(timestep,true,mag,nblv); z=model.z; r=model.r; Pot=model.pot; rathet=model.rathet; N0=obj.N(:,:,1); id=find(timestep==0); timestep(id)=[]; Nend=obj.N(:,:,timestep); if(~isempty(id)) N0=zeros(obj.N.nr,obj.N.nz); Nend=cat(3,Nend(:,:,1:id-1),N0,Nend(:,:,id:end)); end Nend=mean(Nend,3); geomw=obj.geomweight(:,:,1); %z(isnan(Pot))=[]; %r(isnan(Pot))=[]; %Pot(isnan(Pot))=[]; if rescale if obj.spl_bound.nbsplines >0 Pot=Pot/(obj.spl_bound.boundary(2).Dval-obj.spl_bound.boundary(1).Dval); else Pot=Pot/(obj.potout-obj.potinn); end end if rcoord [Zmesh,Rmesh]=meshgrid(obj.zgrid,obj.rgrid); %Pot(obj.geomweight(:,:,1)<=0)=NaN; Pot(Pot<0)=NaN; geow=griddedInterpolant(Zmesh',Rmesh',obj.geomweight(:,:,1)'); [Zmesh,Rmesh]=meshgrid(obj.zgrid,obj.rgrid); finezgrid=obj.zgrid; finergrid=obj.rgrid; % finergrid=[obj.rgrid';[0.5*(obj.rgrid(1:end-1)+obj.rgrid(2:end)); 0]']; % finergrid=finergrid(1:end-1)'; % finezgrid=[obj.zgrid';[0.5*(obj.zgrid(1:end-1)+obj.zgrid(2:end)); 0]']; % finezgrid=finezgrid(1:end-1)'; % [Zmesh,Rmesh]=meshgrid(finezgrid,finergrid); Pot=griddata(z,r,Pot,Zmesh,Rmesh,'natural'); boundaries=geow(Zmesh',Rmesh')'; Pot(boundaries<0)=NaN; contourf(finezgrid*1e3,finergrid*1e3,Pot(1:end,1:end),50,'edgecolor','none','Displayname','Well') xlabel('z [mm]') ylabel('r [mm]') xlim([obj.zgrid(1) obj.zgrid(end)]*1e3) ylim([obj.rgrid(1) obj.rgrid(end)]*1e3) hold(gca, 'on') rdisp=obj.rgrid; %% Magnetic field lines Blines=obj.rAthet; - levels=linspace(min(Blines(obj.geomweight(:,:,1)>0)),max(Blines(obj.geomweight(:,:,1)>0)),20); + levels=linspace(min(Blines(obj.geomweight(:,:,1)>0)),max(Blines(obj.geomweight(:,:,1)>0)),35); Blines(obj.geomweight(:,:,1)<0)=NaN; - [~,h1]=contour(obj.zgrid*1000,obj.rgrid*1000,Blines,real(levels),'m-.','linewidth',1.2,'Displayname','Magnetic field lines'); + [~,h1]=contour(obj.zgrid*1000,obj.rgrid*1000,Blines,real(levels),'k-.','linewidth',1.2,'Displayname','Magnetic field lines'); geomw=obj.geomweight(:,:,1); else lvls=linspace(min(obj.rAthet(:)),max(obj.rAthet(:)),400); rdisp=lvls; [Zmesh,Rmesh]=meshgrid(obj.zgrid,rdisp); finergrid=[rdisp';[0.5*(drisp(1:end-1)+rdisp(2:end)); 0]']; finergrid=finergrid(1:end-1)'; finezgrid=[obj.zgrid';[0.5*(obj.zgrid(1:end-1)+obj.zgrid(2:end)); 0]']; finezgrid=finezgrid(1:end-1)'; [Zmesh,Rmesh]=meshgrid(finezgrid,finergrid); Pot=griddata(z,rathet,Pot,Zmesh,Rmesh,'natural'); boundaries=geow(Zmesh',Rmesh')'; Pot(boundaries<0)=NaN; %Pot=griddata(z,rathet,Pot,Zmesh,Rmesh); [Zinit,~]=meshgrid(obj.zgrid,obj.rAthet(:,1)); % if isempty(obj.maxwellsrce) % end N0=griddata(Zinit,obj.rAthet,N0,Zmesh,Rmesh); Nend=griddata(Zinit,obj.rAthet,Nend,Zmesh,Rmesh); geomw=griddata(Zinit,obj.rAthet,geomw,Zmesh,Rmesh); Pot(geomw<0)=NaN; %geomw(geomw2>0)=-1; contourf(finezgrid,finergrid*1000,Pot(1:end,1:end),'edgecolor','none') ylabel('rA_\theta [Tm^2]') xlabel('z [m]') xlim([obj.zgrid(1) obj.zgrid(end)]*1e3) ylim([min(rdisp) max(rdisp)]*1e3) hold(gca, 'on') end if (~isempty(id) && isempty(timestep)) % the - title(sprintf('Potential well Vacuum')) + title(sprintf('Vacuum potential well')) else title(sprintf('Potential well t=%1.2f [ns]',mean(obj.t2d(timestep))*1e9)) end maxdensend=max(Nend(:)); contourscale=0.1; Nend=(Nend-contourscale*maxdensend)/maxdensend; maxdens0=max(N0(:)); contourscale=0.1; N0=(N0-contourscale*maxdens0)/maxdens0; contour(obj.zgrid*1e3,rdisp*1e3,Nend,linspace(0,1-contourscale,5),'k--','linewidth',1.5,'Displayname','Cloud Boundaries'); contour(obj.zgrid*1e3,rdisp*1e3,N0,[0 0],'k-.','linewidth',1.5,'Displayname','Source boundaries'); %contour(obj.zgrid*1e3,rdisp*1e3,geomw,[0 0],'-','linecolor',[0.5 0.5 0.5],'linewidth',1.5,'Displayname','Vessel Boundaries'); c=colorbar; colormap('jet'); % Grey outline showing the metalic walls [c1,hContour]=contourf(ax1,obj.zgrid*1000,rdisp*1000,-geomw, [0 0]); drawnow; xlim(ax1,[obj.zgrid(1)*1000 obj.zgrid(end)*1000]) if(obj.conformgeom) %ylim([ax1 ],[obj.rgrid(1)*1000 obj.rgrid(rgridend)*1000]) else % ylim([ax1],[obj.rgrid(1)*1000 obj.rgrid(end)*1000]) end %ylim(ax1,[0.05*1000 obj.rgrid(end)*1000]) %xlim([obj.zgrid(1) 0.185]*1e3) xlabel(ax1,'z [mm]') ylabel(ax1,'r [mm]') view(ax1,2) if rescale c.Label.String= 'Normalized well depth (U_{well}/\Delta\phi) [eV/V]'; else c.Label.String= 'well depth [eV]'; end f.PaperUnits='centimeters'; caxis(clims) grid(ax1, 'on'); hFills=hContour.FacePrims; [hFills.ColorType] = deal('truecoloralpha'); % default = 'truecolor' try drawnow hFills(1).ColorData = uint8([150;150;150;255]); for idx = 2 : numel(hFills) hFills(idx).ColorData(4) = 0; % default=255 end catch end + % Plot of the geometry and of the different boundaries + % considered for the calculation of the currents +% geomw=obj.geomweight(:,:,1); +% geomw(geomw>1e-6)=NaN; +% geomw(geomw<1e-6)=max(Pot(:)/1e3); +% [c1,hContour]=contourf(ax1,obj.zgrid*1000,obj.rgrid*1000,geomw, max(Pot(:)/1e3)*[1 1]); +% hold on + dirw=obj.dirichletweight(:,:,1); + mask=obj.geomweight(:,:,1)<=1e-6&dirw>=1e-6; + dirw(obj.geomweight(:,:,1)<=1e-6)=max(Pot(:)/1e3); + dirw(mask)=min(Pot(:)/1e3); + dirw(obj.geomweight(:,:,1)>=1e-6)=NaN; + + + [c1,hContour2]=contourf(ax1,obj.zgrid*1000,obj.rgrid*1000,dirw,'edgecolor','none'); + grid on; + drawnow; + + %legend([h1,h2],{'Magnetic field lines','Equipotentials [kV]'},'location','northeast','Orientation','horizontal') + + %colormap(ax,([255,165,0;255,255,255;150,150,150])./255) + + % We add the coloring for the solid parts of the geometry + + % Dielectrics and metallic parts + hFills=hContour2.FacePrims; + [hFills.ColorType] = deal('truecoloralpha'); % default = 'truecolor' + try + %hFills(1).ColorData = uint8([255;165;0;255]); + hFills(1).ColorData = uint8([150;150;150;255]); + hFills(2).ColorData = uint8([150;150;150;255]); + for idx = 3 : numel(hFills) + hFills(idx).ColorData(4) = 0; % default=255 + end + catch + end + drawnow; + axis equal + pause(0.1) + % add central and external metallic walls if we have a coaxial % configuration if( obj.walltype >=2 && obj.walltype<=4) rectangle('Position',[obj.zgrid(1) max(obj.r_a,obj.r_b) obj.zgrid(end)-obj.zgrid(1) 0.001]*1e3,'FaceColor',[150 150 150]/255,'Edgecolor','none') ylimits=ylim; ylim([ylimits(1),ylimits(2)+1]) end if sum(obj.geomweight(:,1,1))==0 rectangle('Position',[obj.zgrid(1) obj.rgrid(1)-0.001 obj.zgrid(end)-obj.zgrid(1) 0.001]*1e3,'FaceColor',[150 150 150]/255,'Edgecolor','none') ylimits=ylim; ylim([ylimits(1)-1,ylimits(2)]) end axis equal %xlim([-100 200]) [max_depth,id]=max(abs(Pot(:))); [idr,idz]=ind2sub(size(Pot),id); fprintf('Maximum potential wel depth: %f eV\n',max_depth) fprintf('at location r=%f z=%f [mm]\n',finergrid(idr)*1e3, finezgrid(idz)*1e3) papsize=[14 8]; if rcoord obj.savegraph(f,sprintf('%s/%s_wellr%i',obj.folder,obj.name,floor(mean(timestep))),papsize); else obj.savegraph(f,sprintf('%s/%s_wellpsi%i',obj.folder,obj.name,floor(mean(timestep))),papsize); end end \ No newline at end of file diff --git a/matlab/@fennecshdf5/displayNErprof.m b/matlab/@fennecshdf5/displayNErprof.m index 932bc2d..79612d5 100644 --- a/matlab/@fennecshdf5/displayNErprof.m +++ b/matlab/@fennecshdf5/displayNErprof.m @@ -1,40 +1,47 @@ function displayNErprof(obj,zpos,fieldstep) +% Displays the electric field and density in 1D at the axial position zpos +% and time obj.t2d(timestep) +% The vessel radial boundaries are shown by vertical dashed lines f=figure; geomw=obj.geomweight(:,zpos,1); geomw(geomw>=0)=1; geomw(geomw<0)=NaN; ax1=gca; p=plot(ax1,obj.rgrid*1e3,obj.N(:,zpos,fieldstep),'linewidth',1.5); xlim(ax1,[obj.rgrid(1) obj.rgrid(end)]*1e3) xlabel(ax1,'r [mm]') - title(ax1,'Density') - ylabel(ax1,'n[m^{-3}]'); + %title(ax1,'Density') + ylabel(ax1,'n_e[m^{-3}]'); %c.Limits=[0 max(M.N(:))]; hold(ax1, 'on') M=obj; [~,rcenterid]=max(M.geomweight(:,zpos,1)); [~,id1]=min(abs(M.geomweight(1:rcenterid,zpos,1))); [~,id2]=min(abs(M.geomweight(rcenterid:end,zpos,1))); id2=id2+rcenterid; rlim1=M.rgrid(id1)*[1 1]*1e3; rlim2=M.rgrid(id2)*[1 1]*1e3; ylimits=ylim; plot(ax1,rlim1,ylimits,'k--','linewidth',1.5,'Displayname','Boundaries'); plot(ax1,rlim2,ylimits,'k--','linewidth',1.5,'Displayname','Boundaries'); yyaxis(ax1,'right') hold(ax1, 'on') Er=obj.Er(:,zpos,fieldstep).*geomw; Ez=obj.Ez(:,zpos,fieldstep).*geomw; + Erxt=obj.Erxt(:,zpos,1).*geomw; + Ezxt=obj.Ezxt(:,zpos,1).*geomw; p1=plot(ax1,obj.rgrid*1e3,Er,'linewidth',1.5); p2=plot(ax1,obj.rgrid*1e3,Ez,'linewidth',1.5); + p3=plot(ax1,obj.rgrid*1e3,Erxt,'linewidth',1.5); + p4=plot(ax1,obj.rgrid*1e3,Ezxt,'linewidth',1.5); ylabel(ax1,'E [V/m]') if max(abs([Er(:); Ez(:)]))>0 ylim(ax1,[ -max(abs([Er(:); Ez(:)])) max(abs([Er(:); Ez(:)]))]) end - legend(ax1,[p p1 p2],{'n','Er','Ez'},'location','northwest') + legend(ax1,[p p1 p2 p3 p4],{'n_e','E_r','E_z','Vacuum E_r','Vacuum E_z'},'location','northwest') xlim([M.rgrid(id1) M.rgrid(id2)]*1e3) obj.savegraph(f,sprintf('%s/%s_NEproft%i_z%i',obj.folder,obj.name,fieldstep,zpos)); end \ No newline at end of file diff --git a/matlab/@fennecshdf5/displayconfiguration.m b/matlab/@fennecshdf5/displayconfiguration.m index eb71e31..190beca 100644 --- a/matlab/@fennecshdf5/displayconfiguration.m +++ b/matlab/@fennecshdf5/displayconfiguration.m @@ -1,113 +1,125 @@ function f=displayconfiguration(obj,fieldsteps,xlimits,ylimits) %displayconfiguration plot the configuration of the simulation % domain withe boundaries, the magnetic field lines the % electric equipotential lines and the electron density % averaged in time between t2d(fieldsteps(1)) and t2d(fieldsteps(end)) fieldstart=fieldsteps(1); fieldend=fieldsteps(end); if nargin<3 xlimits=inf*[-1 1]; end if nargin<4 ylimits=inf*[-1 1]; end dens=mean(obj.N(:,:,fieldstart:fieldend),3); geomw=obj.geomweight(:,:,1); maxdens=max(dens(:)); geomw(geomw<0)=0; geomw(geomw>0)=maxdens; dens(geomw<=0)=0; geomw(geomw>0)=NaN; f=figure('Name', sprintf('%s fields',obj.name)); ax1=gca; title(sprintf('Configuration')) %dens(dens<=1e13)=NaN; %% electron density h=contourf(ax1,obj.zgrid*1000,obj.rgrid*1000,dens,50,'Displayname','n_e [m^{-3}]', 'linestyle','none'); hold on; colormap(flipud(hot)); %% Magnetic field lines Blines=obj.rAthet; - levels=linspace(min(Blines(obj.geomweight(:,:,1)>0)),max(Blines(obj.geomweight(:,:,1)>0)),50); - [~,h1]=contour(ax1,obj.zgrid*1000,obj.rgrid*1000,Blines,real(levels),'-.','color','k','linewidth',1.5,'Displayname','Magnetic field lines'); + levels=linspace(min(Blines(obj.geomweight(:,:,1)>0)),max(Blines(obj.geomweight(:,:,1)>0)),15); + [~,h1]=contour(ax1,obj.zgrid*1000,obj.rgrid*1000,Blines,real(levels),'-.','color','k','linewidth',1.1,'Displayname','Magnetic field lines'); %% Equipotential lines Pot=mean(obj.pot(:,:,fieldstart:fieldend),3); Pot(obj.geomweight(:,:,1)<0)=NaN; %levels=8;%[-3.4 -5 -10 -15 -20 -25];%7; potcolor='b';%[0.3660 0.6740 0.1880]; - [c1,h2]=contour(ax1,obj.zgrid*1000,obj.rgrid*1000,Pot/1e3,'--','color',potcolor,'ShowText','on','linewidth',1.2,'Displayname','Equipotentials [kV]'); + [c1,h2]=contour(ax1,obj.zgrid*1000,obj.rgrid*1000,Pot/1e3,[-18:4:-2],'--','color',potcolor,'ShowText','on','linewidth',1.2,'Displayname','Equipotentials [kV]'); clabel(c1,h2,'Color',potcolor) - clabel(c1,h2, 'labelspacing', 200); + clabel(c1,h2, 'labelspacing', 450); + clabel(c1,h2, 'fontsize', 13); + + % Grey outline shows metallic parts [c1,hContour]=contourf(ax1,obj.zgrid*1000,obj.rgrid*1000,geomw, [0 0]); drawnow; % set the axia limits xlim(ax1,[obj.zgrid(1)*1000 obj.zgrid(end)*1000]) if(obj.conformgeom) ylim([ax1 ],[obj.rgrid(1)*1000 obj.rgrid(rgridend)*1000]) else ylim([ax1],[obj.rgrid(1)*1000 obj.rgrid(end)*1000]) end legend([h1,h2],{'Magnetic field lines','Equipotentials [kV]'},'location','northeast') xlabel(ax1,'z [mm]') ylabel(ax1,'r [mm]') c = colorbar(ax1); - c.Label.String= 'n[m^{-3}]'; + c.Label.String= 'Electron density [m^{-3}]'; view(ax1,2) + set(ax1,'fontsize',14) grid on; hFills=hContour.FacePrims; [hFills.ColorType] = deal('truecoloralpha'); % default = 'truecolor' try hFills(1).ColorData = uint8([150;150;150;255]); for idx = 2 : numel(hFills) hFills(idx).ColorData(4) = 0; % default=255 end catch end [~, name, ~] = fileparts(obj.file); % with this you could show the outline of the maxwellian source % if obj.maxwellsrce.present % rlen=diff(obj.maxwellsrce.rlim); % zlen=diff(obj.maxwellsrce.zlim); % rectangle('Position',[obj.maxwellsrce.zlim(1) obj.maxwellsrce.rlim(1) zlen rlen]*1000,'Edgecolor','g','Linewidth',2,'Linestyle','--') % end % in case of coaxial configuration, extend the display domain % and add grey rectangles to show metallic boundaries if( obj.walltype >=2 && obj.walltype<=4) rectangle('Position',[obj.zgrid(1) obj.r_b obj.zgrid(end)-obj.zgrid(1) 0.001]*1e3,'FaceColor',[150 150 150]/255,'Edgecolor','none') ylimits=ylim; ylim([ylimits(1),ylimits(2)+1]) end if sum(obj.geomweight(:,1,1))==0 rectangle('Position',[obj.zgrid(1) obj.r_a-0.001 obj.zgrid(end)-obj.zgrid(1) 0.001]*1e3,'FaceColor',[150 150 150]/255,'Edgecolor','none') ylimits=ylim; ylim([ylimits(1)-1,ylimits(2)]) end if nargin>2 xlim(xlimits) end if nargin>3 ylim(ylimits) end f.PaperUnits='centimeters'; %axis equal papsize=[14 5 ]; + %% + axis equal + ylim([60 85]) + xlim([-40 80]) + legend('location','northeast') + Pos=f.Position; + Pos(3)=1.8*Pos(3); + f.Position=Pos; obj.savegraph(f,sprintf('%s/%sFields',obj.folder,obj.name),papsize); end diff --git a/matlab/@fennecshdf5/displaydirichletweight.m b/matlab/@fennecshdf5/displaydirichletweight.m new file mode 100644 index 0000000..f7f0373 --- /dev/null +++ b/matlab/@fennecshdf5/displaydirichletweight.m @@ -0,0 +1,22 @@ +function displaydirichletweight(obj) +%DISPLAYGTILDE Displays the dirichlet weight for the geometry +%% dirichlet weight function +f=figure(); +geomw=obj.geomweight(:,:,1); +%gtilde=(Mtest.gtilde(:,:,1)./(1-Mtest.geomweight(:,:,1))-2).*(1-Mtest.geomweight(:,:,1));%/Mtest.phinorm-1; +gtilde=(obj.dirichletweight(:,:,1)); +gtilde(obj.geomweight(:,:,1)<0)=NaN; +contourf(obj.zgrid*1e3, obj.rgrid*1e3,gtilde,20) +hold on +contour(obj.zgrid*1e3,obj.rgrid*1e3,geomw,[0 0],'r-','linewidth',1.5) +%title('\tilde{g}') +xlabel('z [mm]') +ylabel('r [mm]') +xlim([obj.zgrid(1) obj.zgrid(end)]*1e3) +ylim([obj.rgrid(1) obj.rgrid(end)]*1e3) +c = colorbar; +c.Label.String='w(r,z) [a.u.]'; +axis equal +obj.savegraph(f,sprintf('%s/%s_gtilde',obj.folder,obj.name)); +end + diff --git a/matlab/@fennecshdf5/displaygeometry.m b/matlab/@fennecshdf5/displaygeometry.m index 4404ec7..a80ddf9 100644 --- a/matlab/@fennecshdf5/displaygeometry.m +++ b/matlab/@fennecshdf5/displaygeometry.m @@ -1,107 +1,153 @@ function displaygeometry(obj,ax,xlimits,ylimits) %DISPLAYGEOMETRY Display the simulation geometry in the axis ax -% if ax is not specified, a new figure is generated +% if ax is not specified, a new figure is generated\ +savefile=false; if nargin<2 fig=figure('Name', sprintf('%s geometry',obj.name)); ax=axes(fig); + savefile=true; end geomw=obj.geomweight(:,:,1); %% Magnetic field lines Blines=obj.rAthet; levels=linspace(min(Blines(obj.geomweight(:,:,1)>0)),max(Blines(obj.geomweight(:,:,1)>0)),20); [~,h1]=contour(ax,obj.zgrid*1000,obj.rgrid*1000,Blines,real(levels),'-.','color','k','linewidth',1.5,'Displayname','Magnetic field lines'); hold on %% Equipotential lines Pot=obj.potxt(:,:,1); Pot(obj.geomweight(:,:,1)<0)=NaN; potcolor='b'; - [c1,h2]=contour(ax,obj.zgrid*1000,obj.rgrid*1000,Pot/1e3,'--','color',potcolor,'ShowText','on','linewidth',1.2,'Displayname','Equipotentials [kV]'); - clabel(c1,h2,'Color',potcolor) - clabel(c1,h2, 'labelspacing', 200); + [c1,h2]=contour(ax,obj.zgrid*1000,obj.rgrid*1000,Pot/1e3,'--','color',potcolor,'linewidth',1,'Displayname','Equipotentials [kV]'); + %clabel(c1,h2,'Color',potcolor) + %clabel(c1,h2, 'labelspacing', 200); - % Grey outline shows metallic parts - if obj.spl_bound.nbsplines<1 - [c]=contourc(obj.zgrid*1000,obj.rgrid*1000,geomw, [0 0]); - [x,y,z]=C2xyz(c); - else - x=cell(obj.spl_bound.nbsplines,1); - y=cell(obj.spl_bound.nbsplines,1); - for i=1:obj.spl_bound.nbsplines - z=obj.spl_bound.boundary(i).coefs(:,1)*1000; - r=obj.spl_bound.boundary(i).coefs(:,2)*1000; - if z(1)>obj.zgrid(end)*1000 ||z(end)obj.zgrid(end)*1000 - z=[z(1); z]; - r=[obj.rgrid(1)*1000; r]; - end - if r(1)>obj.rgrid(end)*1000 || r(end)obj.rgrid(end)*1000 - r=[r(1); r]; - z=[obj.zgrid(1)*1000; z]; - end - if r(1)>obj.rgrid(end)*1000 - end - x{i}=z; - y{i}=r; - end - end - for i=1:length(x) - z=[x{i}]; - r=[y{i}]; - patch(z,r,[150,150,150]./255,'edgecolor','none') - end - - %[c1,hContour]=contourf(ax,obj.zgrid*1000,obj.rgrid*1000,geomw, [0 0]); + - drawnow; + +% % Grey outline shows metallic parts +% if obj.spl_bound.nbsplines<1 +% [c]=contourc(obj.zgrid*1000,obj.rgrid*1000,geomw, [0 0]); +% [x,y,z]=C2xyz(c); +% +% else +% x=cell(obj.spl_bound.nbsplines,1); +% y=cell(obj.spl_bound.nbsplines,1); +% for i=1:obj.spl_bound.nbsplines +% z=obj.spl_bound.boundary(i).coefs(:,1)*1000; +% r=obj.spl_bound.boundary(i).coefs(:,2)*1000; +% if z(1)>obj.zgrid(end)*1000 ||z(end)obj.zgrid(end)*1000 +% z=[z(1); z]; +% r=[obj.rgrid(1)*1000; r]; +% end +% if r(1)>obj.rgrid(end)*1000 || r(end)obj.rgrid(end)*1000 +% r=[r(1); r]; +% z=[obj.zgrid(1)*1000; z]; +% end +% if r(1)>obj.rgrid(end)*1000 +% end +% x{i}=z; +% y{i}=r; +% end +% end +% for i=1:length(x) +% z=[x{i}]; +% r=[y{i}]; +% patch(z,r,[150,150,150]./255,'edgecolor','none') +% end + % set the axia limits xlim(ax,[obj.zgrid(1)*1000 obj.zgrid(end)*1000]) if(obj.conformgeom) ylim(ax ,[obj.rgrid(1)*1000 obj.rgrid(rgridend)*1000]) else ylim(ax,[obj.rgrid(1)*1000 obj.rgrid(end)*1000]) end - legend([h1,h2],{'Magnetic field lines','Equipotentials [kV]'},'location','northeast') - xlabel(ax,'z [mm]') - ylabel(ax,'r [mm]') - - grid on; [~, name, ~] = fileparts(obj.file); % in case of coaxial configuration, extend the display domain % and add grey rectangles to show metallic boundaries if( obj.walltype >=2 && obj.walltype<=4) rectangle('Position',[obj.zgrid(1) obj.r_b obj.zgrid(end)-obj.zgrid(1) 0.001]*1e3,'FaceColor',[150 150 150]/255,'Edgecolor','none') ylimits=ylim; ylim([ylimits(1),ylimits(2)+1]) end if sum(obj.geomweight(1,:,1))==0 rectangle('Position',[obj.zgrid(1) obj.r_a-0.001 obj.zgrid(end)-obj.zgrid(1) 0.001]*1e3,'FaceColor',[150 150 150]/255,'Edgecolor','none') ylimits=ylim; ylim([ylimits(1)-1,ylimits(2)]) end if nargin>3 xlim(xlimits) end if nargin>4 ylim(ylimits) end + xlabel(ax,'z [mm]') + ylabel(ax,'r [mm]') + + % Plot of the geometry and of the different boundaries + % considered for the calculation of the currents + geomw=obj.geomweight(:,:,1); + geomw(geomw>1e-6)=NaN; + geomw(geomw<1e-6)=max(Pot(:)/1e3); + [c1,hContour]=contourf(ax,obj.zgrid*1000,obj.rgrid*1000,geomw, max(Pot(:)/1e3)*[1 1]); + hold on + dirw=obj.dirichletweight(:,:,1); + mask=obj.geomweight(:,:,1)<=1e-6&dirw>=1e-6; + dirw(mask)=min(Pot(:)/1e3); + dirw(~mask)=NaN; + [c1,hContour2]=contourf(ax,obj.zgrid*1000,obj.rgrid*1000,dirw,min(Pot(:)/1e3)*[1 1]); + grid on; + + %legend([h1,h2],{'Magnetic field lines','Equipotentials [kV]'},'location','northeast','Orientation','horizontal') + + colormap(ax,([255,165,0;255,255,255;150,150,150])./255) + + % We add the coloring for the solid parts of the geometry + % Metallic parts + hFills=hContour.FacePrims; + [hFills.ColorType] = deal('truecoloralpha'); % default = 'truecolor' + try + hFills(1).ColorData = uint8([150;150;150;255]); + for idx = 2 : numel(hFills) + hFills(idx).ColorData(4) = 0; % default=255 + end + catch + end + drawnow; + % Dielectrics + hFills=hContour2.FacePrims; + [hFills.ColorType] = deal('truecoloralpha'); % default = 'truecolor' + try + hFills(1).ColorData = uint8([255;165;0;255]); + for idx = 2 : numel(hFills) + hFills(idx).ColorData(4) = 0; % default=255 + end + catch + end + drawnow; + axis equal + if savefile + obj.savegraph(fig,sprintf('%s/%sgeometry',obj.folder,obj.name),[16 14]); + end end diff --git a/matlab/@fennecshdf5/displaypot.m b/matlab/@fennecshdf5/displaypot.m new file mode 100644 index 0000000..47220ec --- /dev/null +++ b/matlab/@fennecshdf5/displaypot.m @@ -0,0 +1,158 @@ +function f=displaypot(obj,timestep) + % Display the 2D potential at time obj.t2d(timestep) + % if rcoord is true, the potential is evaluated at grid points in r,z coordinates + % if false, the potential is evaluated at grid points in magnetic field line coordinates + % clims are the values limits in eV for the color coding of the + % potential well + if iscell(timestep) + timestep=cell2mat(timestep); + end + + f=figure('Name',sprintf('%s phi',obj.name)); + ax1=gca; + pot=zeros(obj.pot.nr,obj.pot.nz,length(timestep)); + if(any(timestep==0)) + pot(:,:,timestep==0)=obj.potxt(:,:,1); + end + pot(:,:,timestep~=0)=obj.pot(:,:,timestep(timestep~=0)); + + + N0=obj.N(:,:,1); + id=find(timestep==0); + timestep(id)=[]; + Nend=obj.N(:,:,timestep); + if(~isempty(id)) + N0=zeros(obj.N.nr,obj.N.nz); + Nend=cat(3,Nend(:,:,1:id-1),N0,Nend(:,:,id:end)); + end + Nend=mean(Nend,3); + Nend=(Nend-0.01*max(Nend(:)))/max(Nend(:)); + geomw=obj.geomweight(:,:,1); + %z(isnan(Pot))=[]; + %r(isnan(Pot))=[]; + %Pot(isnan(Pot))=[]; + pot=mean(pot,3); + pot(obj.geomweight(:,:,1)<=0)=NaN; + + contourf(obj.zgrid*1e3,obj.rgrid*1e3,pot,50,'edgecolor','none','Displayname','\phi') + xlabel('z [mm]') + ylabel('r [mm]') + xlim([obj.zgrid(1) obj.zgrid(end)]*1e3) + ylim([obj.rgrid(1) obj.rgrid(end)]*1e3) + hold(gca, 'on') + if(any(timestep~=0)) + contour(obj.zgrid*1e3,obj.rgrid*1e3,Nend,[0 0],'m--','Displayname','n_e') + end + + rdisp=obj.rgrid; + + %% Magnetic field lines +% Blines=obj.rAthet; +% levels=linspace(min(Blines(obj.geomweight(:,:,1)>0)),max(Blines(obj.geomweight(:,:,1)>0)),10); +% Blines(obj.geomweight(:,:,1)<0)=NaN; +% [~,h1]=contour(obj.zgrid*1000,obj.rgrid*1000,Blines,real(levels),'k-.','linewidth',1.2,'Displayname','Magnetic field lines'); + geomw=obj.geomweight(:,:,1); + + if (~isempty(id) && isempty(timestep)) % the + title(sprintf('Vacuum potential')) + else + title(sprintf('Potential t=%1.2f [ns]',mean(obj.t2d(timestep))*1e9)) + end + + c=colorbar; + colormap('jet'); + + + + % Grey outline showing the metalic walls + + [c1,hContour]=contourf(ax1,obj.zgrid*1000,rdisp*1000,-geomw, [0 0]); + + drawnow; + xlim(ax1,[obj.zgrid(1)*1000 obj.zgrid(end)*1000]) + if(obj.conformgeom) + %ylim([ax1 ],[obj.rgrid(1)*1000 obj.rgrid(rgridend)*1000]) + else + % ylim([ax1],[obj.rgrid(1)*1000 obj.rgrid(end)*1000]) + end + %ylim(ax1,[0.05*1000 obj.rgrid(end)*1000]) + %xlim([obj.zgrid(1) 0.185]*1e3) + xlabel(ax1,'z [mm]') + ylabel(ax1,'r [mm]') + view(ax1,2) + + c.Label.String= '\phi [V]'; + f.PaperUnits='centimeters'; + + grid(ax1, 'on'); + hFills=hContour.FacePrims; + [hFills.ColorType] = deal('truecoloralpha'); % default = 'truecolor' + try + drawnow + + hFills(1).ColorData = uint8([150;150;150;255]); + for idx = 2 : numel(hFills) + hFills(idx).ColorData(4) = 0; % default=255 + end + catch + end + + % Plot of the geometry and of the different boundaries + % considered for the calculation of the currents +% geomw=obj.geomweight(:,:,1); +% geomw(geomw>1e-6)=NaN; +% geomw(geomw<1e-6)=max(Pot(:)/1e3); +% [c1,hContour]=contourf(ax1,obj.zgrid*1000,obj.rgrid*1000,geomw, max(Pot(:)/1e3)*[1 1]); +% hold on + dirw=obj.dirichletweight(:,:,1); + mask=obj.geomweight(:,:,1)<=1e-6&dirw>=1e-6; + dirw(obj.geomweight(:,:,1)<=1e-6)=max(pot(:)/1e3); + dirw(mask)=min(pot(:)/1e3); + dirw(obj.geomweight(:,:,1)>=1e-6)=NaN; + + + [c1,hContour2]=contourf(ax1,obj.zgrid*1000,obj.rgrid*1000,dirw,'edgecolor','none'); + grid on; + drawnow; + + %legend([h1,h2],{'Magnetic field lines','Equipotentials [kV]'},'location','northeast','Orientation','horizontal') + + %colormap(ax,([255,165,0;255,255,255;150,150,150])./255) + + % We add the coloring for the solid parts of the geometry + + % Dielectrics and metallic parts + hFills=hContour2.FacePrims; + [hFills.ColorType] = deal('truecoloralpha'); % default = 'truecolor' + try + hFills(1).ColorData = uint8([255;165;0;255]); + hFills(2).ColorData = uint8([150;150;150;255]); + for idx = 3 : numel(hFills) + hFills(idx).ColorData(4) = 0; % default=255 + end + catch + end + drawnow; + axis equal + pause(0.1) + + % add central and external metallic walls if we have a coaxial + % configuration + if( obj.walltype >=2 && obj.walltype<=4) + rectangle('Position',[obj.zgrid(1) max(obj.r_a,obj.r_b) obj.zgrid(end)-obj.zgrid(1) 0.001]*1e3,'FaceColor',[150 150 150]/255,'Edgecolor','none') + ylimits=ylim; + ylim([ylimits(1),ylimits(2)+1]) + end + if sum(obj.geomweight(:,1,1))==0 + rectangle('Position',[obj.zgrid(1) obj.rgrid(1)-0.001 obj.zgrid(end)-obj.zgrid(1) 0.001]*1e3,'FaceColor',[150 150 150]/255,'Edgecolor','none') + ylimits=ylim; + ylim([ylimits(1)-1,ylimits(2)]) + end + + axis equal + %xlim([-100 200]) + + papsize=[14 8]; + obj.savegraph(f,sprintf('%s/%s_phi%i',obj.folder,obj.name,floor(mean(timestep))),papsize); + + end \ No newline at end of file diff --git a/matlab/@fennecshdf5/displaytotcurrevol_geom.m b/matlab/@fennecshdf5/displaytotcurrevol_geom.m index 2361982..8ff5b12 100644 --- a/matlab/@fennecshdf5/displaytotcurrevol_geom.m +++ b/matlab/@fennecshdf5/displaytotcurrevol_geom.m @@ -1,210 +1,254 @@ -function displaytotcurrevol_geom(obj,timesteps,toptitle,scalet,dens,subdiv,nmean) +function displaytotcurrevol_geom(obj,timesteps,toptitle,scalet,dens,subdiv,nmean, rsplit) % Computes and display the time evolution of the outgoing % currents at time obj.t2d(timesteps) - %scalet=true scales the time by the ellastic collision - %frequency - %dens = true plot the time evolution of the maximum electron - %density in the simulation domain otherwise plot the total - %number of electrons in the domain + %-scalet=true scales the time by the ellastic collision + % frequency + %- dens = true plot the time evolution of the maximum electron + % density in the simulation domain otherwise plot the total + % number of electrons in the domain % also plot in a subplot the color coded boundary corresponding % to each current + % - subdiv allows the subdivision of individual boundaries by + % defining relative length e.g. [1 1] divides the boundary in + % two boundaries of equal length + % - nmean defines the window time average for the current and + % density + % - rsplit defines the radial position, for the calculation of the + % time evolution of the density, at which a new cloud is considered. + % This helps tracking the density in two clouds at the same + % time. if nargin<2 timesteps=1:length(obj.t2d); end if nargin<3 + toptitle=""; + end + if nargin<4 scalet=true; end - if nargin <4 + if nargin <5 dens=true; end - if nargin<5 + if nargin<6 subdiv=1; end - if nargin<6 + if nargin<7 nmean=1; end + if nargin<8 + rsplit=0.07; + %rsplit=0.014; + end + if scalet if obj.neutcol.present vexb0=(obj.Ezxt(:,:,1).*obj.Br'-obj.Erxt(:,:,1).*obj.Bz')./(obj.B'.^2); vexb0(obj.geomweight(:,:,1)<=0)=0; potwell=obj.PotentialWell(0); vexb0(isnan(potwell))=NaN; vexb0=mean(abs(vexb0(:)),'omitnan'); E=0.5*obj.msim/obj.weight*vexb0^2/obj.qe; taucol=1/(obj.neutcol.neutdens*vexb0*(obj.sigio(E)+obj.sigmela(E)+obj.sigmio(E))); try Sio_S=1e17*(obj.neutcol.neutdens*vexb0*obj.sigio(E))/(obj.maxwellsrce.frequency*obj.weight/(pi*(obj.maxwellsrce.rlim(2)^2-obj.maxwellsrce.rlim(1)^2)*diff(obj.maxwellsrce.zlim))) catch end tlabel='t/\tau_d [-]'; else taucol=2*pi/obj.omece; tlabel='t/\tau_ce [-]'; end else taucol=1e-9; tlabel='t [ns]'; end if dens N=obj.N(:,:,timesteps); geomw=obj.geomweight(:,:,1); geomw(geomw<0)=0; geomw(geomw>0)=1; N=N.*geomw; %[~,idl]=max(N(:,:,end),[],'all','linear'); %[ir,iz]=ind2sub(size(geomw),idl); %nmax=squeeze(max(max(N,[],1),[],2)); tn=(obj.t2d(timesteps)); - nrhalf=find(obj.rgrid>0.07,1,'first'); + nrhalf=find(obj.rgrid>rsplit,1,'first'); if(nrhalf=obj.t2d(timesteps(1)),1,'first'); t0dlst=find(obj.t0d<=obj.t2d(timesteps(end)),1,'last'); tn=obj.t0d(t0dst:t0dlst); nmax=obj.npart(t0dst:t0dlst)*obj.weight; nlabel='Nb e^-'; ndlabel='Nb e^-'; end - + % We get the current at the desired time steps for each + % boundary [currents,pos]=obj.OutCurrents(timesteps,subdiv); + % The currents are normalized to the simulated pressure P=1; if obj.neutcol.present P=obj.neutcol.neutdens*obj.kb*300/100;% pressure at room temperature in mbar end currents=currents/P; + + % Start of the figure f=figure('Name',sprintf('%s Charges',obj.name)); tiledlayout(2,1) nexttile - % Plot the evolution of nb of particles + % Plot the evolution of nb of particles or density yyaxis right if size(nmax,2)>1 nmax=nmax'; end for i=1:size(nmax,2) p=plot(tn/taucol,nmax(:,i),'b','linewidth',1.8,'Displayname',sprintf('%s, %d',ndlabel,i)); hold on end ylabel(nlabel) axl=gca; axl.YAxis(2).Color=p.Color; + axl.YAxis(1).Color='k'; ylim([0 inf]) if(obj.B(1,1)>obj.B(end,1)) lname='HFS'; rname='LFS'; else lname='LFS'; rname='HFS'; end + % Plot of the different current contributions yyaxis( 'left'); map=colormap(lines); set(axl,'linestyleorder',{'-',':','--','*','+'},... 'ColorOrder',map(2:7,:), 'NextPlot','replacechildren') p(1)=plot(axl,obj.t2d(timesteps)/taucol,movmean(currents(1,:),nmean),'Displayname',lname,'linewidth',1.8); hold on p(2)=plot(axl,obj.t2d(timesteps)/taucol,movmean(currents(2,:),nmean),'Displayname',rname,'linewidth',1.8); % Plot the currents for i=3:size(currents,1) p(i)=plot(axl,obj.t2d(timesteps)/taucol,movmean(currents(i,:),nmean),'Displayname',sprintf('border %i',i-2),'linewidth',1.8); end plot(axl,obj.t2d(timesteps)/taucol,movmean(sum(currents(:,:),1,'omitnan'),nmean),'k-','Displayname','total','linewidth',1.8); xlabel(tlabel) if obj.neutcol.present ylabel('I/p_n [A/mbar]') else ylabel('I [A]') end grid on set(gca,'fontsize',12) ax.YAxis(1).Color='black'; %legend('Orientation','horizontal','location','north','numcolumns',3) if ~isempty(toptitle) title(toptitle) end + % Plot of the geometry and of the different boundaries + % considered for the calculation of the currents ax2=nexttile; + + %% Magnetic field lines + Blines=obj.rAthet; + + levels=linspace(min(Blines(obj.geomweight(:,:,1)>0)),max(Blines(obj.geomweight(:,:,1)>0)),15); + Blines(obj.geomweight(:,:,1)<0)=NaN; + [~,h1]=contour(ax2,obj.zgrid*1000,obj.rgrid*1000,Blines,real(levels),'-.','color','k','linewidth',1.1,'Displayname','Magnetic field lines'); + hold on + + %% Boundaries geomw=obj.geomweight(:,:,1); geomw(geomw<1e-6)=0; geomw(geomw>1e-6)=NaN; [c1,hContour]=contourf(ax2,obj.zgrid*1000,obj.rgrid*1000,geomw, [0 0]); hold on dirw=obj.dirichletweight(:,:,1); geomw=obj.geomweight(:,:,1); - dirw(geomw<=-1e-6&dirw>=-1e-6)=0; + dirw(geomw<=1e-6&dirw>=1e-6)=0; dirw(dirw>0)=NaN; [c1,hContour2]=contourf(ax2,obj.zgrid*1000,obj.rgrid*1000,dirw, [0 0]); drawnow; grid on; for i=1:length(pos) plot(ax2,pos{i}(1,:)*1000,pos{i}(2,:)*1000,'linestyle',p(i+2).LineStyle,... 'color',p(i+2).Color,'marker',p(i+2).Marker,... 'displayname',sprintf('border %i',i),'linewidth',1.8) hold on end title('Domain') plot(ax2,ones(size(obj.rgrid))*obj.zgrid(1)*1000,obj.rgrid*1000,'linestyle',p(1).LineStyle,... 'color',p(1).Color,'marker',p(1).Marker,... 'displayname',lname,'linewidth',1.8) plot(ax2,ones(size(obj.rgrid))*obj.zgrid(end)*1000,obj.rgrid*1000,'linestyle',p(2).LineStyle,... 'color',p(2).Color,'marker',p(2).Marker,... 'displayname',rname,'linewidth',1.8) xlabel('z [mm]') ylabel('r [mm]') grid on set(gca,'fontsize',12) + + + + + % We add the coloring for the solid parts of the geometry + % Metallic parts hFills=hContour.FacePrims; [hFills.ColorType] = deal('truecoloralpha'); % default = 'truecolor' try hFills(1).ColorData = uint8([150;150;150;255]); for idx = 2 : numel(hFills) hFills(idx).ColorData(4) = 0; % default=255 end catch end + % Dielectrics hFills=hContour2.FacePrims; [hFills.ColorType] = deal('truecoloralpha'); % default = 'truecolor' try hFills(1).ColorData = uint8([255;165;0;255]); for idx = 2 : numel(hFills) hFills(idx).ColorData(4) = 0; % default=255 end catch end %legend('Orientation','horizontal','location','north','numcolumns',4) - + % Output to console the mean total current at the end of the + % time considered fprintf('mean total current: %f [A/mbar]\n',mean(sum(currents(:,max(1,size(currents,2)-50):end),1,'omitnan'))); %if nargin <3 % sgtitle(sprintf('\\phi_b-\\phi_a=%.2g kV, B=%f T',(obj.potout-obj.potinn)/1e3,mean(obj.B(:)))) %elseif ~isempty(toptitle) % sgtitle(toptitle) %end xlim([obj.zgrid(1) obj.zgrid(end)]*1e3) ylim([obj.rgrid(1) obj.rgrid(end)]*1e3) + % Save to file if length(subdiv)>1 obj.savegraph(f,sprintf('%s/%s_totIEvol%i%i_div%i',obj.folder,obj.name,scalet,dens,nmean),[16 14]); else obj.savegraph(f,sprintf('%s/%s_totIEvol%i%i_%i',obj.folder,obj.name,scalet,dens,nmean),[16 14]); end end \ No newline at end of file diff --git a/matlab/@fennecshdf5/fennecshdf5.m b/matlab/@fennecshdf5/fennecshdf5.m index eec70cd..6f49753 100644 --- a/matlab/@fennecshdf5/fennecshdf5.m +++ b/matlab/@fennecshdf5/fennecshdf5.m @@ -1,3980 +1,3985 @@ classdef fennecshdf5 %fennecshdf5 General class used to treat hdf5 result files of fennecs code % A result file is loaded with a call to M=fennecshdf5(filename) where filename is the relative or absolute file path % after loading, several quantities and composite diagnostics such as moments of the distribution function or individual particles % quantities can be accessed. properties filename name folder fullpath timestamp info t0d t1d t2d tpart it0 it1 it2 restartsteps restarttimes %% Physical constants vlight=299792458; qe=1.60217662E-19; me=9.109383E-31; eps_0=8.85418781762E-12; kb=1.38064852E-23; %% Run parameters dt % simulation time step nrun % number of time steps simulated nlres nlsave nlclassical % Was the equation of motion solved in the classical framework nlPhis % Was the self-consistent electric field computed nz % number of intervals in the z direction for the grid nnr % number of intervals in the r direction for the grid for each of the 3 mesh regions lz % physical axial dimension of the simulation space nplasma % Number of initial macro particles potinn % Electric potential at the coaxial insert potout % Electric potential at the cylinder surface B0 % Normalization for the magnetic field Rcurv % Magnetic mirror ratio width % Magnetic mirror length n0 % Initial particle density in case of old particle loading temp % Initial particle temperature in case of old particle loading femorder % finite element method order in z and r direction ngauss % Order of the Gauss integration method for the FEM plasmadim % initial dimensions of the plasma for the old particle loading system radii % Radial limits of the three mesh regions coarse,fine,coarse H0 % Initial particle Energy for Davidsons distribution function P0 % Initial particle Angular momentum for Davidsons distribution function normalized % Are the parts quantities normalized in the h5 file nbspecies % Number of species simulated %% Frequencies omepe % Reference plasma frequency used for normalization omece % Reference cyclotronic frequency for normalization %% Normalizations tnorm % Time normalization rnorm % Dimension normalization bnorm % Magnetic field normalization enorm % Electric field normalization phinorm % Electric potential normalization vnorm % Velocity normalization %% Grid data rgrid % Radial grid position points zgrid % Axial grid position points dz % Axial grid step dr % Radial grid step for the three mesh regions CellVol % Volume of the cell used for density calculation celltype % type of cell -1 outside 1 inside 0 border linked_s % location of linked spline bsplinetype %% Magnetic field Br % Radial magnetic field Bz % Axial magnetic field Athet % Azimuthal component of the Magnetic potential vector rAthet % r*Athet used for the representation of magnetic field lines B % Magnetic field amplitude sinthet % ratio to project quantities along the magnetic field lines costhet % ratio to project quantities along the magnetic field lines %% Energies epot % Time evolution of the particles potential energy ekin % Time evolution of the particles kinetic energy etot % Time evolution of the particles total energy etot0 % Time evolution of the reference particle total energy eerr % Time evolution of the error on the energy conservation npart % Time evolution of the number of simulated %% 2D time data evaluated on grid points N % main specie Density fluidUR % main specie radial fluid velocity fluidUZ % main specie axial fluid velocity fluidUTHET % main specie azimuthal fluid velocity pot % Electric potential evaluated at grid points potxt % External Electric potential evaluated at grid points phi % Electric potential in spline form Er % Radial electric field Ez % Axial electric field Erxt % External Radial electric field Ezxt % External Axial electric field Presstens % Pressure tensor fluidEkin % average kinetic energy in each direction %% Splines knotsr % Spline radial knots knotsz % Spline axial knots %% Particle parameters weight % Macro particle numerical weight of the main specie qsim % Macro particle charge msim % Macro particle mass nbparts % Time evolution of the number of simulated particles partepot % Electric potential at the particles positions R % Particles radial position Z % Particles axial position Rindex % Particles radial grid index Zindex % Particles axial grid index partindex % Particles unique id for tracing trajectories VR % Particles radial velocity VZ % Particles axial velocity VTHET % Particles azimuthal velocity THET % Particles azimuthal position species % Array containing the other simulated species species_moments % containing moments for species (parts) %% Celldiag celldiag % Array containing the cell diagnostic data nbcelldiag % Total number of cell diagnostics %% Curvilinear geometry conformgeom % stores if we use the conforming or nonconforming boundary conditions r_a r_b z_r z_0 r_0 r_r L_r L_z Interior above1 above2 interior walltype geomweight dirichletweight gtilde spl_bound %% Maxwell source parameters maxwellsrce %% Collision with neutral parameters neutcol nudcol % effective momentum collision frequency %% Non ideal power supply psupply end methods function file=file(obj) % returns the h5 file name file=obj.filename; end function obj = fennecshdf5(filename,readparts,old) % Reads the new result file filename and read the parts data if readparts==true % adds the helper_classes folder to the path matlabfuncpath = dir([mfilename('fullpath'),'.m']); addpath(sprintf('%s/../helper_classes',matlabfuncpath.folder)); addpath(sprintf('%s/../helper_functions',matlabfuncpath.folder)); addpath(sprintf('%s/../export_fig',matlabfuncpath.folder)); rehash path % Try catch are there for compatibility with older simulation files filedata=dir(filename); if (isempty(filedata)) fullpath=which(filename); filedata=dir(fullpath); if (isempty(filedata)) error("File: ""%s"" doesn't exist",filename) end end obj.folder=filedata.folder; obj.filename=filedata.name; [~, obj.name, ext] = fileparts(obj.filename); obj.filename=[obj.name,ext]; obj.fullpath=[obj.folder,'/',obj.filename]; obj.timestamp=filedata.date; if nargin==1 readparts=true; end if nargin<3 old=false; end %obj.info=h5info(filename); %% Read the run parameters obj.dt = h5readatt(obj.fullpath,'/data/input.00/','dt'); obj.nrun = h5readatt(obj.fullpath,'/data/input.00/','nrun'); obj.nlres = strcmp(h5readatt(obj.fullpath,'/data/input.00/','nlres'),'y'); obj.nlsave = strcmp(h5readatt(obj.fullpath,'/data/input.00/','nlsave'),'y'); obj.nlclassical =strcmp(h5readatt(obj.fullpath,'/data/input.00/','nlclassical'),'y'); obj.nlPhis =strcmp(h5readatt(obj.fullpath,'/data/input.00/','nlPhis'),'y'); obj.nz = h5readatt(obj.fullpath,'/data/input.00/','nz'); obj.nnr = h5read(obj.fullpath,'/data/input.00/nnr'); obj.lz = h5read(obj.fullpath,'/data/input.00/lz'); obj.qsim = h5readatt(obj.fullpath,'/data/input.00/','qsim'); obj.msim = h5readatt(obj.fullpath,'/data/input.00/','msim'); try obj.r_a=h5readatt(obj.fullpath,'/data/input.00/geometry','r_a'); obj.r_b=h5readatt(obj.fullpath,'/data/input.00/geometry','r_b'); obj.z_r=h5readatt(obj.fullpath,'/data/input.00/geometry','z_r'); obj.r_r=h5readatt(obj.fullpath,'/data/input.00/geometry','r_r'); obj.r_0=h5readatt(obj.fullpath,'/data/input.00/geometry','r_0'); obj.z_0=h5readatt(obj.fullpath,'/data/input.00/geometry','z_0'); obj.above1=h5readatt(obj.fullpath,'/data/input.00/geometry','above1'); obj.above2=h5readatt(obj.fullpath,'/data/input.00/geometry','above2'); obj.interior=h5readatt(obj.fullpath,'/data/input.00/geometry','interior'); obj.walltype=h5readatt(obj.fullpath,'/data/input.00/geometry','walltype'); try obj.L_r=h5readatt(obj.fullpath,'/data/input.00/geometry','L_r'); obj.L_z=h5readatt(obj.fullpath,'/data/input.00/geometry','L_z'); catch end obj.conformgeom=false; catch obj.conformgeom=true; obj.walltype=0; obj.r_a=obj.rgrid(1); obj.r_b=obj.rgrid(end); obj.above1=1; obj.above2=-1; obj.L_r=0; obj.L_z=0; end try obj.weight=h5readatt(obj.fullpath,'/data/part/','weight'); catch obj.weight=obj.msim/obj.me; end filesgrpinfo=h5info(obj.fullpath,'/files'); nbrst=h5readatt(obj.fullpath,'/files','jobnum'); obj.restartsteps(1)=0; obj.restarttimes(1)=0; grp=sprintf('/data/input.%02i/',0); obj.dt(1)=h5readatt(obj.fullpath,grp,'dt'); for i=1:nbrst grp=sprintf('/data/input.%02i/',i); obj.restartsteps(i+1)= h5readatt(obj.fullpath,grp,'startstep'); obj.restarttimes(i+1)= obj.restarttimes(i) + (obj.restartsteps(i+1)-obj.restartsteps(i))*obj.dt(i); obj.dt(i+1)=h5readatt(obj.fullpath,grp,'dt'); end obj.nplasma = h5readatt(obj.fullpath,'/data/input.00/','nplasma'); obj.potinn = h5readatt(obj.fullpath,'/data/input.00/','potinn'); obj.potout = h5readatt(obj.fullpath,'/data/input.00/','potout'); obj.B0 = h5readatt(obj.fullpath,'/data/input.00/','B0'); obj.Rcurv = h5readatt(obj.fullpath,'/data/input.00/','Rcurv'); obj.width = h5readatt(obj.fullpath,'/data/input.00/','width'); obj.n0 = h5readatt(obj.fullpath,'/data/input.00/','n0'); obj.temp = h5readatt(obj.fullpath,'/data/input.00/','temp'); try obj.it0 = h5readatt(obj.fullpath,'/data/input.00/','it0d'); obj.it1 = h5readatt(obj.fullpath,'/data/input.00/','it2d'); obj.it2 = h5readatt(obj.fullpath,'/data/input.00/','itparts'); catch obj.it0 = h5readatt(obj.fullpath,'/data/input.00/','it0'); obj.it1 = h5readatt(obj.fullpath,'/data/input.00/','it1'); obj.it1 = h5readatt(obj.fullpath,'/data/input.00/','it2'); end try try obj.nbspecies=h5readatt(obj.fullpath,'/data/part/','nbspecies'); catch obj.nbspecies=h5readatt(obj.fullpath,'/data/input.00/','nbspecies'); end obj.normalized=strcmp(h5readatt(obj.fullpath,'/data/input.00/','rawparts'),'y'); catch obj.nbspecies=1; obj.normalized=false; end try obj.nbcelldiag=h5readatt(obj.fullpath,'/data/celldiag/','nbcelldiag'); catch obj.nbcelldiag=0; end obj.omepe=sqrt(abs(obj.n0)*obj.qe^2/(obj.me*obj.eps_0)); obj.omece=obj.qe*obj.B0/obj.me; obj.npart= h5read(obj.fullpath, '/data/var0d/nbparts'); try obj.nudcol= h5read(obj.fullpath, '/data/var0d/nudcol'); catch end try obj.H0 = h5read(obj.fullpath,'/data/input.00/H0'); obj.P0 = h5read(obj.fullpath,'/data/input.00/P0'); catch obj.H0=3.2e-14; obj.P0=8.66e-25; end % Normalizations if old obj.tnorm=abs(1/obj.omepe); else obj.tnorm=min(abs(1/obj.omepe),abs(1/obj.omece)); end obj.rnorm=obj.vlight*obj.tnorm; obj.bnorm=obj.B0; obj.enorm=obj.vlight*obj.bnorm; obj.phinorm=obj.enorm*obj.rnorm; obj.vnorm=obj.vlight; % Conversion of the bias to V obj.potinn=obj.potinn*obj.phinorm; obj.potout=obj.potout*obj.phinorm; % Grid data obj.rgrid= h5read(obj.fullpath, '/data/var1d/rgrid')*obj.rnorm; obj.zgrid= h5read(obj.fullpath, '/data/var1d/zgrid')*obj.rnorm; obj.dz=(obj.zgrid(end)-obj.zgrid(1))/double(obj.nz); rid=1; for i=1:length(obj.nnr) obj.dr(i)=(obj.rgrid(sum(obj.nnr(1:i))+1)-obj.rgrid(rid))/double(obj.nnr(i)); rid=rid+obj.nnr(i); end Br = h5read(obj.fullpath,'/data/fields/Br')*obj.bnorm; obj.Br= reshape(Br,length(obj.zgrid),length(obj.rgrid)); Bz = h5read(obj.fullpath,'/data/fields/Bz')*obj.bnorm; obj.Bz= reshape(Bz,length(obj.zgrid),length(obj.rgrid)); try Atheta = h5read(obj.fullpath,'/data/fields/Athet'); obj.Athet= reshape(Atheta,length(obj.zgrid),length(obj.rgrid)); [rmeshgrid,~]=meshgrid(obj.rgrid,obj.zgrid); obj.rAthet=(rmeshgrid.*obj.Athet)'; catch end obj.B=sqrt(obj.Bz.^2+obj.Br.^2); obj.costhet=(obj.Br./obj.B)'; obj.sinthet=(obj.Bz./obj.B)'; clear Br Bz try obj.t0d=h5read(obj.fullpath,'/data/var0d/time'); catch obj.t0d=obj.dt.*double(0:length(obj.epot)-1); end try for i=0:nbrst grp=sprintf('/data/input.%02i/',i); obj.Erxt(:,:,i+1)=reshape(h5read(obj.fullpath,[grp,'Erxt']),length(obj.zgrid),length(obj.rgrid))'*obj.enorm; obj.Ezxt(:,:,i+1)=reshape(h5read(obj.fullpath,[grp,'Ezxt']),length(obj.zgrid),length(obj.rgrid))'*obj.enorm; obj.potxt(:,:,i+1)=reshape(h5read(obj.fullpath,[grp,'potxt']),length(obj.zgrid),length(obj.rgrid))'*obj.phinorm; end catch end obj.femorder = h5read(obj.fullpath,'/data/input.00/femorder'); obj.ngauss = h5read(obj.fullpath,'/data/input.00/ngauss'); obj.plasmadim = h5read(obj.fullpath,'/data/input.00/plasmadim'); obj.radii = h5read(obj.fullpath,'/data/input.00/radii'); obj.epot = h5read(obj.fullpath,'/data/var0d/epot'); obj.ekin = h5read(obj.fullpath,'/data/var0d/ekin'); obj.etot = h5read(obj.fullpath,'/data/var0d/etot'); try obj.etot0 = h5read(obj.fullpath,'/data/var0d/etot0'); obj.eerr = obj.etot-obj.etot0; catch obj.eerr = obj.etot-obj.etot(2); end if(obj.normalized) obj.pot=gridquantity(obj.fullpath,'/data/fields/pot',sum(obj.nnr)+1, obj.nz+1,1); obj.Er=gridquantity(obj.fullpath,'/data/fields/Er',sum(obj.nnr)+1, obj.nz+1,1); obj.Ez=gridquantity(obj.fullpath,'/data/fields/Ez',sum(obj.nnr)+1, obj.nz+1,1); else obj.pot=gridquantity(obj.fullpath,'/data/fields/pot',sum(obj.nnr)+1, obj.nz+1,obj.phinorm); obj.Er=gridquantity(obj.fullpath,'/data/fields/Er',sum(obj.nnr)+1, obj.nz+1,obj.enorm); obj.Ez=gridquantity(obj.fullpath,'/data/fields/Ez',sum(obj.nnr)+1, obj.nz+1,obj.enorm); end try obj.t2d = h5read(obj.fullpath,'/data/fields/time'); catch info=h5info(obj.fullpath,'/data/fields/partdensity'); obj.t2d=obj.dt*(0:info.objspace.Size(2)-1)*double(obj.it1); end try info=h5info(obj.fullpath,'/data/fields/moments'); obj.femorder = h5read(obj.fullpath,'/data/input.00/femorder'); kr=obj.femorder(2)+1; obj.knotsr=augknt(obj.rgrid,kr); kz=obj.femorder(1)+1; obj.knotsz=augknt(obj.zgrid,kz); try obj.CellVol= reshape(h5read(obj.fullpath,'/data/fields/volume'),length(obj.knotsz)-kz,length(obj.knotsr)-kr); obj.CellVol=permute(obj.CellVol,[2,1,3])*obj.rnorm^3; zvol=fnder(spmak(obj.knotsz,ones(1,length(obj.knotsz)-kz)), -1 ); rvol=fnder(spmak(obj.knotsr,2*pi*obj.knotsr(kr:length(obj.knotsr)-kr+1)'), -1 ); ZVol=diff(fnval(zvol,obj.knotsz)); RVol=diff(fnval(rvol,obj.knotsr)); CellVolfull=RVol(kr:end-kr+1)*ZVol(kz:end-kz+1)'; CellVolfull=padarray(CellVolfull,double([kr-1,kz-1]),'replicate','post'); % We remove the volumes which are too small and could % lead to noise obj.CellVol(obj.CellVol./CellVolfull<0.1)=0; catch zvol=fnder(spmak(obj.knotsz,ones(1,length(obj.knotsz)-kz)), -1 ); rvol=fnder(spmak(obj.knotsr,2*pi*[obj.rgrid' 2*obj.rgrid(end)-obj.rgrid(end-1)]), -1 ); ZVol=diff(fnval(zvol,obj.knotsz)); RVol=diff(fnval(rvol,obj.knotsr)); obj.CellVol=RVol(3:end-1)*ZVol(3:end-1)'; obj.CellVol=padarray(obj.CellVol,[1,1],'replicate','post'); end try obj.geomweight = h5read(obj.fullpath,'/data/input.00/geometry/geomweight'); obj.geomweight= reshape(obj.geomweight,length(obj.zgrid),length(obj.rgrid),[]); obj.geomweight = permute(obj.geomweight,[2,1,3]); catch obj.geomweight=ones(length(obj.rgrid),length(obj.zgrid),3); end try obj.dirichletweight = h5read(obj.fullpath,'/data/input.00/geometry/dirichletweight'); obj.dirichletweight= reshape(obj.dirichletweight,length(obj.zgrid),length(obj.rgrid),[]); obj.dirichletweight = permute(obj.dirichletweight,[2,1,3]); catch obj.dirichletweight=obj.geomweight; end try obj.gtilde = h5read(obj.fullpath,'/data/input.00/geometry/gtilde'); obj.gtilde= reshape(obj.gtilde,length(obj.zgrid),length(obj.rgrid),[]); obj.gtilde = permute(obj.gtilde,[2,1,3]); catch obj.gtilde=zeros(length(obj.rgrid),length(obj.zgrid),3); end geomweight=ones(length(obj.rgrid),length(obj.zgrid)); if(obj.normalized) obj.N=splinedensity(obj.fullpath, '/data/fields/moments', obj.knotsr, obj.knotsz, obj.femorder, obj.CellVol, 1, geomweight, 1); obj.phi=splinequantity(obj.fullpath,'/data/fields/phi', obj.knotsr, obj.knotsz, obj.femorder, 1, obj.geomweight(:,:,1), -1); else obj.N=splinedensity(obj.fullpath, '/data/fields/moments', obj.knotsr, obj.knotsz, obj.femorder, obj.CellVol, abs(obj.qsim/obj.qe), geomweight, 1); end obj.fluidUR=splinevelocity(obj.fullpath, '/data/fields/moments', obj.knotsr, obj.knotsz, obj.femorder, obj.vnorm, geomweight, 2); obj.fluidUTHET=splinevelocity(obj.fullpath, '/data/fields/moments', obj.knotsr, obj.knotsz, obj.femorder, obj.vnorm, geomweight, 3); obj.fluidUZ=splinevelocity(obj.fullpath, '/data/fields/moments', obj.knotsr, obj.knotsz, obj.femorder, obj.vnorm, geomweight, 4); if(obj.normalized) obj.Presstens=splinepressure(obj.fullpath, '/data/fields/moments', obj.knotsr, obj.knotsz, obj.femorder, obj.CellVol, obj.vnorm^2*obj.me, geomweight); obj.fluidEkin=splineenergy(obj.fullpath, '/data/fields/moments', obj.knotsr, obj.knotsz, obj.femorder, obj.CellVol, obj.vnorm^2*obj.me*0.5, geomweight); else obj.Presstens=splinepressure(obj.fullpath, '/data/fields/moments', obj.knotsr, obj.knotsz, obj.femorder, obj.CellVol, obj.vnorm^2*obj.msim, geomweight); obj.fluidEkin=splineenergy(obj.fullpath, '/data/fields/moments', obj.knotsr, obj.knotsz, obj.femorder, obj.CellVol, obj.vnorm^2*obj.msim*0.5, geomweight); end try obj.celltype=h5read(obj.fullpath,'/data/input.00/geometry/ctype')'; obj.linked_s=h5read(obj.fullpath,'/data/input.00/geometry/linked_s'); obj.bsplinetype=h5read(obj.fullpath,'/data/input.00/geometry/bsplinetype'); obj.bsplinetype=reshape(obj.bsplinetype,length(obj.knotsz)-kz,length(obj.knotsr)-kr); catch obj.celltype=[]; obj.linked_s=[]; end catch obj.CellVol=(obj.zgrid(2:end)-obj.zgrid(1:end-1))*((obj.rgrid(2:end).^2-obj.rgrid(1:end-1).^2)*pi)'; obj.CellVol=obj.CellVol'; obj.N=griddensity(obj.fullpath, '/data/fields/partdensity', sum(obj.nnr)+1, obj.nz+1, obj.CellVol, abs(obj.qsim/obj.qe), true); obj.fluidUR=gridquantity(obj.fullpath, '/data/fields/fluidur', sum(obj.nnr)+1, obj.nz+1, obj.vnorm, true); obj.fluidUTHET=gridquantity(obj.fullpath, '/data/fields/fluiduthet', sum(obj.nnr)+1, obj.nz+1, obj.vnorm, true); obj.fluidUZ=gridquantity(obj.fullpath, '/data/fields/fluiduz', sum(obj.nnr)+1, obj.nz+1, obj.vnorm, true); end % If we have a maxwellian source, read its parameters try obj.maxwellsrce.rlim=h5read(obj.fullpath, '/data/input.00/maxwellsource/rlimits'); obj.maxwellsrce.zlim=h5read(obj.fullpath, '/data/input.00/maxwellsource/zlimits'); obj.maxwellsrce.frequency=h5readatt(obj.fullpath, '/data/input.00/maxwellsource','frequency'); obj.maxwellsrce.radialtype=h5readatt(obj.fullpath, '/data/input.00/maxwellsource','radialtype'); obj.maxwellsrce.temperature=h5readatt(obj.fullpath, '/data/input.00/maxwellsource','temperature'); obj.maxwellsrce.time_end=h5readatt(obj.fullpath, '/data/input.00/maxwellsource','time_end'); obj.maxwellsrce.time_start=h5readatt(obj.fullpath, '/data/input.00/maxwellsource','time_start'); obj.maxwellsrce.vth=h5readatt(obj.fullpath, '/data/input.00/maxwellsource','vth'); obj.maxwellsrce.rate=obj.maxwellsrce.frequency*obj.weight/(pi*(diff(obj.maxwellsrce.rlim.^2))*diff(obj.maxwellsrce.zlim)); obj.maxwellsrce.current=obj.maxwellsrce.frequency*obj.weight*obj.qe; obj.maxwellsrce.present=true; catch obj.maxwellsrce.present=false; end %% load neutcol parameters try obj.neutcol.neutdens=double(h5readatt(obj.fullpath, '/data/input.00/neutcol','neutdens')); obj.neutcol.neutpressure=double(h5readatt(obj.fullpath, '/data/input.00/neutcol','neutpressure')); obj.neutcol.scatter_fac=double(h5readatt(obj.fullpath, '/data/input.00/neutcol','scatter_fac')); obj.neutcol.Eion=double(h5readatt(obj.fullpath, '/data/input.00/neutcol','Eion')); obj.neutcol.E0=double(h5readatt(obj.fullpath, '/data/input.00/neutcol','E0')); obj.neutcol.Escale=double(h5readatt(obj.fullpath, '/data/input.00/neutcol','Escale')); try obj.neutcol.io_cross_sec=double(h5read(obj.fullpath, '/data/input.00/neutcol/io_cross_sec')); obj.neutcol.io_cross_sec(:,2)=obj.neutcol.io_cross_sec(:,2)*obj.rnorm^2; obj.neutcol.io_cross_sec(:,3)=[log(obj.neutcol.io_cross_sec(2:end,2)./obj.neutcol.io_cross_sec(1:end-1,2))... ./log(obj.neutcol.io_cross_sec(2:end,1)./obj.neutcol.io_cross_sec(1:end-1,1)); 0]; obj.neutcol.iom_cross_sec=zeros(500,3); obj.neutcol.iom_cross_sec(:,1)=logspace(log10(obj.neutcol.Eion+0.001),log10(5e4),size(obj.neutcol.iom_cross_sec,1)); obj.neutcol.iom_cross_sec(:,2)=obj.sigmiopre(obj.neutcol.iom_cross_sec(:,1),true); obj.neutcol.iom_cross_sec(:,3)=abs([log(obj.neutcol.iom_cross_sec(2:end,2)./obj.neutcol.iom_cross_sec(1:end-1,2))... ./log(obj.neutcol.iom_cross_sec(2:end,1)./obj.neutcol.iom_cross_sec(1:end-1,1)); 0]); catch obj.neutcol.io_cross_sec=[]; obj.neutcol.iom_cross_sec=[]; end try obj.neutcol.ela_cross_sec=double(h5read(obj.fullpath, '/data/input.00/neutcol/ela_cross_sec')); obj.neutcol.ela_cross_sec(:,2)=obj.neutcol.ela_cross_sec(:,2)*obj.rnorm^2; obj.neutcol.ela_cross_sec(:,3)=[log(obj.neutcol.ela_cross_sec(2:end,2)./obj.neutcol.ela_cross_sec(1:end-1,2))... ./log(obj.neutcol.ela_cross_sec(2:end,1)./obj.neutcol.ela_cross_sec(1:end-1,1)); 0]; catch obj.neutcol.ela_cross_sec=[]; end obj.neutcol.present=true; catch obj.neutcol.present=false; end %% load spline boundaries try obj.spl_bound.nbsplines=h5readatt(obj.fullpath, '/data/input.00/geometry_spl','nbsplines'); for i=1:obj.spl_bound.nbsplines splgroup=sprintf('/data/input.00/geometry_spl/%02d',i); obj.spl_bound.boundary(i).knots=h5read(obj.fullpath,sprintf('%s/knots',splgroup)); obj.spl_bound.boundary(i).Dval=h5readatt(obj.fullpath,splgroup,'Dirichlet_val'); obj.spl_bound.boundary(i).coefs=reshape(h5read(obj.fullpath,sprintf('%s/pos',splgroup)),2,[])'; obj.spl_bound.boundary(i).order=h5readatt(obj.fullpath,splgroup,'order'); obj.spl_bound.boundary(i).kind=h5readatt(obj.fullpath,splgroup,'kind'); try obj.spl_bound.boundary(i).type=h5readatt(obj.fullpath,splgroup,'type'); catch end obj.spl_bound.boundary(i).fun=spmak(obj.spl_bound.boundary(i).knots,obj.spl_bound.boundary(i).coefs'); end catch obj.spl_bound.nbsplines=0; end %% load non ideal power supply parameters try obj.psupply.targetbias=h5readatt(obj.fullpath, '/data/input.00/psupply','targetbias'); obj.psupply.expdens=h5readatt(obj.fullpath, '/data/input.00/psupply','expdens'); obj.psupply.PSresistor=h5readatt(obj.fullpath, '/data/input.00/psupply','PSresistor'); obj.psupply.geomcapacitor=h5readatt(obj.fullpath, '/data/input.00/psupply','geomcapacitor'); obj.psupply.nbhdt=h5readatt(obj.fullpath, '/data/input.00/psupply','nbhdt'); obj.psupply.biases=h5read(obj.fullpath, '/data/var0d/biases'); obj.psupply.current=h5read(obj.fullpath, '/data/var0d/current'); obj.psupply.tau=obj.psupply.PSresistor*obj.psupply.geomcapacitor*obj.psupply.expdens/obj.neutcol.neutdens; obj.psupply.active=true; obj.psupply.bdpos=h5read(obj.fullpath, '/data/input.00/psupply/bdpos'); catch obj.psupply.active=false; end obj.species=h5parts.empty(obj.nbspecies,0); % Read the main particles parameters if(readparts) obj.species(1)=h5parts(obj.fullpath,'/data/part',obj,obj.normalized); if(obj.nbspecies >1) for i=2:obj.nbspecies obj.species(i)=h5parts(obj.fullpath,sprintf('/data/part/%2d',i),obj,true); try obj.species_moments(i-1).N=splinedensity(obj.fullpath, sprintf('/data/part/%2d/moments',i), obj.knotsr, obj.knotsz, obj.femorder, obj.CellVol, 1, geomweight, 1); obj.species_moments(i-1).fluidUR=splinevelocity(obj.fullpath, sprintf('/data/part/%2d/moments',i), obj.knotsr, obj.knotsz, obj.femorder, obj.vnorm, geomweight, 2); obj.species_moments(i-1).fluidUTHET=splinevelocity(obj.fullpath, sprintf('/data/part/%2d/moments',i), obj.knotsr, obj.knotsz, obj.femorder, obj.vnorm, geomweight, 3); obj.species_moments(i-1).fluidUZ=splinevelocity(obj.fullpath, sprintf('/data/part/%2d/moments',i), obj.knotsr, obj.knotsz, obj.femorder, obj.vnorm, geomweight, 4); catch % No moments stored obj.species_moments(i-1)=0; end end end end try obj.tpart = h5read(obj.fullpath,'/data/part/time'); obj.nbparts = h5read(obj.fullpath,'/data/part/Nparts'); catch obj.nbparts=obj.npart; obj.tpart=obj.dt*(0:size(obj.species(1).R,2)-1)*double(obj.it2); end if(obj.nbcelldiag > 0) obj.celldiag=h5parts.empty; j=0; for i=1:obj.nbcelldiag nbparts=h5read(obj.fullpath,sprintf('%s/Nparts',sprintf('/data/celldiag/%02d',i))); if (sum(nbparts)>0) j=j+1; obj.celldiag(j)=h5parts(obj.fullpath,sprintf('/data/celldiag/%02d',i),obj,true); obj.celldiag(j).rindex=double(h5readatt(obj.fullpath, sprintf('/data/celldiag/%02d',i),'rindex'))+(1:2); obj.celldiag(j).zindex=double(h5readatt(obj.fullpath, sprintf('/data/celldiag/%02d',i),'zindex'))+(1:2); end end end end %------------------------------------------ % Functions for accesing secondary simulation quantities function Atheta=Atheta(obj,R,Z) %% returns the magnetic vector potential at position R,Z interpolated from stored Athet in h5 file % halflz=(obj.zgrid(end)+obj.zgrid(1))/2; % Atheta=0.5*obj.B0*(R-obj.width/pi*(obj.Rcurv-1)/(obj.Rcurv+1)... % .*besseli(1,2*pi*R/obj.width).*cos(2*pi*(Z-halflz)/obj.width)); Atheta=interp2(obj.rgrid,obj.zgrid,obj.Athet,R,Z,'spline'); end function quantity=H(obj,indices) %% computes the total energy for the main specie % for the particle with index indices{1} at timepart step indices{2} % which is time obj.timepart(indices{2}) if strcmp(indices{1},':') p=1:obj.species(1).VR.nparts;% if nothing is defined we load all particles else p=indices{1}; end if strcmp(indices{2},':') t=1:length(obj.tpart); %if nothing is defined all time steps are considered else t=indices{2}; end % if track is true we look at specific particles with their % index and follow them in time % if it is false we just care about the distribution function % and specific particles can have different positions in the % resulting array for each timestep if size(indices,1)>2 track=indices{3}; else track=false; end quantity=0.5*obj.me*(obj.species(1).VR(p,t,track).^2+obj.species(1).VTHET(p,t,track).^2+obj.species(1).VZ(p,t,track).^2)+obj.species(1).partepot(p,t,track); end function quantity=P(obj,indices) %P computes the canonical angular momentum for the main specie % for the particle with index indices{1} at timepart step indices{2} % which is time obj.timepart(indices{2}) if strcmp(indices{1},':') p=1:obj.species(1).R.nparts; else p=indices{1}; end if strcmp(indices{2},':') t=1:length(obj.tpart); else t=indices{2}; end % if track is true we look at specific particles with their % index and follow them in time % if it is false we just care about the distribution function % and specific particles can have different positions in the % resulting array for each timestep if size(indices,1)>2 track=indices{3}; else track=false; end quantity=obj.species(1).R(p,t,track).*(obj.species(1).VTHET(p,t,track)*obj.me+sign(obj.qsim)*obj.qe*obj.Atheta(obj.species(1).R(p,t,track),obj.species(1).Z(p,t,track))); end function quantity=Vpar(obj,varargin) %Vpar Computes the parallel velocity for the main specie % for the particle with index indices{1} at timepart step indices{2} % which is time obj.timepart(indices{2}) if(~iscell(varargin)) indices=mat2cell(varargin); else indices=varargin; end if strcmp(indices{1},':') p=1:obj.species(1).R.nparts; else p=indices{1}; end if strcmp(indices{2},':') t=1:length(obj.tpart); else t=indices{2}; end % if track is true we look at specific particles with their % index and follow them in time % if it is false we just care about the distribution function % and specific particles can have different positions in the % resulting array for each timestep if size(indices,1)>2 track=indices{3}; else track=false; end Zp=obj.species(1).Z(p,t,track);% get the particle axial positon Rp=obj.species(1).R(p,t,track);% get the particle radial position % interpolate the magnetic field at the particle position Bzp=interp2(obj.zgrid,obj.rgrid,obj.Bz',Zp,Rp,'makima'); Brp=interp2(obj.zgrid,obj.rgrid,obj.Br',Zp,Rp,'makima'); Bp=sqrt(Bzp.^2+Brp.^2); % calculate the projection angle of the radial and axial % directions on the magnetic field line Costhet=Bzp./Bp; Sinthet=Brp./Bp; % calculate the actuale parallel velocity quantity=obj.species(1).VR(p,t,track).*Sinthet+obj.species(1).VZ(p,t,track).*Costhet; end function quantity=Vperp(obj,varargin) %Vperp Computes the perpendicular velocity in the guidind center reference frame, % for the main specie particle indices{1} at time indices{2} if(~iscell(varargin)) indices=mat2cell(varargin); else indices=varargin; end if strcmp(indices{1},':') p=1:obj.species(1).R.nparts; else p=indices{1}; end if strcmp(indices{2},':') t=1:length(obj.tpart); else t=indices{2}; end % if track is true we look at specific particles with their % index and follow them in time % if it is false we just care about the distribution function % and specific particles can have different positions in the % resulting array for each timestep if size(indices,2)>2 track=indices{3}; else track=false; end % if gcs is true, gives the perpendicular velocity in the % guiding center system by substracting the EXB azimuthal % velocity % else gives the total perpendicular velocity if size(indices,2)>3 gcs=indices{4}; else gcs=false; end % get the particle position Zp=obj.species(1).Z(p,t,track); Rp=obj.species(1).R(p,t,track); % interpolate the magnetic field at the particle position Bzp=interp2(obj.zgrid,obj.rgrid,obj.Bz',Zp,Rp,'makima'); Brp=interp2(obj.zgrid,obj.rgrid,obj.Br',Zp,Rp,'makima'); Bp=sqrt(Bzp.^2+Brp.^2); % calculate the projecting angles Costhet=Bzp./Bp; Sinthet=Brp./Bp; Vdrift=zeros(size(Zp)); if gcs % for each particle and each timestep % calculate the azimuthal ExB drift velocity for j=1:length(t) [~, tfield]=min(abs(obj.t2d-obj.tpart(t(j)))); timeEr=obj.Er(:,:,tfield); timeEz=obj.Ez(:,:,tfield); %posindE=sub2ind(size(timeEr),Rind(:,j),Zind(:,j)); timeErp=interp2(obj.zgrid,obj.rgrid,timeEr,Zp(:,j),Rp(:,j)); timeEzp=interp2(obj.zgrid,obj.rgrid,timeEz,Zp(:,j),Rp(:,j)); Vdrift(:,j)=(timeEzp.*Brp(:,j)-timeErp.*Bzp(:,j))./Bp(:,j).^2; end end % calculate the perpendicular velocity quantity=sqrt((obj.species(1).VTHET(p,t,track)-Vdrift).^2+(obj.species(1).VR(p,t,track).*Costhet-obj.species(1).VZ(p,t,track).*Sinthet).^2); end function quantity=cyclphase(obj,varargin) %cyclphase Computes the cyclotronic phase for the main specie % for particles with indices{1} at time indices{2} if(~iscell(varargin)) indices=mat2cell(varargin); else indices=varargin; end if strcmp(indices{1},':') p=1:obj.species(1).R.nparts; else p=indices{1}; end if strcmp(indices{2},':') t=1:length(obj.tpart); else t=indices{2}; end % if track is true we look at specific particles with their % index and follow them in time % if it is false we just care about the distribution function % and specific particles can have different positions in the % resulting array for each timestep if size(indices,2)>2 track=indices{3}; else track=false; end Zp=obj.species(1).Z(p,t,track); Rp=obj.species(1).R(p,t,track); % [~, zind(1)]=min(abs(obj.zgrid-0.005262)); % [~, zind(2)]=min(abs(obj.zgrid-0.006637)); % [~, rind(1)]=min(abs(obj.rgrid-0.0784)); % [~, rind(2)]=min(abs(obj.rgrid-0.07861)); % indices=Zp=obj.zgrid(zind(1)) &... % Rp=obj.rgrid(rind(1)); %Zp=Zp(indices); %Rp=Rp(indices); %p=indices; Bzp=interp2(obj.zgrid,obj.rgrid,obj.Bz',Zp,Rp,'makima'); Brp=interp2(obj.zgrid,obj.rgrid,obj.Br',Zp,Rp,'makima'); Bp=sqrt(Bzp.^2+Brp.^2); Costhet=Bzp./Bp; Sinthet=Brp./Bp; % compute the projection of the perpendicular velocity in the % radial direction vr=(obj.species(1).VR(p,t,track).*Costhet-obj.species(1).VZ(p,t,track).*Sinthet); % Get the perpendicular velocity vperp=obj.Vperp(p,t,track,true); vr=vr(indices); vperp=vperp(indices); cospsi=vr./vperp; quantity=acos(cospsi); end function p=borderpoints(obj,subdiv) %borderpoints Return a cell array containing the curves %defining the boundary of the domain % for each boundary p(1,:) and p(2,:) give axial and radial position % for each boundary p(3,:) and p(4,:) give axial and radial normals %gw= contourc(obj.zgrid,obj.rgrid,obj.geomweight(:,:,1),[0 0]) p=cell(0,0); if nargin<2 subdiv=1; end ndiv=sum(subdiv); %outer cylinder if any(obj.geomweight(end,:,1)>=0) idp=ceil(length(obj.zgrid)/ndiv); imin=1; for j=1:length(subdiv) imax=min(imin+subdiv(j)*idp-1,length(obj.zgrid)); p{end+1}=[obj.zgrid(imin:imax)';obj.rgrid(end)*ones(imax-imin+1,1)'; zeros(imax-imin+1,1)';ones(imax-imin+1,1)']; imin=imax; end end %inner cylinder if any(obj.geomweight(1,:,1)>=0) idp=ceil(length(obj.zgrid)/ndiv); imin=1; for j=1:length(subdiv) imax=min(imin+subdiv(j)*idp-1,length(obj.zgrid)); p{end+1}=[obj.zgrid(imin:imax)';obj.rgrid(1)*ones(imax-imin+1,1)'; zeros(imax-imin+1,1)';-ones(imax-imin+1,1)']; imin=imax; end end if obj.walltype==2 % We have an elliptic insert that we want to isolate gw=obj.ellipseborder; zpos=obj.zgrid(obj.zgrid<(min(gw(1,:))) | obj.zgrid>(max(gw(1,:)))); p{2}=[zpos,obj.rgrid(end)*ones(size(zpos))]'; p{1}=[obj.zgrid';obj.rgrid(1)*ones(size(obj.zgrid))']; gw=obj.ellipseborder; p{3}=gw; elseif obj.walltype==9 % extract all the walls gw=contourc(obj.zgrid,obj.rgrid,obj.geomweight(:,:,1),[0 0]); [x,y,~]=C2xyz(gw); for i=1:obj.spl_bound.nbsplines %subdiv=[4,1,2]; if( obj.spl_bound.boundary(i).type>1) continue end s=linspace(obj.spl_bound.boundary(i).knots(1),obj.spl_bound.boundary(i).knots(end),5*length(obj.spl_bound.boundary(i).knots)); positions=fnval(obj.spl_bound.boundary(i).fun,s); ndiv=sum(subdiv); idp=ceil(size(positions,2)/ndiv); imin=1; for j=1:length(subdiv) imax=min(imin+subdiv(j)*idp-1,size(positions,2)); p{end+1}=[positions(1,imin:imax);positions(2,imin:imax)]; imin=imax; end end elseif obj.walltype~=0 % extract all the walls gw=contourc(obj.zgrid,obj.rgrid,obj.geomweight(:,:,1),[0 0]); [x,y,~]=C2xyz(gw); for i=1:length(x) %subdiv=[4,1,2]; ndiv=sum(subdiv); idp=ceil(length(x{i})/ndiv); imin=1; for j=1:length(subdiv) imax=min(imin+subdiv(j)*idp-1,length(x{i})); p{end+1}=[x{i}(imin:imax);y{i}(imin:imax)]; imin=imax; end end end % figure % for i=1:length(p) % plot(p{i}(1,:),p{i}(2,:)) % hold on % end end function p=ellipseborder(obj) %ellipseborder returns the boundary points defining the %elliptic insert z=linspace(-0.998,0.998,600)*obj.z_r; p=zeros(4,length(z)); for i=1:length(z) p(1,i)=z(i)+obj.z_0; p(2,i)=obj.r_0-obj.r_r*sqrt(1-(z(i)/obj.z_r)^2); p(3,i)=2/(obj.z_r^2)*(z(i)); p(4,i)=2/(obj.r_r^2)*(p(2,i)-obj.r_0); end norm=sqrt(p(3,:).^2+p(4,:).^2); p(3,:)=double(obj.interior)*p(3,:)./norm; p(4,:)=double(obj.interior)*p(4,:)./norm; end function charge=totcharge(obj,fieldstep) % Integrates the density profile over the full volume to obtain % the total number of electrons in the volume n=splinedensity(obj.fullpath, '/data/fields/moments', obj.knotsr, obj.knotsz, obj.femorder,ones(size(obj.CellVol)), 1, 1); charge=sum(sum(n(:,:,fieldstep))); end function Gamma=Axialflux(obj,timestep,zpos, species_id) if nargin <4 species_id=1; end % Computes the axial particle flux n*Uz at timestep timestep and axial position zpos if species_id ==1 Gamma=obj.fluidUZ(:,zpos,timestep).*obj.N(:,zpos,timestep); else Gamma=obj.species_moments.fluidUZ(:,zpos,timestep).*obj.species_moments.N(:,zpos,timestep); end end function Gamma=Metallicflux(obj,timestep,subdiv) % Computes the particle flux at time obj.t2d(timestep) on the % metallic boundaries if nargin<3 subdiv=1; end % We find the borderpoints p=obj.borderpoints(subdiv); gamma=cell(size(p)); Nr=cell(size(p)); Nz=cell(size(p)); for i=1:length(p) bp=p{i}; if size(bp,1)==2 % We get the normals at these positions and normalise them Nr{i}=-interp2(obj.zgrid,obj.rgrid,obj.geomweight(:,:,3),bp(1,:),bp(2,:),'linear',0); Nz{i}=-interp2(obj.zgrid,obj.rgrid,obj.geomweight(:,:,2),bp(1,:),bp(2,:),'linear',0); norm=sqrt(Nr{i}.^2+Nz{i}.^2); norm(norm==0)=1; norm(isnan(norm))=1; Nr{i}=Nr{i}./norm; Nz{i}=Nz{i}./norm; else Nr{i}=bp(4,:); Nz{i}=bp(3,:); end gamma{i}=zeros(size(bp,2),length(timestep)); end [z,r]=ndgrid(obj.zgrid,obj.rgrid); N=obj.N(:,:,timestep(1)); n=griddedInterpolant(z,r,N'); % choose as function of species # (dep espece) uz=griddedInterpolant(z,r,obj.fluidUZ(:,:,timestep(1))'); ur=griddedInterpolant(z,r,obj.fluidUR(:,:,timestep(1))'); % we get the density and fluid velocities at the desired time % steps and interpolate them at the boundary position for j=1:length(timestep) n.Values=obj.N(:,:,timestep(j))'; % dependence esp %n.Values(obj.geomweight(:,:,1)<=0)=0; uz.Values=obj.fluidUZ(:,:,timestep(j))'; %uz.Values(obj.geomweight(:,:,1)<=0)=0; ur.Values=obj.fluidUR(:,:,timestep(j))'; %ur.Values(obj.geomweight(:,:,1)<=0)=0; for i=1:length(p) bp=p{i}; gamma{i}(:,j)=n(bp(1:2,:)').*(ur(bp(1:2,:)').*Nr{i}'+uz(bp(1:2,:)').*Nz{i}'); end end % return the boundary position p and the corresponding flux % gamma Gamma.p=p; Gamma.gamma=gamma; end function gamma_species = MetallicFlux_species(obj,timestep,subdiv) % Computes the particle flux at time obj.t2d(timestep) on the % metallic boundaries for species 2, supposedly the ions if nargin<3 subdiv=1; end % We find the borderpoints p=obj.borderpoints(subdiv); gamma=cell(size(p)); Nr=cell(size(p)); Nz=cell(size(p)); for i=1:length(p) bp=p{i}; if size(bp,1)==2 % We get the normals at these positions and normalise them Nr{i}=-interp2(obj.zgrid,obj.rgrid,obj.geomweight(:,:,3),bp(1,:),bp(2,:)); Nz{i}=-interp2(obj.zgrid,obj.rgrid,obj.geomweight(:,:,2),bp(1,:),bp(2,:)); norm=sqrt(Nr{i}.^2+Nz{i}.^2); Nr{i}=Nr{i}./norm; Nz{i}=Nz{i}./norm; else Nr{i}=bp(4,:); Nz{i}=bp(3,:); end gamma{i}=zeros(size(bp,2),length(timestep)); end [z,r]=ndgrid(obj.zgrid,obj.rgrid); N=obj.species_moments.N; N = N(:,:,timestep(1)); n=griddedInterpolant(z,r,N'); % choose as function of species # (dep espece) uz=griddedInterpolant(z,r,obj.species_moments.fluidUZ(:,:,timestep(1))'); ur=griddedInterpolant(z,r,obj.species_moments.fluidUR(:,:,timestep(1))'); % we get the density and fluid velocities at the desired time % steps and interpolate them at the boundary position for j=1:length(timestep) n.Values=obj.species_moments.N(:,:,timestep(j))'; % dependence esp uz.Values=obj.species_moments.fluidUZ(:,:,timestep(j))'; ur.Values=obj.species_moments.fluidUR(:,:,timestep(j))'; for i=1:length(p) bp=p{i}; gamma{i}(:,j)=n(bp(1:2,:)').*(ur(bp(1:2,:)').*Nr{i}'+uz(bp(1:2,:)').*Nz{i}'); end end % return the boundary position p and the corresponding flux % gamma gamma_species.p=p; gamma_species.gamma=gamma; end % function [I, pos]=OutCurrents_species(obj,timestep, subdiv) % % Computes the Outgoing currens at the simulation axial boundaries at timestep timestep % % This is simply the surface integral of the axial flux % if nargin<3 % subdiv=1; % end % flux=obj.Axialflux(timestep,[1 obj.nz+1],2); % Iz=squeeze(trapz(obj.species(1).rgrid,flux.*obj.species(1).rgrid)*2*pi*obj.species.q); % Iz(1,:)=-Iz(1,:); % gamm=obj.MetallicFlux_species(timestep, subdiv); % qe = obj.species.q; % % OK TILL HERE % % c=mflux.gamma{i}'*qe/(100^2)/P; % Im=zeros(length(gamm.p),length(timestep)); % pos=cell(size(gamm.p)); % % for i=1:length(gamm.p) % p=gamm.p{i}; % pos{i}=p; % flux=gamm.gamma{i}'*obj.species.q; % for j=1:length(timestep) % % Im(i,j)=pi/2*sum((p(2,1:end-1)+p(2,2:end)).*(flux(2:end,j)+flux(1:end-1,j))'... % % .*sqrt((p(1,2:end)-p(1,1:end-1)).^2+(p(2,2:end)-p(2,1:end-1)).^2)); % % %AxialDensity = flux(j,:).*sqrt(p(1,:).^2 + p(2,:).^2); % AxialDensity = flux(j,:).* p(2,:); % Im(i,j) = 2*pi*trapz(p(1,~isnan(AxialDensity)),AxialDensity(~isnan(AxialDensity))); % end % end % I=cat(1,Iz,Im); % end function [I, pos]=OutCurrents(obj,timestep, subdiv) % Computes the Outgoing currens at the simulation axial boundaries at timestep timestep % This is simply the surface integral of the axial flux if nargin<3 subdiv=1; end flux=obj.Axialflux(timestep,[1 obj.nz+1]); Iz=squeeze(trapz(obj.rgrid,flux.*obj.rgrid)*2*pi*obj.qsim/obj.weight); Iz(1,:)=-Iz(1,:); gamm=obj.Metallicflux(timestep, subdiv); Im=zeros(length(gamm.p),length(timestep)); pos=cell(size(gamm.p)); for i=1:length(gamm.p) p=gamm.p{i}; pos{i}=p; flux=gamm.gamma{i}'; for j=1:length(timestep) Im(i,j)=pi/2*sum((p(2,1:end-1)+p(2,2:end)).*(flux(j,2:end)+flux(j,1:end-1))... .*sqrt((p(1,2:end)-p(1,1:end-1)).^2+(p(2,2:end)-p(2,1:end-1)).^2)); %AxialDensity = flux(j,:).* p(2,:); %Im(i,j) = 2*pi*trapz(p(1,:),AxialDensity); end end I=-cat(1,Iz,Im*obj.qsim/obj.weight); end % % function [I, pos]=OutCurrents(obj,timestep, subdiv) % % Computes the Outgoing currens at the simulation axial boundaries at timestep timestep % % This is simply the surface integral of the axial flux for % % ions % if nargin<3 % subdiv=1; % end % qe = obj.qsim/obj.weight; % electrons charge % flux=obj.Axialflux(timestep,[1 obj.nz+1]); % Iz=squeeze(trapz(obj.rgrid,flux.*obj.rgrid)*2*pi*qe); % Iz(1,:)=-Iz(1,:); % % mflux = obj.Metallicflux(timestep,subdiv); % Im=zeros(length(mflux.p),length(timestep)); % pos=cell(size(mflux.p)); % % for ii =1:length(mflux.gamma) % pos{ii}=mflux.p{ii}; % p=mflux.p{ii}; % for jj = 1:length(timestep) % % flux = qe*mflux.gamma{ii}(:,jj)'.*mflux.p{ii}(2,:); % Im(ii,jj) = 2*pi*trapz(mflux.p{ii}(1,~isnan(flux)), flux(~isnan(flux))); % %Im(ii,jj)=pi/2*sum((p(2,1:end-1)+p(2,2:end)).*(flux(jj,2:end)+flux(jj,1:end-1))... % %.*sqrt((p(1,2:end)-p(1,1:end-1)).^2+(p(2,2:end)-p(2,1:end-1)).^2)); % end % end % % I=-cat(1,Iz,Im); % end function [I, pos]=OutCurrents_species(obj,timestep, subdiv) % Computes the Outgoing currens at the simulation axial boundaries at timestep timestep % This is simply the surface integral of the axial flux for % ions if nargin<3 subdiv=1; end flux=obj.Axialflux(timestep,[1 obj.nz+1],2); Iz=squeeze(trapz(obj.species(1).rgrid,flux.*obj.species(1).rgrid)*2*pi*obj.species.q); Iz(1,:)=-Iz(1,:); mflux = obj.MetallicFlux_species(timestep,subdiv); qe = abs(obj.species.q); % ions charge Im=zeros(length(mflux.p),length(timestep)); pos=cell(size(mflux.p)); for ii =1:length(mflux.gamma) pos{ii}=mflux.p{ii}; for jj = 1:length(timestep) flux = qe*mflux.gamma{ii}(:,jj)'.*mflux.p{ii}(2,:); Im(ii,jj) = 2*pi*trapz(mflux.p{ii}(1,~isnan(flux)), flux(~isnan(flux))); end end I=cat(1,Iz,Im); end function [pot] = PotentialWell(obj,fieldstep,fieldaligned) %PotentialWell Computes the potential well at the given timestep on the FEM grid points % interpolates the model data on rgrid and zgrid if nargin<3 fieldaligned=false; end model=obj.potentialwellmodel(fieldstep); z=model.z; modpot=model.pot; if fieldaligned r=model.rathet; lvls=linspace(min(obj.rAthet(:)),max(obj.rAthet(:)),400); [Zmesh,Rmesh]=meshgrid(obj.zgrid,lvls); else r=model.r; [Zmesh,Rmesh]=meshgrid(obj.zgrid,obj.rgrid); end pot=zeros(size(Zmesh,2),size(Zmesh,1),length(fieldstep)); for i=1:length(fieldstep) pot(:,:,i)=griddata(z,r,modpot(:,i),Zmesh,Rmesh)'; end end function Epar = Epar(obj,fieldstep) % Computes the electric field component parallel to the magnetic field line Epar=obj.Er(:,:,fieldstep).*(obj.Br./obj.B)' + (obj.Bz./obj.B)'.*obj.Ez(:,:,fieldstep); end function Eperp = Eperp(obj,fieldstep) % Computes the electric field component perpendicular to the magnetic field line Eperp=obj.Er(:,:,fieldstep).*(obj.Bz./obj.B)' - (obj.Br./obj.B)'.*obj.Ez(:,:,fieldstep); end function Ekin = Ekin(obj,varargin) %Ekin Computes the classical kinetic energy of particles indices{1} at % time obj.tpart(indices{2}) in Joules if(~iscell(varargin)) indices=mat2cell(varargin); else indices=varargin; end if strcmp(indices{1},':') p=1:obj.species(1).R.nparts; else p=indices{1}; end if strcmp(indices{2},':') t=1:length(obj.tpart); else t=indices{2}; end % if track is true we look at specific particles with their % index and follow them in time % if it is false we just care about the distribution function % and specific particles can have different positions in the % resulting array for each timestep if size(indices,1)>2 track=indices{3}; else track=false; end Vr=obj.species(1).VR(p,t,track); Vthet= obj.species(1).VTHET(p,t,track); Vz=obj.species(1).VZ(p,t,track); Ekin=0.5*obj.msim/obj.weight*(Vr.^2+Vthet.^2+Vz.^2); end function sig=sigio(obj,E,init) %sigio returns the total ionisation cross-section in m^2 % at energy E[eV] % init is only used during the loading of the h5 file if nargin <3 init=false; end sig=zeros(size(E)); if(~init &&( ~obj.neutcol.present || isempty(obj.neutcol.io_cross_sec))) sig=zeros(size(E)); return end for i=1:length(E(:)) if(E(i)>obj.neutcol.Eion) sig(ind2sub(size(E),i))=obj.fit_cross_sec(E(ind2sub(size(E),i)),obj.neutcol.io_cross_sec); end end end function sig=sigmio(obj,E) %sigmio returns the total ionisation cross-section for momentum exchange for the incoming electron in m^2 % at energy E[eV] sig=zeros(size(E)); if(~obj.neutcol.present || isempty(obj.neutcol.iom_cross_sec)) return end for i=1:length(E(:)) if(E(i)>obj.neutcol.Eion) sig(ind2sub(size(E),i))=obj.fit_cross_sec(E(ind2sub(size(E),i)),obj.neutcol.iom_cross_sec); end end end function sigm=sigmela(obj,E) %sigmela returns the elastic collision cross-section for momentum exchange for the incoming electron in m^2 % at energy E[eV] sigm=zeros(size(E)); if(~obj.neutcol.present || isempty(obj.neutcol.ela_cross_sec)) return end for i=1:length(E(:)) sigm(ind2sub(size(E),i))=obj.fit_cross_sec(E(ind2sub(size(E),i)),obj.neutcol.ela_cross_sec); end end function sig=sigela(obj,E) %sigmela returns the elastic collision cross-section for the incoming electron in m^2 % at energy E[eV] % if used this will give the frequency of elastic collisions E0=obj.neutcol.E0; chi=E./(0.25*E0+E); sig=(2*chi.^2)./((1-chi).*((1+chi).*log((1+chi)./(1-chi))-2*chi)).*obj.sigmela(E); end function [Forces, Density]=Forcespline(obj,it,fdens,getmean) %Forcespline calculates the fluid force terms in each direction %at time obj.t2d(it) % if fdens return the force density in N/m^3 othewise give % the force in N % if getmean return only the time averaged quanties over % time samples[it(1)...it(end] if strcmp(it,':') it=floor(0.95*size(obj.t2d)):size(obj.t2d)-1; end if nargin<3 fdens=true; end if nargin <4 getmean=false; end % To be able to calculate the centered finite difference in % time, we remove the first and last time indices it(it<2)=[]; it(it>length(obj.t2d)-1)=[]; m_e=obj.msim/obj.weight; q_e=obj.qsim/obj.weight; n=obj.N(:,:,it); [r,~]=meshgrid(obj.rgrid,obj.zgrid); Rinv=1./r'; Rinv(isinf(Rinv))=0; % get inverse of density to get the force in N Density.N=n; invn=1./n; invn(isnan(invn) | isinf(invn))=0; % Calculate electric forces Eforcer=q_e*obj.Er(:,:,it); Eforcez=q_e*obj.Ez(:,:,it); Dragforcer=zeros(size(n,1),size(n,2),size(n,3)); Dragforcethet=zeros(size(n,1),size(n,2),size(n,3)); Dragforcez=zeros(size(n,1),size(n,2),size(n,3)); time=obj.t2d(it); Forces.it=it; Forces.time=time; if getmean if ~fdens n=ones(size(n)); end % Electric forces Forces.Eforcer=mean(n.*q_e.*obj.Er(:,:,it),3); Forces.Eforcez=mean(n.*q_e.*obj.Ez(:,:,it),3); % Magnetic forces Forces.Bforcer=mean(q_e.*obj.fluidUTHET(:,:,it).*obj.Bz'.*n,3); Forces.Bforcethet=mean(q_e.*(obj.fluidUZ(:,:,it).*obj.Br'-obj.fluidUR(:,:,it).*obj.Bz').*n,3); Forces.Bforcez=mean(-q_e.*obj.fluidUTHET(:,:,it).*obj.Br'.*n,3); % Inertial forces Forces.inertforcer=mean(-m_e.*n.*(-obj.fluidUTHET(:,:,it).^2.*Rinv... +obj.fluidUR(:,:,it).*obj.fluidUR.der(:,:,it,[1 0])... +obj.fluidUZ(:,:,it).*obj.fluidUR.der(:,:,it,[0 1])),3); Forces.inertforcethet=mean(-m_e*n.*(obj.fluidUR(:,:,it).*obj.fluidUTHET(:,:,it).*Rinv... +obj.fluidUR(:,:,it).*obj.fluidUTHET.der(:,:,it,[1 0])... +obj.fluidUZ(:,:,it).*obj.fluidUTHET.der(:,:,it,[0 1])),3); Forces.inertforcez=mean(-m_e*n.*(obj.fluidUR(:,:,it).*obj.fluidUZ.der(:,:,it,[1 0])... +obj.fluidUZ(:,:,it).*obj.fluidUZ.der(:,:,it,[0 1])),3); % Pressure forces Forces.Pressforcer=mean(-n.*( squeeze(obj.Presstens.der(1,:,:,it,[1 0]))... + squeeze(obj.Presstens(1,:,:,it) - obj.Presstens(4,:,:,it)).*Rinv... + squeeze(obj.Presstens.der(3,:,:,it,[0 1])))... .*invn,3); Forces.Pressforcethet=mean(-n.*( squeeze(obj.Presstens.der(2,:,:,it,[1 0]))... + squeeze(obj.Presstens.der(5,:,:,it,[0 1])) ... + 2*squeeze(obj.Presstens(2,:,:,it)).*Rinv ... ).*invn,3); Forces.Pressforcez=mean(-n.*( squeeze(obj.Presstens.der(3,:,:,it,[1 0]))... + squeeze(obj.Presstens(3,:,:,it)).*Rinv... + squeeze(obj.Presstens.der(6,:,:,it,[0 1])) )... .*invn,3); % ellastic coll drag forces if( obj.neutcol.present) Ek=squeeze(obj.fluidEkin(1,:,:,it)+obj.fluidEkin(2,:,:,it)+obj.fluidEkin(3,:,:,it)); sigm=obj.sigmela(Ek/obj.qe)+obj.sigio(Ek/obj.qe)+obj.sigmio(Ek/obj.qe); dragfreq=obj.neutcol.neutdens.*sigm.*sqrt(2*obj.weight/obj.msim*Ek); Forces.Dragforcer=mean(-m_e*n.*dragfreq.*obj.fluidUR(:,:,it),3); Forces.Dragforcethet=mean(-m_e*n.*dragfreq.*obj.fluidUTHET(:,:,it),3); Forces.Dragforcez=mean(-m_e*n.*dragfreq.*obj.fluidUZ(:,:,it),3); else Forces.Dragforcer=0; Forces.Dragforcethet=0; Forces.Dragforcez=0; end % effective drag frequency due to the maxwellian source if( obj.maxwellsrce.present) dragfreqsrc=obj.maxwellsrce.frequency*obj.weight/(pi*diff(obj.maxwellsrce.zlim)*(obj.maxwellsrce.rlim(2)^2-obj.maxwellsrce.rlim(1)^2)).*invn; dragfreqsrc(isinf(dragfreqsrc))=0; Forces.Dragforcer=Forces.Dragforcer+mean(-n.*m_e.*dragfreqsrc.*obj.fluidUR(:,:,it),3); Forces.Dragforcethet=Forces.Dragforcethet+mean(-n.*m_e.*dragfreqsrc.*obj.fluidUTHET(:,:,it),3); Forces.Dragforcez=Forces.Dragforcez+mean(-n.*m_e.*dragfreqsrc.*obj.fluidUZ(:,:,it),3); end % Time derivative for fluid accelleration cdt=(obj.t2d(it+1)-obj.t2d(it-1)); cdt=reshape(cdt,1,1,[]); Forces.durdt=mean(m_e*(obj.fluidUR(:,:,it+1)-obj.fluidUR(:,:,it-1))./cdt,3); Forces.duthetdt=mean(m_e*(obj.fluidUTHET(:,:,it+1)-obj.fluidUTHET(:,:,it-1))./cdt,3); Forces.duzdt=mean(m_e*(obj.fluidUZ(:,:,it+1)-obj.fluidUZ(:,:,it-1))./cdt,3); else % Allocate memory Bforcer=zeros(size(n,1),size(n,2),size(n,3)); Bforcez=zeros(size(n,1),size(n,2),size(n,3)); Bforcethet=zeros(size(n,1),size(n,2),size(n,3)); inertforcer=zeros(size(n,1),size(n,2),size(n,3)); inertforcez=zeros(size(n,1),size(n,2),size(n,3)); inertforcethet=zeros(size(n,1),size(n,2),size(n,3)); Pressforcer=zeros(size(n,1),size(n,2),size(n,3)); Pressforcethet=zeros(size(n,1),size(n,2),size(n,3)); Pressforcez=zeros(size(n,1),size(n,2),size(n,3)); durdt=zeros(size(n,1),size(n,2),size(n,3)); duthetdt=zeros(size(n,1),size(n,2),size(n,3)); duzdt=zeros(size(n,1),size(n,2),size(n,3)); fluiduThet=obj.fluidUTHET(:,:,it); Density.fluiduThet=fluiduThet; for j=1:size(n,3) % Magnetic forces Bforcer(:,:,j)=q_e.*fluiduThet(:,:,j).*obj.Bz'; Bforcethet(:,:,j)=q_e.*(obj.fluidUZ(:,:,it(j)).*obj.Br'-obj.fluidUR(:,:,it(j)).*obj.Bz'); Bforcez(:,:,j)=-q_e.*fluiduThet(:,:,j).*obj.Br'; % Inertial forces inertforcer(:,:,j)=-m_e.*(-fluiduThet(:,:,j).^2.*Rinv... +obj.fluidUR(:,:,it(j)).*obj.fluidUR.der(:,:,it(j),[1 0])... +obj.fluidUZ(:,:,it(j)).*obj.fluidUR.der(:,:,it(j),[0 1])); inert1=obj.fluidUR(:,:,it(j)).*fluiduThet(:,:,j).*Rinv; inert2=obj.fluidUR(:,:,it(j)).*obj.fluidUTHET.der(:,:,it(j),[1 0]); inert3=obj.fluidUZ(:,:,it(j)).*obj.fluidUTHET.der(:,:,it(j),[0 1]); inertforcethet(:,:,j)=-m_e.*(inert1... +inert2... +inert3); inertforcez(:,:,j)=-m_e.*(obj.fluidUR(:,:,it(j)).*obj.fluidUZ.der(:,:,it(j),[1 0])... +obj.fluidUZ(:,:,it(j)).*obj.fluidUZ.der(:,:,it(j),[0 1])); % Pressure forces Pr1=squeeze(obj.Presstens.der(1,:,:,it(j),[1 0])); Pr2=squeeze(obj.Presstens(1,:,:,it(j)) - obj.Presstens(4,:,:,it(j))).*Rinv; Pr3=squeeze(obj.Presstens.der(3,:,:,it(j),[0 1])); Pressforcer(:,:,j)=-( Pr1... + Pr2... + Pr3 )... .*invn(:,:,j); Pthet1=squeeze(obj.Presstens.der(2,:,:,it(j),[1 0])); Pthet2=squeeze(obj.Presstens.der(5,:,:,it(j),[0 1])); Pthet3=2*squeeze(obj.Presstens(2,:,:,it(j))).*Rinv; Pressforcethet(:,:,j)=-( Pthet1... + Pthet2 ... + Pthet3 ... ).*invn(:,:,j); Pz1=squeeze(obj.Presstens.der(3,:,:,it(j),[1 0])); Pz2=squeeze(obj.Presstens(3,:,:,it(j))).*Rinv; Pz3=squeeze(obj.Presstens.der(6,:,:,it(j),[0 1])); Pressforcez(:,:,j)=-( Pz1... + Pz2... + Pz3 )... .*invn(:,:,j); % ellastic coll drag forces if( obj.neutcol.present) Ek=squeeze(obj.fluidEkin(1,:,:,it(j))+obj.fluidEkin(2,:,:,it(j))+obj.fluidEkin(3,:,:,it(j))); sigm=obj.sigmela(Ek/obj.qe)+obj.sigio(Ek/obj.qe)+obj.sigmio(Ek/obj.qe); dragfreq=obj.neutcol.neutdens.*sigm.*sqrt(2*obj.weight/obj.msim*Ek); Dragforcer(:,:,j)=-m_e*dragfreq.*obj.fluidUR(:,:,it(j)); Dragforcethet(:,:,j)=-m_e*dragfreq.*obj.fluidUTHET(:,:,it(j)); Dragforcez(:,:,j)=-m_e*dragfreq.*obj.fluidUZ(:,:,it(j)); end % effective drag frequency due to the maxwellian source if( obj.maxwellsrce.present) dragfreqsrc=obj.maxwellsrce.frequency*obj.weight/(pi*diff(obj.maxwellsrce.zlim)*(obj.maxwellsrce.rlim(2)^2-obj.maxwellsrce.rlim(1)^2))*invn(:,:,j); dragfreqsrc(isinf(dragfreqsrc))=0; Dragforcer(:,:,j)=Dragforcer(:,:,j)+-m_e*dragfreqsrc.*obj.fluidUR(:,:,it(j)); Dragforcethet(:,:,j)=Dragforcethet(:,:,j)+-m_e*dragfreqsrc.*obj.fluidUTHET(:,:,it(j)); Dragforcez(:,:,j)=Dragforcez(:,:,j)+-m_e*dragfreqsrc.*obj.fluidUZ(:,:,it(j)); end % Time derivative cdt=(obj.t2d(it(j)+1)-obj.t2d(it(j)-1)); durdt(:,:,j)=m_e*(obj.fluidUR(:,:,it(j)+1)-obj.fluidUR(:,:,it(j)-1))/cdt; duthetdt(:,:,j)=m_e*(obj.fluidUTHET(:,:,it(j)+1)-obj.fluidUTHET(:,:,it(j)-1))/cdt; duzdt(:,:,j)=m_e*(obj.fluidUZ(:,:,it(j)+1)-obj.fluidUZ(:,:,it(j)-1))/cdt; end if(~fdens) Forces.Eforcer=Eforcer; Forces.Eforcez=Eforcez; Forces.Bforcer=Bforcer; Forces.Bforcethet=Bforcethet; Forces.Bforcez=Bforcez; Forces.inertforcer=inertforcer; Forces.inertforcethet=inertforcethet; Forces.inertforcez=inertforcez; Forces.Pressforcer=Pressforcer; Forces.Pressforcethet=Pressforcethet; Forces.Pressforcez=Pressforcez; Forces.durdt=durdt; Forces.duthetdt=duthetdt; Forces.duzdt=duzdt; Forces.Dragforcer=Dragforcer; Forces.Dragforcethet=Dragforcethet; Forces.Dragforcez=Dragforcez; else % multiply by density to have force density Forces.Eforcer=Eforcer.*n; Forces.Eforcez=Eforcez.*n; Forces.Bforcer=Bforcer.*n; Forces.Bforcethet=Bforcethet.*n; Forces.Bforcez=Bforcez.*n; Forces.inertforcer=inertforcer.*n; Forces.inertforcethet=inertforcethet.*n; Forces.inertforcez=inertforcez.*n; Forces.Pressforcer=Pressforcer.*n; Forces.Pressforcethet=Pressforcethet.*n; Forces.Pressforcez=Pressforcez.*n; Forces.durdt=durdt.*n; Forces.duthetdt=duthetdt.*n; Forces.duzdt=duzdt.*n; Forces.Dragforcer=Dragforcer.*n; Forces.Dragforcethet=Dragforcethet.*n; Forces.Dragforcez=Dragforcez.*n; end end end function [lr,rb,lz,zb]= clouddims(obj,it,zpos,fracn) % clouddims return the cloud axial and radial limit at time it % and axial position zpos % fracn defines the fraction of the maximum density below which % we consider to have a vacuum if nargin<4 fracn=0.1; end % get the density n=obj.N(:,:,it); lr=cell(1,length(it)); lz=lr; rb=lr; zb=rb; for i=1:size(n,3) nthresh=fracn*max(max(n(:,:,i))); % find the points outside of the cloud outside=find(n(:,zpos,i)2) rmpos=outside(j); rppos=outside(j+1); lr{i}(k)=obj.rgrid(rppos-1)-obj.rgrid(rmpos+1); rb{i}(:,k)=[max(rmpos+1,1) min(rppos-1,sum(obj.nnr))]; k=k+1; end end maxgap=2; k=1; for I=rmpos+1:rppos-1 outside=find(n(I,:,i)maxgap) maxgap=zgap(j); zmpos=outside(j); zppos=outside(j+1); lz{i}(k)=obj.zgrid(zppos-1)-obj.zgrid(zmpos+1); zb{i}(:,k)=[max(zmpos+1,1) min(zppos-1,obj.nz)]; k=k+1; end end end end end function displaygeomweight(self) figure contourf(self.zgrid,self.rgrid,self.geomweight(:,:,1)) end %------------------------------------------ % Functions for plotting evolving quantities function line=displaysplbound(obj,ax,rescale,markers) %displaysplbound display on axis ax the boundary of the %simulation domain and the Dirichlet and Neumann walls defined %with spline curves if nargin<2 ax=gca; end if nargin<3 rescale=1; end if nargin<4 markers=true; end hold on for i=1:obj.spl_bound.nbsplines + if(obj.spl_bound.boundary(i).type==0) + %continue + end knots=obj.spl_bound.boundary(i).knots(1:end); coeffs=obj.spl_bound.boundary(i).coefs'*rescale; pp=spmak(knots,coeffs); sizec=size(coeffs,2); order=length(knots)-sizec; - s=linspace(knots(order),knots(sizec+1),1000); + s=linspace(knots(order),knots(sizec+1),max(200,3*length(knots))); fittedpos=fnval(pp,s); line=plot(fittedpos(1,:),fittedpos(2,:),'-','linewidth',2); %ine=plot(coeffs(1,:),coeffs(2,:),'-','linewidth',2); if markers plot(coeffs(1,:),coeffs(2,:),'rx','markersize',14) for j=1:size(coeffs,2) text(coeffs(1,j),coeffs(2,j),sprintf('%i',j),'fontsize',14) end end end end function displayraddim(obj,it,zpos,fracn) %displayraddim display the evolution of the radial dimension of the cloud in %time to find if the cloud size get below a critical radial %size at which the ionisation is not sufficient to compensate %the losses % also plot the well radial dimensions in time if nargin<3 zpos=floor(length(obj.zgrid)/2); end if nargin<4 fracn=0.1; end [lr,rb,lz,zb]=obj.clouddims(it,zpos,fracn); t=obj.t2d(it); Lr=zeros(size(lr)); er=obj.Er(:,:,it); r_min=Lr; r_minpred=r_min; well_r=Lr; nb=Lr; for i=1:length(lr) if ~isempty(lr{i}) && ~isempty(lz{i}) [Lr(i),id]=max(lr{i}); rm=rb{i}(1,id); rp=rb{i}(2,id); nb(i)=mean(obj.N(rm:rp,zpos,it(i))); Lp=min(lz{i}); Lm=mean(lz{i}); rpos=rm:rp; vperp=-er(rpos,zpos,i)./obj.Bz(zpos,rpos)'; Ek=0.5*obj.me*vperp.^2/obj.qe; sigio=obj.sigio(Ek); sigd=obj.sigmela(Ek)+obj.sigmio(Ek)+sigio; omegap2=obj.qe^2*obj.N(rpos,zpos,it(i))/obj.eps_0/obj.me; omegac2=(obj.qe*obj.Bz(zpos,rpos)'/obj.me).^2; ur=er(rpos,zpos,i)*obj.qe./((omegap2-omegac2)*obj.me).*sigd.*vperp*obj.neutcol.neutdens; r_minpred(i)=mean(obj.N(rp,zpos,it(i))*Lp*ur./(nb(i)*obj.neutcol.neutdens*sigio.*vperp*Lm));%mean(1./(-1/obj.rgrid(rm)+obj.neutcol.neutdens*sigio.*vperp./ur*(Lm/Lp)*nb(i)/obj.N(rp,zpos,it(i)))); rpos=rp; vperp=-er(rpos,zpos,i)./obj.Bz(zpos,rpos)'; Ek=0.5*obj.me*vperp.^2/obj.qe; sigio=obj.sigio(Ek); ur=obj.fluidUR(rpos,zpos,it(i)); r_min(i)=max(obj.N(rp,zpos,it(i))*Lp*ur/(nb(i)*obj.neutcol.neutdens*sigio.*vperp*Lm),0);%max(mean(1./(-1/obj.rgrid(rm)+obj.neutcol.neutdens*sigio.*vperp./ur*(Lm/Lp)*nb(i)/obj.N(rp,zpos,it(i)))),0); nb(i)=nb(i)*Lm*2*pi*obj.rgrid(rm)*Lr(i); else Lr(i)=NaN; r_min(i)=NaN; r_minpred(i)=NaN; end potwell=obj.PotentialWell(it(i))'; outside=find(isnan(potwell(:,zpos))); gap=diff(outside); for j=1:length(gap) if(gap(j)>2) rmpos=outside(j)+1; rppos=outside(j+1)-1; well_r(i)=obj.rgrid(rppos)-obj.rgrid(rmpos); end end end f=figure('Name', sprintf('%s rlims B=%f phi=%f',obj.name,obj.B0, (obj.potout-obj.potinn))); plot(t,Lr,'displayname','\Deltar_{cloud}','linewidth',1.3) hold on plot(t,r_min,'displayname','\Deltar_{min} (u_r simu)','linewidth',1.3) plot(t,r_minpred,'displayname','\Deltar_{min} (u_r pred)','linewidth',1.3) plot(t,well_r,'displayname','\Deltar_{well}','linewidth',1.3) ylabel('\Delta r [m]') yyaxis right plot(t,nb,'--','displayname','N') legend('location','eastoutside') xlabel('t [s]') ylabel('N') set(gca,'fontsize',12) yyaxis left ylimits=ylim; %ylim([ylimits(1) 1.1*max(Lr)]) title(sprintf('cloud radial limits at z=%1.2e[m]',obj.zgrid(zpos))) obj.savegraph(f,sprintf('%s/%s_%d_rlims',obj.folder,obj.name,zpos),[15 10]); end function displaypsi(obj,deltat) %% plot the initial and final radial profile at position z=0 and show the normalized enveloppe function Psi % relevant for Davidson annular distribution function f=figure('Name', sprintf('%s Psi',obj.name)); f.Name= sprintf('%s Psi',obj.name); zpos=floor(length(obj.zgrid)/2); tinit=1; tend=length(obj.t2d); if iscell(deltat) deltat=cell2mat(deltat); end if(obj.species(1).R.nt<2) h0=obj.H0; p0=obj.P0; else h0=mean(H(obj,{1:obj.species(1).VR.nparts,obj.species(1).VR.nt,false})); p0=mean(P(obj,{1:obj.species(1).VR.nparts,obj.species(1).VR.nt,false})); end lw=1.5; Mirrorratio=(obj.Rcurv-1)/(obj.Rcurv+1); locpot=mean(obj.pot(:,zpos,tend-deltat:tend),3); psi=1+obj.qe*locpot(:)/h0-1/(2*obj.me*h0)*(p0./obj.rgrid+obj.qe*0.5*obj.B0.*(obj.rgrid-obj.width/pi*Mirrorratio*cos(2*pi*obj.zgrid(zpos)/obj.width)*besseli(1,2*pi*obj.rgrid/obj.width))).^2; locdens=mean(obj.N(:,zpos,tend-deltat:tend),3); [maxn,In]=max(locdens);%M.N(:,zpos,tinit)); plot(obj.rgrid*1e3,obj.N(:,zpos,tinit),'b-','DisplayName',sprintf('t=%1.2f[ns]',obj.t2d(tinit)*1e9),'linewidth',lw) hold on plot(obj.rgrid*1e3,locdens,'r-','DisplayName',sprintf('t=[%1.2f-%1.2f] [ns] averaged',obj.t2d(tend-deltat)*1e9,obj.t2d(tend)*1e9),'linewidth',lw) %r0=0.005;% r0=obj.rgrid(In); %maxn=5e14; plot(obj.rgrid(In-5:end)*1e3,1./obj.rgrid(In-5:end)*r0*maxn,'--','DisplayName','n_{e,fit}=a/r','linewidth',lw) %plot(obj.rgrid(In-2:end),1./obj.rgrid(In-2:end).^2*maxn*obj.rgrid(In)^2,'DisplayName','N=c*1/r^2','linewidth',lw) %plot(obj.rgrid(In-2:end),1./obj.rgrid(In-2:end).^4*maxn*obj.rgrid(In)^4,'DisplayName','N=c*1/r^4','linewidth',lw) xlabel('r [mm]') ylabel('n_e [m^{-3}]') I=find(psi>0); if (length(I)>1) I=[I(1)-2; I(1)-1; I; I(end)+1; I(end)+2]; else I=obj.nnr(1):length(psi); end rq=linspace(obj.rgrid(max(I(1),1)),obj.rgrid(I(end)),500); psiinterp=interp1(obj.rgrid(I),psi(I),rq,'pchip'); zeroindices=find(diff(psiinterp>=0),2); maxpsiinterp=max(psiinterp); plot(rq*1e3,maxn*psiinterp/abs(maxpsiinterp),'--','Displayname','normalized \zeta [a.u.]','linewidth',lw) ylim([0 inf]); drawnow ylimits=ylim; for i=1:length(zeroindices) border=plot([rq(zeroindices(i)) rq(zeroindices(i))]*1e3,[0 1./obj.rgrid(In-5)*r0*maxn],'--','linewidth',lw,'Color',[.7 .7 .7]); set(get(get(border,'Annotation'),'LegendInformation'),'IconDisplayStyle','off'); end legend xlim([0 0.02]*1e3) grid on %title(sprintf('Radial density profile at z=%1.2e[m]',obj.zgrid(zpos))) set(gca,'fontsize',12) obj.savegraph(f,sprintf('%sPsi',obj.name),[15 10]); end function f=displayrprofile(obj,t,zpos,init) %% plot the initial and final radial profile at the axial center of the simulation space % also plot the azimuthal fluid rotation frequency profile % t: time index considered % zpos: axial position index % init: initial time considered for comparison f=figure('Name', sprintf('%s Prof',obj.name)); if nargin < 3 || length(zpos)<1 zpos=floor(length(obj.zgrid)/2); end if nargin<4 init=false; end if(iscell(t)) t=cell2mat(t); end lw=1.5; if init tinit=t(1); t=t(2:end); end locdens=mean(obj.N(:,zpos,t),3); %inverse of radius Rinv=1./obj.rgrid; Rinv(isnan(Rinv))=0; %azimuthal velocity and azimuthal rotation frequency in m/s and %1/s vthet=mean(obj.fluidUTHET(:,zpos,t),3); omegare=(vthet.*Rinv); % plot the initial density if(init) plot(obj.rgrid,obj.N(:,zpos,tinit),'bx-','DisplayName',sprintf('t=%1.2f[ns]',obj.t2d(tinit)*1e9),'linewidth',lw) end hold on %plot the time averaged current density plot(obj.rgrid,locdens,'rx-','DisplayName',sprintf('t=[%1.2f-%1.2f] [ns] averaged',obj.t2d(t(1))*1e9,obj.t2d(t(end))*1e9),'linewidth',lw) xlabel('r [m]') ylabel('n_e [m^{-3}]') legend('location','Northwest') % limit the axis to the simulation domain if obj.conformgeom xlim([obj.rgrid(1) obj.rgrid(sum(obj.nnr(1:2)))]) else xlim([obj.rgrid(1) obj.rgrid(end)]) end grid on ylimits=ylim(); % plot the metallic walls for a constant radius coaxial % configuration if obj.conformgeom plot(obj.rgrid(1)*[1 1],ylimits,'k--') plot(obj.rgrid(end)*[1 1],ylimits,'k--') else plot(obj.r_a*[1 1],ylimits,'k--') if obj.walltype==0 plot(obj.r_b*[1 1],ylimits,'k--') elseif obj.walltype==1 rmax=obj.r_0-obj.r_r*sqrt(1-(obj.zgrid(zpos)-obj.z_0)^2/obj.z_r^2); plot(rmax*[1 1],ylimits,'k--') end end yyaxis right % plot the azimuthal fluid rotation frequency profile plot(obj.rgrid,omegare,'DisplayName',sprintf('<\\omega_{re}> t=[%1.2f-%1.2f] [ns] averaged',obj.t2d(t(1))*1e9,obj.t2d(t(end))*1e9),'linewidth',lw) ylabel('\omega_{re} [1/s]') title(sprintf('Radial density profile at z=%1.2e[m]',obj.zgrid(zpos))) obj.savegraph(f,sprintf('%srProf',obj.name),[15 10]); end function displayenergy(obj) %% Plot the time evolution of the system energy and number of simulated macro particles tmin=2; tmax=length(obj.ekin); f=figure('Name', sprintf('%s Energy',obj.name)); subplot(1,2,1) semilogy(obj.t0d(tmin:tmax)*1e9,obj.ekin(tmin:tmax),'-',... obj.t0d(tmin:tmax)*1e9,obj.epot(tmin:tmax),':',... obj.t0d(tmin:tmax)*1e9,obj.etot(tmin:tmax),'-.', ... 'linewidth',4) obj.t0d(tmin:tmax)*1e9,obj.etot0(tmin:tmax),'--','linewidth',4) %obj.t0d(tmin:tmax),obj.ekin(tmin:tmax)-obj.epot(tmin:tmax),'--', legend('E_{kin}', 'E_{pot}', 'E_{tot}','E_{ref}','location','east') xlabel('Time [ns]') ylabel('Energies [J]') grid on xlim([obj.t0d(tmin) obj.t0d(tmax)]*1e9); xlimits=xlim(); - ylim([1e-7 1e-3]) + %ylim([1e-7 1e-3]) set(gca,'fontsize',14) subplot(1,2,2) try semilogy(obj.t0d(tmin:tmax)*1e9,abs(obj.eerr(tmin:tmax)./obj.etot0(tmin:tmax)),'-','linewidth',1.5) catch semilogy(obj.t0d(tmin:tmax)*1e9,abs(obj.eerr(tmin:tmax)/obj.etot(2)),'-','linewidth',1.5) end hold on xlabel('Time [ns]') ylabel('Total energy relative error [-]') xlim(xlimits) grid on - % try - % yyaxis right - % plot(obj.t0d(tmin:tmax),abs(obj.npart(tmin:tmax)./obj.npart(1)*100),'d--') - % ylabel('Nparts %') - % %ylim([0 110]) - % catch - % end +% try +% yyaxis right +% plot(obj.t0d(tmin:tmax),abs(obj.npart(tmin:tmax)./obj.npart(1)*100),'d--') +% ylabel('Nparts %') +% %ylim([0 110]) +% catch +% end ylimits=ylim; for i=1:length(obj.restarttimes) - plot(obj.restarttimes(i)*[1 1],ylimits,'k--') + plot(obj.restarttimes(i)*[1 1]*1e9,ylimits,'k--') end set(gca,'fontsize',14) Position=f.Position; Position(3)=1.5*Position(3); f.Position=Position; obj.savegraph(f,sprintf('%s/%sEnergy',obj.folder,obj.name)); end function out=displaycharge(obj,scalet,f,linelegend) %% Plot the time evolution of the system charge of electrons % f: figure handle if you want to stack several such curves % on the same figure % linelegend: legend for this charge evolution tmin=1; tmax=length(obj.ekin); if nargin<2 scalet =false; end if nargin<3 f=figure('Name', sprintf('%s Charge',obj.name)); end if nargin<4 linelegend=''; end ax=f.CurrentAxes; if isempty(ax) ax=axes(f); end if scalet if obj.neutcol.present vexb0=(obj.Ez(:,:,1).*obj.Br'-obj.Er(:,:,1).*obj.Bz')./(obj.B'.^2); vexb0(obj.geomweight(:,:,1)<=0)=0; E=0.5*obj.msim/obj.weight*mean(abs(vexb0(:)))^2/obj.qe; taucol=1/(obj.neutcol.neutdens*mean(abs(vexb0(:)))*(obj.sigio(E)+obj.sigmela(E)+obj.sigmio(E))); try Sio_S=1e17*(obj.neutcol.neutdens*mean(abs(vexb0(:)))*obj.sigio(E))/(obj.maxwellsrce.frequency*obj.weight/(pi*(obj.maxwellsrce.rlim(2)^2-obj.maxwellsrce.rlim(1)^2)*diff(obj.maxwellsrce.zlim))) catch end tlabel='t/\tau_d [-]'; else taucol=2*pi/obj.omece; tlabel='t/\tau_ce [-]'; end else taucol=1e-9; tlabel='t [ns]'; end try plot(ax,obj.t0d(tmin:tmax)/taucol,abs(obj.npart(tmin:tmax)*obj.qsim),'linewidth',2,'displayname',linelegend) hold on ylabel(ax,'Total charge [C]') xlabel(ax,tlabel) grid on if(nargin>2) legend end set(ax,'fontsize',12) catch end if nargin < 2 obj.savegraph(f,sprintf('%s/%scharge',obj.folder,obj.name)); end out.time = obj.t0d(tmin:tmax)/taucol; out.charge = abs(obj.npart(tmin:tmax)*obj.qsim); end function displaySimParticles(obj) %% Plot the time evolution of the number of simulated markers in the main specie f=figure('Name', sprintf('%s Trapped particles',obj.name)); plot(obj.t0d,obj.npart,'linewidth',1.5) xlabel('t [s]') ylabel('N particles') set(gca,'fontsize',12) obj.savegraph(f,sprintf('%s/%sntrapped',obj.folder,obj.name),[10 12]); end function displayLarmorRad(obj,time2d) if nargin<2 time2d=length(obj.t2d); end % Plot the larmor radius for created particles with low energy % the larmor radius is calculated by considering that the % initial perpendicular velocity \approx the ExB velocity if time2d>0 Er=obj.Er(:,:,time2d); Ez=obj.Ez(:,:,time2d); else Er=obj.Erxt(:,:,1); Ez=obj.Ezxt(:,:,1); end rl=abs(obj.me/obj.qe*(-Er.*obj.Bz'+Ez.*obj.Br')./(obj.B.^3)'); figure rl(obj.geomweight(:,:,1)<0)=0; contourf(obj.zgrid,obj.rgrid,rl) hold on contour(obj.zgrid,obj.rgrid,obj.geomweight(:,:,1),[0 0],'r-','linewidth',3) if time2d>0 n=obj.N(:,:,time2d); maxN=max(n (:)); n=n/maxN*mean(rl(:)); contour(obj.zgrid,obj.rgrid,n,linspace(0,1,6)*mean(rl(:)),'r:','linewidth',3) end c=colorbar; xlabel('z [m]') ylabel('r [m]') c.Label.String='r_L [m]'; end function displayHP(obj,tstart) % Plot the histogramm of the total energy and canonical angular momentum at time tstart and % end time of the simulation over the full simulation space for the main specie if(iscell(tstart)) tstart=cell2mat(tstart); end if(obj.species(1).R.nt>=2) tstart=obj.species(1).R.nt; f=figure('Name', sprintf('%s HP',obj.name)); legtext=sprintf("t=%2.1f - %2.1f [ns]",obj.tpart(tstart)*1e9,obj.tpart(end)*1e9); subplot(1,2,1) partsmax=min(obj.nbparts(end),obj.species(1).R.nparts); Hloc=H(obj,{1:obj.nbparts(1),1,false}); h1=histogram(Hloc,20,'BinLimits',[min(Hloc(:)) max(Hloc(:))],'DisplayName',sprintf("t=%2.3d [ns]",obj.tpart(1)*1e9)); hold on Hloc=H(obj,{1:partsmax,obj.species(1).R.nt,false}); %,'Binwidth',h1.BinWidth h1=histogram(Hloc,20,'BinLimits',[min(Hloc(:)) max(Hloc(:))],'DisplayName',legtext); ylabel('counts') xlabel('H [J]') legend subplot(1,2,2) Ploc=P(obj,{1:obj.nbparts(1),1,false}); h2=histogram(Ploc,50,'BinLimits',[min(Ploc(:)) max(Ploc(:))],'DisplayName',sprintf("t=%2.3d [ns]",obj.tpart(1)*1e9)); hold on Ploc=P(obj,{1:partsmax,obj.species(1).R.nt,false}); histogram(Ploc,50,'BinLimits',[min(Ploc(:)) max(Ploc(:))],'DisplayName',legtext); ylabel('counts') xlabel('P [kg\cdotm^2\cdots^{-1}]') %clear P %clear H legend %xlim([0.95*h2.BinLimits(1) 1.05*h2.BinLimits(2)]) obj.savegraph(f,sprintf('%s/%sParts_HP',obj.folder,obj.name)); end end function displayaveragetemp(obj) % Computes and show the particles average temperature as a function of time f=figure('Name',sprintf('%s potinn=%f part temperature',obj.name,obj.potinn)); vr2=obj.species(1).VR(:,:,false); vr2=mean(vr2.^2,1)-mean(vr2,1).^2; vz2=obj.species(1).VZ(:,:,false); vz2=mean(vz2.^2,1)-mean(vz2,1).^2; vthet2=obj.species(1).VTHET(:,:,false); vthet2=mean(vthet2.^2,1)-mean(vthet2,1).^2; plot(obj.tpart,0.5*obj.me*vr2/obj.qe,'displayname','T_r') hold on plot(obj.tpart,0.5*obj.me*vz2/obj.qe,'displayname','T_z') plot(obj.tpart,0.5*obj.me*vthet2/obj.qe,'displayname','T_{thet}') xlabel('time [s]') ylabel('T [eV]') title(sprintf('\\phi_a=%.1f kV \\phi_b=%.1f kV R=%.1f',obj.potinn/1e3,obj.potout/1e3,obj.Rcurv)) legend grid obj.savegraph(f,sprintf('%s/%s_partstemp',obj.folder,obj.name)); end function displayCurrentsevol(obj,timesteps,species_id) % Computes and display the time evolution of the outgoing currents on each domain boundary % at timesteps timesteps P=obj.neutcol.neutdens*obj.kb*300/100; if nargin<2 timesteps=1:length(obj.t2d); end if nargin<3 species_id=1; end if species_id ==1 currents=obj.OutCurrents(timesteps); currents = currents/P; else currents=obj.OutCurrents_species(timesteps); currents = currents/P; end f=figure('Name',sprintf('%s Currents',obj.name)); if(obj.B(1,1)>obj.B(end,1)) lname='HFS'; rname='LFS'; else lname='LFS'; rname='HFS'; end plot(obj.t2d(timesteps),currents(1,:),'Displayname',lname,'linewidth',1.8); hold on plot(obj.t2d(timesteps),currents(2,:),'Displayname',rname,'linewidth',1.8); plot(obj.t2d(timesteps),currents(3,:),'Displayname','outer cylinder','linewidth',1.8); plot(obj.t2d(timesteps),currents(4,:),'Displayname','inner cylinder','linewidth',1.8); if size(currents,1)>=5 plot(obj.t2d(timesteps),currents(5,:),'Displayname','ellipse','linewidth',1.8); end legend('location','Northeast') xlabel('time [s]') ylabel('I [A/mbar]') grid on set(gca,'fontsize',12) title(sprintf('\\phi_b-\\phi_a=%.2g kV, R=%.1f',(obj.potout-obj.potinn)/1e3,obj.Rcurv)) obj.savegraph(f,sprintf('%s/%s_outCurrents',obj.folder,obj.name),[16 12]); end function displayChargeLossevol(obj,timesteps,toptitle,scalet,dens) % Computes and display the time evolution of the outgoing currents on each domain boundary % at time obj.t2d(timesteps) %scalet=true scales the time by the ellastic collision %frequency %dens = true plot the time evolution of the maximum electron %density in the simulation domain otherwise plot the total %number of electrons in the domain if nargin<2 timesteps=1:length(obj.t2d); end if nargin<4 scalet=true; end if nargin <5 dens=true; end if scalet if obj.neutcol.present vexb0=(obj.Ez(:,:,1).*obj.Br'-obj.Er(:,:,1).*obj.Bz')./(obj.B'.^2); vexb0(obj.geomweight(:,:,1)<=0)=0; E=0.5*obj.msim/obj.weight*mean(abs(vexb0(:)))^2/obj.qe; taucol=1/(obj.neutcol.neutdens*mean(abs(vexb0(:)))*(obj.sigio(E)+obj.sigmela(E)+obj.sigmio(E))); try Sio_S=1e17*(obj.neutcol.neutdens*mean(abs(vexb0(:)))*obj.sigio(E))/(obj.maxwellsrce.frequency*obj.weight/(pi*(obj.maxwellsrce.rlim(2)^2-obj.maxwellsrce.rlim(1)^2)*diff(obj.maxwellsrce.zlim))) catch end tlabel='t/\tau_d [-]'; else taucol=2*pi/obj.omece; tlabel='t/\tau_ce [-]'; end else taucol=1e-9; tlabel='t [ns]'; end if dens N=obj.N(:,:,timesteps); geomw=obj.geomweight(:,:,1); geomw(geomw<0)=0; geomw(geomw>0)=1; N=N.*geomw; nmax=squeeze(max(max(N,[],1),[],2)); tn=(obj.t2d(timesteps)); nlabel='n_{e,max} [m^{-3}]'; ndlabel='n_{e,max}'; else t0dst=find(obj.t0d>=obj.t2d(timesteps(1)),1,'first'); t0dlst=find(obj.t0d<=obj.t2d(timesteps(end)),1,'last'); tn=obj.t0d(t0dst:t0dlst); nmax=obj.npart(t0dst:t0dlst)*obj.weight; nlabel='Nb e^-'; ndlabel='Nb e^-'; end [currents,pos]=obj.OutCurrents(timesteps); P=obj.neutcol.neutdens*obj.kb*300/100;% pressure at room temperature in mbar currents=currents/P; f=figure('Name',sprintf('%s Charges',obj.name)); % Plot the evolution of nb of particles yyaxis right p=plot(tn/taucol,nmax,'b-.','linewidth',1.8,'Displayname',ndlabel); ylabel(nlabel) ax=gca; ax.YAxis(2).Color=p.Color; ylim([0 inf]) if(obj.B(1,1)>obj.B(end,1)) lname='HFS'; rname='LFS'; else lname='LFS'; rname='HFS'; end yyaxis left mincurr=max(currents(:))*5e-3; if (max(currents(1,:)>mincurr)) plot(obj.t2d(timesteps)/taucol,currents(1,:),'r:','Displayname',lname,'linewidth',1.8); end hold on if (max(currents(2,:)>mincurr)) plot(obj.t2d(timesteps)/taucol,currents(2,:),'r--','Displayname',rname,'linewidth',1.8); end if (max(currents(3,:)>mincurr)) plot(obj.t2d(timesteps)/taucol,currents(3,:),'r-','Displayname','outer cylinder','linewidth',1.8); end if (max(currents(4,:)>mincurr)) plot(obj.t2d(timesteps)/taucol,currents(4,:),'Displayname','inner cylinder','linewidth',1.8); end if (size(currents,1)>=5 && max(currents(5,:)>mincurr)) plot(obj.t2d(timesteps)/taucol,currents(5,:),'r-','Displayname','ellipse','linewidth',1.8); end xlabel(tlabel) ylabel('I/p_n [A/mbar]') grid on set(gca,'fontsize',12) ax.YAxis(1).Color='red'; legend('Orientation','horizontal','location','south','numcolumns',3) if nargin <3 title(sprintf('\\phi_b-\\phi_a=%.2g kV, B=%f T',(obj.potout-obj.potinn)/1e3,max(obj.B(:)))) elseif ~isempty(toptitle) title(toptitle) end obj.savegraph(f,sprintf('%s/%s_ChargeEvol%i%i',obj.folder,obj.name,scalet,dens),[16 14]); end function out = displaytotcurrevol(obj,timesteps,species_id,all_cur_id, toptitle,scalet,dens,subdiv,nmean) % Computes and display the time evolution of the outgoing % currents at time obj.t2d(timesteps) %scalet=true scales the time by the ellastic collision %frequency %dens = true plot the time evolution of the maximum electron %density in the simulation domain otherwise plot the total %number of electrons in the domain % also plot in a subplot the color coded boundary corresponding % to each current if nargin<2 timesteps=1:length(obj.t2d); end if nargin<3 species_id =1; end if nargin<4 all_cur_id = 0; end if nargin<5 toptitle=""; end if nargin<6 scalet=true; end if nargin <7 dens=true; end if nargin<8 subdiv=1; end if nargin<9 nmean=1; end if scalet if obj.neutcol.present vexb0=(obj.Ez(:,:,1).*obj.Br'-obj.Er(:,:,1).*obj.Bz')./(obj.B'.^2); vexb0(obj.geomweight(:,:,1)<=0)=0; E=0.5*obj.msim/obj.weight*mean(abs(vexb0(:)))^2/obj.qe; taucol=1/(obj.neutcol.neutdens*mean(abs(vexb0(:)))*(obj.sigio(E)+obj.sigmela(E)+obj.sigmio(E))); try Sio_S=1e17*(obj.neutcol.neutdens*mean(abs(vexb0(:)))*obj.sigio(E))/(obj.maxwellsrce.frequency*obj.weight/(pi*(obj.maxwellsrce.rlim(2)^2-obj.maxwellsrce.rlim(1)^2)*diff(obj.maxwellsrce.zlim))) catch end tlabel='t/\tau_d [-]'; else taucol=2*pi/obj.omece; tlabel='t/\tau_ce [-]'; end else taucol=1e-9; tlabel='t [ns]'; end if dens if species_id==1 N=obj.N(:,:,timesteps); else N=obj.species_moments.N(:,:,timesteps); end geomw=obj.geomweight(:,:,1); geomw(geomw<0)=0; geomw(geomw>0)=1; N=N.*geomw; %[~,idl]=max(N(:,:,end),[],'all','linear'); %[ir,iz]=ind2sub(size(geomw),idl); %nmax=squeeze(max(max(N,[],1),[],2)); tn=(obj.t2d(timesteps)); nmax=zeros(2,length(tn)); nrhalf= floor(0.5*length(obj.rgrid));%find(obj.rgrid>0.07); nmax(1,:)=squeeze(max(max(N(1:nrhalf,:,:),[],1),[],2)); nmax(2,:)=squeeze(max(max(N(nrhalf+1:end,:,:),[],1),[],2)); nlabel='n_{e,max} [m^{-3}]'; ndlabel='n_{e,max}'; else t0dst=find(obj.t0d>=obj.t2d(timesteps(1)),1,'first'); t0dlst=find(obj.t0d<=obj.t2d(timesteps(end)),1,'last'); tn=obj.t0d(t0dst:t0dlst); nmax=obj.npart(t0dst:t0dlst)*obj.weight; nlabel='Nb e^-'; ndlabel='Nb e^-'; end if species_id ==1 [currents,pos]=obj.OutCurrents(timesteps,subdiv); P=obj.neutcol.neutdens*obj.kb*300/100;% pressure at room temperature in mbar currents=currents/P; else % for ionic currents [currents,pos]=obj.OutCurrents_species(timesteps,subdiv); P=obj.neutcol.neutdens*obj.kb*300/100;% pressure at room temperature in mbar currents=currents/P; end % hack to sum ionic + electronic current if all_cur_id==1 [el_curr,pos]=obj.OutCurrents(timesteps,subdiv); P=obj.neutcol.neutdens*obj.kb*300/100;% pressure at room temperature in mbar out.elec_currents=el_curr/P; [ion_curr,pos]=obj.OutCurrents_species(timesteps,subdiv); P=obj.neutcol.neutdens*obj.kb*300/100;% pressure at room temperature in mbar out.ion_currents=ion_curr/P; totCurr_el = sum(out.elec_currents(1:end-1,:),1); totCurr_ion = sum(out.ion_currents,1); TotalCurrent = totCurr_el+totCurr_ion; out.temps = tn/taucol; end % plot f=figure('Name',sprintf('%s Charges',obj.name)); tiledlayout(2,1) nexttile % Plot the evolution of nb of particles yyaxis right for i=1:size(nmax,1) p=plot(tn/taucol,nmax(i,:),'b','linewidth',2.2,'Displayname',sprintf('%s, %d',ndlabel,i)); hold on end ylabel(nlabel) axl=gca; axl.YAxis(2).Color=p.Color; ylim([0 inf]) if(obj.B(1,1)>obj.B(end,1)) lname='HFS'; rname='LFS'; else lname='LFS'; rname='HFS'; end yyaxis( 'left'); map=colormap(lines); set(axl,'linestyleorder',{'-',':','--','*','+'},... 'ColorOrder',map(2:7,:), 'NextPlot','replacechildren') p(1)=plot(axl,obj.t2d(timesteps)/taucol,movmean(currents(1,:),nmean),'Displayname',lname,'linewidth',1.8); hold on p(2)=plot(axl,obj.t2d(timesteps)/taucol,movmean(currents(2,:),nmean),'Displayname',rname,'linewidth',1.8); % Plot the currents for i=3:size(currents,1) p(i)=plot(axl,obj.t2d(timesteps)/taucol,movmean(currents(i,:),nmean),'Displayname',sprintf('border %i',i-2),'linewidth',1.8); end if all_cur_id ==0 plot(axl,obj.t2d(timesteps)/taucol,movmean(sum(currents(:,:),1,'omitnan'),nmean),'k-','Displayname','total','linewidth',1.8); else % plot(axl,obj.t2d(timesteps)/taucol,movmean(sum(out.elec_currents + out.ion_currents,1,'omitnan'),nmean),'k-','Displayname','total','linewidth',1.8); plot(axl,obj.t2d(timesteps)/taucol,movmean(TotalCurrent,nmean),'k-','Displayname','total','linewidth',1.8); hold on p(size(currents,1))=plot(axl,obj.t2d(timesteps)/taucol,movmean(out.ion_currents(end,:),nmean),'Displayname',sprintf('border %i',i-2),'linewidth',1.8); end hold on xlabel(tlabel) ylabel('I/p_n [A/mbar]') grid on set(gca,'fontsize',12) ax.YAxis(1).Color='black'; %legend('Orientation','horizontal','location','north','numcolumns',3) if ~isempty(toptitle) title(toptitle) end ax2=nexttile; geomw=obj.geomweight(:,:,1); geomw(geomw<=0)=0; geomw(geomw>0)=NaN; [c1,hContour]=contourf(ax2,obj.zgrid*1000,obj.rgrid*1000,geomw, [0 0]); hold on drawnow; grid on; for i=1:length(pos) plot(ax2,pos{i}(1,:)*1000,pos{i}(2,:)*1000,'linestyle',p(i+2).LineStyle,... 'color',p(i+2).Color,'marker',p(i+2).Marker,... 'displayname',sprintf('border %i',i),'linewidth',1.8) hold on end title('Domain') plot(ax2,ones(size(obj.rgrid))*obj.zgrid(1)*1000,obj.rgrid*1000,'linestyle',p(1).LineStyle,... 'color',p(1).Color,'marker',p(1).Marker,... 'displayname',lname,'linewidth',1.8) plot(ax2,ones(size(obj.rgrid))*obj.zgrid(end)*1000,obj.rgrid*1000,'linestyle',p(2).LineStyle,... 'color',p(2).Color,'marker',p(2).Marker,... 'displayname',rname,'linewidth',1.8) xlabel('z [mm]') ylabel('r [mm]') grid on set(gca,'fontsize',12) hFills=hContour.FacePrims; [hFills.ColorType] = deal('truecoloralpha'); % default = 'truecolor' try hFills(1).ColorData = uint8([150;150;150;255]); for idx = 2 : numel(hFills) hFills(idx).ColorData(4) = 0; % default=255 end catch end %legend('Orientation','horizontal','location','north','numcolumns',4) fprintf('mean total current: %f [A/mbar]\n',mean(sum(currents(:,max(1,size(currents,2)-30):end),1,'omitnan'))); %if nargin <3 % sgtitle(sprintf('\\phi_b-\\phi_a=%.2g kV, B=%f T',(obj.potout-obj.potinn)*obj.phinorm/1e3,mean(obj.B(:)))) %elseif ~isempty(toptitle) % sgtitle(toptitle) %end if length(subdiv)>1 obj.savegraph(f,sprintf('%s/%s_totIEvol%i%i_div',obj.folder,obj.name,scalet,dens),[16 14]); else obj.savegraph(f,sprintf('%s/%s_totIEvol%i%i',obj.folder,obj.name,scalet,dens),[16 14]); end end % % function displaytotcurrevol(obj,timesteps,species_id,all_cur_id,toptitle,scalet,dens,subdiv,nmean) % % Computes and display the time evolution of the outgoing % % currents at time obj.t2d(timesteps) % %scalet=true scales the time by the ellastic collision % %frequency % %dens = true plot the time evolution of the maximum electron % %density in the simulation domain otherwise plot the total % %number of electrons in the domain % % also plot in a subplot the color coded boundary corresponding % % to each current % if nargin<2 % timesteps=1:length(obj.t2d); % end % if nargin<3 % species_id =1; % end % if nargin<4 % all_cur_id=0; % end % if nargin<5 % toptitle=""; % end % if nargin<6 % scalet=true; % end % if nargin <7 % dens=true; % end % if nargin<8 % subdiv=1; % end % if nargin<9 % nmean=1; % end % % if scalet % if obj.neutcol.present % vexb0=(obj.Ez(:,:,1).*obj.Br'-obj.Er(:,:,1).*obj.Bz')./(obj.B'.^2); % vexb0(obj.geomweight(:,:,1)<=0)=0; % E=0.5*obj.msim/obj.weight*mean(abs(vexb0(:)))^2/obj.qe; % taucol=1/(obj.neutcol.neutdens*mean(abs(vexb0(:)))*(obj.sigio(E)+obj.sigmela(E)+obj.sigmio(E))); % try % Sio_S=1e17*(obj.neutcol.neutdens*mean(abs(vexb0(:)))*obj.sigio(E))/(obj.maxwellsrce.frequency*obj.weight/(pi*(obj.maxwellsrce.rlim(2)^2-obj.maxwellsrce.rlim(1)^2)*diff(obj.maxwellsrce.zlim))) % catch % end % tlabel='t/\tau_d [-]'; % else % taucol=2*pi/obj.omece; % tlabel='t/\tau_ce [-]'; % end % else % taucol=1e-9; % tlabel='t [ns]'; % end % % if dens % if species_id==1 % N=obj.N(:,:,timesteps); % else % N=obj.species_moments.N(:,:,timesteps); % end % geomw=obj.geomweight(:,:,1); % geomw(geomw<0)=0; % geomw(geomw>0)=1; % N=N.*geomw; % %[~,idl]=max(N(:,:,end),[],'all','linear'); % %[ir,iz]=ind2sub(size(geomw),idl); % %nmax=squeeze(max(max(N,[],1),[],2)); % tn=(obj.t2d(timesteps)); % nmax=zeros(2,length(tn)); % nrhalf= floor(0.5*length(obj.rgrid));%find(obj.rgrid>0.07); % % nmax(1,:)=squeeze(max(max(N(1:nrhalf,:,:),[],1),[],2)); % nmax(2,:)=squeeze(max(max(N(nrhalf+1:end,:,:),[],1),[],2)); % % % nlabel='n_{e,max} [m^{-3}]'; % ndlabel='n_{e,max}'; % else % t0dst=find(obj.t0d>=obj.t2d(timesteps(1)),1,'first'); % t0dlst=find(obj.t0d<=obj.t2d(timesteps(end)),1,'last'); % tn=obj.t0d(t0dst:t0dlst); % nmax=obj.npart(t0dst:t0dlst)*obj.weight; % nlabel='Nb e^-'; % ndlabel='Nb e^-'; % end % % if all_cur_id == 0 % if species_id ==1 % [currents,pos]=obj.OutCurrents(timesteps,subdiv); % P=obj.neutcol.neutdens*obj.kb*300/100;% pressure at room temperature in mbar % currents=currents/P; % else % for ionic currents % [currents,pos]=obj.OutCurrents_species(timesteps,subdiv); % P=obj.neutcol.neutdens*obj.kb*300/100;% pressure at room temperature in mbar % currents=currents/P; % end % else % [currents_el,pos]=obj.OutCurrents(timesteps,subdiv); % P=obj.neutcol.neutdens*obj.kb*300/100;% pressure at room temperature in mbar % currents_el=currents_el/P; % [currents_ion,pos]=obj.OutCurrents_species(timesteps,subdiv); % currents_ion = current_ion/P; % end % % f=figure('Name',sprintf('%s Charges',obj.name)); % tiledlayout(2,1) % nexttile % % Plot the evolution of nb of particles % yyaxis right % for i=1:size(nmax,1) % p=plot(tn/taucol,nmax(i,:),'b','linewidth',2.2,'Displayname',sprintf('%s, %d',ndlabel,i)); % hold on % end % ylabel(nlabel) % axl=gca; % axl.YAxis(2).Color=p.Color; % ylim([0 inf]) % % if(obj.B(1,1)>obj.B(end,1)) % lname='HFS'; % rname='LFS'; % else % lname='LFS'; % rname='HFS'; % end % % yyaxis( 'left'); % map=colormap(lines); % set(axl,'linestyleorder',{'-',':','--','*','+'},... % 'ColorOrder',map(2:7,:), 'NextPlot','replacechildren') % p(1)=plot(axl,obj.t2d(timesteps)/taucol,movmean(currents(1,:),nmean),'Displayname',lname,'linewidth',1.8); % hold on % p(2)=plot(axl,obj.t2d(timesteps)/taucol,movmean(currents(2,:),nmean),'Displayname',rname,'linewidth',1.8); % % Plot the currents % for i=3:size(currents,1) % p(i)=plot(axl,obj.t2d(timesteps)/taucol,movmean(currents(i,:),nmean),'Displayname',sprintf('border %i',i-2),'linewidth',1.8); % end % plot(axl,obj.t2d(timesteps)/taucol,movmean(sum(currents(:,:),1,'omitnan'),nmean),'k-','Displayname','total','linewidth',1.8); % hold on % xlabel(tlabel) % ylabel('I/p_n [A/mbar]') % grid on % set(gca,'fontsize',12) % ax.YAxis(1).Color='black'; % % %legend('Orientation','horizontal','location','north','numcolumns',3) % % if ~isempty(toptitle) % title(toptitle) % end % % ax2=nexttile; % geomw=obj.geomweight(:,:,1); % geomw(geomw<=0)=0; % geomw(geomw>0)=NaN; % [c1,hContour]=contourf(ax2,obj.zgrid*1000,obj.rgrid*1000,geomw, [0 0]); % hold on % drawnow; % grid on; % % for i=1:length(pos) % plot(ax2,pos{i}(1,:)*1000,pos{i}(2,:)*1000,'linestyle',p(i+2).LineStyle,... % 'color',p(i+2).Color,'marker',p(i+2).Marker,... % 'displayname',sprintf('border %i',i),'linewidth',1.8) % hold on % end % title('Domain') % plot(ax2,ones(size(obj.rgrid))*obj.zgrid(1)*1000,obj.rgrid*1000,'linestyle',p(1).LineStyle,... % 'color',p(1).Color,'marker',p(1).Marker,... % 'displayname',lname,'linewidth',1.8) % plot(ax2,ones(size(obj.rgrid))*obj.zgrid(end)*1000,obj.rgrid*1000,'linestyle',p(2).LineStyle,... % 'color',p(2).Color,'marker',p(2).Marker,... % 'displayname',rname,'linewidth',1.8) % xlabel('z [mm]') % ylabel('r [mm]') % grid on % set(gca,'fontsize',12) % hFills=hContour.FacePrims; % [hFills.ColorType] = deal('truecoloralpha'); % default = 'truecolor' % try % hFills(1).ColorData = uint8([150;150;150;255]); % for idx = 2 : numel(hFills) % hFills(idx).ColorData(4) = 0; % default=255 % end % catch % end % %legend('Orientation','horizontal','location','north','numcolumns',4) % % % fprintf('mean total current: %f [A/mbar]\n',mean(sum(currents(:,max(1,size(currents,2)-30):end),1,'omitnan'))); % % %if nargin <3 % % sgtitle(sprintf('\\phi_b-\\phi_a=%.2g kV, B=%f T',(obj.potout-obj.potinn)*obj.phinorm/1e3,mean(obj.B(:)))) % %elseif ~isempty(toptitle) % % sgtitle(toptitle) % %end % if length(subdiv)>1 % obj.savegraph(f,sprintf('%s/%s_totIEvol%i%i_div',obj.folder,obj.name,scalet,dens),[16 14]); % else % obj.savegraph(f,sprintf('%s/%s_totIEvol%i%i',obj.folder,obj.name,scalet,dens),[16 14]); % end % % end function display1Dpotentialwell(obj,timestep,rpos) % Display the potential well along the magentic field line % passing by rgrid(rpos) at the center of the simulation space if iscell(timestep) timestep=cell2mat(timestep); end f=figure('Name',sprintf('%s 1D Potential well',obj.name)); model=obj.potentialwellmodel(timestep); z=model.z; r=model.r; Pot=model.pot; rathet=model.rathet; if (mod(rpos, 1) ~= 0) [~,rpos]=min(abs(obj.rgrid-rpos)); end crpos=obj.rgrid(rpos); id=find(timestep==0); timestep(id)=[]; n=obj.N(:,:,timestep); if(~isempty(timestep==0)) N0=zeros(obj.N.nr+1,obj.N.nz+1); n=cat(3,n(:,:,1:id-1),N0,n(:,:,id:end)); end n=mean(n,3); linepot=zeros(length(obj.zgrid),length(timestep)); rathetpos=obj.rAthet(rpos,ceil(length(obj.zgrid)/2)); F=scatteredInterpolant(z',rathet',Pot(:,1)); for i=1:length(timestep) F=scatteredInterpolant(z',rathet',Pot(:,i)); linepot(:,i)=F(obj.zgrid,rathetpos*ones(size(obj.zgrid))); %linepot(:,i)=griddata(z,rathet,pot(:,i),obj.zgrid,rathetpos); end linepot=mean(linepot,2); [Zinit,~]=meshgrid(obj.zgrid,obj.rAthet(:,1)); n=griddata(Zinit,obj.rAthet,n,obj.zgrid,rathetpos); plot(obj.zgrid,linepot) ylabel('Potentiel [eV]') xlabel('z [m]') xlim([obj.zgrid(1) obj.zgrid(end)]) hold(gca, 'on') yyaxis right plot(obj.zgrid,n) ylabel('n [m^{-3}]') if length(timestep)==1 title(sprintf('Potential well t=%1.2f [ns] r=%1.2f [mm]',obj.t2d(timestep)*1e9,1e3*crpos)) else title(sprintf('Potential well t=[%1.2f-%1.2f] [ns] r=%1.2f [mm]',obj.t2d(timestep(1))*1e9,obj.t2d(timestep(end))*1e9,1e3*crpos)) end obj.savegraph(f,sprintf('%s/%s_well1Dr_%d',obj.folder,obj.name,rpos)); end function displayVdistribRThetZ(obj,timestep, rpos, zpos) %displayVdistribRThetZ plot the velocity distribution function % in m/s %extracted from the markers at position window from rpos(1) %rpos(end) and zpos(1) to zpos(end) % and at time obj.tpart(timestep) %rpos and zpos are given as grid indices if(obj.species(1).R.nt>=2) if nargin<2 timesteppart=length(obj.tpart); timestep=timesteppart; else timesteppart=timestep; end if nargin<3 || isempty(rpos) rpos=1:length(obj.rgrid); rspan=[obj.rgrid(1) obj.rgrid(end)]; else r=[obj.rgrid(1);(obj.rgrid(1:end-1)+obj.rgrid(2:end))*0.5;obj.rgrid(end)]; rspan=[r(rpos) r(rpos+1)]; end if nargin<4 || isempty(zpos) zpos=1:length(obj.zgrid); zspan=[obj.zgrid(1) obj.zgrid(end)]; else z=[obj.zgrid(1);(obj.zgrid(1:end-1)+obj.zgrid(2:end))*0.5;obj.zgrid(end)]; zspan=[z(zpos) z(zpos+1)]; end nbp=min(obj.nbparts(1),obj.species(1).R.nparts); R=obj.species(1).R(1:nbp,1,false); Z=obj.species(1).Z(1:nbp,1,false); Vr=obj.species(1).VR(1:nbp,1,false); Vz=obj.species(1).VZ(1:nbp,1,false); Vthet=obj.species(1).VTHET(1:nbp,1,false); ids=R>=rspan(1) & R<=rspan(2) & Z>=zspan(1) & Z<=zspan(2); Vr=Vr(ids); Vz=Vz(ids); Vthet=Vthet(ids); vTr=std(Vr,1); vTz=std(Vz,1); vTthet=std(Vthet,1); nbp=min(obj.nbparts(timesteppart),obj.species(1).R.nparts); Rend=obj.species(1).R(1:nbp,timesteppart,false); Zend=obj.species(1).Z(1:nbp,timesteppart,false); Vrend=obj.species(1).VR(1:nbp,timesteppart,false); Vzend=obj.species(1).VZ(1:nbp,timesteppart,false); Vthetend=obj.species(1).VTHET(1:nbp,timesteppart,false); ids=Rend>=rspan(1) & Rend<=rspan(2) & Zend>=zspan(1) & Zend<=zspan(2); nbtot=sum(ids) Vrend=Vrend(ids); Vzend=Vzend(ids); Vthetend=Vthetend(ids); vTrend=std(Vrend,1); vTzend=std(Vzend,1); vTthetend=std(Vthetend,1); binwidth=abs(max(Vrend)-min(Vrend))/sqrt(length(Vrend)); f=figure('Name',sprintf("%s vrz distrib",obj.file)); [~,time2did]=min(abs(obj.t2d-obj.tpart(timestep))); subplot(1,4,1); obj.dispV(Vr,Vrend,'V_r [m/s]',[1,timesteppart]) [~,time2did]=min(abs(obj.t2d-obj.tpart(timestep))); if length(rpos)==1 vexb=-obj.Er(rpos,zpos,time2did)/obj.Bz(zpos,rpos)'; vexb=mean(vexb(:)); if ~isempty(obj.neutcol.ela_cross_sec) % plot the radial drift velocity as nu_dE_r/(B\Omega_c) vdr=obj.neutcol.neutdens*obj.sigmela(vexb^2*obj.me*0.5/obj.qe)*vexb*-obj.Er(rpos,zpos,time2did)... ./(obj.B(zpos,rpos)'.*obj.B(zpos,rpos)'*obj.qe/obj.me); vdr=mean(vdr(:)); ylimits=ylim; plot(vdr*[1 1],ylimits,'k--','displayname',sprintf('V_{d,pred}=%1.2g [m/s]',vdr)) end end subplot(1,4,2); obj.dispV(Vthet,Vthetend,'V\theta [m/s]',[1,timesteppart]) hold on drawnow ylimits=ylim; if length(rpos)==1 if ~isempty(obj.Erxt) vexbext=-obj.Erxt(rpos,zpos)/obj.Bz(zpos,rpos)'; plot(vexbext*[1 1],ylimits,'k--','displayname',sprintf('V_{ExB,ext}=%1.2g [m/s]',vexbext)) end plot(vexb*[1 1],ylimits,'k-.','displayname',sprintf('V_{ExB,tot}=%1.2g [m/s]',vexb)) end subplot(1,4,3); obj.dispV(Vz,Vzend,'Vz [m/s]',[1,timesteppart]) subplot(1,4,4); obj.dispV(sqrt(Vr.^2+(Vthet).^2+Vz.^2),sqrt(Vrend.^2+(Vthetend).^2+Vzend.^2),'Vtot [m/s]',[1,timesteppart],'maxwell') sgtitle(sprintf('t=%1.2e[ns] r=[%2.1f, %2.1f] [mm] z=[%2.1f, %2.1f] [mm]',obj.tpart(timestep)*1e9, rspan*1e3, zspan*1e3)) obj.savegraph(f,sprintf('%s/%sParts_V_RZ',obj.folder,obj.name),[25 14]); end end function displayEkin(obj,timestep, rpos, zpos) %displayEkin plot the kinetic energy distribution function in %eV %extracted from the markers at position window from rpos(1) %rpos(end) and zpos(1) to zpos(end) % and at time obj.tpart(timestep) %rpos and zpos are given as grid indices if(obj.species(1).R.nt>=2) if nargin<2 timesteppart=[1 length(obj.tpart)]; else if length(timestep)<2 timesteppart=[1 timestep]; else timesteppart=[timestep(1) timestep(end)]; end end if nargin<3 || isempty(rpos) rspan=[obj.rgrid(1) obj.rgrid(end)]; else r=[obj.rgrid(1);(obj.rgrid(1:end-1)+obj.rgrid(2:end))*0.5;obj.rgrid(end)]; rspan=[r(rpos) r(rpos+1)]; end if nargin<4 || isempty(zpos) zspan=[obj.zgrid(1) obj.zgrid(end)]; else z=[obj.zgrid(1);(obj.zgrid(1:end-1)+obj.zgrid(2:end))*0.5;obj.zgrid(end)]; zspan=[z(zpos) z(zpos+1)]; end nbp=min(obj.nbparts(timesteppart(1)),obj.species(1).R.nparts); R=obj.species(1).R(1:nbp,timesteppart(1),false); Z=obj.species(1).Z(1:nbp,timesteppart(1),false); Ekin=obj.Ekin(1:nbp,timesteppart(1),false); ids=R>=rspan(1) & R<=rspan(2) & Z>=zspan(1) & Z<=zspan(2); Ekin=Ekin(ids)/obj.qe; nbp=min(obj.nbparts(timesteppart(2)),obj.species(1).R.nparts); Rend=obj.species(1).R(1:nbp,timesteppart(2),false); Zend=obj.species(1).Z(1:nbp,timesteppart(2),false); Ekinend=obj.Ekin(1:nbp,timesteppart(2),false); ids=Rend>=rspan(1) & Rend<=rspan(2) & Zend>=zspan(1) & Zend<=zspan(2); Ekinend=Ekinend(ids)/obj.qe; f=figure('Name',sprintf("%s E_k distrib",obj.file)); obj.dispV(Ekin,Ekinend,'E_k',timesteppart,'maxwell') sgtitle(sprintf('dt=%1.2e[ns] r=[%2.1f, %2.1f] [mm] z=[%2.1f, %2.1f] [mm]',obj.dt*1e9, rspan*1e3, zspan*1e3)) obj.savegraph(f,sprintf('%s/%sParts_E_kin',obj.folder,obj.name)); end end function displayVdistribParPer(obj,timestep, rpos, zpos, gcs) %displayVdistribParPer plot the velocity distribution function % in m/s for the parallel and perpendicular velocity %extracted from the markers at position window from rpos(1) %rpos(end) and zpos(1) to zpos(end) % and at time obj.tpart(timestep) %rpos and zpos are given as grid indices % gcs define if you give the perpendicular velocity in the % guiding center frame or in the laboratory frame if(obj.species(1).R.nt>=2) if nargin<2 timesteppart=length(obj.tpart); else timesteppart=timestep; end if nargin<3 || isempty(rpos) rspan=[obj.rgrid(1) obj.rgrid(end)]; else r=[obj.rgrid(1);(obj.rgrid(1:end-1)+obj.rgrid(2:end))*0.5;obj.rgrid(end)]; rspan=[r(rpos) r(rpos+1)]; end if nargin<4 || isempty(zpos) zspan=[obj.zgrid(1) obj.zgrid(end)]; else z=[obj.zgrid(1);(obj.zgrid(1:end-1)+obj.zgrid(2:end))*0.5;obj.zgrid(end)]; zspan=[z(zpos) z(zpos+1)]; end if nargin<5 gcs=false; % define if we look in the guiding center system end nbp=min(obj.nbparts(1),obj.species(1).R.nparts); R=obj.species(1).R(1:nbp,1,false); Z=obj.species(1).Z(1:nbp,1,false); ids=R>=rspan(1) & R<=rspan(2) & Z>=zspan(1) & Z<=zspan(2); Vperp=obj.Vperp(1:nbp,1,false,gcs); Vpar=obj.Vpar(1:nbp,1,false); Vperp=Vperp(ids); Vpar=Vpar(ids); nbp=min(obj.nbparts(timesteppart),obj.species(1).R.nparts); R=obj.species(1).R(1:nbp,timesteppart,false); Z=obj.species(1).Z(1:nbp,timesteppart,false); ids=R>=rspan(1) & R<=rspan(2) & Z>=zspan(1) & Z<=zspan(2); Vperpend=obj.Vperp(1:nbp,timesteppart,false,gcs); Vparend=obj.Vpar(1:nbp,timesteppart,false); Vperpend=Vperpend(ids); Vparend=Vparend(ids); %binwidth=abs(max(Vparend)-min(Vparend))/500; f=figure('Name',sprintf("%s v parper distrib",obj.file)); subplot(1,2,1) if gcs lgd='v_\perp gcs [m/s]'; else lgd='v_\perp [m/s]'; end obj.dispV(Vperp,Vperpend,lgd,[1,timesteppart], 'maxwell') subplot(1,2,2) obj.dispV(abs(Vpar),abs(Vparend),'v_{par} [m/s]',[1,timesteppart],'None') sgtitle(sprintf('t=%1.2e[ns] r=[%2.1f, %2.1f] [mm] z=[%2.1f, %2.1f] [mm]',obj.tpart(timestep)*1e9, rspan*1e3, zspan*1e3)) obj.savegraph(f,sprintf('%s/%sParts_V_parper',obj.folder,obj.name)); if gcs obj.savegraph(f,sprintf('%s/%sParts_V_parpergcs',obj.folder,obj.name)); else obj.savegraph(f,sprintf('%s/%sParts_V_parper',obj.folder,obj.name)); end end end function display2DVdistrib(obj,timestep, rpos, zpos, gcs) %display2DVdistrib plot the velocity distribution function % in m/s for the parallel and perpendicular velocity % and for the radial azimuthal velocity % as a 2D contour plot the show the velocity phase space distribution %extracted from the markers at position window from rpos(1) %rpos(end) and zpos(1) to zpos(end) % and at time obj.tpart(timestep) %rpos and zpos are given as grid indices % gcs define if you give the perpendicular velocity in the % guiding center frame or in the laboratory frame if(obj.species(1).R.nt>=2) if nargin<2 timesteppart=length(obj.tpart); else timesteppart=timestep; end if nargin<3 || isempty(rpos) rspan=[obj.rgrid(1) obj.rgrid(end)]; else r=[obj.rgrid(1);(obj.rgrid(1:end-1)+obj.rgrid(2:end))*0.5;obj.rgrid(end)]; rspan=[r(rpos(1)) r(rpos(end)+1)]; end if nargin<4 || isempty(zpos) zspan=[obj.zgrid(1) obj.zgrid(end)]; else z=[obj.zgrid(1);(obj.zgrid(1:end-1)+obj.zgrid(2:end))*0.5;obj.zgrid(end)]; zspan=[z(zpos(1)) z(zpos(end)+1)]; end if nargin<5 gcs=false; % define if we look in the guiding center system end nbp=min(obj.nbparts(timesteppart),obj.species(1).R.nparts); R=obj.species(1).R(1:nbp,timesteppart,false); Z=obj.species(1).Z(1:nbp,timesteppart,false); ids=R>=rspan(1) & R<=rspan(2) & Z>=zspan(1) & Z<=zspan(2); Vperp=obj.Vperp(1:nbp,timesteppart,false,gcs); Vpar=obj.Vpar(1:nbp,timesteppart,false); Vr=obj.species(1).VR(1:nbp,timesteppart,false); Vthet=obj.species(1).VTHET(1:nbp,timesteppart,false); Vper=Vperp(ids); Vpar=Vpar(ids); Vr=Vr(ids); Vthet=Vthet(ids); nbp=sum(ids(:)); f=figure('Name',sprintf("%s v parper distrib",obj.file)); subplot(2,1,1) [N,Xedges,Yedges] = histcounts2(Vpar,Vper,20); Xedges=(Xedges(1:end-1)+Xedges(2:end))/2; Yedges=(Yedges(1:end-1)+Yedges(2:end))/2; contourf(Xedges,Yedges,N') xlabel('v_{par} [m/s]') ylabel('v_{\perp} [m/s]') c=colorbar; c.Label.String='Counts'; subplot(2,1,2) [N,Xedges,Yedges] = histcounts2(Vthet,Vr,20); Xedges=(Xedges(1:end-1)+Xedges(2:end))/2; Yedges=(Yedges(1:end-1)+Yedges(2:end))/2; contourf(Xedges,Yedges,N') %histogram2(Vthet,Vr,'displaystyle','tile','binmethod','auto') %scatter(Vthet,Vr) xlabel('v_\theta [m/s]') ylabel('v_r [m/s]') c=colorbar; c.Label.String='Counts'; sgtitle(sprintf('t=%1.2e[ns] r=[%2.1f, %2.1f] [mm] z=[%2.1f, %2.1f] [mm] N=%3i',mean(obj.tpart(timestep))*1e9, rspan*1e3, zspan*1e3,nbp)) mkdir(sprintf('%s/vdist',obj.folder)) if gcs obj.savegraph(f,sprintf('%s/vdist/%sParts_V_2dparpergcs_r%iz%it%i',obj.folder,obj.name,floor(mean(rpos)),floor(mean(zpos)),floor(mean(timestep)))); else obj.savegraph(f,sprintf('%s/vdist/%sParts_V_2dparper_r%iz%it%i',obj.folder,obj.name,floor(mean(rpos)),floor(mean(zpos)),floor(mean(timestep)))); end end end function [p, maxnb, c]=displayPhaseSpace(obj,type,partsstep, Rindex, Zindex,legendtext, figtitle, f, maxnb, c, gcs) if nargin<8 f=figure; f=gca; end if nargin<7 figtitle=sprintf('r=%1.2f [mm] z=%1.2f [mm] \\Delta\\phi=%1.1f[kV] R=%1.1f',obj.rgrid(Rindex)*1e3,obj.zgrid(Zindex)*1e3,(obj.potout-obj.potinn)*obj.phinorm/1e3,obj.Rcurv); end if nargin <6 legendtext=sprintf('t=%1.3g [s]',obj.tpart(partsstep)); end fieldstep=find(obj.tpart(partsstep(end))==obj.t2d,1); if nargin>=10 ctemp=c; n=zeros(length(c{1}),length(c{2})); else nbins=15; n=zeros(nbins); end if nargin <11 gcs=true; end for i=1:length(partsstep) odstep=find(obj.tpart(partsstep(i))==obj.t0d); nbp=min(obj.species(1).R.nparts,obj.nbparts(partsstep(i))); Rp=obj.species(1).R(1:nbp,partsstep(i),false); Zp=obj.species(1).Z(1:nbp,partsstep(i),false); deltar=obj.dr(2)/2; deltarm=obj.rgrid(Rindex)-sqrt(obj.rgrid(Rindex)^2-deltar^2-2*obj.rgrid(Rindex)*deltar); deltaz=obj.dz/2; Indices=Rp>=obj.rgrid(Rindex)-deltarm & Rp=obj.zgrid(Zindex)-deltaz & Zp0)),max(Blines(obj.geomweight(:,:,1)>0)),20); Blines(obj.geomweight(:,:,1)<0)=NaN; [~,h1]=contour(ax1,obj.zgrid*1000,obj.rgrid*1000,Blines,real(levels),'-.','color','k','linewidth',1.5,'Displayname','Magnetic field lines'); % Draw the metallic boundaries and the geometry itself [c1,hContour]=contourf(ax1,obj.zgrid*1000,obj.rgrid*1000,-geomw,[0,0],'linewidth',1.5); drawnow; xlim(ax1,[obj.zgrid(1)*1000 obj.zgrid(end)*1000]) % Change the color of the metallic boundaries to grey hFills=hContour.FacePrims; [hFills.ColorType] = deal('truecoloralpha'); % default = 'truecolor' try hFills(end).ColorData = uint8([150;150;150;255]); for idx = 1 : numel(hFills)-1 hFills(idx).ColorData(4) = 0; % default=255 end catch end grid on; hold on; f.PaperOrientation='landscape'; f.PaperUnits='centimeters'; papsize=[16 14]; f.PaperSize=papsize; set(ax1,'fontsize',14) %axis equal obj.savegraph(f,sprintf('%sfluid_dens',obj.name)) end function display_ionicconfigurration(obj, fieldstart, fieldend, species_id) %displayconfiguration plot the configuration of the simulation % domain withe boundaries, the magnetic field lines the % electric equipotential lines and the electron density % averaged in time between t2d(fieldstart) and t2d(fieldend) % species_id: gathers the ion species indices in an array. for ii = 1 :species_id(end-1) dens(ii,:,:)=mean(obj.species_moments(ii).N(:,:,fieldstart:fieldend),3); end geomw=obj.geomweight(:,:,1); maxdens=max(dens(:)); geomw(geomw<0)=0; geomw(geomw>0)=maxdens; dens(geomw<=0)=0; geomw(geomw>0)=NaN; f=figure('Name', sprintf('%s fields',obj.name)); ax1=gca; title(sprintf('Configuration')) %dens(dens<=1e13)=NaN; %% electron density for ii =1:2 h(ii)=contourf(ax1,obj.zgrid*1000,obj.rgrid*1000,dens(ii,:,:),50,'Displayname','n_e [m^{-3}]', 'linestyle','none'); hold on; end colormap(flipud(hot)); %% Magnetic field lines Blines=obj.rAthet; levels=linspace(min(Blines(obj.geomweight(:,:,1)>0)),max(Blines(obj.geomweight(:,:,1)>0)),20); [~,h1]=contour(ax1,obj.zgrid*1000,obj.rgrid*1000,Blines,real(levels),'-.','color','k','linewidth',1.5,'Displayname','Magnetic field lines'); %% Equipotential lines Pot=mean(obj.pot(:,:,fieldstart:fieldend),3); Pot(obj.geomweight(:,:,1)<0)=NaN; %levels=8;%[-3.4 -5 -10 -15 -20 -25];%7; potcolor='b';%[0.3660 0.6740 0.1880]; [c1,h2]=contour(ax1,obj.zgrid*1000,obj.rgrid*1000,Pot,'--','color',potcolor,'ShowText','on','linewidth',1.2,'Displayname','Equipotentials [kV]'); clabel(c1,h2,'Color',potcolor) % Grey outline shows metallic parts [c1,hContour]=contourf(ax1,obj.zgrid*1000,obj.rgrid*1000,geomw, [0 0]); drawnow; % set the axia limits xlim(ax1,[obj.zgrid(1)*1000 obj.zgrid(end)*1000]) if(obj.conformgeom) ylim([ax1 ],[obj.rgrid(1)*1000 obj.rgrid(rgridend)*1000]) else ylim([ax1],[obj.rgrid(1)*1000 obj.rgrid(end)*1000]) end legend([h1,h2],{'Magnetic field lines','Equipotentials [V]'},'location','northeast') xlabel(ax1,'z [mm]') ylabel(ax1,'r [mm]') c = colorbar(ax1); c.Label.String= 'n[m^{-3}]'; view(ax1,2) grid on; hFills=hContour.FacePrims; [hFills.ColorType] = deal('truecoloralpha'); % default = 'truecolor' try hFills(1).ColorData = uint8([150;150;150;255]); for idx = 2 : numel(hFills) hFills(idx).ColorData(4) = 0; % default=255 end catch end [~, name, ~] = fileparts(obj.file); % with this you could show the outline of the maxwellian source % if obj.maxwellsrce.present % rlen=diff(obj.maxwellsrce.rlim); % zlen=diff(obj.maxwellsrce.zlim); % rectangle('Position',[obj.maxwellsrce.zlim(1) obj.maxwellsrce.rlim(1) zlen rlen]*1000,'Edgecolor','g','Linewidth',2,'Linestyle','--') % end % in case of coaxial configuration, extend the display domain % and add grey rectangles to show metallic boundaries if( obj.walltype >=2 && obj.walltype<=4) rectangle('Position',[obj.zgrid(1) obj.r_b obj.zgrid(end)-obj.zgrid(1) 0.001]*1e3,'FaceColor',[150 150 150]/255,'Edgecolor','none') ylimits=ylim; ylim([ylimits(1),ylimits(2)+1]) end if sum(obj.geomweight(:,1,1))==0 rectangle('Position',[obj.zgrid(1) obj.r_a-0.001 obj.zgrid(end)-obj.zgrid(1) 0.001]*1e3,'FaceColor',[150 150 150]/255,'Edgecolor','none') ylimits=ylim; ylim([ylimits(1)-1,ylimits(2)]) end f.PaperUnits='centimeters'; %axis equal papsize=[14 5 ]; obj.savegraph(f,sprintf('%s/%sFields',obj.folder,obj.name),papsize); end - function displayconfiguration(obj,fieldstart,fieldend) - %displayconfiguration plot the configuration of the simulation - % domain withe boundaries, the magnetic field lines the - % electric equipotential lines and the electron density - % averaged in time between t2d(fieldstart) and t2d(fieldend) - dens=mean(obj.N(:,:,fieldstart:fieldend),3); - geomw=obj.geomweight(:,:,1); - maxdens=max(dens(:)); - geomw(geomw<0)=0; - geomw(geomw>0)=maxdens; - dens(geomw<=0)=0; - geomw(geomw>0)=NaN; - - - - f=figure('Name', sprintf('%s fields',obj.name)); - ax1=gca; - title(sprintf('Configuration')) - %dens(dens<=1e13)=NaN; - %% electron density - h=contourf(ax1,obj.zgrid*1000,obj.rgrid*1000,dens,50,'Displayname','n_e [m^{-3}]', 'linestyle','none'); - hold on; - colormap(flipud(hot)); - %% Magnetic field lines - Blines=obj.rAthet; - levels=linspace(min(Blines(obj.geomweight(:,:,1)>0)),max(Blines(obj.geomweight(:,:,1)>0)),20); - [~,h1]=contour(ax1,obj.zgrid*1000,obj.rgrid*1000,Blines,real(levels),'-.','color','k','linewidth',1.5,'Displayname','Magnetic field lines'); - - %% Equipotential lines - Pot=mean(obj.pot(:,:,fieldstart:fieldend),3); - Pot(obj.geomweight(:,:,1)<0)=NaN; - %levels=8;%[-3.4 -5 -10 -15 -20 -25];%7; - potcolor='b';%[0.3660 0.6740 0.1880]; - [c1,h2]=contour(ax1,obj.zgrid*1000,obj.rgrid*1000,Pot,'--','color',potcolor,'ShowText','on','linewidth',1.2,'Displayname','Equipotentials [kV]'); - clabel(c1,h2,'Color',potcolor) - - % Grey outline shows metallic parts - [c1,hContour]=contourf(ax1,obj.zgrid*1000,obj.rgrid*1000,geomw, [0 0]); - - drawnow; - - % set the axia limits - xlim(ax1,[obj.zgrid(1)*1000 obj.zgrid(end)*1000]) - if(obj.conformgeom) - ylim([ax1 ],[obj.rgrid(1)*1000 obj.rgrid(rgridend)*1000]) - else - ylim([ax1],[obj.rgrid(1)*1000 obj.rgrid(end)*1000]) - end - legend([h1,h2],{'Magnetic field lines','Equipotentials [V]'},'location','northeast') - xlabel(ax1,'z [mm]') - ylabel(ax1,'r [mm]') - - c = colorbar(ax1); - c.Label.String= 'n[m^{-3}]'; - view(ax1,2) - - grid on; - hFills=hContour.FacePrims; - [hFills.ColorType] = deal('truecoloralpha'); % default = 'truecolor' - try - hFills(1).ColorData = uint8([150;150;150;255]); - for idx = 2 : numel(hFills) - hFills(idx).ColorData(4) = 0; % default=255 - end - catch - end - [~, name, ~] = fileparts(obj.file); - - % with this you could show the outline of the maxwellian source - % if obj.maxwellsrce.present - % rlen=diff(obj.maxwellsrce.rlim); - % zlen=diff(obj.maxwellsrce.zlim); - % rectangle('Position',[obj.maxwellsrce.zlim(1) obj.maxwellsrce.rlim(1) zlen rlen]*1000,'Edgecolor','g','Linewidth',2,'Linestyle','--') - % end - - % in case of coaxial configuration, extend the display domain - % and add grey rectangles to show metallic boundaries - if( obj.walltype >=2 && obj.walltype<=4) - rectangle('Position',[obj.zgrid(1) obj.r_b obj.zgrid(end)-obj.zgrid(1) 0.001]*1e3,'FaceColor',[150 150 150]/255,'Edgecolor','none') - ylimits=ylim; - ylim([ylimits(1),ylimits(2)+1]) - end - if sum(obj.geomweight(:,1,1))==0 - rectangle('Position',[obj.zgrid(1) obj.r_a-0.001 obj.zgrid(end)-obj.zgrid(1) 0.001]*1e3,'FaceColor',[150 150 150]/255,'Edgecolor','none') - ylimits=ylim; - ylim([ylimits(1)-1,ylimits(2)]) - end - f.PaperUnits='centimeters'; - %axis equal - - papsize=[14 5 ]; - - - obj.savegraph(f,sprintf('%s/%sFields',obj.folder,obj.name),papsize); - end +% function displayconfiguration(obj,fieldstart,fieldend) +% %displayconfiguration plot the configuration of the simulation +% % domain withe boundaries, the magnetic field lines the +% % electric equipotential lines and the electron density +% % averaged in time between t2d(fieldstart) and t2d(fieldend) +% dens=mean(obj.N(:,:,fieldstart:fieldend),3); +% geomw=obj.geomweight(:,:,1); +% maxdens=max(dens(:)); +% geomw(geomw<0)=0; +% geomw(geomw>0)=maxdens; +% dens(geomw<=0)=0; +% geomw(geomw>0)=NaN; +% +% +% +% f=figure('Name', sprintf('%s fields',obj.name)); +% ax1=gca; +% title(sprintf('Configuration')) +% %dens(dens<=1e13)=NaN; +% %% electron density +% h=contourf(ax1,obj.zgrid*1000,obj.rgrid*1000,dens,50,'Displayname','n_e [m^{-3}]', 'linestyle','none'); +% hold on; +% colormap(flipud(hot)); +% %% Magnetic field lines +% Blines=obj.rAthet; +% levels=linspace(min(Blines(obj.geomweight(:,:,1)>0)),max(Blines(obj.geomweight(:,:,1)>0)),20); +% [~,h1]=contour(ax1,obj.zgrid*1000,obj.rgrid*1000,Blines,real(levels),'-.','color','k','linewidth',1.5,'Displayname','Magnetic field lines'); +% +% %% Equipotential lines +% Pot=mean(obj.pot(:,:,fieldstart:fieldend),3); +% Pot(obj.geomweight(:,:,1)<0)=NaN; +% %levels=8;%[-3.4 -5 -10 -15 -20 -25];%7; +% potcolor='b';%[0.3660 0.6740 0.1880]; +% [c1,h2]=contour(ax1,obj.zgrid*1000,obj.rgrid*1000,Pot,'--','color',potcolor,'ShowText','on','linewidth',1.2,'Displayname','Equipotentials [kV]'); +% clabel(c1,h2,'Color',potcolor) +% +% % Grey outline shows metallic parts +% [c1,hContour]=contourf(ax1,obj.zgrid*1000,obj.rgrid*1000,geomw, [0 0]); +% +% drawnow; +% +% % set the axia limits +% xlim(ax1,[obj.zgrid(1)*1000 obj.zgrid(end)*1000]) +% if(obj.conformgeom) +% ylim([ax1 ],[obj.rgrid(1)*1000 obj.rgrid(rgridend)*1000]) +% else +% ylim([ax1],[obj.rgrid(1)*1000 obj.rgrid(end)*1000]) +% end +% legend([h1,h2],{'Magnetic field lines','Equipotentials [V]'},'location','northeast') +% xlabel(ax1,'z [mm]') +% ylabel(ax1,'r [mm]') +% +% c = colorbar(ax1); +% c.Label.String= 'n[m^{-3}]'; +% view(ax1,2) +% +% grid on; +% hFills=hContour.FacePrims; +% [hFills.ColorType] = deal('truecoloralpha'); % default = 'truecolor' +% try +% hFills(1).ColorData = uint8([150;150;150;255]); +% for idx = 2 : numel(hFills) +% hFills(idx).ColorData(4) = 0; % default=255 +% end +% catch +% end +% [~, name, ~] = fileparts(obj.file); +% +% % with this you could show the outline of the maxwellian source +% % if obj.maxwellsrce.present +% % rlen=diff(obj.maxwellsrce.rlim); +% % zlen=diff(obj.maxwellsrce.zlim); +% % rectangle('Position',[obj.maxwellsrce.zlim(1) obj.maxwellsrce.rlim(1) zlen rlen]*1000,'Edgecolor','g','Linewidth',2,'Linestyle','--') +% % end +% +% % in case of coaxial configuration, extend the display domain +% % and add grey rectangles to show metallic boundaries +% if( obj.walltype >=2 && obj.walltype<=4) +% rectangle('Position',[obj.zgrid(1) obj.r_b obj.zgrid(end)-obj.zgrid(1) 0.001]*1e3,'FaceColor',[150 150 150]/255,'Edgecolor','none') +% ylimits=ylim; +% ylim([ylimits(1),ylimits(2)+1]) +% end +% if sum(obj.geomweight(:,1,1))==0 +% rectangle('Position',[obj.zgrid(1) obj.r_a-0.001 obj.zgrid(end)-obj.zgrid(1) 0.001]*1e3,'FaceColor',[150 150 150]/255,'Edgecolor','none') +% ylimits=ylim; +% ylim([ylimits(1)-1,ylimits(2)]) +% end +% f.PaperUnits='centimeters'; +% %axis equal +% +% papsize=[14 5 ]; +% +% +% obj.savegraph(f,sprintf('%s/%sFields',obj.folder,obj.name),papsize); +% end function displaymagfield(obj) %displaymagfield display the magnetic field lines and the %amplitude of the magnetic field using a contour % also show the domain boundaries B=obj.B'; f=figure('Name', sprintf('%s B field',obj.name)); B(obj.geomweight(:,:,1)<0)=NaN; ax1=gca; title(sprintf('Configuration')) Blv=linspace(min(B(:)),max(B(:)),25); if length(Blv)<2 Blv=min(B(:))*[1 1]; end h=contourf(ax1,obj.zgrid*1000,obj.rgrid*1000,B,Blv,'Displayname','B [T]', 'linestyle','none'); hold on; %% Magnetic field lines Blines=obj.rAthet; - levels=linspace(min(Blines(obj.geomweight(:,:,1)>0)),max(Blines(obj.geomweight(:,:,1)>0)),10); + levels=linspace(min(Blines(obj.geomweight(:,:,1)>0)),max(Blines(obj.geomweight(:,:,1)>0)),30); Blines(obj.geomweight(:,:,1)<0)=NaN; [~,h1]=contour(ax1,obj.zgrid*1000,obj.rgrid*1000,Blines,real(levels),'r-.','linewidth',1.5,'Displayname','Magnetic field lines'); colormap(ax1,'parula') % Grey outline geomw=obj.geomweight(:,:,1); geomw(geomw>0)=NaN; geomw(geomw<0)=min(B(:)); [c1,hContour]=contourf(ax1,obj.zgrid*1000,obj.rgrid*1000,geomw, [0 0]); drawnow; xlim(ax1,[obj.zgrid(1)*1000 obj.zgrid(end)*1000]) if(obj.conformgeom) ylim([ax1 ],[obj.rgrid(1)*1000 obj.rgrid(rgridend)*1000]) else ylim([ax1],[obj.rgrid(1)*1000 obj.rgrid(end)*1000]) end %legend([h1],{'Magnetic field lines'},'location','northwest') xlabel(ax1,'z [mm]') ylabel(ax1,'r [mm]') %title(ax1,sprintf('Density t=[%1.2g-%1.2g]s n_e=%1.2gm^{-3}',M.t2d(fieldstart),M.t2d(fieldend),double(maxdens))) c = colorbar(ax1); c.Label.String= '|B| [T]'; view(ax1,2) %set(h,'edgecolor','none'); grid on; hFills=hContour.FacePrims; [hFills.ColorType] = deal('truecoloralpha'); % default = 'truecolor' %caxis([min(B(:)) max(B(:))]) try hFills(1).ColorData = uint8([150;150;150;255]); for idx = 2 : numel(hFills) hFills(idx).ColorData(4) = 0; % default=255 end catch end [~, name, ~] = fileparts(obj.file); if( obj.walltype >=2 && obj.walltype<=4) rectangle('Position',[obj.zgrid(1) obj.r_b obj.zgrid(end)-obj.zgrid(1) 0.001]*1e3,'FaceColor',[150 150 150]/255,'Edgecolor','none') ylimits=ylim; ylim([ylimits(1),ylimits(2)+1]) end if(isempty(obj.spl_bound)) rectangle('Position',[obj.zgrid(1) obj.r_a-0.001 obj.zgrid(end)-obj.zgrid(1) 0.001]*1e3,'FaceColor',[150 150 150]/255,'Edgecolor','none') ylimits=ylim; ylim([ylimits(1)-1,ylimits(2)]) end f.PaperUnits='centimeters'; %axis equal set(gca,'fontsize',14) papsize=[14 5 ]; pos=f.Position; pos(3)=floor(1.5*pos(3)); f.Position=pos; axis equal obj.savegraph(f,sprintf('%s/%s_Bfield',obj.folder,obj.name),papsize); end function displaySurfFlux(obj,timestep, subdiv, species_id,scalet) %displaySurfFlux plot the current densities %on the domain boundaries for time t2d(timestep) %directly on the boundaries themselves %make it easier to see where the currents are collected if nargin<3 subdiv=1; end if nargin<4 species_id =1; end if nargin<5 scalet = false; end if species_id ==1 mflux= obj.Metallicflux(timestep,subdiv); lflux= -squeeze(obj.Axialflux(timestep,1,species_id))'; rflux= squeeze(obj.Axialflux(timestep,length(obj.zgrid),species_id))'; qe = obj.qe; else mflux= obj.MetallicFlux_species(timestep,subdiv); lflux= -squeeze(obj.Axialflux(timestep,1,species_id))'; rflux= squeeze(obj.Axialflux(timestep,length(obj.zgrid),species_id))'; qe = obj.species(species_id-1).q; end time=obj.t2d(timestep); if nargin<3 ids=1:length(mflux); end %% P=obj.neutcol.neutdens*obj.kb*300/100;% pressure at room temperature in mbar f=figure('name','fluxevol'); linew=3; %obj.displaysplbound(gca,1e3); % Grey outline geomw=obj.geomweight(:,:,1); geomw(geomw>0)=NaN; geomw(geomw<0)=0; [c1,hContour]=contourf(obj.zgrid*1000,obj.rgrid*1000,geomw, [0 0]); hold on contour(obj.zgrid*1e3,obj.rgrid*1e3,obj.geomweight(:,:,1),[0 0],'b-','linewidth',1.5); hold on for i=1:length(mflux.p) x=mflux.p{i}(1,:)*1000; y=mflux.p{i}(2,:)*1000; y(end)=NaN; c=mean(mflux.gamma{i},2)'*qe/(100^2)/P; %c=mflux.gamma{i}'*obj.qe/(100^2)/P; %c=mflux.gamma{i}'*qe/(100^2)/P; c(c<=1e-4*max(c))=NaN; patch(x,y,c,'EdgeColor','interp','LineWidth',linew); hold on end x=obj.zgrid(1)*ones(size(obj.rgrid))*1000; y=obj.rgrid*1000; y(end)=NaN; c=mean(lflux,1)*qe/(100^2)/P; %c=lflux*obj.qe/(100^2)/P; %c=lflux*qe/(100^2)/P; c(c<=1e-4*max(c))=NaN; patch(x,y,c,'EdgeColor','interp','LineWidth',linew); x=obj.zgrid(end)*ones(size(obj.rgrid))*1e3; y=obj.rgrid*1000; y(end)=NaN; c=mean(rflux,1)*qe/(100^2)/P; %c=rflux*obj.qe/(100^2)/P; %c=rflux*qe/(100^2)/P; c(c<=1e-4*max(c))=NaN; patch(x,y,c,'EdgeColor','interp','LineWidth',linew); if scalet == false title(sprintf('t=%4.2f [ns]',mean(time)*1e9)) else if obj.neutcol.present vexb0=(obj.Ez(:,:,1).*obj.Br'-obj.Er(:,:,1).*obj.Bz')./(obj.B'.^2); vexb0(obj.geomweight(:,:,1)<=0)=0; E=0.5*obj.msim/obj.weight*mean(abs(vexb0(:)))^2/obj.qe; taucol=1/(obj.neutcol.neutdens*mean(abs(vexb0(:)))*(obj.sigio(E)+obj.sigmela(E)+obj.sigmio(E))); try Sio_S=1e17*(obj.neutcol.neutdens*mean(abs(vexb0(:)))*obj.sigio(E))/(obj.maxwellsrce.frequency*obj.weight/(pi*(obj.maxwellsrce.rlim(2)^2-obj.maxwellsrce.rlim(1)^2)*diff(obj.maxwellsrce.zlim))) catch end tlabel='t/\tau_d [-]'; else taucol=2*pi/obj.omece; tlabel='t/\tau_ce [-]'; end title(sprintf('t/\\tau_d=%4.2f [-]', mean(time)/taucol)) end c=colorbar; c.Label.String= 'j\cdotn [A/(cm^2 mbar)]'; xlabel('z [mm]') ylabel('r [mm]') colormap(jet) set(gca,'colorscale','log') set(gca,'fontsize',10) %% Magnetic field lines Blines=obj.rAthet; levels=linspace(min(Blines(obj.geomweight(:,:,1)>0)),max(Blines(obj.geomweight(:,:,1)>0)),15); Blines(obj.geomweight(:,:,1)<0)=NaN; [~,h1]=contour(obj.zgrid*1000,obj.rgrid*1000,Blines,real(levels),'k-.','linewidth',1.5,'Displayname','Magnetic field lines'); %axis equal drawnow % Set boundaries to gray hFills=hContour.FacePrims; [hFills.ColorType] = deal('truecoloralpha'); % default = 'truecolor' try hFills(1).ColorData = uint8([150;150;150;255]); for idx = 2 : numel(hFills) hFills(idx).ColorData(4) = 0; % default=255 end catch end pos=f.Position; %pos(3)=floor(1.5*pos(3)); f.Position=pos; %axis equal xlim([obj.zgrid(1) obj.zgrid(end)]*1e3+0.1*[-1 1]) xlim([20*1e-3 obj.zgrid(end)]*1e3+0.1*[-1 1]) ylim([obj.rgrid(1) obj.rgrid(end)]*1e3+0.1*[-1 1]) drawnow pause(0.5) c.Ticks=[1e-2 1e-1 1 1e1 1e2]; obj.savegraph(f,sprintf('%s/%s_surfFlux_it2d_%i',obj.folder,obj.name,floor(mean(timestep))),[16 14]); end % interactive window to display the terms of the pressure tensor guiPressure(obj,logdensity,showgrid,fixed,temperature) % interactive window to display the electron density, magnetic % field lines, electric potential and field at given time steps guiFields(obj,logdensity,showgrid,fixed,parper) function displaycollfreq(obj) %displaycollfreq plot the collision frequencies in Hz/mbar for a range of %electron kinetic energies in eV for the different collision %processes considered: ionisation and elastic collisions E=logspace(1,4,1000); v=sqrt(2/obj.msim*obj.weight*E*obj.qe); P=obj.neutcol.neutdens*obj.kb*300/100;% pressure at room temperature in mbar tauio=P./(obj.neutcol.neutdens*obj.sigio(E).*v); tauiom=P./(obj.neutcol.neutdens*obj.sigmio(E).*v); tauelam=P./(obj.neutcol.neutdens*obj.sigmela(E).*v); f=figure('name','t scales coll'); loglog(E,1./tauio,'displayname','ionisation','linewidth',1.5) hold on loglog(E,1./tauiom,'displayname','ionisation momentum','linewidth',1.5) loglog(E,1./tauelam,'displayname','elastic','linewidth',1.5) loglog(E,1./tauio+1./tauiom+1./tauelam,'displayname','total drag','linewidth',1.5) loglog([E(1) E(end)],1./(2*pi/obj.omece)* [1 1],'--','displayname','cyclotronic','linewidth',1.5) xlabel('Electron kinetic energy [eV]') ylabel('\nu [Hz/mbar]') legend('location','southeast') grid on obj.savegraph(f,sprintf('%s/collfreqscales',obj.folder),[14 12]); end function displaycrosssec(obj) %displaycrosssec plot the collision crosssections in m^2 for a range of %electron kinetic energies in eV for the different collision %processes considered: ionisation and elastic collisions E=logspace(1,4,1000); sig_io=obj.sigio(E); sig_iom=obj.sigmio(E); sig_elam=obj.sigmela(E); f=figure('name','t scales coll'); loglog(E,sig_io,'displayname','ionisation','linewidth',1.5) hold on loglog(E,sig_iom,'displayname','ionisation momentum','linewidth',1.5) loglog(E,sig_elam,'displayname','elastic','linewidth',1.5) loglog(E,sig_io+sig_elam+sig_iom,'displayname','total drag','linewidth',1.5) xlabel('Energy [eV]') ylabel('\sigma [m^{2}]') legend('location','southeast') grid on obj.savegraph(f,sprintf('%s/coll_cross_sec_scales',obj.folder),[14 12]); end %------------------------------------------ % Helper functions needed for other functions function [zpos,rpos]=getpos(obj,tstep) % interactive window to return an specific axial and radial % position picked from the cloud density if nargin<2 tstep=length(obj.t2d); end n=obj.N(:,:,tstep); n(obj.geomweight(:,:,1)<0)=NaN; figure contourf(obj.zgrid,obj.rgrid,n); xlabel('z [m]') ylabel('r [m]') [x,y]=ginput(1); zpos=find(x>obj.zgrid,1,'last'); rpos=find(y>obj.rgrid,1,'last'); hold on plot(obj.zgrid(zpos),obj.rgrid(rpos),'rx') fprintf('zpos=%i rpos=%i z=%1.4f r=%1.4f\n',zpos,rpos,obj.zgrid(zpos),obj.rgrid(rpos)) end function changed=ischanged(obj) %ischanged Check if the file has been changed since the initial loading of the file %and if some data must be reloaded try filedata=dir(obj.fullpath); checkedtimestamp=filedata.date; if (max(checkedtimestamp > obj.timestamp) ) changed=true; return end changed=false; return catch changed=true; return end end function dispV(obj,V,Vend,label,t, dist, vd) %dispV generic functio to plot the velocity distribution and %comapare two timesteps V and Vend at time t(1) and t(2) if nargin<6 dist='gaussian'; end if nargin<7 vd=0; end vmean=mean(V(~isnan(V))); vtherm=std(V(~isnan(V)),1); vmeanend=mean(Vend(~isnan(Vend))); vthermend=std(Vend(~isnan(Vend)),1); if(length(V)>1) [Counts,edges]=histcounts(V,'binmethod','sqrt'); binwidth=mean(diff(edges)); plot([edges(1) 0.5*(edges(2:end)+edges(1:end-1)) edges(end)],[0 Counts 0],'DisplayName',sprintf("t=%2.3d [ns]",obj.tpart(t(1))*1e9)); hold on end hold on [Counts,edges]=histcounts(Vend,'binmethod','sqrt'); plot([edges(1) 0.5*(edges(2:end)+edges(1:end-1)) edges(end)],[0 Counts 0],'DisplayName',sprintf("t=%2.3d [ns]",obj.tpart(t(2))*1e9)); if strcmp(dist,'maxwell') vfit=linspace(0,edges(end),300); a=vmeanend/sqrt(2); dist=sqrt(2/pi)*vfit.^2.*exp(-((vfit).^2-vd^2)/2/a^2)/a^3; dist=dist/max(dist); plot(vfit,max(Counts)*dist,'displayname',sprintf('Maxw mu=%2.2g sigma=%2.2g',vmeanend,vthermend)) elseif strcmp(dist,'gaussian') vfit=linspace(edges(1),edges(end),300); dist=exp(-(vfit-vmeanend).^2/2/vthermend^2); plot(vfit,max(Counts)*dist,'displayname',sprintf('gauss mu=%2.2g sigma=%2.2g',vmeanend,vthermend)) end ylabel('counts') xlabel(label) grid on legend('location','southoutside','orientation','vertical') end function cross_sec=fit_cross_sec(obj,energy,crosssec_table) %Interpolate the cross-section at the given energy using the %crosssec_table and an exponential fitting cross_sec=0; if (energy<=0 || isnan(energy) || isinf(energy)) return end id=find(energy>crosssec_table(:,1),1,'last'); if(isempty(id)) id=1; end id=min(size(crosssec_table,1)-1,id); id=max(1,id); cross_sec=crosssec_table(id,2)*(energy/crosssec_table(id,1))^crosssec_table(id,3); %cross_sec=crosssec_table(id,2)+(crosssec_table(id+1,2)-crosssec_table(id,2))*(energy-crosssec_table(id,1))/((crosssec_table(id+1,1)-crosssec_table(id,1))); end function fighandle=savegraph(obj, fighandle, name, papsize) %% Saves the given figure as a pdf a .fig and an eps using export_fig - + % fighandle is the handle to the figure being saved + % name is the path to the saved file without extension + % papsize is the dimension of the pdf print in cm if (nargin < 4) papsize=[14 16]; end %export_fig(fighandle,name,'-png','-r300') exportgraphics(fighandle,sprintf('%s.png',name),'Resolution',300) print(fighandle,name,'-dpdf','-fillpage') savefig(fighandle,name) fighandle.PaperUnits='centimeters'; set(fighandle, 'Color', 'w'); fighandle.PaperSize=papsize; exportgraphics(fighandle,sprintf('%s.eps',name)) export_fig(fighandle,name,'-eps','-painters') end function sig=dsigmaio(obj,Ekin, Ebar, Ei, E0, chi, gamma) % calculates the integrand used for the ionisation collision % cross section for momentum exchange for the incoming electron % it is only used by obj.sigmiopre gamma=reshape(gamma,1,[],1); chi=reshape(chi,1,1,[]); siggamma=sin(gamma).*(E0^2+8*(1-chi)*(Ekin-Ei)*E0)./(E0+4*(1-chi)*(Ekin-Ei)-4*(1-chi)*(Ekin-Ei).*cos(gamma)).^2/2; sigchi=(Ekin-Ei)./(Ebar*atan((Ekin-Ei)/(2*Ebar)).*(1+(chi*(Ekin-Ei)/Ebar).^2)); dp=1- trapz(gamma,sqrt((1-chi).*(1-Ei/Ekin)).*cos(gamma).*siggamma,2);%- trapz(gamma,sqrt((1-chi).*(1-Ei/Ekin)).*cos(gamma).*siggamma,2); sig=sigchi.*dp; end function sigm=sigmiopre(obj,E, init) % returns the precalculated values used for the interpolation % of the ionisation collision cross-section for momentum % exchange for the incoming electron if nargin <3 init=false; end if(~init &&( ~obj.neutcol.present || isempty(obj.neutcol.io_cross_sec))) sigm=zeros(size(E)); return end Ebar=obj.neutcol.scatter_fac; Ei=obj.neutcol.Eion; E0=obj.neutcol.E0; nE=numel(E); nchi=300; ngamma=300; gamma=linspace(0,pi,ngamma); chi=linspace(0,0.5,nchi); %sigm2=zeros(nE,nchi); sigm=zeros(size(E)); for i=1:nE if(E(i)>=Ei) sigm2=zeros(nchi,1); for j=1:nchi %sigm2(j)=trapz(alpha,trapz(gamma,obj.dsigmaio(E(i),Ebar,Ei,E0,chi(j),alpha,gamma),2),1); sigm2(j)=obj.dsigmaio(E(i),Ebar,Ei,E0,chi(j),gamma); end sigm(i)=trapz(chi,sigm2)*obj.sigio(E(i),init); %sigm(i)=trapz(chi,trapz(alpha,trapz(gamma,dsigmaio(obj,E(i),Ebar,Ei,E0,chi,alpha,gamma),2),1),3)*obj.sigio(E(i),init); end end end end end diff --git a/matlab/@fennecshdf5/guiRProf.m b/matlab/@fennecshdf5/guiRProf.m index 3f99701..430869c 100644 --- a/matlab/@fennecshdf5/guiRProf.m +++ b/matlab/@fennecshdf5/guiRProf.m @@ -1,351 +1,351 @@ function guiRProf(M,logdensity,showgrid,fixed,parper) %dispespicFields Allows to display the time evolution of the density, electric potential and electric fields % M is of class fennecshdf5 and contains the simulation results fieldstep=1; zpos=1; if nargin <2 logdensity=false; showgrid=false; fixed=false; end if nargin <3 showgrid=false; fixed=false; end if nargin <4 fixed=false; end if nargin <5 parper=false; end fixed=fi(fixed); f=uifigure('Name',sprintf('Grid data %s',M.name)); mf=uipanel(f,'Position',[5 50 f.Position(3)-30 f.Position(4)-55]); mf.AutoResizeChildren='off'; m=uipanel(f,'Position',[5 5 f.Position(3)-10 40]); rpanel=uipanel(f,'Position',[f.Position(3)-28 50 25 f.Position(4)-55]); sgtitle(mf,sprintf('step=%d t=%0.5e s',fieldstep*M.it1,M.t2d(fieldstep))) sld = uislider(m,'Position',[10 30 0.6*m.Position(3) 3]); sld.Value=fieldstep; sld.Limits=[1 size(M.t2d,1)]; sld.Tag='timeslider'; sldr = uislider(rpanel,'Orientation','vertical','Position',[5 35 40 rpanel.Position(4)-40]); sldr.Value=zpos; sldr.Limits=[1 length(M.zgrid)]; sldr.Tag='axialslider'; edr = uieditfield(rpanel,'numeric','Limits',[1 length(M.zgrid)],'Value',1); edr.Position=[sldr.Position(1) sldr.Position(2)-30 40 20]; edr.RoundFractionalValues='on'; edr.Tag='axialfield'; edt = uieditfield(m,'numeric','Limits',[1 size(M.t2d,1)],'Value',1); edt.Position=[sld.Position(1)+sld.Position(3)+25 5 40 20]; edt.RoundFractionalValues='on'; edt.Tag='timefield'; MaxN=0; Printbt=uibutton(m,'Position',[edt.Position(1)+edt.Position(3)+10 5 40 20],'Text', 'Save'); Play=uibutton(m,'Position',[Printbt.Position(1)+Printbt.Position(3)+10 5 40 20],'Text', 'Play'); Pause=uibutton(m,'Position',[Play.Position(1)+Play.Position(3)+10 5 40 20],'Text', 'Pause'); %Playbt=uibutton(m,'Position',[Printbt.Position(1)+Printbt.Position(3)+10 5 40 20],'Text', 'Play/Pause'); stop=false; sld.ValueChangingFcn={@updatefigdata,edt,mf}; edt.ValueChangedFcn={@updatefigdata,sld,mf}; sldr.ValueChangingFcn={@updatefigdata,edr,mf}; edr.ValueChangedFcn={@updatefigdata,sldr,mf}; Printbt.ButtonPushedFcn={@plotGridButtonPushed}; Play.ButtonPushedFcn={@plotPlayButtonPushed}; Pause.ButtonPushedFcn={@PauseButtonPushed}; set(f,'KeyPressFcn',{ @onKeyDown,sld,edt,mf}) Plotfennecsgriddata(mf,M,fieldstep,zpos); function plotPlayButtonPushed(btn,ax) stop=false; i=sld.Value; while ~stop edt.Value=i; sld.Value=i; updatesubplotsdata(i,mf); pause(0.01) i=sld.Value; i=i+10; if(i>sld.Limits(2)) stop=true; end end end function PauseButtonPushed(btn,ax) stop = true; end function onKeyDown(src,event,slider,editfield, fig) direction=0; if strcmp(event.Key,'leftarrow') direction=-1; elseif strcmp(event.Key,'rightarrow') direction=+1; elseif strcmp(event.Key,'uparrow') direction=+10; elseif strcmp(event.Key,'downarrow') direction=-10; end if(direction~=0) currval=slider.Value; slider.Value=max(slider.Limits(1),min(currval+direction,slider.Limits(2))); updatefigdata(slider, event, editfield ,fig) end end function Plotfennecsgriddata(fig,M,fieldstep,zpos) %Plotfennecsgriddata Plot the 2d data of fennecs at time step fieldstep sgtitle(fig,sprintf('step=%d t=%0.5e s z=%0.3e mm',(fieldstep-1)*M.it1,M.t2d(fieldstep),M.zgrid(zpos)*1e3)) geomw=M.geomweight(:,zpos,1)>=0; ax1=subplot(2,2,1,'Parent',fig); - p=plot(ax1,M.rgrid*1e3,M.N(:,zpos,fieldstep),'linewidth',1.5); + p=plot(ax1,M.rgrid*1e3,M.N(:,zpos,fieldstep),'x-','linewidth',1.5); xlim(ax1,[M.rgrid(1) M.rgrid(end)]*1e3) xlabel(ax1,'r [mm]') title(ax1,'Density') ylabel(ax1,'n[m^{-3}]'); %c.Limits=[0 max(M.N(:))]; hold(ax1, 'on') [~,id1]=min(abs(M.geomweight(1:10,zpos,1))); [~,id2]=min(abs(M.geomweight(11:end,zpos,1))); id2=id2+10; ylimits=ylim(ax1); plot(ax1,M.rgrid(id1)*[1 1]*1e3,ylimits,'k--','linewidth',1.5,'Displayname','Boundaries'); plot(ax1,M.rgrid(id2)*[1 1]*1e3,ylimits,'k--','linewidth',1.5,'Displayname','Boundaries'); yyaxis(ax1,'right') hold(ax1, 'on') Er=M.Er(:,zpos,fieldstep).*geomw; Ez=M.Ez(:,zpos,fieldstep).*geomw; Er0=M.Erxt(:,zpos,1).*geomw; Ez0=M.Ezxt(:,zpos,1).*geomw; p1=plot(ax1,M.rgrid*1e3,Er,'linewidth',1.5); p2=plot(ax1,M.rgrid*1e3,Ez,'linewidth',1.5); p3=plot(ax1,M.rgrid*1e3,Er0,'linewidth',1.5); p4=plot(ax1,M.rgrid*1e3,Ez0,'linewidth',1.5); ylabel(ax1,'E [V/m]') if max(abs([Er(:); Ez(:)]))>0 ylim(ax1,[ -max(abs([Er(:); Ez(:)])) max(abs([Er(:); Ez(:)]))]) end legend(ax1,[p p1 p2 p3 p4],{'n','Er','Ez','Erxt','Ezxt'},'location','northwest') ax2=subplot(2,2,2,'Parent',fig); ur=M.fluidUR(:,zpos,fieldstep); plot(ax2,M.rgrid*1e3,ur,'linewidth',1.5); xlim(ax2,[M.rgrid(1) M.rgrid(end)]*1e3) xlabel(ax2,'r [mm]') title(ax2,'radial velocity') ylabel(ax2,'v_r [m/s]'); %c.Limits=[0 max(M.N(:))]; hold(ax2, 'on') if max(ur)>0 ylim(ax2,[ -max(ur) max(ur)]) end %ylim(ax2,[ -max(ur) max(ur)]) ylimits=ylim(ax2); plot(ax2,M.rgrid(id1)*[1 1]*1e3,ylimits,'k--','linewidth',1.5,'Displayname','Boundaries'); plot(ax2,M.rgrid(id2)*[1 1]*1e3,ylimits,'k--','linewidth',1.5,'Displayname','Boundaries'); ax3=subplot(2,2,3,'Parent',fig); uthet=M.fluidUTHET(:,zpos,fieldstep); plot(ax3,M.rgrid*1e3,uthet,'linewidth',1.5); xlim(ax3,[M.rgrid(1) M.rgrid(end)]*1e3) xlabel(ax3,'r [mm]') title(ax3,'Azimuthal velocity') ylabel(ax3,'v_\theta [m/s]'); %c.Limits=[0 max(M.N(:))]; hold(ax3, 'on') if max(uthet)>0 ylim(ax3,[ -max(uthet) max(uthet)]) end ylimits=ylim(ax3); plot(ax3,M.rgrid(id1)*[1 1]*1e3,ylimits,'k--','linewidth',1.5,'Displayname','Boundaries'); plot(ax3,M.rgrid(id2)*[1 1]*1e3,ylimits,'k--','linewidth',1.5,'Displayname','Boundaries'); uExb=-M.Er(:,zpos,fieldstep)./M.Bz(zpos,:)'.*(uthet~=0); plot(ax3,M.rgrid*1e3,uExb,'linewidth',1.5); ax4=subplot(2,2,4,'Parent',fig); uz=M.fluidUZ(:,zpos,fieldstep); plot(ax4,M.rgrid*1e3,uz,'linewidth',1.5); xlim(ax4,[M.rgrid(1) M.rgrid(end)]*1e3) xlabel(ax4,'r [mm]') title(ax4,'Axial velocity') ylabel(ax4,'v_z [m/s]'); %c.Limits=[0 max(M.N(:))]; hold(ax4, 'on') if max(uz)>0 ylim(ax4,[ -max(uz) max(uz)]) end ylimits=ylim(ax4); plot(ax4,M.rgrid(id1)*[1 1]*1e3,ylimits,'k--','linewidth',1.5,'Displayname','Boundaries'); plot(ax4,M.rgrid(id2)*[1 1]*1e3,ylimits,'k--','linewidth',1.5,'Displayname','Boundaries'); linkaxes([ax1,ax2,ax3,ax4],'x'); grid([ax1 ax2 ax3 ax4],'minor') end function plotGridButtonPushed(btn,ax) %UNTITLED2 Summary of this function goes here % Detailed explanation goes here f=figure(); Plotfennecsgriddata(f,M,sld.Value,edr.Value); f.PaperOrientation='landscape'; [~, name, ~] = fileparts(M.file); print(f,sprintf('%sGrid%d%d',name,sld.Value,edr.Value),'-dpdf','-fillpage') end function updatefigdata(control, event, Othercontrol, fig) if contains(event.Source.Tag,'time') if strcmp(event.EventName,'ValueChanged') fieldstep=floor(control.Value); control.Value=fieldstep; elseif strcmp(event.EventName,'KeyPress') fieldstep=floor(control.Value); control.Value=fieldstep; else fieldstep=floor(event.Value); end Othercontrol.Value=fieldstep; elseif contains(event.Source.Tag,'axial') if strcmp(event.EventName,'ValueChanged') zpos=floor(control.Value); control.Value=zpos; elseif strcmp(event.EventName,'KeyPress') zpos=floor(control.Value); control.Value=zpos; else zpos=floor(event.Value); end Othercontrol.Value=zpos; end updatesubplotsdata(fieldstep, zpos, fig); end function updatesubplotsdata(fieldstep, zpos, fig) sgtitle(fig,sprintf('step=%d t=%0.5e s z=%0.3e mm',(fieldstep-1)*M.it1,M.t2d(fieldstep),M.zgrid(zpos)*1e3)) [~,rcenterid]=max(M.geomweight(:,zpos,1)); [~,id1]=min(abs(M.geomweight(1:rcenterid,zpos,1))); [~,id2]=min(abs(M.geomweight(rcenterid:end,zpos,1))); id2=id2+rcenterid; try rlim1=M.rgrid(id1)*[1 1]*1e3; rlim2=M.rgrid(id2)*[1 1]*1e3; catch end %% update density ax1=fig.Children(end); geomw=M.geomweight(:,zpos,1)>=0; dens=M.N(:,zpos,fieldstep).*geomw; Er=M.Er(:,zpos,fieldstep).*geomw; Ez=M.Ez(:,zpos,fieldstep).*geomw; Er0=M.Erxt(:,zpos,1).*geomw; Ez0=M.Ezxt(:,zpos,1).*geomw; yyaxis(ax1,'left') ax1.Children(end).YData=dens; ylimits=ylim(ax1); try ax1.Children(end-1).XData=rlim1; ax1.Children(end-1).YData=ylimits; ax1.Children(end-2).XData=rlim2; ax1.Children(end-2).YData=ylimits; catch end yyaxis(ax1,'right') ax1.Children(end).YData=Er; ax1.Children(end-1).YData=Ez; ax1.Children(end-2).YData=Er0; ax1.Children(end-3).YData=Ez0; if max(abs([Er; Ez]))>0 ylim(ax1,1.05*max(abs([Er; Ez]))*[ -1 1]) end % view(ax1,2) %% update Radial velocity ax2=fig.Children(end-2); ur=M.fluidUR(:,zpos,fieldstep).*geomw; ax2.Children(end).YData=ur; if max(abs(ur))>0 ylim(ax2,max(abs(ur))*[ -1 1]) end try ax2.Children(end-1).XData=rlim1; ax2.Children(end-2).XData=rlim2; ylimits=ylim(ax2); ax2.Children(end-1).YData=ylimits; ax2.Children(end-2).YData=ylimits; catch end %% update Azimuthal velocity ax3=fig.Children(end-3); uthet=M.fluidUTHET(:,zpos,fieldstep).*geomw; uExb=-M.Er(:,zpos,fieldstep)./M.Bz(zpos,:)'.*(uthet~=0); ax3.Children(end-3).YData=uExb'; ax3.Children(end).YData=uthet; if max(abs(uthet))>0 ylim(ax3,1.05*max(abs(uthet))*[-1 1]) end try ax3.Children(end-1).XData=rlim1; ax3.Children(end-2).XData=rlim2; ylimits=ylim(ax3); ax3.Children(end-1).YData=ylimits; ax3.Children(end-2).YData=ylimits; catch end %% update Axial velocity ax4=fig.Children(end-4); uz=M.fluidUZ(:,zpos,fieldstep).*geomw; ax4.Children(end).YData=uz; if max(abs(uz))>0 ylim(ax4,1.05*max(abs(uz))*[ -1 1]) end try ax4.Children(end-1).XData=rlim1; ax4.Children(end-2).XData=rlim2; ylimits=ylim(ax4); ax4.Children(end-1).YData=ylimits; ax4.Children(end-2).YData=ylimits; catch end drawnow limitrate end end diff --git a/matlab/helper_classes/splinequantity.m b/matlab/helper_classes/splinequantity.m index 1e416b4..ec902e9 100644 --- a/matlab/helper_classes/splinequantity.m +++ b/matlab/helper_classes/splinequantity.m @@ -1,195 +1,196 @@ classdef splinequantity < h5quantity properties knotsr knotsz femorder index postscale rgrid zgrid invdr invdz rcenters zcenters end methods function obj=splinequantity(filename, dataset, knotsr, knotsz, femorder, scale, postscale, index) if nargin<6 scale=1; end if nargin<8 index=-1; end obj=obj@h5quantity(filename, dataset, length(knotsr)-2*femorder(2), length(knotsz)-2*femorder(1), scale); obj.knotsr=knotsr; obj.knotsz=knotsz; obj.femorder=double(femorder); if nargin < 7 obj.postscale=ones(length(knotsr)-2*femorder(2), length(knotsz)-2*femorder(1)); else obj.postscale=postscale; end if nargin < 8 obj.index=-1; else obj.index=index; end obj.rgrid=obj.knotsr((1:obj.nr) +obj.femorder(2)); obj.zgrid=obj.knotsz((1:obj.nz) +obj.femorder(1)); [dz,dr]=meshgrid(obj.zgrid(3:end)-obj.zgrid(1:end-2),obj.rgrid(3:end)-obj.rgrid(1:end-2)); obj.invdr=1./dr; obj.invdz=1./dz; - obj.rcenters=movmean(obj.knotsr,femorder(2)+1); + obj.rcenters=movmean(obj.knotsr,[femorder(2) 1]); - obj.zcenters=movmean(obj.knotsz,femorder(1)+1); - if ~mod(femorder(2),2) - obj.rcenters=obj.rcenters(femorder(2):end-femorder(2)); - else - obj.rcenters=obj.rcenters(femorder(2):end-femorder(2)+1); - end - if ~mod(femorder(1),2) - obj.zcenters=obj.zcenters(femorder(1):end-femorder(1)); - else - obj.zcenters=obj.zcenters(femorder(1):end-femorder(1)+1); - end + obj.zcenters=movmean(obj.knotsz,[femorder(1) 1]); + %if ~mod(femorder(2),2) + obj.rcenters=[obj.rgrid(1); obj.rcenters(femorder(2)+2:end-2); obj.rgrid(end)] ; + %else + % obj.rcenters=[obj.rgrid(1); obj.rcenters(femorder(2)+2:end-2); obj.rgrid(end)] ; + %end + %if ~mod(femorder(1),2) + %obj.zcenters=obj.zcenters(femorder(1):end-femorder(1)); + obj.zcenters=[obj.zgrid(1); obj.zcenters(femorder(2)+2:end-2); obj.zgrid(end)] ; + %else + %obj.zcenters=[obj.zgrid(1); obj.zcenters(femorder(2)+1:end-femorder(2)); obj.zgrid(end)] ; + %end end function quantity=coeffs(obj,indices) if strcmp(indices{1},':') r=1:obj.nr+obj.femorder(2)-1; else r=indices{1}; end if strcmp(indices{2},':') z=1:obj.nz+obj.femorder(1)-1; else z=indices{2}; end if strcmp(indices{3},':') t=1:obj.nt; else t=indices{3}; end temp=zeros((obj.nz+obj.femorder(1)-1)*(obj.nr+obj.femorder(2)-1),length(t)); if obj.index ~= -1 if(length(unique(diff(t))) == 1 && length(t)>1) stride=t(2)-t(1); temp = h5read(obj.filename, obj.dataset,[obj.index 1 t(1)],[1 Inf length(t)],[1 1 stride]); else for i=1:length(t) temp(:,i) = h5read(obj.filename, obj.dataset,[obj.index 1 t(i)],[1 Inf 1]); end end else if(sum(diff(diff(t))) == 0 && length(t)>1) stride=t(2)-t(1); temp = h5read(obj.filename, obj.dataset,[1 t(1)],[Inf length(t)],[1 stride]); else for i=1:length(t) temp(:,i) = h5read(obj.filename, obj.dataset,[1 t(i)],[Inf 1]) ; end end end temp=reshape(squeeze(temp),obj.nz+obj.femorder(1)-1,obj.nr+obj.femorder(2)-1,[]); temp=permute(temp,[2,1,3]); quantity=temp(r,z,:)*obj.scale; end function quantity=val(obj,indices) if strcmp(indices{1},':') r=1:obj.nr; else r=indices{1}; end if strcmp(indices{2},':') z=1:obj.nz; else z=indices{2}; end if strcmp(indices{3},':') t=1:obj.nt; else t=indices{3}; end count=length(t); temp=obj.coeffs({':',':',t}); quantity=zeros(length(r),length(z),count); [Z,R]=ndgrid(obj.zcenters,obj.rcenters); [zg,rg]=ndgrid(obj.zgrid,obj.rgrid); valued=griddedInterpolant(Z,R,zeros(length(obj.rgrid)+obj.femorder(2)-1,length(obj.zgrid)+obj.femorder(1)-1)'); for i=1:size(temp,3) - quantity(:,:,i)=obj.postscale(r,z).*fnval(spmak({obj.knotsr,obj.knotsz},temp(:,:,i)),{obj.knotsr(r+obj.femorder(2)),obj.knotsz(z+obj.femorder(1))}); - %valued=interp2(Z,R,squeeze(temp(:,:,i)),zg,rg); -% valued.Values=squeeze(temp(:,:,i))'; -% vals=valued(zg,rg)'; -% quantity(:,:,i)=vals(r,z); + %quantity(:,:,i)=obj.postscale(r,z).*fnval(spmak({obj.knotsr,obj.knotsz},temp(:,:,i)),{obj.knotsr(r+obj.femorder(2)),obj.knotsz(z+obj.femorder(1))}); + %valued=interp2(Z,R,squeeze(temp(:,:,i))',zg,rg); + valued.Values=squeeze(temp(:,:,i))'; + vals=valued(zg,rg)'; + quantity(:,:,i)=vals(r,z); end end function quantity=posval(obj,indices) if strcmp(indices{1},':') r=1:obj.nr; else r=indices{1}; end if strcmp(indices{2},':') z=1:obj.nz; else z=indices{2}; end if strcmp(indices{3},':') t=1:obj.nt; else t=indices{3}; end count=length(t); temp=obj.coeffs({':',':',t}); if(length(r) ~= length(z)) error("r and z array must be the same size") end quantity=zeros(min(length(r),length(z)),count); for i=1:size(temp,3) quantity(:,i)=fnval(spmak({obj.knotsr,obj.knotsz},temp(:,:,i)),[r(:)';z(:)']); end end function quantity=der(obj,indices) if strcmp(indices{1},':') r=1:obj.nr; else r=indices{1}; end if strcmp(indices{2},':') z=1:obj.nz; else z=indices{2}; end if strcmp(indices{3},':') t=1:obj.nt; else t=indices{3}; end order=indices{4}; count=length(t); temp=obj.coeffs({':',':',t}); quantity=zeros(length(r),length(z),count); for i=1:size(temp,3) %f=spmak({obj.knotsr,obj.knotsz},temp(:,:,i)); %preder=fnval(f,{obj.knotsr(r+obj.femorder(2)),obj.knotsz(z+obj.femorder(1))}); preder=obj.val({r,z,t(i)});% if order(1)>0 preder(2:end-1,2:end-1)=(preder(3:end,2:end-1)-preder(1:end-2,2:end-1)).*obj.invdr; end if order(2)>0 preder(2:end-1,2:end-1)=(preder(2:end-1,3:end)-preder(2:end-1,1:end-2)).*obj.invdz; end quantity(2:end-1,2:end-1,i)=preder(2:end-1,2:end-1); end end end end diff --git a/src/.depend b/src/.depend index 696a1d8..0b5c432 100644 --- a/src/.depend +++ b/src/.depend @@ -1,123 +1,100 @@ +advance_state__genmod.o : advance_state__genmod.f90 +antithetic_get__genmod.o : antithetic_get__genmod.f90 +antithetic_memory__genmod.o : antithetic_memory__genmod.f90 +antithetic_set__genmod.o : antithetic_set__genmod.f90 auxval.o : auxval.f90 random_mod.o beam_mod.o fields_mod.o basic_mod.o constants.o auxval__genmod.o : auxval__genmod.f90 basic_mod.o : basic_mod.f90 random_mod.o mpihelper_mod.o constants.o beam_mod.o : beam_mod.f90 ion_induced_mod.o geometry_mod.o weighttypes_mod.o particletypes_mod.o distrib_mod.o basic_mod.o mpihelper_mod.o constants.o celldiag_mod.o : celldiag_mod.f90 beam_mod.o basic_mod.o mpihelper_mod.o constants.o chkrst.o : chkrst.f90 mv2bk.o psupply_mod.o constants.o fields_mod.o beam_mod.o basic_mod.o chkrst__genmod.o : chkrst__genmod.f90 constants.o : constants.f90 cp2bk__genmod.o : cp2bk__genmod.f90 decimal_to_seed__genmod.o : decimal_to_seed__genmod.f90 diagnose.o : diagnose.f90 mv2bk.o psupply_mod.o weighttypes_mod.o splinebound_mod.o geometry_mod.o celldiag_mod.o fields_mod.o xg_mod.o beam_mod.o neutcol_mod.o maxwsrce_mod.o basic_mod.o diagnose__genmod.o : diagnose__genmod.f90 distrib_mod.o : distrib_mod.f90 random_mod.o constants.o -elliptic_ea__genmod.o : elliptic_ea__genmod.f90 -elliptic_ea_values__genmod.o : elliptic_ea_values__genmod.f90 -elliptic_ek__genmod.o : elliptic_ek__genmod.f90 -elliptic_ek_values__genmod.o : elliptic_ek_values__genmod.f90 -elliptic_em__genmod.o : elliptic_em__genmod.f90 -elliptic_em_values__genmod.o : elliptic_em_values__genmod.f90 -elliptic_fa__genmod.o : elliptic_fa__genmod.f90 -elliptic_fa_values__genmod.o : elliptic_fa_values__genmod.f90 -elliptic_fk__genmod.o : elliptic_fk__genmod.f90 -elliptic_fk_values__genmod.o : elliptic_fk_values__genmod.f90 -elliptic_fm__genmod.o : elliptic_fm__genmod.f90 -elliptic_fm_values__genmod.o : elliptic_fm_values__genmod.f90 -elliptic_inc_ea__genmod.o : elliptic_inc_ea__genmod.f90 -elliptic_inc_ea_values__genmod.o : elliptic_inc_ea_values__genmod.f90 -elliptic_inc_ek__genmod.o : elliptic_inc_ek__genmod.f90 -elliptic_inc_ek_values__genmod.o : elliptic_inc_ek_values__genmod.f90 -elliptic_inc_em__genmod.o : elliptic_inc_em__genmod.f90 -elliptic_inc_em_values__genmod.o : elliptic_inc_em_values__genmod.f90 -elliptic_inc_fa__genmod.o : elliptic_inc_fa__genmod.f90 -elliptic_inc_fa_values__genmod.o : elliptic_inc_fa_values__genmod.f90 -elliptic_inc_fk__genmod.o : elliptic_inc_fk__genmod.f90 -elliptic_inc_fk_values__genmod.o : elliptic_inc_fk_values__genmod.f90 -elliptic_inc_fm__genmod.o : elliptic_inc_fm__genmod.f90 -elliptic_inc_fm_values__genmod.o : elliptic_inc_fm_values__genmod.f90 -elliptic_inc_pia__genmod.o : elliptic_inc_pia__genmod.f90 -elliptic_inc_pia_values__genmod.o : elliptic_inc_pia_values__genmod.f90 -elliptic_inc_pik__genmod.o : elliptic_inc_pik__genmod.f90 -elliptic_inc_pik_values__genmod.o : elliptic_inc_pik_values__genmod.f90 -elliptic_inc_pim__genmod.o : elliptic_inc_pim__genmod.f90 -elliptic_inc_pim_values__genmod.o : elliptic_inc_pim_values__genmod.f90 elliptic_mod.o : elliptic_mod.f90 -elliptic_pia__genmod.o : elliptic_pia__genmod.f90 -elliptic_pia_values__genmod.o : elliptic_pia_values__genmod.f90 -elliptic_pik__genmod.o : elliptic_pik__genmod.f90 -elliptic_pik_values__genmod.o : elliptic_pik_values__genmod.f90 -elliptic_pim__genmod.o : elliptic_pim__genmod.f90 -elliptic_pim_values__genmod.o : elliptic_pim_values__genmod.f90 endrun.o : endrun.f90 fields_mod.o beam_mod.o basic_mod.o endrun__genmod.o : endrun__genmod.f90 energies.o : energies.f90 basic_mod.o -fields_mod.o : fields_mod.f90 splinebound_mod.o geometry_mod.o particletypes_mod.o mpihelper_mod.o beam_mod.o basic_mod.o constants.o +fields_mod.o : fields_mod.f90 splinebound_mod.o geometry_mod.o magnet_mod.o particletypes_mod.o mpihelper_mod.o beam_mod.o basic_mod.o constants.o geometry_mod.o : geometry_mod.f90 basic_mod.o weighttypes_mod.o splinebound_mod.o constants.o +get_state__genmod.o : get_state__genmod.f90 +i4_uni__genmod.o : i4_uni__genmod.f90 +ig_get__genmod.o : ig_get__genmod.f90 +ig_memory__genmod.o : ig_memory__genmod.f90 +ig_set__genmod.o : ig_set__genmod.f90 incomplete_gamma_mod.o : incomplete_gamma_mod.f90 inital.o : inital.f90 splinebound_mod.o neutcol_mod.o geometry_mod.o maxwsrce_mod.o mpihelper_mod.o fields_mod.o beam_mod.o basic_mod.o inital__genmod.o : inital__genmod.f90 +init_generator__genmod.o : init_generator__genmod.f90 +initialized_get__genmod.o : initialized_get__genmod.f90 +initialized_memory__genmod.o : initialized_memory__genmod.f90 +initialized_set__genmod.o : initialized_set__genmod.f90 +initialize__genmod.o : initialize__genmod.f90 inputvariables_mod.o : inputvariables_mod.f90 ion_induced_mod.o : ion_induced_mod.f90 incomplete_gamma_mod.o random_mod.o geometry_mod.o materials_mod.o basic_mod.o constants.o particletypes_mod.o -jacobi_cn__genmod.o : jacobi_cn__genmod.f90 -jacobi_cn_values__genmod.o : jacobi_cn_values__genmod.f90 -jacobi_dn__genmod.o : jacobi_dn__genmod.f90 -jacobi_dn_values__genmod.o : jacobi_dn_values__genmod.f90 -jacobi_sn__genmod.o : jacobi_sn__genmod.f90 -jacobi_sn_values__genmod.o : jacobi_sn_values__genmod.f90 +lg_get__genmod.o : lg_get__genmod.f90 +lg_memory__genmod.o : lg_memory__genmod.f90 +lg_set__genmod.o : lg_set__genmod.f90 magnet_mod.o : magnet_mod.f90 elliptic_mod.o basic_mod.o constants.o main.o : main.f90 basic_mod.o materials_mod.o : materials_mod.f90 constants.o maxwsrce_mod.o : maxwsrce_mod.f90 distrib_mod.o beam_mod.o basic_mod.o mpihelper_mod.o constants.o mpihelper_mod.o : mpihelper_mod.f90 particletypes_mod.o constants.o +multmod__genmod.o : multmod__genmod.f90 mv2bk.o : mv2bk.f90 mv2bk__genmod.o : mv2bk__genmod.f90 neutcol_mod.o : neutcol_mod.f90 distrib_mod.o random_mod.o beam_mod.o basic_mod.o constants.o newrun.o : newrun.f90 newrun__genmod.o : newrun__genmod.f90 next_seed3__genmod.o : next_seed3__genmod.f90 next_seed__genmod.o : next_seed__genmod.f90 particletypes_mod.o : particletypes_mod.f90 constants.o psupply_mod.o : psupply_mod.f90 mpihelper_mod.o particletypes_mod.o fields_mod.o weighttypes_mod.o geometry_mod.o basic_mod.o splinebound_mod.o constants.o +r4_uni_01__genmod.o : r4_uni_01__genmod.f90 +r8_uni_01__genmod.o : r8_uni_01__genmod.f90 rand_axc__genmod.o : rand_axc__genmod.f90 rand_batch__genmod.o : rand_batch__genmod.f90 rand_next_seed__genmod.o : rand_next_seed__genmod.f90 random_array__genmod.o : random_array__genmod.f90 random_cosdist__genmod.o : random_cosdist__genmod.f90 random_gauss__genmod.o : random_gauss__genmod.f90 random__genmod.o : random__genmod.f90 random_init__genmod.o : random_init__genmod.f90 random_isodist__genmod.o : random_isodist__genmod.f90 random_mod.o : random_mod.f90 random.h random_one__genmod.o : random_one__genmod.f90 randomone__genmod.o : randomone__genmod.f90 -rc__genmod.o : rc__genmod.f90 -rd__genmod.o : rd__genmod.f90 restart.o : restart.f90 restart__genmod.o : restart__genmod.f90 resume.o : resume.f90 neutcol_mod.o geometry_mod.o maxwsrce_mod.o sort_mod.o fields_mod.o basic_mod.o beam_mod.o resume__genmod.o : resume__genmod.f90 -rf__genmod.o : rf__genmod.f90 -rj__genmod.o : rj__genmod.f90 +rnglib.o : rnglib.f90 seed_to_decimal__genmod.o : seed_to_decimal__genmod.f90 +set_initial_seed__genmod.o : set_initial_seed__genmod.f90 set_random_seed__genmod.o : set_random_seed__genmod.f90 +set_seed__genmod.o : set_seed__genmod.f90 sncndn__genmod.o : sncndn__genmod.f90 sort_mod.o : sort_mod.f90 basic_mod.o constants.o beam_mod.o splinebound_mod.o : splinebound_mod.f90 distrib_mod.o basic_mod.o constants.o srandom_array__genmod.o : srandom_array__genmod.f90 srandom_cosdist__genmod.o : srandom_cosdist__genmod.f90 srandom_gauss__genmod.o : srandom_gauss__genmod.f90 srandom__genmod.o : srandom__genmod.f90 srandom_isodist__genmod.o : srandom_isodist__genmod.f90 srandom_one__genmod.o : srandom_one__genmod.f90 srandomone__genmod.o : srandomone__genmod.f90 start.o : start.f90 psupply_mod.o fields_mod.o beam_mod.o neutcol_mod.o geometry_mod.o maxwsrce_mod.o basic_mod.o start__genmod.o : start__genmod.f90 stepon.o : stepon.f90 beam_mod.o psupply_mod.o sort_mod.o neutcol_mod.o celldiag_mod.o maxwsrce_mod.o fields_mod.o constants.o basic_mod.o stepon__genmod.o : stepon__genmod.f90 string_to_seed__genmod.o : string_to_seed__genmod.f90 surfsrce_mod.o : surfsrce_mod.f90 distrib_mod.o beam_mod.o basic_mod.o mpihelper_mod.o constants.o tesend.o : tesend.f90 basic_mod.o tesend__genmod.o : tesend__genmod.f90 timestamp__genmod.o : timestamp__genmod.f90 weighttypes_mod.o : weighttypes_mod.f90 basic_mod.o splinebound_mod.o constants.o xg_mod.o : xg_mod.f90 fields_mod.o beam_mod.o basic_mod.o constants.o diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 807ac8e..42e15fb 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -1,76 +1,78 @@ project(fennecs_src Fortran C) add_executable(fennecs) set(SRCS main.f90 basic_mod.f90 newrun.f90 restart.f90 auxval.f90 inital.f90 resume.f90 start.f90 diagnose.f90 stepon.f90 tesend.f90 endrun.f90 chkrst.f90 mv2bk.f90 constants.f90 fields_mod.f90 beam_mod.f90 mpihelper_mod.f90 sort_mod.f90 distrib_mod.f90 maxwsrce_mod.f90 celldiag_mod.f90 geometry_mod.f90 random_mod.f90 neutcol_mod.f90 particletypes_mod.f90 splinebound_mod.f90 weighttypes_mod.f90 psupply_mod.f90 ion_induced_mod.f90 incomplete_gamma_mod.f90 materials_mod.f90 extra.c random.f randother.f +elliptic_mod.f90 +magnet_mod.f90 ) target_sources(fennecs PRIVATE ${SRCS}) set_property(SOURCE ${SRCS} APPEND PROPERTY COMPILE_OPTIONS -cpp -fpp -qopenmp ) include_directories(SYSTEM ${MPI_INCLUDE_PATH} ${forSISL_INCLUDE_DIR} ${bsplines_INCLUDES} ${futils_INCLUDES}) if(MKL_Fortran_FLAGS) separate_arguments(MKL_Fortran_FLAGS) target_compile_options(fennecs PUBLIC ${MKL_Fortran_FLAGS}) target_link_options(fennecs PUBLIC ${MKL_Fortran_FLAGS}) endif() add_custom_command(TARGET fennecs POST_BUILD COMMAND ${CMAKE_COMMAND} -E copy ${CMAKE_CURRENT_BINARY_DIR}/fennecs ${CMAKE_CURRENT_BINARY_DIR}/../fennecs) target_include_directories(fennecs PRIVATE $ futils) target_link_libraries(fennecs PUBLIC futils bsplines MPI::MPI_Fortran OpenMP::OpenMP_Fortran ${BLAS_LIBRARIES} ${MUMPS_LIBRARIES} ${LAPACK_LIBRARIES} ${forSISL_LIBRARY} ${sisl_LIBRARY} ${futils_LIBRARY} ${bsplines_LIBRARY} ) diff --git a/src/Makefile b/src/Makefile index 9893853..892e0f1 100644 --- a/src/Makefile +++ b/src/Makefile @@ -1,124 +1,125 @@ .DEFAULT_GOAL := all ifeq ($(PLATFORM),) $(error Please specify the env variable PLATFORM (mac, intel)) else $(info *** Using $(PLATFORM).mk ***) include $(PLATFORM).mk endif include .depend PROG = fennecs SRCS = main.f90 basic_mod.f90 newrun.f90 restart.f90 \ auxval.f90 inital.f90 resume.f90 start.f90 diagnose.f90 \ stepon.f90 tesend.f90 endrun.f90 chkrst.f90 mv2bk.f90 \ - constants.f90 fields_mod.f90 beam_mod.f90 \ - mpihelper_mod.f90 sort_mod.f90 distrib_mod.f90 \ - maxwsrce_mod.f90 celldiag_mod.f90 geometry_mod.f90 \ - random_mod.f90 neutcol_mod.f90 particletypes_mod.f90 \ - splinebound_mod.f90 weighttypes_mod.f90 psupply_mod.f90\ - ion_induced_mod.f90 materials_mod.f90 incomplete_gamma_mod.f90 + constants.f90 fields_mod.f90 beam_mod.f90 \ + mpihelper_mod.f90 sort_mod.f90 distrib_mod.f90 \ + maxwsrce_mod.f90 celldiag_mod.f90 geometry_mod.f90 \ + random_mod.f90 neutcol_mod.f90 particletypes_mod.f90 \ + splinebound_mod.f90 weighttypes_mod.f90 psupply_mod.f90 \ + ion_induced_mod.f90 materials_mod.f90 incomplete_gamma_mod.f90 \ + magnet_mod.f90 elliptic_mod.f90 SRCS_C = extra.c SRCS_F = random.f randother.f MKDIR_P = mkdir -p OUT_DIR = release F90FLAGS += -I$(BSPLINES)/include -I$(FUTILS)/include \ -I$(MUMPS)/include -I../ CCFLAGS += -O3 LDFLAGS += -L$(BSPLINES)/lib -L$(FUTILS)/lib -L${HDF5}/lib -L${HDF5}/lib \ -L$(MUMPS)/lib -L$(PARMETIS)/lib LIBS += -lbsplines -lpppack -lfutils -lhdf5_fortran -lhdf5 -lz $(MUMPSLIBS) -lpputils2 ifeq ($(USE_X),) F90FLAGS+=-DUSE_X=0 else $(info *** Using Xgrafix ***) LIBS+=-lXGF -lXGC -lX11 -lSWIG LDFLAGS+=-L/usr/local/xgrafix_1.2/src-double F90FLAGS+=-DUSE_X=1 SRCS+=xg_mod.f90 endif OBJS =${SRCS_F:.f=.o} ${SRCS:.f90=.o} ${SRCS_F90:.F90=.o} ${SRCS_C:.c=.o} FPP =${SRCS:.f90=.i90} OBJS_ =$(addprefix ./$(OUT_DIR)/,$(OBJS)) debug: F90FLAGS += $(DEBUGFLAGS) debug: OUT_DIR=debug debug: $(OUT_DIR) all profile: F90FLAGS+=$(PROFILEFLAGS) profile: LDFLAGS+= $(PROFILEFLAGS) profile: OUT_DIR=profile profile: $(OUT_DIR) all $(info *** Using $(OBJS) ***) .PHONY: directories clean debug profile all: directories $(PROG) $(PROG): $(OBJS) $(F90) $(LDFLAGS) $(F90FLAGS) -o $@ $(OBJS_) $(LIBS) tags: etags *.f90 clean: rm -f $(OBJS_) *.mod $(FPP) distclean: clean rm -f $(PROG) *~ a.out *.o TAGS extra.o: extra.c ifeq ($(USE_X),) ./$(OUT_DIR)/diagnose.o : diagnose.f90 fields_mod.o beam_mod.o basic_mod.o else ./$(OUT_DIR)/diagnose.o : diagnose.f90 fields_mod.o xg_mod.o beam_mod.o basic_mod.o endif directories: ${OUT_DIR} ${OUT_DIR}: ${MKDIR_P} ${OUT_DIR} .SUFFIXES: $(SUFFIXES) .f .f90 .c ./$(OUT_DIR)/%.o: %.f ${MKDIR_P} ${OUT_DIR} $(F90) $(F90FLAGS) -MD -c -o $@ $< ./$(OUT_DIR)/%.o: %.f90 ${MKDIR_P} ${OUT_DIR} $(F90) $(F90FLAGS) -MD -c -o $@ $< ./$(OUT_DIR)/%.o: %.c $(CC) $(CCFLAGS) -c -o $@ $< %.o: %.f $(F90) $(F90FLAGS) -c -o ./$(OUT_DIR)/$@ $< %.o: %.c $(CC) $(CCFLAGS) -c -o ./$(OUT_DIR)/$@ $< %.o: %.f90 $(F90) $(F90FLAGS) -c -o ./$(OUT_DIR)/$@ $< depend .depend .depend_rel .depend_deb : makedepf90 *.[fF]90 > .depend diff --git a/src/basic_mod.f90 b/src/basic_mod.f90 index f1af4f9..4e25c39 100644 --- a/src/basic_mod.f90 +++ b/src/basic_mod.f90 @@ -1,426 +1,449 @@ MODULE basic ! USE hashtable USE constants USE bsplines USE mumps_bsplines USE futils USE mpihelper use random IMPLICIT NONE ! ! Basic module for time dependent problems ! CHARACTER(len=128) :: label1, label2, label3, label4 ! ! BASIC Namelist ! LOGICAL :: nlres = .FALSE. !< Restart flag LOGICAL :: nlsave = .TRUE. !< Checkpoint (save) flag LOGICAL :: newres=.FALSE. !< New result HDF5 file LOGICAL :: nlxg=.FALSE. !< Show graphical interface Xgrafix LOGICAL :: nlmaxwellsource = .FALSE. !< Activate the maxwell source INTEGER :: nrun=1 !< Number of time steps to run REAL(kind=db) :: job_time=3600.0 !< Time allocated to this job in seconds REAL(kind=db) :: tmax=100000.0 !< Maximum simulation time REAL(kind=db) :: extra_time=60.0 !< Extra time allocated REAL(kind=db) :: dt=1 !< Time step REAL(kind=db) :: time=0 !< Current simulation time (Init from restart file) ! ! Other basic global vars and arrays ! INTEGER :: jobnum !< Job number INTEGER :: step=0 !< Calculation step of this run INTEGER :: cstep=0 !< Current step number (Init from restart file) LOGICAL :: nlend=.false. !< Signal end of run INTEGER :: ierr !< Integer used for MPI INTEGER :: it0d=1 !< Number of iterations between 0d values writes to hdf5 INTEGER :: it2d=100 !< Number of iterations between 2d values writes to hdf5 INTEGER :: itparts=1000 !< Number of iterations between particles values writes to hdf5 INTEGER :: ittext=10 !< Number of iterations between text outputs in the console INTEGER :: itrestart=10000 !< Number of iterations between save of restart.h5 file INTEGER :: ittracer=100 !< Number of iterations between save of traced particles position and velocity INTEGER :: itcelldiag=100000 !< Number of iterations between save of celldiag diagnostic INTEGER :: nbcelldiag=0 !< Number of celldiagnostics INTEGER :: itgraph !< Number of iterations between graphical interface updates INTEGER :: mpirank !< MPIrank of the current processus INTEGER :: mpisize !< Size of the MPI_COMM_WORLD communicator INTEGER :: rightproc !< Rank of next processor in the z decomposition INTEGER :: leftproc !< Rank of previous processor in the z decomposition ! ! List of logical file units INTEGER :: lu_in = 90 !< File duplicated from STDIN INTEGER :: lu_stop = 91 !< stop file, see subroutine TESEND INTEGER :: lu_partfile = 120 !< particle loading file, see beam::loadpartfile ! ! HDF5 file CHARACTER(len=256) :: resfile = "results.h5" !< Main result file CHARACTER(len=256) :: rstfile = "restart.h5" !< Restart file CHARACTER(len=256) :: magnetfile = "" !< H5 file containing the magnetic field definition where r,z are in m and Br, Bz are in T CHARACTER(len=256) :: partfile(10)="" !< Particle loading file CHARACTER(len=256) :: addedtestspecfile(10)="" !< Particle file list for added particles at restart INTEGER :: fidres !< File ID for resfile INTEGER :: fidrst !< File ID for restart file TYPE(BUFFER_TYPE) :: hbuf0 !< Hashtable for 0d var ! ! Plasma parameters - LOGICAL :: nlPhis= .TRUE. !< Calculate self consistent electric field flag - LOGICAL :: nlfreezephi= .FALSE. !< Freeze the Poisson solver to the field obtained at (re-)start LOGICAL :: nlclassical= .FALSE. !< If true, solves the equation of motion according to classical !! dynamics - LOGICAL :: nlperiod(2)=(/.false.,.false./)!< Set periodic splines on or off LOGICAL :: partperiodic= .TRUE. !< Sets if the particles boundary conditions are periodic or open INTEGER :: nbaddtestspecies=0 !< On restart number of files to read to add test particles INTEGER :: nplasma !< Number of macro-particles on initialisation + REAL(kind=db) :: qsim !< Charge of superparticles [C] + REAL(kind=db) :: msim !< Mass of superparticles [kg] + REAL(kind=db) :: partmass=me !< Mass of physical particle [kg] INTEGER :: nbspecies = 1 !< Number of particles species also counting tracing particles INTEGER :: npartsalloc = 0 !< Size of particle memory allocated at the begining of the simulation INTEGER :: nblock !< Number of slices in Z for stable distribution initialisation - REAL(kind=db) :: potinn=0 !< Electric potential at the inner metallic wall - REAL(kind=db) :: potout=0 !< Electric potential at the outer metallic wall + REAL(kind=db) :: n0 !< Physical plasma density parameter [m-3] used in distribtype=1 and for time scales normlisation + REAL(kind=db) :: plasmadim(4) !< Zmin Zmax Rmin Rmax values for plasma particle loading [m] + REAL(kind=db) :: H0=0 !< Initial value of Hamiltonian for distribution 2 [J] + REAL(kind=db) :: P0=0 !< Initial canonical angular momentum for distribution 2 [kg m^2/s] + REAL(kind=db) :: temp !< Initial temperature of plasma [K] for distribtype=1 + + REAL(kind=db) :: weights_scale=1.0 !< Scale factor for the particle weights on restart (only for newres=.true.) + REAL(kind=db) :: temprescale = -1.0 !< Factor used for temperature rescaling in case of a restart (<0 -> no rescaling) Currently not implemented + INTEGER :: samplefactor =-1 !< Factor used for the up-sampling of the particles number + ! + ! Fields parameters REAL(kind=db) :: B0 !< Max magnitude of magnetic field [T] and normalisation factor for magnetic field - REAL(kind=db), allocatable :: Bz(:), Br(:) !< Normalised magnetic field components - REAL(kind=db), allocatable :: Athet(:) !< Theta component of the magnetic vector potential Tm - TYPE(spline2d), SAVE :: splrz !< Spline at r and z for total electric field - TYPE(spline2d), SAVE :: splrz_ext !< Spline at r and z for external electric field - REAL(kind=db), allocatable :: Ez(:), Er(:) !< Normalised electric field components ( ext+self ) - REAL(kind=db), allocatable :: pot(:) !< Normalised electrostatic potential ( ext+self ) + ! If magnetfile ='' The magnetic field is one of a magnetic mirror with maximum amplitude on axis of B0 + ! and + REAL(kind=db) :: Rcurv = 1.0 !< Magnetic field curvature coefficient + REAL(kind=db) :: Width = 1.0 !< Distance between two magnetic mirrors + REAL(kind=db), allocatable :: Bz(:), Br(:) !< Normalised magnetic field components + REAL(kind=db), allocatable :: Athet(:) !< Theta component of the magnetic vector potential Tm + INTEGER :: bscaling = -1 !< if >0 rescale the magnetic field read from h5 file before calculating value at grid points, if <0 rescale after interpolation, if = 0 doesn't rescale + LOGICAL :: nlperiod(2)=(/.false.,.false./)!< Set periodic splines on or off + LOGICAL :: nlPhis= .TRUE. !< Calculate self consistent electric field flag + LOGICAL :: nlfreezephi= .FALSE. !< Freeze the Poisson solver to the field obtained at (re-)start + INTEGER :: femorder(2) !< FEM order + INTEGER :: ngauss(2) !< Number of gauss points for FEM integration + LOGICAL :: nlppform =.TRUE. !< Defines if spline evaluation is done using ppform (faster with true) + INTEGER, SAVE :: nrank(2) !< Number of splines in both directions + TYPE(spline2d), SAVE :: splrz !< Spline at r and z for total electric field + TYPE(spline2d), SAVE :: splrz_ext !< Spline at r and z for external electric field + TYPE(spline2d), SAVE :: splrthet !< Spline at r and theta for total electric field + TYPE(spline2d), SAVE :: splrthet_ext !< Spline at r and theta for external electric field + REAL(kind=db) :: potinn=0 !< Electric potential at the inner metallic wall + REAL(kind=db) :: potout=0 !< Electric potential at the outer metallic wall + REAL(kind=db), allocatable :: Ez(:), Er(:) !< Normalised electric field components ( ext+self ) + REAL(kind=db), allocatable :: pot(:) !< Normalised electrostatic potential ( ext+self ) REAL(kind=db), allocatable :: Ezxt(:), Erxt(:) !< Normalised external Electric field components REAL(kind=db), allocatable :: potxt(:) !< Normalised external Electro static potential - REAL(kind=db) :: radii(11) !< Inner and outer radius of cylinder and radii of fine mesh region [m] - REAL(kind=db) :: plasmadim(4) !< Zmin Zmax Rmin Rmax values for plasma particle loading [m] + REAL(kind=db) :: radii(11) !< Inner and outer radius of cylinder and radii of fine mesh region [m] INTEGER :: distribtype=1 !< Type of distribution function used to load the particles !!1: gaussian, 2: Stable as defined in 4.95 of Davidson, 7 use particle input file - REAL(kind=db) :: H0=0 !< Initial value of Hamiltonian for distribution 2 [J] - REAL(kind=db) :: P0=0 !< Initial canonical angular momentum for distribution 2 [kg m^2/s] - REAL(kind=db) :: temprescale = -1.0 !< Factor used for temperature rescaling in case of a restart (<0 -> no rescaling) - INTEGER :: samplefactor =-1 !< Factor used for the up-sampling of the particles number REAL(kind=db) :: lz(11) !< Lower and upper cylinder limits in z direction [m] - REAL(kind=db) :: n0 !< Physical plasma density parameter [m-3] used in distribtype=1 and for time scales normlisation - !REAL(kind=db), DIMENSION(:,:), ALLOCATABLE, SAVE:: moments !< Moments of the distribution function evaluated every it2d REAL(kind=db), DIMENSION(:), ALLOCATABLE, SAVE:: rhs !< right hand side of the poisson equation solver REAL(kind=db), DIMENSION(:), ALLOCATABLE, SAVE:: volume !< Volume covered by each spline for density calculation INTEGER :: nz !< Total Number of grid intervals in z INTEGER :: nnz(10) !< Number of grid intervals in z INTEGER :: nsubz=10 !< Number of sub-intervals in z INTEGER :: nr !< Total number of grid intervals in r INTEGER :: nnr(10) !< Number of grid intervals in r in each subdomain INTEGER :: nsubr=10 !< Number of sub-intervals in r + INTEGER :: nthet=0 !< Total Number of grid intervals in theta REAL(kind=db) :: dz(10) !< Cell size in z REAL(kind=db) :: dr(10) !< Cell size in r for each region + Real(kind=db) :: dthet !< Cell size in theta + REAL(kind=db) :: invdz(10), invdr(10) !< inverse of the grid cell step + Real(kind=db) :: invdthet !< inverse of the theta grid cell step REAL(kind=db), ALLOCATABLE :: zgrid(:) !< Nodes positions in longitudinal direction REAL(kind=db), ALLOCATABLE :: rgrid(:) !< Nodes positions in radial direction + REAL(kind=db), ALLOCATABLE :: thetgrid(:) !< Nodes positions in azimuthal direction REAL(kind=db) :: bnorm,enorm,vnorm,tnorm,rnorm,phinorm,qnorm !< Normalization constants - REAL(kind=db) :: qsim !< Charge of superparticles [C] - REAL(kind=db) :: msim !< Mass of superparticles [kg] - REAL(kind=db) :: partmass=me !< Mass of physical particle [kg] - INTEGER :: femorder(2) !< FEM order - INTEGER :: ngauss(2) !< Number of gauss points for FEM integration - LOGICAL :: nlppform =.TRUE. !< Defines if spline evaluation is done using ppform (faster with true) - INTEGER, SAVE :: nrank(2) !< Number of splines in both directions - REAL(kind=db) :: omegac !< yclotronic frequency at B0 [1/s] + REAL(kind=db) :: omegac !< cylotronic frequency at B0 [1/s] REAL(kind=db) :: omegap !< Plasma frequency at n0 [1/s] - REAL(kind=db) :: temp !< Initial temperature of plasma [K] for distribtype=1 - - ! If magnetfile ='' The magnetic field is one of a magnetic mirror with maximum amplitude on axis of B0 - ! and - REAL(kind=db) :: Rcurv = 1.0 !< Magnetic field curvature coefficient - REAL(kind=db) :: Width = 1.0 !< Distance between two magnetic mirrors - - REAL(kind=db) :: weights_scale=1.0 !< Scale factor for the particle weights on restart (only for newres=.true.) + INTEGER, DIMENSION(:), ALLOCATABLE :: Zbounds !< Index of bounds for local processus in Z direction for MPI decomposition - INTEGER :: bscaling = -1 !< if >0 rescale the magnetic field read from h5 file before calculating value at grid points, if <0 rescale after interpolation, if = 0 doesn't rescale - REAL(kind=db):: invdz(10), invdr(10) !< inverse of the grid cell step + CONTAINS ! !================================================================================ SUBROUTINE basic_data ! ! Define basic data ! use mpihelper USE omp_lib Use random IMPLICIT NONE ! ! Local vars and arrays CHARACTER(len=256) :: inputfilename INTEGER :: i, nbprocs ! NAMELIST /BASIC/ job_time, extra_time, nrun, tmax, dt, nlres, nlsave, newres, nlxg, & & nplasma, potinn, potout, B0, lz, n0, nz, nnz, nnr, femorder, ngauss, & & nlppform, plasmadim, radii, temp, Rcurv, width, it0d, it2d, itparts, ittext, & & resfile, rstfile, itgraph, nlPhis, distribtype, nblock, nlclassical, H0, P0, partperiodic, & & temprescale, samplefactor, nlmaxwellsource, npartsalloc, partfile, partmass, nbspecies, & & ittracer, itcelldiag, nbcelldiag, magnetfile, weights_scale, nlfreezephi, nbaddtestspecies, & - & addedtestspecfile, bscaling + & addedtestspecfile, bscaling, nthet !________________________________________________________________________________ ! 1. Process Standard Input File ! IF(COMMAND_ARGUMENT_COUNT().NE.1)THEN WRITE(*,*)'ERROR, ONE COMMAND-LINE ARGUMENT REQUIRED, STOPPING' STOP ENDIF CALL GET_COMMAND_ARGUMENT(1,inputfilename) OPEN(UNIT=lu_in,FILE=trim(inputfilename),ACTION='READ') IF(mpirank .eq. 0) THEN !________________________________________________________________________________ ! 1. Label the run ! READ(lu_in,'(a)') label1 READ(lu_in,'(a)') label2 READ(lu_in,'(a)') label3 READ(lu_in,'(a)') label4 ! WRITE(*,'(12x,a/)') label1(1:len_trim(label1)) WRITE(*,'(12x,a/)') label2(1:len_trim(label2)) WRITE(*,'(12x,a/)') label3(1:len_trim(label3)) WRITE(*,'(12x,a/)') label4(1:len_trim(label4)) !________________________________________________________________________________ ! 2. Read in basic data specific to run ! READ(lu_in,basic) WRITE(*,basic) #if _DEBUG==1 WRITE(*,*) "Compiled in debug mode" #endif ELSE READ(lu_in,basic) END IF CALL mpitypes_init ! initialize all mpi types that will be needed in the simulation WRITE(*,'(a,i4.2,a,i4.2,a)')"Running on ",mpisize," tasks with", omp_get_max_threads() ," openMP threads" + WRITE(*,*)"db given kind", db IF(samplefactor .gt. 1 .and. .not. newres) THEN IF(mpirank.eq.0) WRITE(*,*)"To increase the number of particles, you need to create a new result file (set newres to 1)" CALL MPI_abort(MPI_COMM_WORLD,-1,ierr) END IF IF (npartsalloc .lt. nplasma) THEN npartsalloc=nplasma END IF ! Total number of intervals nr=sum(nnr) if (any(nnz.gt.0)) then nz=sum(nnz) else nnz(1)=nz end if ! Normalisation constants if(nplasma .gt. 0) then qsim=pi*(plasmadim(2)-plasmadim(1))*(plasmadim(4)**2-plasmadim(3)**2)*n0*elchar/nplasma else qsim=sign(n0,elchar) end if msim=abs(qsim)/elchar*partmass vnorm=vlight omegac=sign(elchar,qsim)/partmass*B0 omegap=sqrt(elchar**2*abs(n0)/partmass/eps_0) tnorm=min(abs(1/omegac),abs(1/omegap)) rnorm=vnorm*tnorm bnorm=B0 enorm=vlight*bnorm phinorm=enorm*rnorm ! Normalised boundary conditions potinn=potinn/phinorm potout=potout/phinorm ! Normalised dt dt=dt/tnorm ! Characteristic frequencies and normalised volume IF(mpirank .eq. 0) THEN IF(abs(omegap).GT. abs(omegac)) THEN WRITE(*,'(a,3(1pe12.3))') 'omegap, omegac, omegap/omegac', omegap, omegac, omegap/omegac ELSE WRITE(*,'(a,3(1pe12.3))') 'omegap, omegac, omegac/omegap', omegap, omegac, omegac/omegap END IF END IF ! Construction of the mesh rgrid in r and zgrid in z and its normalisation CALL mesh rgrid=rgrid/rnorm zgrid=zgrid/rnorm dz=dz/rnorm dr=dr/rnorm Where(dr.gt.0) invdr=1/dr Where(dz.gt.0) invdz=1/dz !invdz=1/dz ! Initialize random number generator nbprocs = omp_get_max_threads() allocate(seed(ran_s,nbprocs), ran_index(nbprocs), ran_array(ran_k,nbprocs)) IF(.false.) then call date_and_time(time=random_seed_str) CALL MPI_BCAST(random_seed_str,10,MPI_CHARACTER,0,MPI_COMM_WORLD,ierr) write(*,*) "MPI seed:", mpirank, random_seed_str end if Do i=1,nbprocs ! Generate seed from the default seed-string in random module CALL decimal_to_seed(random_seed_str, seed(:,i)) ! Generate a different seed for each processor from the mother seed CALL next_seed(mpirank*nbprocs+i,seed(:,i)) ! Initialize the random array (first hundred numbers) CALL random_init(seed(:,i), ran_index(i), ran_array(:,i)) end do ! END SUBROUTINE basic_data !================================================================================ SUBROUTINE daytim(str) ! ! Print date and time ! IMPLICIT NONE ! CHARACTER(len=*), INTENT(in) :: str ! ! Local vars and arrays CHARACTER(len=16) :: d, t, dat, functime !________________________________________________________________________________ ! CALL DATE_AND_TIME(d,t) dat=d(7:8) // '/' // d(5:6) // '/' // d(1:4) functime=t(1:2) // ':' // t(3:4) // ':' // t(5:10) WRITE(*,'(a,1x,a,1x,a)') str, dat(1:10), functime(1:12) ! END SUBROUTINE daytim !================================================================================ SUBROUTINE timera(cntrl, str, eltime) ! ! Timers (cntrl=0/1 to Init/Update) ! IMPLICIT NONE INTEGER, INTENT(in) :: cntrl CHARACTER(len=*), INTENT(in) :: str REAL(kind=db), OPTIONAL, INTENT(out) :: eltime ! INTEGER, PARAMETER :: ncmax=128 INTEGER, SAVE :: icall=0, nc=0 REAL(kind=db), SAVE :: startt0=0.0 CHARACTER(len=16), SAVE :: which(ncmax) INTEGER :: lstr, found, i REAL(kind=db) :: seconds REAL(kind=db), DIMENSION(ncmax), SAVE :: startt = 0.0, endt = 0.0 !________________________________________________________________________________ IF( icall .EQ. 0 ) THEN icall = icall+1 startt0 = seconds() END IF lstr = LEN_TRIM(str) IF( lstr .GT. 0 ) found = loc(str) !________________________________________________________________________________ ! SELECT CASE (cntrl) ! CASE(-1) ! Current wall time IF( PRESENT(eltime) ) THEN eltime = seconds() - startt0 ELSE WRITE(*,'(/a,a,1pe10.3/)') "++ ", ' Wall time used so far = ', seconds() - startt0 END IF ! CASE(0) ! Init Timer IF( found .EQ. 0 ) THEN ! Called for the 1st time for 'str' nc = nc+1 which(nc) = str(1:lstr) found = nc END IF startt(found) = seconds() ! CASE(1) ! Update timer endt(found) = seconds() - startt(found) IF( PRESENT(eltime) ) THEN eltime = endt(found) ELSE WRITE(*,'(/a,a,1pe10.3/)') "++ "//str, ' wall clock time = ', endt(found) END IF ! CASE(2) ! Update and reset timer endt(found) = endt(found) + seconds() - startt(found) startt(found) = seconds() IF( PRESENT(eltime) ) THEN eltime = endt(found) END IF ! CASE(9) ! Display all timers IF( nc .GT. 0 ) THEN WRITE(*,'(a)') "Timer Summary" WRITE(*,'(a)') "=============" DO i=1,nc WRITE(*,'(a20,2x,2(1pe12.3))') TRIM(which(i))//":", endt(i) END DO END IF ! END SELECT ! CONTAINS INTEGER FUNCTION loc(funcstr) CHARACTER(len=*), INTENT(in) :: funcstr INTEGER :: j, ind loc = 0 DO j=1,nc ind = INDEX(which(j), funcstr(1:lstr)) IF( ind .GT. 0 .AND. LEN_TRIM(which(j)) .EQ. lstr ) THEN loc = j EXIT END IF END DO END FUNCTION loc END SUBROUTINE timera !================================================================================ !--------------------------------------------------------------------------- !> @author !> Patryk Kaminski EPFL/SPC +!> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> -!> @brief Creates the mesh in r and z direction for calculating the electric and magnetic fields. +!> @brief Creates the mesh in r, theta and z direction for calculating the electric and magnetic fields. !--------------------------------------------------------------------------- SUBROUTINE mesh INTEGER :: j,i,k - ALLOCATE(zgrid(0:nz),rgrid(0:nr)) + ALLOCATE(zgrid(0:nz),rgrid(0:nr),thetgrid(0:nthet)) !dz=(lz(2)-lz(1))/nz k=0 nsubz=count(nnz.gt.0) zgrid(0)=lz(1) do i=1,nsubz dz(i)=(lz(i+1)-lz(i))/nnz(i) if (nnz(i).gt.0) then DO j=1,nnz(i) zgrid(j+k)=lz(i)+j*dz(i) END DO end if k=k+nnz(i) end do nsubr=count(nnr.gt.0) k=0 rgrid(0)=radii(1) do i=1,nsubr dr(i)=(radii(i+1)-radii(i))/nnr(i) if (nnr(i).gt.0) then DO j=1,nnr(i) rgrid(j+k)=radii(i)+j*dr(i) END DO end if k=k+nnr(i) end do + + thetgrid(0)=0 + dthet=0.0_db + invdthet=0.0_db + if(nthet.gt.0) then + dthet=2*pi/nthet + invdthet=1/dthet + do i=1,nthet + thetgrid(i)=i*dthet + end do + end if + + END SUBROUTINE mesh END MODULE basic diff --git a/src/beam_mod.f90 b/src/beam_mod.f90 index 7e1679d..535a565 100644 --- a/src/beam_mod.f90 +++ b/src/beam_mod.f90 @@ -1,2234 +1,2235 @@ MODULE beam !------------------------------------------------------------------------------ ! EPFL/Swiss Plasma Center !------------------------------------------------------------------------------ ! ! MODULE: beam ! !> @author !> Guillaume Le Bars EPFL/SPC !> Patryk Kaminski EPFL/SPC !> Trach Minh Tran EPFL/SPC ! ! DESCRIPTION: !> Module responsible for loading, advancing and computing the necessary diagnostics for the simulated particles. !------------------------------------------------------------------------------ ! USE constants use mpi USE mpihelper USE basic, ONLY: mpirank, mpisize USE distrib USE particletypes USE weighttypes IMPLICIT NONE ! !TYPE(particles) :: parts !< Storage for all the particles !SAVE :: parts TYPE(particles), DIMENSION(:), ALLOCATABLE, SAVE :: partslist ! Diagnostics (scalars) REAL(kind=db) :: ekin=0 !< Total kinetic energy (J) REAL(kind=db) :: epot=0 !< Total potential energy (J) REAL(kind=db) :: etot=0 !< Current total energy (J) REAL(kind=db) :: etot0=0 !< Initial total energy (J) REAL(kind=db) :: loc_etot0=0 !< theoretical local total energy (J) REAL(kind=db) :: Energies(4) !< (1) kinetic energy, (2) potential energy, (3) total energy and (4) gained/lossed energy due to gain or loss of particles (J) ! INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: Nplocs_all !< Array containing the local numbers of particles in each MPI process INTERFACE add_created_part MODULE PROCEDURE add_linked_created_part, add_list_created_part END INTERFACE add_created_part ! abstract interface subroutine rloader(nbase,y,rminus,rplus) USE constants REAL(kind=db), INTENT(out) :: y(:) INTEGER, INTENT(in) :: nbase REAL(kind=db), INTENT(in) :: rplus, rminus end subroutine REAL(kind=db) FUNCTION gamma(UZ, UR, UTHET) USE constants REAL(kind=db), INTENT(IN):: UR,UZ,UTHET end FUNCTION end interface CONTAINS !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> @brief Loads the particles at the beginning of the simulation and create the parts variable if necessary !--------------------------------------------------------------------------- SUBROUTINE load_parts USE basic, ONLY: nplasma, mpirank, ierr, distribtype, nlclassical, nbspecies, partfile use mpi INTEGER:: i REAL(kind=db), DIMENSION(:), ALLOCATABLE :: VZ, VR, VTHET ALLOCATE(VZ(nplasma), VR(nplasma), VTHET(nplasma)) ! Select case to define the type of distribution SELECT CASE(distribtype) CASE(1) ! Gaussian distribution in V, uniform in Z and 1/R in R CALL loaduniformRZ(partslist(1), VR, VZ, VTHET) CASE(2) !Stable distribution from Davidson 4.95 p.119 CALL loadDavidson(partslist(1), VR, VZ, VTHET, lodunir) CASE(3) !Stable distribution from Davidson 4.95 p.119 but with constant distribution in R CALL loadDavidson(partslist(1), VR, VZ, VTHET, lodinvr) CASE(4) !Stable distribution from Davidson 4.95 p.119 but with gaussian distribution in R CALL loadDavidson(partslist(1), VR, VZ, VTHET, lodgausr) CASE(5) !Stable distribution from Davidson 4.95 p.119 with gaussian in V computed from v_th given by temp CALL loadDavidson(partslist(1), VR, VZ, VTHET, lodunir) CASE(6) ! Uniform distribution in R and Z and Gaussian distribution in V with Vz @brief Checks for each particle if the z position is outside of the local/global simulation space. !> Depending on the boundary conditions, the leaving particles are sent to the correct neighbouring MPI process !> or deleted. ! !> @param[in] p particles structure ! !> @author Guillaume Le Bars EPFL/SPC !--------------------------------------------------------------------------- SUBROUTINE bound(p) USE basic, ONLY: zgrid, nz, rgrid, nr, Zbounds, mpirank, step, leftproc, rightproc, partperiodic use omp_lib IMPLICIT NONE type(particles), INTENT(INOUT):: p INTEGER :: i,j, rsendnbparts, lsendnbparts, nblostparts INTEGER :: receivednbparts, partdiff LOGICAL:: leftcomm, rightcomm INTEGER, ALLOCATABLE:: partstoremove(:) INTEGER,allocatable :: nblost(:) allocate(nblost(size(p%nblost,1))) nblost=0 IF (p%Nploc .gt. 0) THEN ! We communicate with the left processus leftcomm = leftproc .ne. -1 ! We communicate with the right processus rightcomm = rightproc .ne. -1 ! Boundary condition at z direction !$OMP DO SIMD DO i=1,p%Nploc p%losthole(i)=0 p%sendhole(i)=0 ! If the particle is above or below the simulation domain IF(p%pos(1,i) .gt. rgrid(nr)) THEN p%losthole(i)=4 cycle else if(p%pos(1,i) .lt. rgrid(0))then p%losthole(i)=3 cycle end if ! If the particle is to the right of the local simulation space, it is sent to the right MPI process IF (p%pos(3,i) .ge. zgrid(Zbounds(mpirank+1))) THEN IF(partperiodic) THEN DO WHILE (p%pos(3,i) .GT. zgrid(nz)) p%pos(3,i) = p%pos(3,i) - zgrid(nz) + zgrid(0) END DO END IF !!$OMP CRITICAL (nbparts) IF(rightcomm) THEN p%sendhole(i)=i ELSE IF(.not. partperiodic) THEN p%losthole(i)=2 END IF !!$OMP END CRITICAL (nbparts) ! If the particle is to the left of the local simulation space, it is sent to the left MPI process ELSE IF (p%pos(3,i) .lt. zgrid(Zbounds(mpirank))) THEN IF(partperiodic) THEN DO WHILE (p%pos(3,i) .LT. zgrid(0)) p%pos(3,i) = p%pos(3,i) + zgrid(nz) - zgrid(0) END DO END IF !!$OMP CRITICAL (nbparts) IF(leftcomm) THEN ! We send the particle to the left process p%sendhole(i)=-i ELSE IF(.not. partperiodic) THEN ! we destroy the particle p%losthole(i)=1 END IF !!$OMP END CRITICAL (nbparts) END IF END DO !$OMP END DO SIMD END IF !$OMP MASTER receivednbparts=0 nblost=0 j=1 rsendnbparts=0 lsendnbparts=0 Do i=1,p%Nploc if(p%sendhole(i) .eq. 0) cycle p%sendhole(j)=p%sendhole(i) if(p%sendhole(i).gt.0)then rsendnbparts=rsendnbparts+1 else lsendnbparts=lsendnbparts+1 end if j=j+1 end do j=1 nblostparts=0 Do i=1,p%Nploc if(p%losthole(i) .eq. 0) cycle nblost(p%losthole(i))=nblost(p%losthole(i))+1 p%losthole(j)=i j=j+1 nblostparts=nblostparts+1 end do p%nblost=nblost+p%nblost IF(mpisize .gt. 1) THEN ! We send the particles leaving the local simulation space to the closest neighbour CALL particlescommunication(p, lsendnbparts, rsendnbparts, receivednbparts, (/leftproc,rightproc/)) END IF ! If the boundary conditions are not periodic, we delete the corresponding particles IF(nblostparts .gt. 0 .and. step .ne. 0) THEN DO i=1,nblostparts CALL delete_part(p, p%losthole(i), .false. ) END DO !WRITE(*,'(i8.2,a,i4.2)') nblostparts, " particles lost in z on process: ", mpirank END IF ! computes if we received less particles than we sent partdiff=max(lsendnbparts+rsendnbparts-receivednbparts,0) IF(nblostparts + partdiff .gt. 0) THEN ALLOCATE(partstoremove(nblostparts+partdiff)) partstoremove(1:partdiff)=abs(p%sendhole(receivednbparts+1:receivednbparts+partdiff)) partstoremove(partdiff+1:partdiff+nblostparts)=abs(p%losthole(1:nblostparts)) call LSDRADIXSORT(partstoremove,nblostparts + partdiff) ! If we received less particles than we sent, or lost particles we fill the remaining holes with the particles from the end of the parts arrays DO i=nblostparts+partdiff,1,-1 CALL move_part(p, p%Nploc, partstoremove(i)) p%partindex(p%Nploc)=-1 p%Nploc = p%Nploc-1 END DO deallocate(partstoremove) END IF !$OMP END MASTER deallocate(nblost) END subroutine bound !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> @brief Check if a particle is outside the simulation domain and remove it if needed !> @param[in] p particles structure !--------------------------------------------------------------------------- SUBROUTINE boundary_loss(p) USE basic, ONLY: rgrid, nr Use geometry, ONLY: geom_weight, dom_weight,is_insidegeom Use omp_lib !--------------------------------------------------------------------------- ! add below the usage of module iiee USE iiee IMPLICIT NONE type(particles), INTENT(INOUT):: p INTEGER :: i,j,isup, nblostparts, iend,nbunch INTEGER, DIMENSION(16)::idwall INTEGER :: nblost(size(p%nblost,1)), ii, Nploc_init, Nploc_new logical::inside nblost=0 nbunch=16 IF (p%Nploc .le. 0) return !$OMP DO DO i=1,p%Nploc,nbunch ! Avoid segmentation fault caused by accessing non relevant data iend=min(i+nbunch-1,p%Nploc) p%losthole(i:iend)=0 ! calculate the weight do determine if a particle is inside the simulation domain. do j=i,iend - call p_calc_rzindex(p,j) - call is_insidegeom(p%pos(3,j), p%pos(1,j),p%zindex(j),p%rindex(j),idwall(j-i+1),inside) + call p_calc_cellindex(p,j) + call is_insidegeom(p%pos(3,j), p%pos(1,j),p%cellindex(3,j),p%cellindex(1,j),idwall(j-i+1),inside) if(.not. inside) then ! If the particle is outside of the vacuum region it is deleted. p%losthole(j)=max(idwall(j-i+1),1) end if end do call geom_weight(p%pos(3,i:iend), p%pos(1,i:iend), p%geomweight(:,i:iend)) END DO !$OMP END DO NOWAIT !!$OMP critical (lostparts_red) ! p%nblost=nblost+p%nblost !!$OMP END CRITICAL (lostparts_red) !$OMP BARRIER !$OMP MASTER nblostparts=0 nblost=0 j=1 Do i=1,p%Nploc if(p%losthole(i) .eq. 0) cycle nblost(p%losthole(i)+4)=nblost(p%losthole(i)+4)+1 p%losthole(j)=i j=j+1 nblostparts=nblostparts+1 end do p%nblost=nblost+p%nblost IF(nblostparts.gt.0) THEN !call qsort(losthole,p%Nploc,sizeof(losthole(1)),compare_int) !call LSDRADIXSORT(p%losthole(1:nblostparts),nblostparts) !Write(*,'(a,60i)') "losthole: ", losthole(1:nblostparts+1) IF(p%iiee_id.gt.0) THEN Nploc_init = partslist(p%iiee_id)%Nploc CALL ion_induced(p, p%losthole, partslist(p%iiee_id), nblostparts) Nploc_new = partslist(p%iiee_id)%Nploc if (Nploc_new-Nploc_init .ge. 1) then DO ii =Nploc_init+1,Nploc_new - Call p_calc_rzindex(partslist(p%iiee_id),ii) + Call p_calc_cellindex(partslist(p%iiee_id),ii) call geom_weight(partslist(p%iiee_id)%pos(3,ii), partslist(p%iiee_id)%pos(1,ii), partslist(p%iiee_id)%geomweight(:,ii)) END DO end if !---------------------------------------------------------- ! CALL ion_induced(p,losthole,partslist(indpelec)) ! here we call our routine to create electrons out of ! eliminated ions. ! need to define in this file: indpelec (need not to since) ! we have the index p%iiee_id !---------------------------------------------------------- END IF DO i=nblostparts,1,-1 CALL delete_part(p,p%losthole(i)) END DO END IF !$OMP END MASTER !$OMP BARRIER END SUBROUTINE boundary_loss !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> @brief Computes the radial and axial cell index of the particle i !> @param[in] p particles structure !> @param[in] i index in p of the particle !--------------------------------------------------------------------------- -subroutine p_calc_rzindex(p,i) - use basic, only: rgrid,zgrid,invdz,invdr, nnr, nsubr,nsubz, nnz +subroutine p_calc_cellindex(p,i) + use basic, only: rgrid,zgrid,invdz,invdr, nnr, nsubr,nsubz, nnz, invdthet integer::i,j,k type(particles)::p k=0 do j=1,nsubr IF (p%pos(1,i) .GT. rgrid(k) .AND. p%pos(1,i) .LT. rgrid(k+nnr(j))) THEN - p%rindex(i)=floor((p%pos(1,i)-rgrid(k))*invdr(j))+k + p%cellindex(1,i)=floor((p%pos(1,i)-rgrid(k))*invdr(j))+k exit end if k=k+nnr(j) end do k=0 do j=1,nsubz IF (p%pos(3,i) .GT. zgrid(k) .AND. p%pos(3,i) .LT. zgrid(k+nnz(j))) THEN - p%zindex(i)=floor((p%pos(3,i)-zgrid(k))*invdz(j))+k + p%cellindex(3,i)=floor((p%pos(3,i)-zgrid(k))*invdz(j))+k exit end if k=k+nnz(j) end do + p%cellindex(2,i)=floor(p%pos(2,i)*invdthet) !p%zindex(i)=floor((p%Z(i)-zgrid(0))*invdz) -end subroutine p_calc_rzindex +end subroutine p_calc_cellindex !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> @brief Computes the magnetic field amplitude at each particle position interpolated from the magnetic field at the closeset grid point !> @param[in] p particles structure !--------------------------------------------------------------------------- SUBROUTINE comp_mag_p(p) USE basic, ONLY: zgrid, rgrid, BZ, BR, nz, invdz type(particles), INTENT(INOUT):: p INTEGER :: i Real(kind=db):: WZ,WR INTEGER:: j1,j2,j3,j4 !$OMP DO SIMD DO i=1,p%Nploc - WZ=(p%pos(3,i)-zgrid(p%zindex(i)))/(zgrid(p%zindex(i)+1)-zgrid(p%zindex(i))); - WR=(p%pos(1,i)-rgrid(p%rindex(i)))/(rgrid(p%rindex(i)+1)-rgrid(p%rindex(i))); - J1=(p%rindex(i))*(nz+1) + p%zindex(i)+1 - J2=(p%rindex(i))*(nz+1) + p%zindex(i)+2 - J3=(p%rindex(i)+1)*(nz+1)+p%zindex(i)+1 - J4=(p%rindex(i)+1)*(nz+1)+p%zindex(i)+2 + WZ=(p%pos(3,i)-zgrid(p%cellindex(3,i)))/(zgrid(p%cellindex(3,i)+1)-zgrid(p%cellindex(3,i))); + WR=(p%pos(1,i)-rgrid(p%cellindex(1,i)))/(rgrid(p%cellindex(1,i)+1)-rgrid(p%cellindex(1,i))); + J1=(p%cellindex(1,i))*(nz+1) + p%cellindex(3,i)+1 + J2=(p%cellindex(1,i))*(nz+1) + p%cellindex(3,i)+2 + J3=(p%cellindex(1,i)+1)*(nz+1)+p%cellindex(3,i)+1 + J4=(p%cellindex(1,i)+1)*(nz+1)+p%cellindex(3,i)+2 ! Interpolation for magnetic field p%B(2,i)=(1-WZ)*(1-WR)*Bz(J4) & & +WZ*(1-WR)*Bz(J3) & & +(1-WZ)*WR*Bz(J2) & & +WZ*WR*Bz(J1) p%B(1,i)=(1-WZ)*(1-WR)*Br(J4) & & +WZ*(1-WR)*Br(J3) & & +(1-WZ)*WR*Br(J2) & & +WZ*WR*Br(J1) END DO !$OMP END DO SIMD NOWAIT end subroutine comp_mag_p !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Routine used to compute the lorentz factor \f$\gamma\f$ in the classical simulations. !> This routine systematically returns 1.0 to treat the system according to classical dynamic. ! !> @param[out] gamma the lorentz factor \f$\gamma\f$ !> @param[in] UZ \f$\gamma\beta_z=\gamma v_z/c\f$ the normalized particle longitudinal velocity !> @param[in] UR \f$\gamma\beta_r=\gamma v_r/c\f$ the normalized particle radial velocity !> @param[in] UTHET \f$\gamma\beta_\theta=\gamma v_\theta/c\f$ the normalized particle azimuthal velocity !--------------------------------------------------------------------------- REAL(kind=db) FUNCTION gamma_classical(UZ, UR, UTHET) !!#if __INTEL_COMPILER > 1700 !$OMP declare simd(gamma_classical) !!#endif REAL(kind=db), INTENT(IN):: UR,UZ,UTHET gamma_classical=1.0 END FUNCTION gamma_classical !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> @brief Routine used to compute the lorentz factor \f$\gamma\f$ in the relativistic simulations. !> This routine computes the Lorentz factor \f$\gamma=\sqrt{1+\mathbf{\gamma\beta}^2}\f$ ! !> @param[out] gamma the lorentz factor \f$\gamma\f$ !> @param[in] UZ \f$\gamma\beta_z=\gamma v_z/c\f$ the normalized particle longitudinal velocity !> @param[in] UR \f$\gamma\beta_r=\gamma v_r/c\f$ the normalized particle radial velocity !> @param[in] UTHET \f$\gamma\beta_\theta=\gamma v_\theta/c\f$ the normalized particle azimuthal velocity !--------------------------------------------------------------------------- REAL(kind=db) FUNCTION gamma_relativistic(UZ, UR, UTHET) !!#if __INTEL_COMPILER > 1700 !$OMP declare simd(gamma_relativistic) !!#endif REAL(kind=db), INTENT(IN):: UR,UZ,UTHET gamma_relativistic=sqrt(1+UZ**2+UR**2+UTHET**2) END FUNCTION gamma_relativistic !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> @brief General routine to compute the velocities at time t+1. !> This routine allows to treat the classical and relativistic case efficiently from a numerical standpoint, !> by using a pointer to the routine computing gamma. This avoid the nlclassical flag check on each particle. ! !> @param[in] p The particles structure being updated !--------------------------------------------------------------------------- SUBROUTINE comp_velocity(p) ! ! Computes the new velocity of the particles due to Lorentz force ! USE basic, ONLY : nlclassical type(particles), INTENT(INOUT):: p ! Store old Velocities !CALL swappointer(p%UZold, p%UZ) !$OMP master CALL swappointer2(p%Uold, p%U) !CALL swappointer(p%UTHETold, p%UTHET) CALL swappointer(p%Gammaold, p%Gamma) !$OMP end master !$OMP BARRIER IF (nlclassical) THEN CALL comp_velocity_fun(p, gamma_classical) ELSE CALL comp_velocity_fun(p, gamma_relativistic) END IF END SUBROUTINE comp_velocity !--------------------------------------------------------------------------- !> @author !> Patryk Kaminski EPFL/SPC !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> @brief Routine called by comp_velocity to compute the velocities at time t+1. !> This routine allows to treat the classical and relativistic case efficiently from a numerical standpoint, !> by using the routine computing gamma as an input. This avoid the nlclassical flag check on each particle. ! !> @param[in] gamma the function used to compute the value of the lorentz factor \f$\gamma\f$ !> @param[in] p The particles structure being updated !--------------------------------------------------------------------------- SUBROUTINE comp_velocity_fun(p, gammafun) ! ! Computes the new velocity of the particles due to Lorentz force ! USE basic, ONLY : bnorm, dt, tnorm procedure(gamma)::gammafun type(particles), INTENT(INOUT):: p REAL(kind=db) :: tau REAL(kind=db):: BRZ, BRR, ZBR, ZBZ, ZPR, ZPZ, ZPTHET, SQR, ZBZ2, ZBR2 INTEGER:: J1, J2, J3, J4 INTEGER:: i ! Normalized time increment tau=p%qmRatio*bnorm*0.5*dt*tnorm IF (p%Nploc .NE. 0) THEN !$OMP DO SIMD DO i=1,p%Nploc ! First half of electric pulse p%U(3,i)=p%Uold(3,i)+p%E(2,i)*tau p%U(1,i)=p%Uold(1,i)+p%E(1,i)*tau p%Gamma(i)=gammafun(p%U(3,i), p%U(1,i), p%Uold(2,i)) ! Rotation along magnetic field ZBZ=tau*p%B(2,i)/p%Gamma(i) ZBR=tau*p%B(1,i)/p%Gamma(i) ZPZ=p%U(3,i)-ZBR*p%Uold(2,i) !u'_{z} ZPR=p%U(1,i)+ZBZ*p%Uold(2,i) !u'_{r} ZPTHET=p%Uold(2,i)+(ZBR*p%U(3,i)-ZBZ*p%U(1,i)) !u'_{theta} SQR=1+ZBZ*ZBZ+ZBR*ZBR ZBZ2=2*ZBZ/SQR ZBR2=2*ZBR/SQR p%U(3,i)=p%U(3,i)-ZBR2*ZPTHET !u+_{z} p%U(1,i)=p%U(1,i)+ZBZ2*ZPTHET !u+_{r} p%U(2,i)=p%Uold(2,i)+(ZBR2*ZPZ-ZBZ2*ZPR) !u+_{theta} ! Second half of acceleration p%U(3,i)=p%U(3,i)+p%E(2,i)*tau p%U(1,i)=p%U(1,i)+p%E(1,i)*tau ! Final computation of the Lorentz factor p%Gamma(i)=gammafun(p%U(3,i), p%U(1,i), p%U(2,i)) END DO !$OMP END DO SIMD NOWAIT END IF p%collected=.false. END SUBROUTINE comp_velocity_fun !--------------------------------------------------------------------------- !> @author !> Patryk Kaminski EPFL/SPC !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> @brief Routine called by comp_velocity to compute the velocities at time t+1. !> This routine allows to treat the classical and relativistic case efficiently from a numerical standpoint, !> by using the routine computing gamma as an input. This avoid the nlclassical flag check on each particle. ! !> @param[in] gamma the function used to compute the value of the lorentz factor \f$\gamma\f$ !> @param[in] p The particles structure being updated !--------------------------------------------------------------------------- SUBROUTINE comp_velocity_fun3d(p, gammafun) ! ! Computes the new velocity of the particles due to Lorentz force ! USE basic, ONLY : bnorm, dt, tnorm procedure(gamma)::gammafun type(particles), INTENT(INOUT):: p REAL(kind=db) :: tau REAL(kind=db):: BRZ, BRR, ZBR, ZBZ, ZPR, ZPZ, ZPTHET, SQR, ZBZ2, ZBR2 INTEGER:: J1, J2, J3, J4 INTEGER:: i ! Normalized time increment tau=p%qmRatio*bnorm*0.5*dt*tnorm IF (p%Nploc .NE. 0) THEN !$OMP DO SIMD DO i=1,p%Nploc ! First half of electric pulse p%U(3,i)=p%Uold(3,i)+p%E(3,i)*tau p%U(2,i)=p%Uold(2,i)+p%E(2,i)*tau p%U(1,i)=p%Uold(1,i)+p%E(1,i)*tau p%Gamma(i)=gammafun(p%U(3,i), p%U(1,i), p%Uold(2,i)) ! Rotation along magnetic field ZBZ=tau*p%B(2,i)/p%Gamma(i) ZBR=tau*p%B(1,i)/p%Gamma(i) ZPZ=p%U(3,i)-ZBR*p%Uold(2,i) !u'_{z} ZPR=p%U(1,i)+ZBZ*p%Uold(2,i) !u'_{r} ZPTHET=p%Uold(2,i)+(ZBR*p%U(3,i)-ZBZ*p%U(1,i)) !u'_{theta} SQR=1+ZBZ*ZBZ+ZBR*ZBR ZBZ2=2*ZBZ/SQR ZBR2=2*ZBR/SQR p%U(3,i)=p%U(3,i)-ZBR2*ZPTHET !u+_{z} p%U(1,i)=p%U(1,i)+ZBZ2*ZPTHET !u+_{r} p%U(2,i)=p%Uold(2,i)+(ZBR2*ZPZ-ZBZ2*ZPR) !u+_{theta} ! Second half of acceleration p%U(3,i)=p%U(3,i)+p%E(3,i)*tau p%U(2,i)=p%U(2,i)+p%E(2,i)*tau p%U(1,i)=p%U(1,i)+p%E(1,i)*tau ! Final computation of the Lorentz factor p%Gamma(i)=gammafun(p%U(3,i), p%U(1,i), p%U(2,i)) END DO !$OMP END DO SIMD NOWAIT END IF p%collected=.false. END SUBROUTINE comp_velocity_fun3d !--------------------------------------------------------------------------- !> @author !> Patryk Kaminski EPFL/SPC !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Computes the particles position at time t+1 !> This routine computes the particles position at time t+1 according to the Bunemann algorithm. ! !> @param[in] p The particles structure being updated !--------------------------------------------------------------------------- SUBROUTINE push(p) Use basic, ONLY: dt type(particles), INTENT(INOUT):: p REAL(kind=db):: XP, YP, COSA, SINA, U1, U2, ALPHA INTEGER :: i IF (p%Nploc .NE. 0) THEN !!$OMP PARALLEL DO SIMD DEFAULT(SHARED) PRIVATE(XP, YP, COSA, SINA, U1, U2, ALPHA) !$OMP DO SIMD DO i=1,p%Nploc ! Local Cartesian coordinates XP=p%pos(1,i)+dt*p%U(1,i)/p%Gamma(i) YP=dt*p%U(2,i)/p%Gamma(i) ! Conversion to cylindrical coordiantes p%pos(3,i)=p%pos(3,i)+dt*p%U(3,i)/p%Gamma(i) p%pos(1,i)=sqrt(XP**2+YP**2) ! Computation of the rotation angle IF (p%pos(1,i) .EQ. 0) THEN COSA=1 SINA=0 ALPHA=0 ELSE COSA=XP/p%pos(1,i) SINA=YP/p%pos(1,i) ALPHA=asin(SINA) END IF ! New azimuthal position p%pos(2,i)=MOD(p%pos(2,i)+ALPHA,2*pi) ! Velocity in rotated reference frame U1=COSA*p%U(1,i)+SINA*p%U(2,i) U2=-SINA*p%U(1,i)+COSA*p%U(2,i) p%U(1,i)=U1 p%U(2,i)=U2 END DO !$OMP END DO SIMD NOWAIT END IF !$OMP SINGLE p%collected=.false. !$OMP END SINGLE NOWAIT END SUBROUTINE push !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Computes several diagnostic quantities !> This routine computes the total kinetic and electric potential energy. !> It keeps track of the reference energy and the number of particle per mpi node. ! !--------------------------------------------------------------------------- SUBROUTINE partdiagnostics ! ! Compute energies ! USE constants, ONLY: vlight USE basic, ONLY: phinorm, cstep, nlclassical, ierr, nbspecies INTEGER:: i,j ! Reset the quantities !$OMP SINGLE ekin=0 epot=0 etot=0 !$OMP END SINGLE NOWAIT ! Computation of the kinetic and potential energy as well as fluid velocities and density !!$OMP PARALLEL DO REDUCTION(+:epot, ekin) DEFAULT(SHARED), PRIVATE(i,j) Do j=1,nbspecies if(.not. partslist(j)%is_field) CYCLE !$OMP DO reduction(+:epot,ekin) DO i=1,partslist(j)%Nploc ! Potential energy epot=epot+(partslist(j)%pot(i)+partslist(j)%potxt(i))*partslist(j)%q*partslist(j)%weight ! Kinetic energy IF(.not. nlclassical) THEN ekin=ekin+(0.5*(partslist(j)%Gammaold(i)+partslist(j)%Gamma(i))-1)*partslist(j)%m*partslist(j)%weight ELSE ekin=ekin+0.5*( partslist(j)%U(1,i)*partslist(j)%Uold(1,i) & & + partslist(j)%U(3,i)*partslist(j)%Uold(3,i) & & + partslist(j)%U(2,i)*partslist(j)%Uold(2,i) )*partslist(j)%m*partslist(j)%weight END IF END DO !$OMP END DO NOWAIT END DO !$OMP BARRIER !$OMP MASTER !!$OMP END PARALLEL DO epot=epot*phinorm*0.5 ekin=ekin*vlight**2 ! Shift to Etot at cstep=1 (not valable yet at cstep=0!) IF(cstep.EQ. 1) THEN ! Compute the local total energy loc_etot0 = epot+ekin etot0=0 END IF ! Compute the total energy etot=epot+ekin Energies=(/ekin,epot,etot,loc_etot0/) ! The computed energy is sent to the root process IF(mpisize .gt.1) THEN IF(mpirank .eq.0 ) THEN CALL MPI_REDUCE(MPI_IN_PLACE, Energies, 4, db_type, db_sum_op, & & 0, MPI_COMM_WORLD, ierr) etot0=etot0+Energies(4) ekin=Energies(1) epot=Energies(2) etot=Energies(3) ELSE CALL MPI_REDUCE(Energies, Energies, 4, db_type, db_sum_op, & & 0, MPI_COMM_WORLD, ierr) END IF ELSE etot0=etot0+loc_etot0 END IF loc_etot0=0 ! Send the local number of particles on each node to the root process IF(mpisize .gt. 1) THEN Nplocs_all(mpirank)=partslist(1)%Nploc IF(mpirank .eq.0 ) THEN CALL MPI_gather(MPI_IN_PLACE, 1, MPI_INTEGER, Nplocs_all, 1, MPI_INTEGER,& & 0, MPI_COMM_WORLD, ierr) !CALL MPI_REDUCE(MPI_IN_PLACE,partslist(1)%nudcol,3,db_type,db_sum_op,0,MPI_COMM_WORLD,ierr) partslist(1)%Nptot=sum(Nplocs_all) !partslist(1)%nudcol=partslist(1)%nudcol/partslist(1)%Nptot ELSE CALL MPI_gather(Nplocs_all(mpirank), 1, MPI_INTEGER, Nplocs_all, 1, MPI_INTEGER,& & 0, MPI_COMM_WORLD, ierr) !CALL MPI_REDUCE(partslist(1)%nudcol,partslist(1)%nudcol,3,db_type,db_sum_op,0,MPI_COMM_WORLD,ierr) END IF ELSE partslist(1)%Nptot=partslist(1)%Nploc END IF !$OMP END MASTER !$OMP BARRIER end subroutine partdiagnostics !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> @brief Collect the particles positions and velocities on the root process. !> If the collection has already been performed at this time step, the routine does nothing. ! !--------------------------------------------------------------------------- SUBROUTINE collectparts(p) USE basic, ONLY: mpirank, mpisize, ierr type(particles), INTENT(INOUT):: p INTEGER, DIMENSION(:), ALLOCATABLE :: displs, Nploc INTEGER:: i INTEGER:: particles_type(mpisize-1) !< Stores the MPI data type used for particles gathering on node 0 and broadcast from node 0 INTEGER :: part_requests(mpisize-1) INTEGER:: stats(MPI_STATUS_SIZE,mpisize-1) part_requests=MPI_REQUEST_NULL particles_type=MPI_DATATYPE_NULL IF(p%collected) RETURN ! exit subroutine if particles have already been collected during this time step ALLOCATE(Nploc(0:mpisize-1)) ALLOCATE(displs(0:mpisize-1)) displs=0 Nploc(mpirank)=p%Nploc CALL MPI_Allgather(MPI_IN_PLACE, 1, MPI_INTEGER, Nploc, 1, MPI_INTEGER,& & MPI_COMM_WORLD, ierr) p%Nptot=sum(Nploc) IF(p%Nptot .eq. 0 ) THEN p%partindex=-1 p%collected=.true. RETURN END IF Do i=1,mpisize-1 displs(i)=displs(i-1)+Nploc(i-1) END DO IF(mpirank.eq.0 .and. p%Nptot .gt. size(p%pos,2)) THEN CALL change_parts_allocation(p,max(p%Nptot-size(P%pos,2),floor(0.5*size(P%pos,2)))) END IF IF(mpirank .ne. 0) THEN if(Nploc(mpirank) .gt. 0) THEN Call init_particles_gather_mpi(p,1,Nploc(mpirank),particles_type(mpirank)) ! Send Particles informations to root process CALL MPI_SEND(p, 1, particles_type(mpirank), 0, partsgather_tag, MPI_COMM_WORLD, ierr) CALL MPI_TYPE_FREE(particles_type(mpirank),ierr) END IF ELSE ! Receive particle information from all processes DO i=1,mpisize-1 if(Nploc(i) .lt. 1) cycle Call init_particles_gather_mpi(p,displs(i)+1,Nploc(i),particles_type(i)) CALL MPI_IRECV(p,1,particles_type(i),i,partsgather_tag,MPI_COMM_WORLD, part_requests(i), ierr) END DO CALL MPI_WAITALL(mpisize-1,part_requests, stats, ierr) p%partindex(sum(Nploc)+1:)=-1 Do i=1,mpisize-1 if(Nploc(i) .lt. 1) cycle CALL MPI_TYPE_FREE(particles_type(i),ierr) END DO END IF p%collected=.TRUE. END SUBROUTINE collectparts !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> @brief Computes the velocities at time t-1/2 delta t to keep the second order precision in time on the velocity. !> This should only be used at particle initialisation time, ot in the case of a restart. ! !--------------------------------------------------------------------------- SUBROUTINE adapt_vinit(p) !! Computes the velocity at time -dt/2 from velocities computed at time 0 ! USE basic, ONLY : bnorm, dt, tnorm, nlclassical, phinorm, distribtype, vnorm type(particles), INTENT(INOUT):: p REAL(kind=db) :: tau, BRZ, BRR, ZBR, ZBZ, ZPR, ZPZ, ZPTHET, & & SQR, Vperp, v2 INTEGER :: i REAL(kind=db), DIMENSION(:), ALLOCATABLE :: VZ, VR, VTHET ! In case Davidson distribution is used the longitudinal and radial velocities are adapted to take into account the ! electric potential. IF(distribtype .EQ. 2 .OR. distribtype .EQ. 3 .OR. distribtype .EQ. 4 .or. p%Davidson) THEN ALLOCATE(VR(p%Nploc),VZ(p%Nploc),VTHET(p%Nploc)) CALL loduni(7,VZ) VZ=VZ*2*pi VTHET=p%U(2,:)/p%Gamma*vnorm DO i=1,p%Nploc Vperp=sqrt(MAX(2*p%H0/p%m-2*p%qmRatio*p%pot(i)*phinorm-VTHET(i)**2,0.0_db)) VR(i)=Vperp*sin(VZ(i)) VZ(i)=Vperp*cos(VZ(i)) IF(nlclassical) THEN p%Gamma(i)=1 ELSE v2=VR(i)**2+VZ(i)**2+VTHET(i)**2 p%Gamma(i)=sqrt(1/(1-v2/vnorm**2)) END IF p%U(1,i)=p%Gamma(i)*VR(i)/vnorm p%U(3,i)=p%Gamma(i)*VZ(i)/vnorm p%U(2,i)=p%Gamma(i)*VTHET(i)/vnorm END DO DEALLOCATE(VR,VZ,VTHET) END IF ! Normalised time increment !tau=-omegac/2/omegap*dt/tnorm tau=-p%qmRatio*bnorm*0.5*dt*tnorm ! Store old Velocities CALL swappointer2(p%Uold, p%U) !CALL swappointer(p%URold, p%UR) !CALL swappointer(p%UTHETold, p%UTHET) CALL swappointer(p%Gammaold, p%Gamma) IF (p%Nploc .NE. 0) THEN !$OMP PARALLEL DO SIMD DEFAULT(SHARED) PRIVATE(BRZ, BRR, ZBR, ZBZ, ZPR, ZPZ, ZPTHET, SQR) DO i=1,p%Nploc ! Half inverse Rotation along magnetic field ZBZ=tau*p%B(2,i)/p%Gammaold(i) ZBR=tau*p%B(1,i)/p%Gammaold(i) SQR=1+ZBZ*ZBZ+ZBR*ZBR ZPZ=(p%Uold(3,i)-ZBR*p%Uold(2,i))/SQR !u-_{z} ZPR=(p%Uold(1,i)+ZBZ*p%Uold(2,i))/SQR !u-_{r} ZPTHET=p%Uold(2,i)+(ZBR*p%Uold(3,i)-ZBZ*p%Uold(1,i))/SQR !u-_{theta} p%U(3,i)=ZPZ p%U(1,i)=ZPR p%U(2,i)=ZPTHET ! half of decceleration p%U(3,i)=p%U(3,i)+p%E(2,i)*tau p%U(1,i)=p%U(1,i)+p%E(1,i)*tau IF(.not. nlclassical) THEN p%Gamma(i)=sqrt(1+p%U(3,i)**2+p%U(1,i)**2+p%U(2,i)**2) END IF END DO !$OMP END PARALLEL DO SIMD END IF END SUBROUTINE adapt_vinit !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> @brief Calculates the number of particles per column of the spatial grid ( at fixed axial cell position) !> This facilitate the computation of the axial grid limits for each MPI worker ! !--------------------------------------------------------------------------- SUBROUTINE calcnbperz(p,nbperz) USE basic, only: nz IMPLICIT NONE type(particles):: p INTEGER, INTENT(INOUT):: nbperz(0:) Integer::i, zindex nbperz=0 !! $OMP PARALLEL DO DEFAULT(SHARED) reduction(+:nbperz), private(zindex,i) Do i=1,p%Nploc ! we make sure zindex is in [0, nz-1] to avoid segmentation faults - zindex=min(nz-1,max(p%zindex(i),0)) + zindex=min(nz-1,max(p%cellindex(3,i),0)) nbperz(zindex)=nbperz(zindex)+1 END DO !! $OMP END PARALLEL DO END SUBROUTINE calcnbperz !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> @brief In the case of MPI parallelism, computes the axial limits of the local domain. !--------------------------------------------------------------------------- SUBROUTINE calc_Zbounds(p, Zbounds, norder) ! Computes the start and end indices for the Z boundaries on local processus ! Computes the particle indices from initial particle loading vector, that stay in current process USE basic, ONLY: nz, cstep, mpirank, mpisize,step USE mpihelper TYPE(particles), INTENT(INOUT):: p INTEGER:: Zbounds(0:) INTEGER:: norder(2) INTEGER:: old_Zbounds(0:size(Zbounds,1)-1) INTEGER:: k, i, nbparts REAL(kind=db):: idealnbpartsperproc INTEGER, DIMENSION(0:nz-1):: partspercol ! Vector containing the number of particles between zgrid(n) and zgrid(n+1) INTEGER:: Zmin, Zmax ! Minimum and maximum indices of particles in Z direction INTEGER:: Zperproc, ierr, remparts CHARACTER(12)::fmt ! calculatese the axial disstibution integrated along the radial direction call calcnbperz(p,partspercol) ! gather this data on all nodes if(step .gt. 0 .and. mpisize .gt. 1) THEN old_Zbounds=Zbounds CALL MPI_ALLREDUCE(MPI_IN_PLACE, partspercol, nz, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierr) END IF ! estimate the ideal number of particle per MPI worker idealnbpartsperproc = p%Nptot/mpisize ! find the start and end indices where particles are present Zmin=0 Zmax=nz-1 Do k=0,nz-1 if(partspercol(k) .gt.0) then Zmin=k exit end if end do Do k=nz-1,0,-1 if(partspercol(k) .gt.0) then Zmax=k exit end if end do ! Find naive axial limits assuming uniform axial distribution IF(Zmax .le. 0) Zmax=nz-1 IF(Zmin .gt. nz) Zmin=0 Zperproc=(Zmax-Zmin)/mpisize IF (Zperproc .lt. 1 .or. cstep .eq. 0) THEN !! No particles are present initially Zperproc=nz/mpisize Zmin=0 ! Define boundaries using naive guess on start or restart (allow to start with 0 parts) DO k=1,mpisize-1 IF(k .lt. mpisize-1-MODULO(Zmax-Zmin,mpisize)) THEN Zbounds(k)=Zmin+k*Zperproc-1 ELSE Zbounds(k)=Zmin+k*Zperproc-1+k-mpisize+2+MODULO(Zmax-Zmin,mpisize) END IF END DO ELSE i=0 ! Define axial boundaries using the axial distribution information. ! the subdomains are not equal remparts=p%Nptot DO k=1,mpisize-1 nbparts=0 DO WHILE(nbparts<0.98*idealnbpartsperproc .and. i .lt. Zmax .and. (nbparts+partspercol(i)).lt.1.25*idealnbpartsperproc) nbparts=nbparts+partspercol(i) i=i+1 END DO remparts=remparts-nbparts Zbounds(k)=i END DO END IF IF(step .gt. 0 .and. mpirank .eq. 0) THEN Do i=1,mpisize-1 !We check that the new limits will not exceed the old limits of the left and right process ! This avoids particle communications with process >mpirank+2 and < mpirank-2 ! However this should converge over time IF(Zbounds(i) .lt. old_Zbounds(i-1)) Zbounds(i)=old_Zbounds(i-1) if(Zbounds(i) .gt. old_Zbounds(i+1))Zbounds(i)=old_Zbounds(i+1) ! If a process would have an axial domain shoter than axial norder, we revert to the old boundaries. IF((Zbounds(i)-Zbounds(i-1)).lt. norder(1) .or. (Zbounds(i+1)-Zbounds(i)).lt. norder(1)) THEN Zbounds=old_Zbounds EXIT END IF END DO END IF ! send the new boundaries to all the workers CALL MPI_Bcast(Zbounds,mpisize+1,MPI_INTEGER,0,MPI_COMM_WORLD, ierr) DO k=0,mpisize-1 Nplocs_all(k)=SUM(partspercol(Zbounds(k):Zbounds(k+1)-1)) END DO if(mpirank .eq. 0) THEN WRITE(fmt,'(a,i3,a)')"(a,",mpisize+1, "i5)" WRITE(*,fmt) "Zbounds: ", Zbounds WRITE(fmt,'(a,i3,a)')"(a,",mpisize, "i8)" WRITE(*,fmt) "Nplocs: ", Nplocs_all END IF END SUBROUTINE calc_Zbounds !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> @brief After a restart keep only the particles in the local domain of the current MPI worker !--------------------------------------------------------------------------- SUBROUTINE keep_mpi_self_parts(p,Zbounds) TYPE(particles),INTENT(INOUT):: p INTEGER,INTENT(in)::Zbounds(0:) INTEGER :: i, partstart, old_sum,ierr partstart=1 p%Nploc=0 Do i=1,p%Nptot - IF(p%Zindex(i).ge.Zbounds(mpirank).and.p%Zindex(i).lt.Zbounds(mpirank+1)) THEN + IF(p%cellindex(3,i) .ge.Zbounds(mpirank).and.p%cellindex(3,i).lt.Zbounds(mpirank+1)) THEN p%Nploc=p%Nploc+1 CALL move_part(p,i,p%Nploc) END IF END DO old_sum=p%Nptot CALL MPI_REDUCE(p%Nploc, p%Nptot,1,MPI_INTEGER, MPI_SUM, 0, MPI_COMM_WORLD, ierr) IF(p%Nptot .ne. old_sum) THEN WRITE(*,*) "Error in particle distribution kept: ", p%Nptot, "/",old_sum !call MPI_Abort(MPI_COMM_WORLD, -1, ierr) !stop END IF END SUBROUTINE keep_mpi_self_parts !_______________________________________________________________________________ !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Manage the particle communication between neighbours. !> This routine is responsible to receive the incoming particles from the MPI neighbours and to send its outgoing !> particles to these neighbours ! !> @param [in] lsendnbparts number of particles to send to the left neighbour (mpirank-1) !> @param [in] rsendnbparts number of particles to send to the right neighbour (mpirank+1) !--------------------------------------------------------------------------- SUBROUTINE particlescommunication(p, lsendnbparts, rsendnbparts, receivednbparts, procs) USE mpihelper, ONLY: particle_type #ifdef _DEBUG USE basic, ONLY: step #endif type(particles), INTENT(INOUT):: p INTEGER, INTENT(inout) :: lsendnbparts, rsendnbparts INTEGER, INTENT(out) :: receivednbparts INTEGER, INTENT(in) :: procs(2) INTEGER :: rrecvnbparts=0, lrecvnbparts=0 INTEGER :: sendrequest(2), recvrequest(2) INTEGER :: sendstatus(MPI_STATUS_SIZE,2), recvstatus(MPI_STATUS_SIZE,2) TYPE(particle), ALLOCATABLE :: rrecvpartbuff(:), lrecvpartbuff(:), rsendpartbuff(:), lsendpartbuff(:) ! buffers to send and receive particle from left and right processes INTEGER :: lsentnbparts, rsentnbparts INTEGER :: lreceivednbparts, rreceivednbparts, ierr lsentnbparts=lsendnbparts rsentnbparts=rsendnbparts sendrequest=MPI_REQUEST_NULL recvrequest=MPI_REQUEST_NULL lrecvnbparts=0 rrecvnbparts=0 ! Send and receive the number of particles to exchange CALL MPI_IRECV(lrecvnbparts, 1, MPI_INTEGER, procs(1), nbpartsexchange_tag, MPI_COMM_WORLD, recvrequest(1), ierr) CALL MPI_IRECV(rrecvnbparts, 1, MPI_INTEGER, procs(2), nbpartsexchange_tag, MPI_COMM_WORLD, recvrequest(2), ierr) CALL MPI_ISEND(lsentnbparts, 1, MPI_INTEGER, procs(1), nbpartsexchange_tag, MPI_COMM_WORLD, sendrequest(1), ierr) CALL MPI_ISEND(rsentnbparts, 1, MPI_INTEGER, procs(2), nbpartsexchange_tag, MPI_COMM_WORLD, sendrequest(2), ierr) CALL MPI_Waitall(2,recvrequest(1:2), recvstatus(:,1:2), ierr) recvrequest=MPI_REQUEST_NULL lreceivednbparts=lrecvnbparts rreceivednbparts=rrecvnbparts ! Re/allocate enough memory to store the incoming particles ALLOCATE(rrecvpartbuff(rreceivednbparts)) ALLOCATE(lrecvpartbuff(lreceivednbparts)) ! Receive particles from left and right processes to the corresponding buffers IF ( lrecvnbparts .gt. 0) THEN CALL MPI_IRECV(lrecvpartbuff, lreceivednbparts, particle_type, procs(1), partsexchange_tag, MPI_COMM_WORLD, recvrequest(1), ierr) END IF IF( rrecvnbparts .gt. 0) THEN CALL MPI_IRECV(rrecvpartbuff, rreceivednbparts, particle_type, procs(2), partsexchange_tag, MPI_COMM_WORLD, recvrequest(2), ierr) END IF ALLOCATE(rsendpartbuff(rsendnbparts)) ALLOCATE(lsendpartbuff(lsendnbparts)) ! Copy the leaving particles to the corresponding send buffers IF ( (lsendnbparts + rsendnbparts) .gt. 0) THEN CALL AddPartSendBuffers(p, lsendnbparts, rsendnbparts, lsendpartbuff, rsendpartbuff) END IF CALL MPI_Waitall(2,sendrequest(1:2), sendstatus(:,1:2), ierr) ! Send the particles to the left and right neighbours IF( lsendnbparts .gt. 0) THEN CALL MPI_ISEND(lsendpartbuff, lsendnbparts, particle_type, procs(1), partsexchange_tag, MPI_COMM_WORLD, sendrequest(1), ierr) #ifdef _DEBUG !WRITE(*,*)"snding ", lsendnbparts , " to left at step: ",step #endif END IF IF( rsendnbparts .gt. 0) THEN CALL MPI_ISEND(rsendpartbuff, rsendnbparts, particle_type, procs(2), partsexchange_tag, MPI_COMM_WORLD, sendrequest(2), ierr) #ifdef _DEBUG !WRITE(*,*)"snding ", rsendnbparts , " to right at step: ",step #endif END IF receivednbparts=rreceivednbparts+lreceivednbparts IF(p%Nploc+receivednbparts-lsendnbparts-rsendnbparts .gt. size(p%pos,2)) THEN CALL change_parts_allocation(p,receivednbparts) END IF ! Receive the incoming parts in the receive buffers IF ( lreceivednbparts .gt. 0) THEN CALL MPI_Wait(recvrequest(1), recvstatus(:,1), ierr) IF(ierr .ne. MPI_SUCCESS) THEN WRITE(*,*) "Error in particle reception on proc:", mpirank, " error code:", ierr, "status:", recvstatus(:,1) CALL MPI_Abort(MPI_COMM_WORLD, -1, ierr) END IF #ifdef _DEBUG !WRITE(*,*)"rcvd ", lreceivednbparts , " from left at step: ",step #endif END IF IF ( rreceivednbparts .gt. 0) THEN CALL MPI_Wait(recvrequest(2), recvstatus(:,2), ierr) IF(ierr .ne. MPI_SUCCESS) THEN WRITE(*,*) "Error in particle reception on proc:", mpirank, " error code:", ierr, "status:", recvstatus(:,2) CALL MPI_Abort(MPI_COMM_WORLD, -1, ierr) END IF #ifdef _DEBUG !WRITE(*,*)"rcvd ", rreceivednbparts , " from right at step: ",step #endif END IF ! Copy the incoming particles from the receive buffers to the simulation parts variable CALL Addincomingparts(p, rreceivednbparts, lreceivednbparts, lsendnbparts+rsendnbparts, & & lrecvpartbuff, rrecvpartbuff) ! Wait for the outgoing particles to be fully received by the neighbours IF( lsendnbparts .gt. 0) THEN CALL MPI_Wait(sendrequest(1), sendstatus(:,1), ierr) #ifdef _DEBUG !WRITE(*,*)"sent ", lsentnbparts , " to left at step: ",step #endif END IF IF( rsendnbparts .gt. 0) THEN CALL MPI_Wait(sendrequest(2), sendstatus(:,2), ierr) #ifdef _DEBUG !WRITE(*,*)"sent ", rsentnbparts , " to right at step: ",step #endif END IF ! ! END SUBROUTINE particlescommunication !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Copy the particles from the receive buffers to the local simulation variable parts. !> The incoming particles will first be stored in the holes left by the outgoing particles, then they !> will be added at the end of the parts variable ! !> @param [in] rrecvnbparts number of particles received from the right neighbour (mpirank+1) !> @param [in] lrecvnbparts number of particles received from the left neighbour (mpirank-1) !> @param [in] sendnbparts total number of particles having left the local domain !--------------------------------------------------------------------------- SUBROUTINE Addincomingparts(p, rrecvnbparts, lrecvnbparts, sendnbparts,lrecvpartbuff, rrecvpartbuff) ! USE mpihelper TYPE(particles), INTENT(INOUT):: p INTEGER, INTENT(in) :: rrecvnbparts, lrecvnbparts, sendnbparts TYPE(particle), INTENT(IN) :: rrecvpartbuff(:), lrecvpartbuff(:) INTEGER k,partpos ! First import the particles coming from the right IF(rrecvnbparts .gt. 0) THEN Do k=1,rrecvnbparts IF(k .le. sendnbparts) THEN ! Fill the holes left by sent parts partpos=abs(p%sendhole(k)) ELSE ! Add at the end of parts and keep track of number of parts p%Nploc=p%Nploc+1 partpos=p%Nploc END IF CALL Insertincomingpart(p, rrecvpartbuff(k), partpos) END DO END IF ! Then import the particles coming from the left IF(lrecvnbparts .gt. 0) THEN Do k=1,lrecvnbparts IF(k+rrecvnbparts .le. sendnbparts) THEN ! Fill the holes left by sent parts partpos=abs(p%sendhole(k+rrecvnbparts)) ELSE ! Add at the end of parts and keep track of number of parts p%Nploc=p%Nploc+1 partpos=p%Nploc END IF CALL Insertincomingpart(p, lrecvpartbuff(k), partpos) END DO END IF ! END SUBROUTINE Addincomingparts !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Copy the particles from the local parts variable to the left and right send buffers. ! !> @param [in] lsendnbparts number of particles to send to the left neighbour (mpirank-1) !> @param [in] rsendnbparts number of particles to send to the right neighbour (mpirank+1) !--------------------------------------------------------------------------- SUBROUTINE AddPartSendBuffers(p, lsendnbparts, rsendnbparts, lsendpartbuff, rsendpartbuff) ! USE mpihelper TYPE(particles), INTENT(INOUT):: p INTEGER, INTENT(in) :: lsendnbparts, rsendnbparts TYPE(particle), INTENT(OUT) :: rsendpartbuff(:), lsendpartbuff(:) INTEGER:: partpos, k INTEGER:: lsendpos, rsendpos lsendpos=0 rsendpos=0 ! Loop over the outgoing particles and fill the correct send buffer Do k=lsendnbparts+rsendnbparts,1,-1 partpos=abs(p%sendhole(k)) IF(p%sendhole(k) .GT. 0) THEN rsendpos=rsendpos+1 CALL Insertsentpart(p, rsendpartbuff, rsendpos, partpos) ELSE IF(p%sendhole(k) .LT. 0) THEN lsendpos=lsendpos+1 CALL Insertsentpart(p, lsendpartbuff, lsendpos, partpos) END IF END DO ! ! END SUBROUTINE AddPartSendBuffers !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> @brief Add the particles stored in the buffer to the main particle storage p in particles form !> @param[in] p particles structure to add particles to !> @param[in] buffer memory containing the particles to be added !> @param[in] nb_ins number of particles stored in buffer !--------------------------------------------------------------------------- SUBROUTINE add_list_created_part(p, buffer,nb_ins) IMPLICIT NONE TYPE(particles), INTENT(INOUT):: p TYPE(particle), ALLOCATABLE, INTENT(in) :: buffer(:) INTEGER, OPTIONAL:: nb_ins INTEGER:: i, nptotinit, parts_size_increase, nb_added nptotinit=p%Nploc+1 if(present(nb_ins)) THEN nb_added=nb_ins ELSE nb_added=size(buffer,1) end if IF(nb_added .le. 0) RETURN ! No particles to add ! if there is not enough space in the parts simulation buffer, increase the parst size IF(p%Nploc + nb_added .gt. size(p%pos,2)) THEN parts_size_increase=Max(floor(0.1*size(p%pos,2)),nb_added) CALL change_parts_allocation(p, parts_size_increase) END IF DO i=1,nb_added CALL add_created_particle(p,buffer(i)) END DO nb_added=p%Nploc-nptotinit+1 if(p%is_field) then IF(allocated(p%addedlist)) then call change_array_size_int(p%addedlist,2) else allocate(p%addedlist(2)) end if p%addedlist(size(p%addedlist)-1)=nptotinit p%addedlist(size(p%addedlist))=nb_added end if END SUBROUTINE add_list_created_part !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> @brief Add the particles stored in the linked buffer to the main particle storage p in particles form !> @param[in] p particles structure to add particles to !> @param[in] linked_buffer memory containing the particles to be added in linked list format !> @param[in] destroy Indicates if the memory of the linked buffer must be freed after copy to p !> @param[in] zerovelocity Define if the velocity of the particles in p is set to 0 or copied from the buffer !--------------------------------------------------------------------------- SUBROUTINE add_linked_created_part(p, linked_buffer, destroy, zerovelocity) IMPLICIT NONE TYPE(particles), INTENT(INOUT):: p TYPE(linked_part_row), INTENT(in) :: linked_buffer LOGICAL:: destroy, zerovelocity TYPE(linked_part), POINTER:: part INTEGER:: i, nptotinit, parts_size_increase, nb_added nptotinit=p%Nploc+1 nb_added=linked_buffer%n IF(nb_added .le. 0) RETURN ! No particles to add ! if there is not enough space in the parts simulation buffer, increase the parst size IF(p%Nploc + nb_added .gt. size(p%pos,2)) THEN parts_size_increase=Max(floor(0.2*size(p%pos,2)),nb_added) CALL change_parts_allocation(p, parts_size_increase) END IF part=>linked_buffer%start DO i=1,nb_added CALL add_created_particle(p,part%p) part=>part%next END DO nb_added=p%Nploc-nptotinit+1 if(p%is_field) then IF(allocated(p%addedlist)) then call change_array_size_int(p%addedlist,2) else allocate(p%addedlist(2)) end if p%addedlist(size(p%addedlist)-1)=nptotinit p%addedlist(size(p%addedlist))=nb_added end if if(zerovelocity)then p%U(:,nptotinit:p%Nploc)=0 !p%UTHET(nptotinit:p%Nploc)=0 !p%UZ(nptotinit:p%Nploc)=0 end if if (destroy) call destroy_linked_parts(linked_buffer%start) if (p%is_field) then ! we keep track of energy by removing the ionisation energy ! with conversion from electronvolt to joules loc_etot0=loc_etot0-sum(p%pot(nptotinit:p%Nploc)*elchar) end if END SUBROUTINE add_linked_created_part !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Add created particles from a buffer of type particle to the main species storages. ! !> @param [in] p specie memory where we want to add particles !> @param [in] part particle buffer storing the data we want to add to p !--------------------------------------------------------------------------- SUBROUTINE add_created_particle(p,part) USE geometry TYPE(particles):: p TYPE(particle):: part p%Nploc=p%Nploc+1 p%newindex=p%newindex+1 ! add the data to the p structure CALL Insertincomingpart(p, part, p%Nploc) p%partindex(p%Nploc)=p%newindex ! calculate the new domain weight CALL dom_weight(p%pos(3,p%Nploc),p%pos(1,p%Nploc),p%geomweight(0,p%Nploc)) ! delete the particle if it is outside of the computational domain if( .not. is_inside(p,p%Nploc) ) then p%Nploc=p%Nploc-1 p%newindex=p%newindex-1 RETURN end if ! Calculate the geometric weight for the Poisson solver and the grid indices CALL geom_weight(p%pos(3,p%Nploc),p%pos(1,p%Nploc),p%geomweight(:,p%Nploc)) - call p_calc_rzindex(p,p%Nploc) + call p_calc_cellindex(p,p%Nploc) END SUBROUTINE add_created_particle !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Checks if the particle id in p is inside of the simulation domain ! !> @param [in] p specie memory !> @param [in] id index of the particle we want to test !--------------------------------------------------------------------------- function is_inside(p,id) Use basic, ONLY: rgrid,zgrid, nr, nz IMPLICIT NONE logical :: is_inside type(particles) :: p integer :: id is_inside=.true. ! Check if the particle is in the simulation domain if(p%geomweight(0,id).le.0)then is_inside=.false. return end if ! check if the particle is in the simulation grid if(p%pos(1,id).ge.rgrid(nr) .or. p%pos(1,id) .le. rgrid(0))then is_inside=.false. return end if if(p%pos(3,id).ge.zgrid(nz) .or. p%pos(3,id) .le. zgrid(0))then is_inside=.false. return end if end function is_inside !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Calculate the energy added by new particles to the system for diagnostic purposes ! !> @param [in] p specie memory !--------------------------------------------------------------------------- SUBROUTINE calc_newparts_energy(p) USE basic, ONLY: phinorm, nlclassical type(particles)::p integer::i,n,nptotinit,nbadded, nptotend ! exit if these particles dont participate in the Poisson equation if(.not. p%is_field) return if( allocated(p%addedlist)) then n=size(p%addedlist) ! For each set of added particles Do i=1,n,2 nptotinit=p%addedlist(i) nbadded=p%addedlist(i+1) p%nbadded=p%nbadded+nbadded nptotend=nptotinit+nbadded-1 ! Potential energy loc_etot0=loc_etot0+p%q*p%weight*sum(p%pot(nptotinit:nptotend))*phinorm ! Kinetic energy IF(.not. nlclassical) THEN loc_etot0=loc_etot0+p%m*p%weight*vlight**2*sum(0.5*(p%Gamma(nptotinit:nptotend)+p%Gammaold(nptotinit:nptotend))-1) ELSE loc_etot0=loc_etot0+0.5*p%m*p%weight*vlight**2*sum(p%U(1,nptotinit:nptotend)*p%Uold(1,nptotinit:nptotend) & & +p%U(3,nptotinit:nptotend)*p%Uold(3,nptotinit:nptotend) & & +p%U(2,nptotinit:nptotend)*p%Uold(2,nptotinit:nptotend)) END IF end do deallocate(p%addedlist) end if end subroutine calc_newparts_energy !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Delete particle at given index removing its energy from the diagnosed quantities ! !> @param [in] index index of particle to be deleted !--------------------------------------------------------------------------- SUBROUTINE delete_part(p, index, replace) !! This will destroy particle at the given index USE constants, ONLY: vlight USE bsplines USE geometry USE basic, ONLY: phinorm, nlclassical TYPE(particles), INTENT(INOUT):: p INTEGER, INTENT(IN) :: index LOGICAL, OPTIONAL :: replace LOGICAL:: repl IF(present(replace)) THEN repl=replace ELSE repl=.true. END IF !Computes the potential at the particle position with phi_ext+phi_s IF(index .le. p%Nploc) THEN IF(p%is_field) THEN loc_etot0=loc_etot0-p%q*p%weight*(p%pot(index))*phinorm IF(.not. nlclassical) THEN loc_etot0=loc_etot0-p%m*p%weight*vlight**2*(p%Gamma(index)-1) ELSE loc_etot0=loc_etot0-0.5*p%m*p%weight*vlight**2*(p%U(1,index)**2+p%U(3,index)**2+p%U(2,index)**2) END IF END IF IF(repl) THEN ! We fill the gap CALL move_part(p, p%Nploc, index) p%partindex(p%Nploc)=-1 ! Reduce the total number of simulated parts p%Nploc=p%Nploc-1 END IF END IF END SUBROUTINE delete_part !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Loads a uniform density of particles on a rectangular annulus qith maxwellian velocities ! !> @param [inout] p particle memory to load into !> @param [inout] VR array of radial velocity for the particles !> @param [inout] VTHET array of azimuthal velocity for the particles !> @param [inout] VZ array of axial velocity for the particles !--------------------------------------------------------------------------- SUBROUTINE loaduniformRZ(p, VR,VZ,VTHET) USE basic, ONLY: plasmadim, rnorm, temp, qsim, msim USE constants, ONLY: me, kb, elchar REAL(kind=db), INTENT(inout) ::VZ(:), VR(:), VTHET(:) TYPE(particles), INTENT(INOUT):: p CALL creat_parts(p, size(VR,1)) p%Nploc=size(VR,1) p%Nptot=size(VR,1) p%q=sign(elchar,qsim) p%weight=msim/me p%m=me p%qmRatio=qsim/msim ! Initial distribution in z with normalisation CALL loduni(1,p%pos(3,1:p%Nploc)) p%pos(3,1:p%Nploc)=(plasmadim(1)+(plasmadim(2)-plasmadim(1))*p%pos(3,1:p%Nploc))/rnorm ! Initial distribution in r with normalisation CALL lodlinr(2,p%pos(1,1:p%Nploc),plasmadim(3),plasmadim(4)) p%pos(1,1:p%Nploc)=p%pos(1,1:p%Nploc)/rnorm ! Initial velocities distribution CALL loadGaussianVelocities(p, VR, VZ, VTHET, temp) END SUBROUTINE loaduniformRZ !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Loads a cloud of electrons trapped in a magnetic mirror according to Davidsons equilibrium !> p117 of physics of non-neutral plasma book ! !> @param [inout] p particle memory to load into !> @param [inout] VR array of radial velocity for the particles !> @param [inout] VTHET array of azimuthal velocity for the particles !> @param [inout] VZ array of axial velocity for the particles !--------------------------------------------------------------------------- SUBROUTINE loadDavidson(p, VR,VZ,VTHET, lodr) USE constants, ONLY: me, kb, elchar USE basic, ONLY: nplasma, rnorm, plasmadim, distribtype, H0, P0, Rcurv, width, qsim, msim, & & omegac, zgrid, nz, rnorm, n0, nblock, temp procedure(rloader)::lodr TYPE(particles), INTENT(INOUT):: p REAL(kind=db), INTENT(INOUT)::VZ(:), VR(:), VTHET(:) REAL(kind=db), DIMENSION(:), ALLOCATABLE::ra, rb, z REAL(kind=db) :: r0, deltar2, halfLz, Mirrorratio, Le, VOL INTEGER :: j, n, blockstart, blockend, addedpart, remainparts INTEGER, DIMENSION(:), ALLOCATABLE :: blocksize CALL creat_parts(p, size(VR,1)) p%Nploc=size(VR,1) p%Nptot=p%Nploc Allocate(ra(nblock),rb(nblock), z(0:nblock)) !r0=(plasmadim(4)+plasmadim(3))/2 r0=sqrt(4*H0/(me*omegac**2)) halfLz=(zgrid(nz)+zgrid(0))/2 MirrorRatio=(Rcurv-1)/(Rcurv+1) z(0)=plasmadim(1) DO n=1,nblock ! Compute limits in radius and load radii for each part Le=(plasmadim(2)-plasmadim(1))/nblock*(n-0.5)-halfLz*rnorm+plasmadim(1) z(n)=z(0)+n*(plasmadim(2)-plasmadim(1))/nblock deltar2=1-MirrorRatio*cos(2*pi*Le/width) rb(n)=r0/deltar2*sqrt(1-P0*abs(omegac)/2/H0*deltar2+sqrt(1-P0*abs(omegac)/H0*deltar2)) ra(n)=r0/deltar2*sqrt(1-P0*abs(omegac)/2/H0*deltar2-sqrt(1-P0*abs(omegac)/H0*deltar2)) END DO VOL=SUM(2*pi*MINVAL(ra)*(rb-ra)*(plasmadim(2)-plasmadim(1))/nblock) qsim=VOL*n0*elchar/nplasma msim=abs(qsim)/elchar*me p%weight=abs(qsim)/elchar p%m=me p%q=sign(elchar,qsim) p%qmRatio=p%q/p%m blockstart=1 blockend=0 ALLOCATE(blocksize(nblock)) WRITE(*,*) "blocksize: ", size(blocksize), nblock DO n=1,nblock blocksize(n)=nplasma/VOL*2*pi*MINVAL(ra)*(rb(n)-ra(n))*(plasmadim(2)-plasmadim(1))/nblock END DO remainparts=p%Nploc-SUM(blocksize) addedpart=1 n=nblock/2 j=1 DO WHILE(remainparts .GT. 0) blocksize(n)=blocksize(n)+addedpart remainparts=remainparts-addedpart n=n+j j=-1*(j+SIGN(1,j)) END DO CALL loadPartSlices(p, lodr, ra, rb, z, blocksize) IF(distribtype .eq. 5) THEN CALL loadGaussianVelocities(p, VR, VZ, VTHET, temp) VZ=VZ/4 VR=VR*8 VTHET=VTHET*8 ELSE Call loadDavidsonVelocities(p, VR, VZ, VTHET, H0, P0) END IF END SUBROUTINE loadDavidson !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Computes the velocities for a cloud of electrons trapped in a magnetic mirror according to Davidsons equilibrium !> p117 of physics of non-neutral plasma book. This equilibrium assume mono energy and mono canonical angular momentum ! !> @param [inout] p particle memory to load into !> @param [inout] VR array of radial velocity for the particles !> @param [inout] VTHET array of azimuthal velocity for the particles !> @param [inout] VZ array of axial velocity for the particles !> @param [in] H0 Total energy of each particle !> @param [in] P0 Initial canonical angular momentum of each particle !--------------------------------------------------------------------------- SUBROUTINE loadDavidsonVelocities(p, VR,VZ,VTHET, H0, P0) USE constants, ONLY: me, kb, elchar USE basic, ONLY: rnorm, Rcurv, B0, width, vnorm, zgrid, nz TYPE(particles), INTENT(INOUT):: p REAL(kind=db), INTENT(INOUT)::VZ(:), VR(:), VTHET(:) REAL(kind=db), INTENT(IN):: H0, P0 REAL(kind=db) :: athetpos, rg, zg, halfLz, Mirrorratio, Pcomp, Acomp INTEGER :: i MirrorRatio=(Rcurv-1)/(Rcurv+1) halfLz=(zgrid(nz)+zgrid(0))/2 ! Load velocities theta velocity ! Loading of r and z velocity is done in adapt_vinit to have ! access to parts%pot DO i=1,p%Nploc ! Interpolation for Magnetic potential rg=p%pos(1,i)*rnorm zg=(p%pos(3,i)-halfLz)*rnorm Athetpos=0.5*B0*(rg - width/pi*MirrorRatio*bessi1(2*pi*rg/width)*COS(2*pi*zg/width)) Pcomp=P0/rg/p%m Acomp=-p%qmRatio*Athetpos VTHET(i)=SIGN(MIN(abs(Pcomp+Acomp),sqrt(2*H0/p%m)),Pcomp+Acomp) !VTHET(i)=Pcomp+Acomp END DO VTHET=VTHET/vnorm VZ=0._db VR=0._db p%Davidson=.true. p%H0=H0 p%P0=P0 END SUBROUTINE loadDavidsonvelocities !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Computes the particles velocities according to a maxwellian distribution of temperature temperature [K] ! !> @param [inout] p particle memory to load into !> @param [inout] VR array of radial velocity for the particles !> @param [inout] VTHET array of azimuthal velocity for the particles !> @param [inout] VZ array of axial velocity for the particles !> @param [in] temperature temperature in [k] of the distribution function !--------------------------------------------------------------------------- SUBROUTINE loadGaussianVelocities(p, VR,VZ,VTHET, temperature) USE basic, ONLY: vnorm USE constants, ONLY: kb REAL(kind=db), INTENT(inout) ::VZ(:), VR(:), VTHET(:) TYPE(particles), INTENT(INOUT):: p REAL(kind=db), INTENT(IN):: temperature REAL(kind=db):: vth ! Initial velocities distribution vth=sqrt(2.0/3.0*kb*temperature/p%m)/vnorm !thermal velocity CALL lodgaus(3,VZ) CALL lodgaus(5,VR) CALL lodgaus(7,VTHET) VZ=VZ*vth VR=VR*vth VTHET=VTHET*vth p%temperature=temperature p%Davidson=.false. END SUBROUTINE loadGaussianVelocities !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Computes the particles velocities with a uniform distribution centered in meanv and limited by meanv+spanv and meanv-spanv ! !> @param [inout] p particle memory to load into !> @param [inout] VR array of radial velocity for the particles !> @param [inout] VTHET array of azimuthal velocity for the particles !> @param [inout] VZ array of axial velocity for the particles !> @param [in] meanv mean velocity in each direction [m/s] !> @param [in] spanv extent of the velocity in each direction above and below the mean velocity [m/s] !--------------------------------------------------------------------------- SUBROUTINE loadFlatTopVelocities(p, VR,VZ,VTHET, meanv, spanv) USE basic, ONLY: vnorm USE constants, ONLY: kb REAL(kind=db), INTENT(inout) ::VZ(:), VR(:), VTHET(:) TYPE(particles), INTENT(INOUT):: p REAL(kind=db), INTENT(INOUT):: meanv(3), spanv(3) ! Initial velocities distribution meanv=meanv/vnorm !thermal velocity spanv=spanv/vnorm CALL loduni(3,VZ) CALL loduni(5,VR) CALL loduni(7,VTHET) VR=(VR*2-1)*spanv(1)+meanv(1) VTHET=(VTHET*2-1)*spanv(2)+meanv(2) VZ=(VZ*2-1)*spanv(3)+meanv(3) p%Davidson=.false. END SUBROUTINE loadFlatTopVelocities !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Load slices of particles defined by axial and radial limits ! !> @param [inout] p particle memory to load into !> @param [in] lodr sampling function definig the particle distribution in r !> @param [in] ra lower radial limit of the slice !> @param [in] rb upper radial limit of the slice !> @param [in] z array giving the axial limits of each slice (slice i is betwwen z(i-1) and z(i)) !> @param [in] blocksize array containing the number of particles for each slice !--------------------------------------------------------------------------- SUBROUTINE loadPartslices(p, lodr, ra, rb, z, blocksize) USE basic, ONLY: rnorm TYPE(particles), INTENT(INOUT):: p REAL(kind=db), INTENT(IN)::ra(:), rb(:), z(0:) INTEGER, DIMENSION(:), INTENT(IN) :: blocksize procedure(rloader)::lodr INTEGER :: n, blockstart, blockend, nblock nblock=size(blocksize,1) blockstart=1 blockend=0 DO n=1,nblock blockstart=blockend+1 blockend=MIN(blockstart+blocksize(n)-1,p%Nploc) ! Initial distribution in z with normalisation between magnetic mirrors CALL loduni(1, p%pos(3,blockstart:blockend)) p%pos(3,blockstart:blockend)= (z(n-1)+p%pos(3,blockstart:blockend)*(z(n)-z(n-1)))/rnorm CALL lodr(2, p%pos(1,blockstart:blockend), ra(n), rb(n)) p%pos(1,blockstart:blockend)=p%pos(1,blockstart:blockend)/rnorm END DO END SUBROUTINE loadPartslices !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Read a particle file format to load a simulated specie in the simulation ! !--------------------------------------------------------------------------- SUBROUTINE read_part_file(p, partfilename, VR, VZ, VTHET) USE basic, ONLY: lu_partfile, rnorm, vnorm implicit None TYPE(particles), INTENT(INOUT):: p REAL(kind=db), DIMENSION(:), ALLOCATABLE, INTENT(INOUT)::VR, VZ, VTHET CHARACTER(len=*)::partfilename INTEGER:: nblock = 0 REAL(kind=db), Dimension(:), ALLOCATABLE:: ra, rb, z INTEGER, Dimension(:), ALLOCATABLE:: npartsslice INTEGER:: velocitytype=1 !< 1) gaussian with temp 2) Davidson with H0, P0 INTEGER:: radialtype=1 !< 1) 1/R 2) uniform 3) 1/R^2 4) gauss INTEGER:: npartsalloc !< initial size of particles arrays INTEGER:: iiee_id !< index of species to add particles to for IIEE INTEGER:: neuttype_id !< index of neutral gas producing ions INTEGER:: material_id !< index determining the type of electrode material LOGICAL:: zero_vel !< logical to chose wether or not el. are gen. with non 0 init. vel. REAL(kind=db):: mass=me REAL(kind=db):: charge=-elchar REAL(kind=db):: weight=1.0 REAL(kind=db):: qmratioscale REAL(kind=db):: meanv(3) !< mean velocity in each direction for velocitytype 3 [m/s] REAL(kind=db):: spanv(3) !< pos/neg extent of velocity in each direction for velocitytype 3 [m/s] CHARACTER(len=256) :: header=' ' !< header of csv file section REAL(kind=db):: H0=3.2e-14 !< Total energy [J] - REAL(kind=db):: P0=8.66e-25 !< Canonical angula r momentum + REAL(kind=db):: P0=8.66e-25 !< Canonical angular momentum [kg m^2/s] REAL(kind=db):: temperature=10000 !< temperature in kelvins real(kind=db):: n0 !< density factor LOGICAL :: is_test !< Defines if particle are saved on ittracer or not LOGICAL :: is_field !< Defines if particle contributes to Poisson solver LOGICAL :: calc_moments !< Defines if moments matrix must be calculated each it2d CHARACTER(len=16) :: partformat = 'slices' INTEGER:: i, ierr, openerr NAMELIST /partsload/ nblock, mass, charge, weight, npartsalloc, velocitytype, & & radialtype, temperature, H0, P0, is_test, n0, partformat, meanv, spanv, & & calc_moments, qmratioscale, is_field, iiee_id, neuttype_id, material_id, zero_vel ! Set defaults qmratioscale=1.0 weight=1.0 meanv=0 spanv=0 mass=me charge=-elchar calc_moments=.false. is_test=.false. is_field=.true. iiee_id = -1 neuttype_id=1 material_id=1 zero_vel = .true. ! Open the paticle file OPEN(UNIT=lu_partfile,FILE=trim(partfilename),ACTION='READ',IOSTAT=openerr) header=' ' IF(openerr .ne. 0) THEN CLOSE(unit=lu_partfile) RETURN END IF READ(lu_partfile,partsload) IF(mpirank .eq.0) THEN WRITE(*,'(a,a)')"reading partfile: ", trim(partfilename) WRITE(*,partsload) END IF ! The plasma cloud is defined as a set of slices IF(trim(partformat).eq.'slices') THEN IF( nblock .ge. 1) THEN ALLOCATE(z(0:nblock),ra(nblock),rb(nblock), npartsslice(nblock)) DO WHILE(header(1:8) .ne. '//slices') READ(lu_partfile,'(a)') header END DO DO i=1,nblock READ(lu_partfile,*) z(i-1),ra(i),rb(i),npartsslice(i) END DO READ(lu_partfile,*) z(nblock) CALL creat_parts(p,max(npartsalloc,sum(npartsslice))) p%Nploc=sum(npartsslice) p%Nptot=p%Nploc IF( allocated(VR) ) THEN DEALLOCATE(VR,VZ,VTHET) end if if(.not. allocated(VR)) THEN ALLOCATE(VR(p%Nploc)) ALLOCATE(VZ(p%Nploc)) ALLOCATE(VTHET(p%Nploc)) END IF p%m=mass p%q=charge p%weight=weight p%qmRatio=charge/mass*qmratioscale p%is_test=is_test p%is_field=is_field p%calc_moments=calc_moments p%Newindex=sum(npartsslice) p%iiee_id = iiee_id p%neuttype_id = neuttype_id p%material_id = material_id p%zero_vel = zero_vel SELECT CASE(radialtype) CASE(1) ! 1/R distribution in R CALL loadPartslices(p, lodunir, ra, rb, z, npartsslice) CASE(2) ! flat top distribution in R CALL loadPartslices(p, lodlinr, ra, rb, z, npartsslice) CASE(3) ! 1/R^2 distribution in R CALL loadPartslices(p, lodinvr, ra, rb, z, npartsslice) CASE(4) ! gaussian distribution in R CALL loadPartslices(p, lodgausr, ra, rb, z, npartsslice) CASE DEFAULT IF (mpirank .eq. 0) WRITE(*,*) "Unknown type of radial distribution:", radialtype CALL MPI_Abort(MPI_COMM_WORLD, -1, ierr) END SELECT SELECT CASE(velocitytype) CASE(1) ! Gaussian with temperature CALL loadGaussianVelocities(p, VR, VZ, VTHET, temperature) CASE(2) ! Davidson magnetic mirror high wr equilibrium CALL loadDavidsonVelocities(p, VR, VZ, VTHET, H0, P0) CASE(3) ! flat top velocity CALL loadFlatTopVelocities(p, VR, VZ, VTHET, meanv, spanv) CASE DEFAULT IF (mpirank .eq. 0) WRITE(*,*) "Unknown type of velocity distribution:", velocitytype CALL MPI_Abort(MPI_COMM_WORLD, -1, ierr) END SELECT END IF END IF ! The plasma cloud is defined as a set individual particles IF( trim(partformat) .eq. 'parts' ) THEN IF( nblock .ge. 1) THEN !Allocate necessary memory CALL creat_parts(p,max(npartsalloc,nblock)) IF( allocated(VR) ) THEN DEALLOCATE(VR,VZ,VTHET) end if if(.not. allocated(VR)) THEN ALLOCATE(VR(nblock)) ALLOCATE(VZ(nblock)) ALLOCATE(VTHET(nblock)) END IF ! Read the particles from the file DO WHILE(header(1:8) .ne. '//parts') READ(lu_partfile,'(a)') header END DO DO i=1,nblock READ(lu_partfile,*) p%pos(1,i),p%pos(2,i),p%pos(3,i), VR(i), VTHET(i), VZ(i) END DO p%Nploc=nblock p%Nptot=p%Nploc p%m=mass p%q=charge p%Newindex=nblock p%weight=weight p%qmRatio=charge/mass*qmratioscale p%is_test=is_test p%is_field=is_field p%calc_moments=calc_moments p%iiee_id = iiee_id p%neuttype_id = neuttype_id p%material_id = material_id p%zero_vel = zero_vel !normalizations p%pos(1,:)=p%pos(1,:)/rnorm p%pos(3,:)=p%pos(3,:)/rnorm !p%z=p%z/rnorm VR=VR/vnorm VTHET=VTHET/vnorm VZ=VZ/vnorm END IF END IF CLOSE(unit=lu_partfile) END SUBROUTINE !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Increase the number of macroparticles by separating each previous macroparticles into !> samplefactor new macroparticles of equally divided weight. The new sub particles are distributed !> uniformly in space to maintain the density and other moments. ! !> @param [in] samplefactor multiplicator of the number of macroparticles. !> @param [in] p particles type to increase. !--------------------------------------------------------------------------- SUBROUTINE upsample(p, samplefactor) USE basic, ONLY : nplasma, dr, dz INTEGER, INTENT(IN) ::samplefactor TYPE(particles), INTENT(INOUT):: p INTEGER:: i, j, currentindex REAL(kind=db), DIMENSION(p%Nploc) :: spreaddir ! random direction for the spread of each initial macro particle REAL(kind=db) :: dir ! Direction in which the particle is moved REAL(kind=db) :: dl ! Particle displacement used for ! Load and scale the direction angle for spreading the new particles CALL loduni(2, spreaddir) spreaddir=spreaddir*2*pi/samplefactor dl=min(minval(dz,1,dz.GT.0),minval(dr,1,dr.GT.0))/10 DO i=1,p%Nploc DO j=1,samplefactor-1 currentindex=p%Nploc+(i-1)*(samplefactor-1)+j CALL move_part(p,i,currentindex) p%partindex(currentindex)=currentindex dir = spreaddir(i)+2*pi*j/samplefactor p%pos(1,currentindex)=p%pos(1,currentindex) + dl*cos(dir) p%pos(3,currentindex)=p%pos(3,currentindex) + dl*sin(dir) END DO p%partindex(i)=i p%pos(1,i)=p%pos(1,i) + dl*cos(spreaddir(i)) p%pos(3,i)=p%pos(3,i) + dl*sin(spreaddir(i)) END DO nplasma=nplasma*samplefactor p%weight=p%weight/samplefactor p%Nploc=p%Nploc*samplefactor p%Nptot=p%Nptot*samplefactor END SUBROUTINE upsample ! Taken from https://rosettacode.org/wiki/Sorting_algorithms/Radix_sort#Fortran ! No Copyright is exerted due to considerable prior art in the Public Domain. ! This Fortran version by Peter Kelly ~ peter.kelly@acm.org ! ! Permission is hereby granted, free of charge, to any person obtaining ! a copy of this software and associated documentation files (the ! "Software"), to deal in the Software without restriction, including ! without limitation the rights to use, copy, modify, merge, publish, ! distribute, sublicense, and/or sell copies of the Software, and to ! permit persons to whom the Software is furnished to do so, subject to ! the following conditions: ! The above copyright notice and this permission notice shall be ! included in all copies or substantial portions of the Software. ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ! EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ! IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ! CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ! TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ! SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ! ! Implementation of a classic Radix Sort LSD style :) SUBROUTINE LSDRADIXSORT(A , N) IMPLICIT NONE ! ! Dummy arguments ! INTEGER :: N INTEGER , target, DIMENSION(0:N - 1) :: A ! All arrays based off zero, one day I'll fix it INTENT (IN) N INTENT (INOUT) A ! ! Local variables ! INTEGER , DIMENSION(0:9) :: counts INTEGER :: digitplace INTEGER :: i INTEGER :: j INTEGER :: largestnum INTEGER, DIMENSION(0:N - 1) :: results ! digitplace = 1 ! Count of the keys largestnum = MAXVAL(A) DO WHILE ( (largestnum/digitplace)>0 ) counts = 0 ! Init the count array DO i = 0 , N - 1 , 1 J = (A(i)/digitplace) J = MODULO(j , 10) counts(j) = counts(j) + 1 END DO ! Change count(i) so that count(i) now contains actual position of this digit in result() ! Working similar to the counting sort algorithm DO i = 1 , 9 , 1 counts(i) = counts(i) + counts(i - 1) ! Build up the prefix sum END DO ! DO i = N - 1 , 0 , -1 ! Move from left to right j = (A(i)/digitplace) j = MODULO(j, 10) results(counts(j) - 1) = A(i) ! Need to subtract one as we are zero based but prefix sum is 1 based counts(j) = counts(j) - 1 END DO ! DO i = 0 , N - 1 , 1 ! Copy the semi-sorted data into the input A(i) = results(i) END DO ! digitplace = digitplace*10 END DO ! While loop RETURN END SUBROUTINE LSDRADIXSORT END MODULE beam diff --git a/src/celldiag_mod.f90 b/src/celldiag_mod.f90 index c9f2117..dd2c7a0 100644 --- a/src/celldiag_mod.f90 +++ b/src/celldiag_mod.f90 @@ -1,189 +1,189 @@ !------------------------------------------------------------------------------ ! EPFL/Swiss Plasma Center !------------------------------------------------------------------------------ ! ! MODULE: celldiag ! !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> Represent a diagnostic positioned at cell indices (rindex,zindex) that saves the individual particles !> position and velocity !------------------------------------------------------------------------------ MODULE celldiag ! USE constants use mpi USE mpihelper USE basic, ONLY: mpirank, mpisize, vnorm, rnorm, Zbounds, zgrid, & & nlclassical, nlmaxwellsource, phinorm, nbcelldiag USE beam USE futils IMPLICIT NONE PRIVATE INTEGER, SAVE, ALLOCATABLE :: specieid(:) !< position of the specie in partslist INTEGER, SAVE, ALLOCATABLE :: rindex(:) !< radial index for the diagnostic position INTEGER, SAVE, ALLOCATABLE :: zindex(:) !< axial index for the diagnostic position TYPE(particles), ALLOCATABLE, SAVE :: diagnosed_parts(:) !< Stores the particles properties at position (rindex,zindex) CHARACTER(len=20), SAVE, ALLOCATABLE :: groupname(:) !< Name of the group in the hdf5 file INTEGER, SAVE , ALLOCATABLE :: h5storelength(:) !< particles capacity of the hdf5 dataset NAMELIST /celldiagparams/ specieid, rindex, zindex PUBLIC:: celldiag_init, celldiag_save contains subroutine celldiag_init(lu_in, diagfile_id) implicit none INTEGER, INTENT(IN) :: lu_in INTEGER, INTENT(IN):: diagfile_id INTEGER:: i ALLOCATE(specieid(nbcelldiag), rindex(nbcelldiag), zindex(nbcelldiag)) ALLOCATE(diagnosed_parts(nbcelldiag), groupname(nbcelldiag), h5storelength(nbcelldiag)) Rewind(lu_in) if(nbcelldiag .gt. 0) then READ(lu_in, celldiagparams) if(mpirank .eq. 0) WRITE(*, celldiagparams) Do i=1,nbcelldiag CALL creat_parts(diagnosed_parts(i), 500) IF(mpirank .eq. 0) THEN WRITE(groupname(i),'(a,i2.2)') "/data/celldiag/",i If(.not. isgroup(diagfile_id, "/data/celldiag/")) THEN CALL creatg(diagfile_id, "/data/celldiag") CALL attach(diagfile_id, "/data/celldiag", "nbcelldiag", nbcelldiag) END IF CALL celldiag_createh5group(diagfile_id, groupname(i), rindex(i), zindex(i), specieid(i), diagnosed_parts(i), h5storelength(i)) END IF END DO END IF End subroutine celldiag_init subroutine celldiag_createh5group(diagfile_id, groupname, rindex, zindex, specid, diag_parts, h5strlength) INTEGER, INTENT(IN):: diagfile_id, rindex, zindex, specid CHARACTER(len=*), INTENT(IN):: groupname TYPE(particles), INTENT(IN):: diag_parts INTEGER, INTENT(INOUT):: h5strlength INTEGER:: partsrank, partsdim(2) If(.not. isgroup(diagfile_id, TRIM(groupname))) CALL creatg(diagfile_id, TRIM(groupname)) CALL attach(diagfile_id, TRIM(groupname), "rindex", rindex) CALL attach(diagfile_id, TRIM(groupname), "zindex", zindex) CALL attach(diagfile_id, trim(groupname), "q", partslist(specid)%q) CALL attach(diagfile_id, trim(groupname), "m", partslist(specid)%m) CALL attach(diagfile_id, trim(groupname), "weight", partslist(specid)%weight) If(.not. isdataset(diagfile_id, trim(groupname) // "/time")) CALL creatd(diagfile_id, 0, SHAPE(rindex), trim(groupname) // "/time", "time") If(.not. isdataset(diagfile_id, trim(groupname) // "/Nparts")) CALL creatd(diagfile_id, 0, SHAPE(rindex), trim(groupname) //"/Nparts", "number of remaining parts") If(.not. isdataset(diagfile_id, trim(groupname) // "/R")) CALL creatd(diagfile_id, 1, SHAPE(diag_parts%pos(1,:)), trim(groupname) // "/R", "radial pos") If(.not. isdataset(diagfile_id, trim(groupname) // "/Z")) CALL creatd(diagfile_id, 1, SHAPE(diag_parts%pos(1,:)), trim(groupname) // "/Z", "axial pos") If(.not. isdataset(diagfile_id, trim(groupname) // "/THET")) CALL creatd(diagfile_id, 1, SHAPE(diag_parts%pos(1,:)), trim(groupname) // "/THET", "azimuthal pos") If(.not. isdataset(diagfile_id, trim(groupname) // "/UZ")) CALL creatd(diagfile_id, 1, SHAPE(diag_parts%pos(1,:)), trim(groupname) // "/UZ", "axial beta*gamma") If(.not. isdataset(diagfile_id, trim(groupname) // "/UR")) CALL creatd(diagfile_id, 1, SHAPE(diag_parts%pos(1,:)), trim(groupname) // "/UR", "radial beta*gamma") If(.not. isdataset(diagfile_id, trim(groupname) // "/UTHET")) CALL creatd(diagfile_id, 1, SHAPE(diag_parts%pos(1,:)), trim(groupname) // "/UTHET", "azimuthal beta*gamma") If(.not. isdataset(diagfile_id, trim(groupname) // "/pot")) CALL creatd(diagfile_id, 1, SHAPE(diag_parts%pot), trim(groupname) // "/pot", "electric potential") CALL getdims(diagfile_id, trim(groupname) // '/R', partsrank, partsdim) h5strlength=partsdim(1) END subroutine celldiag_createh5group subroutine celldiag_save(time, diagfile_id) implicit none REAL(kind=db), INTENT(IN) :: time INTEGER, INTENT(IN) :: diagfile_id INTEGER :: Nbtosave, i ! check if source is on IF(.not. celldiag_on(time)) THEN RETURN END IF Do i=1,nbcelldiag CALL celldiag_save_specie(partslist(specieid(i)),rindex(i),zindex(i),diagnosed_parts(i)) END DO !$OMP BARRIER !$OMP MASTER Do i=1,nbcelldiag if(mpisize .gt. 1) then call collectparts(diagnosed_parts(i)) else diagnosed_parts(i)%Nptot=diagnosed_parts(i)%Nploc end if Nbtosave=min(diagnosed_parts(i)%Nptot,h5storelength(i)) CALL celldiag_write_specie(diagfile_id, diagnosed_parts(i), groupname(i), Nbtosave, time) END DO !$OMP END MASTER !$OMP BARRIER end subroutine celldiag_save SUBROUTINE celldiag_save_specie(p, rindex, zindex, savedp) Type(particles), INTENT(IN) :: p Type(particles), INTENT(INOUT) :: savedp INTEGER, INTENT(IN) :: rindex, zindex INTEGER:: i, destcopyindex savedp%Nploc=0 savedp%collected=.false. IF (p%Nploc .gt. 0 .and. zindex .ge. Zbounds(mpirank) .and. zindex .lt. Zbounds(mpirank+1)) THEN ! Boundary condition at z direction !$OMP DO DO i=1,p%Nploc ! If the particle is in the correct cell, it is saved - IF (p%Zindex(i) .eq. zindex.and. p%Rindex(i) .eq. rindex ) THEN + IF (p%cellindex(3,i) .eq. zindex.and. p%cellindex(1,i) .eq. rindex ) THEN !$OMP CRITICAL (diagparts) savedp%Nploc=savedp%Nploc+1 destcopyindex= savedp%Nploc !$OMP END CRITICAL (diagparts) CALL copy_part(p,i,destcopyindex,savedp) END IF END DO !$OMP END DO NOWAIT END IF END subroutine celldiag_save_specie SUBROUTINE celldiag_write_specie(diagfile_id, savedp, groupname, Nbtosave, time) Type(particles), INTENT(IN) :: savedp INTEGER, INTENT(IN) :: diagfile_id CHARACTER(LEN=*), INTENT(IN) :: groupname INTEGER, INTENT(IN) :: Nbtosave REAL(kind=db), INTENT(IN) :: time IF(mpirank .eq. 0) THEN CALL append(diagfile_id, trim(groupname) // "/time", time) CALL append(diagfile_id, trim(groupname) // "/Nparts", REAL(savedp%Nptot,kind=db)) CALL append(diagfile_id, trim(groupname) // "/R", savedp%pos(1,1:Nbtosave)*rnorm) CALL append(diagfile_id, trim(groupname) // "/Z", savedp%pos(3,1:Nbtosave)*rnorm) CALL append(diagfile_id, trim(groupname) // "/THET", savedp%pos(2,1:Nbtosave)) CALL append(diagfile_id, trim(groupname) // "/UZ", savedp%U(3,1:Nbtosave)/savedp%gamma(1:Nbtosave)) CALL append(diagfile_id, trim(groupname) // "/UR", savedp%U(1,1:Nbtosave)/savedp%gamma(1:Nbtosave)) CALL append(diagfile_id, trim(groupname) // "/UTHET", savedp%U(2,1:Nbtosave)/savedp%gamma(1:Nbtosave)) CALL append(diagfile_id, trim(groupname) // "/pot", savedp%pot(1:Nbtosave)*phinorm) END IF END subroutine celldiag_write_specie logical function celldiag_on(time) REAL(kind=db), intent(in):: time celldiag_on=.true. end function End Module celldiag diff --git a/src/chkrst.f90 b/src/chkrst.f90 index dd2f11a..bb26433 100644 --- a/src/chkrst.f90 +++ b/src/chkrst.f90 @@ -1,420 +1,420 @@ SUBROUTINE chkrst(flag) ! ! Process checkpoint/restart file ! USE basic USE futils USE beam USE fields USE constants, ONLY: elchar, me Use psupply use filemanip USE mumps_bsplines IMPLICIT NONE INTEGER, INTENT(in) :: flag INTEGER :: remainingparts REAL(kind=db):: old_msim, old_qsim, old_n0 INTEGER:: partsrank, partsdim(1), i, err REAL(kind=db), ALLOCATABLE:: charges(:), weights(:), masses(:) CHARACTER(len=64):: group CHARACTER(len=2):: specieindex real(kind=db):: old_rnorm, old_tnorm, qmratioscale real(kind=db):: prev_bias INTEGER:: logical_val, id ! Only process 0 should save on file ! ! Local vars and arrays !________________________________________________________________________________ ! SELECT CASE(flag) !________________________________________________________________________________ ! 1. Open and read restart file ! CASE(0) CALL openf(rstfile, fidrst,'r',real_prec='d') CALL getatt(fidrst, '/Basic', 'cstep', cstep) CALL getatt(fidrst, '/Basic', 'time', time) CALL getatt(fidrst, '/Basic', 'n0', old_n0) IF(isgroup(fidrst,'/Basic/norm')) THEN CALL getatt(fidrst, '/Basic/norm', 'rnorm', old_rnorm) CALL getatt(fidrst, '/Basic/norm', 'tnorm', old_tnorm) else old_rnorm=rnorm old_tnorm=tnorm end if IF(isdataset(fidrst,'/Parts/charges')) THEN ! If we have multiple saved species we need to load all of them CALL getatt(fidrst,'/Parts','nbspecies',nbspecies) nbspecies=nbspecies ALLOCATE(charges(nbspecies),masses(nbspecies),weights(nbspecies)) ALLOCATE(partslist(nbspecies+nbaddtestspecies)) CALL getarr(fidrst, '/Parts/charges', charges) CALL getarr(fidrst, '/Parts/masses', masses) CALL getarr(fidrst, '/Parts/weights', weights) weights(1)=weights(1)/old_n0*n0 ELSE ! If we have an old restart file, we load only the electrons CALL getatt(fidrst, '/Basic', 'msim', old_msim) CALL getatt(fidrst, '/Basic', 'qsim', old_qsim) qsim=old_qsim/old_n0*n0 msim=old_msim/old_n0*n0 nbspecies=1 ALLOCATE(charges(nbspecies),masses(nbspecies),weights(nbspecies)) ALLOCATE(partslist(nbspecies)) charges(1)=sign(elchar,qsim) weights(1)=msim/me masses(1)=me END IF if(newres) then weights=weights*weights_scale end if CALL getatt(fidrst, '/var0d', 'etot0', loc_etot0) etot0=loc_etot0 if(n0.ne.old_n0) cstep=0 loc_etot0=0 CALL getatt(fidrst, '/var0d', 'epot', epot) CALL getatt(fidrst, '/var0d', 'ekin', ekin) CALL getatt(fidrst, '/var0d', 'etot', etot) CALL getatt(fidrst, '/Parts', 'nplasma', nplasma) CALL getatt(fidrst, '/Parts', 'remainingparts', remainingparts) if(remainingparts .gt. 0) Then CALL getdims(fidrst, '/Parts/Z', partsrank, partsdim) else partsdim=0 end if IF (samplefactor .gt. 1 ) THEN ! We increase the number of macro particles CALL creat_parts(partslist(1),max(remainingparts*samplefactor,partsdim(1))) ELSE CALL creat_parts(partslist(1),partsdim(1)) END IF partslist(1)%q=charges(1) partslist(1)%m=masses(1) partslist(1)%weight=weights(1) partslist(1)%qmRatio=charges(1)/masses(1) err=0 CALL getatt(fidrst, 'Parts', 'qmratioscale', qmratioscale, err) if(err .ge.0) partslist(1)%qmRatio=partslist(1)%qmRatio*qmratioscale if(remainingparts .gt. 0) then CALL getarr(fidrst, '/Parts/Z', partslist(1)%pos(3,:)) CALL getarr(fidrst, '/Parts/R', partslist(1)%pos(1,:)) ! Renormalize R and Z IF(isgroup(fidrst,'/Basic/norm')) THEN partslist(1)%pos(1,:)=partslist(1)%pos(1,:)*old_rnorm/rnorm partslist(1)%pos(3,:)=partslist(1)%pos(3,:)*old_rnorm/rnorm ELSE partslist(1)%pos(1,:)=partslist(1)%pos(1,:)*sqrt(n0/old_n0) partslist(1)%pos(3,:)=partslist(1)%pos(3,:)*sqrt(n0/old_n0) END IF CALL getarr(fidrst, '/Parts/THET', partslist(1)%pos(2,:)) CALL getarr(fidrst, '/Parts/UZ', partslist(1)%U(3,:)) CALL getarr(fidrst, '/Parts/UR', partslist(1)%U(1,:)) CALL getarr(fidrst, '/Parts/UTHET', partslist(1)%U(2,:)) CALL getarr(fidrst, '/Parts/UZ', partslist(1)%Uold(3,:)) CALL getarr(fidrst, '/Parts/UR', partslist(1)%Uold(1,:)) CALL getarr(fidrst, '/Parts/UTHET', partslist(1)%Uold(2,:)) - CALL getarr(fidrst, '/Parts/Zindex', partslist(1)%Zindex) - CALL getarr(fidrst, '/Parts/Rindex', partslist(1)%Rindex) + CALL getarr(fidrst, '/Parts/Zindex', partslist(1)%cellindex(3,:)) + CALL getarr(fidrst, '/Parts/Rindex', partslist(i)%cellindex(1,:)) CALL getarr(fidrst, '/Parts/partindex', partslist(1)%partindex) IF(isdataset(fidrst,'/Parts/fluidur')) THEN CALL getarr(fidrst, '/Parts/GAMMA', partslist(1)%Gamma) END IF end if partslist(1)%Nploc=remainingparts partslist(1)%Nptot=partslist(1)%Nploc partslist(1)%Newindex=maxval(partslist(1)%partindex) CALL getatt(fidrst, trim('/Parts'), 'zero_vel', logical_val,err) if(err .ge.0)then if(logical_val.gt.0) partslist(1)%zero_vel =.true. end if CALL getatt(fidrst, trim('/Parts'), 'iiee_id',id, err) if (err .ge. 0) then partslist(1)%iiee_id = id end if CALL getatt(fidrst, trim('/Parts'), 'neuttype_id',id, err) if (err .ge. 0) then partslist(1)%neuttype_id = id end if CALL getatt(fidrst, trim('/Parts'), 'material_id',id, err) if (err .ge. 0) then partslist(1)%material_id = id end if WRITE(*,*) "Read ", partslist(1)%Nploc, " particles out of ", remainingparts IF(nbspecies .gt. 1) THEN DO i=2,nbspecies WRITE(group,'(a,i2)')'/Parts/',i WRITE(specieindex,'(i2)') i partsdim=0 CALL getatt(fidrst, trim(group), 'remainingparts', remainingparts) if(remainingparts .gt. 0) Then CALL getdims(fidrst, trim(group) // '/Z', partsrank, partsdim) else partsdim=0 end if IF(partsdim(1).gt.remainingparts) THEN CALL creat_parts(partslist(i),partsdim(1)) partslist(i)%Nploc=remainingparts ELSE CALL creat_parts(partslist(i),max(500000,remainingparts)) ENDIF partslist(i)%q=charges(i) partslist(i)%m=masses(i) partslist(i)%weight=weights(i) partslist(i)%qmRatio=charges(i)/masses(i) err=0 CALL getatt(fidrst, trim(group), 'qmratioscale', qmratioscale, err) if(err .ge.0) partslist(i)%qmRatio=partslist(i)%qmRatio*qmratioscale partslist(i)%Nptot=remainingparts partslist(i)%Nploc=remainingparts partslist(i)%is_test =.false. partslist(i)%is_field =.false. partslist(i)%calc_moments =.false. err=0 CALL getatt(fidrst, trim(group), 'is_test', logical_val,err) if(err .ge.0)then if(logical_val.gt.0) partslist(i)%is_test =.true. end if err=0 CALL getatt(fidrst, trim(group), 'is_field', logical_val,err) if(err .ge.0)then if(logical_val.gt.0) partslist(i)%is_field =.true. end if err=0 CALL getatt(fidrst, trim(group), 'calc_moments', logical_val,err) if(err .ge.0)then if(logical_val.gt.0) partslist(i)%calc_moments =.true. end if ! --------------------------------------------------------------------------------- ! IIEE PARAMETERS CALL getatt(fidrst, trim(group), 'zero_vel', logical_val,err) if(err .ge.0)then if(logical_val.gt.0) partslist(i)%zero_vel =.true. end if CALL getatt(fidrst, trim(group), 'iiee_id',id, err) if (err .ge. 0) then partslist(i)%iiee_id = id end if CALL getatt(fidrst, trim(group), 'neuttype_id',id, err) if (err .ge. 0) then partslist(i)%neuttype_id = id end if CALL getatt(fidrst, trim(group), 'material_id',id, err) if (err .ge. 0) then partslist(i)%material_id = id end if ! END IIEE PARAMETERS ! --------------------------------------------------------------------------------- IF(partslist(i)%Nptot .gt. 0) THEN CALL getarr(fidrst, trim(group) // '/Z', partslist(i)%pos(3,:)) CALL getarr(fidrst, trim(group) // '/R', partslist(i)%pos(1,:)) CALL getarr(fidrst, trim(group) // '/THET', partslist(i)%pos(2,:)) CALL getarr(fidrst, trim(group) // '/UZ', partslist(i)%U(3,:)) CALL getarr(fidrst, trim(group) // '/UR', partslist(i)%U(1,:)) CALL getarr(fidrst, trim(group) // '/UTHET', partslist(i)%U(2,:)) CALL getarr(fidrst, trim(group) // '/UZ', partslist(i)%Uold(3,:)) CALL getarr(fidrst, trim(group) // '/UR', partslist(i)%Uold(1,:)) CALL getarr(fidrst, trim(group) // '/UTHET', partslist(i)%Uold(2,:)) CALL getarr(fidrst, trim(group) // '/GAMMA', partslist(i)%Gamma) - CALL getarr(fidrst, trim(group) // '/Zindex', partslist(i)%Zindex) - CALL getarr(fidrst, trim(group) // '/Rindex', partslist(i)%Rindex) + CALL getarr(fidrst, trim(group) // '/Zindex', partslist(i)%cellindex(3,:)) + CALL getarr(fidrst, trim(group) // '/Rindex', partslist(i)%cellindex(1,:)) CALL getarr(fidrst, trim(group) // '/partindex', partslist(i)%partindex) IF(isgroup(fidrst,'/Basic/norm')) THEN partslist(i)%pos(1,:)=partslist(i)%pos(1,:)*old_rnorm/rnorm partslist(i)%pos(3,:)=partslist(i)%pos(3,:)*old_rnorm/rnorm ELSE partslist(i)%pos(1,:)=partslist(i)%pos(1,:)*sqrt(n0/old_n0) partslist(i)%pos(3,:)=partslist(i)%pos(3,:)*sqrt(n0/old_n0) END IF partslist(i)%Newindex=maxval(partslist(i)%partindex) END IF END DO END IF IF(isgroup(fidrst,'/psupply')) THEN call getatt(fidrst,'/psupply', 'active', logical_val) if(logical_val .gt. 0) then call getatt(fidrst,'/psupply', 'bias', prev_bias) the_ps%active=.true. the_ps%bias=prev_bias/phinorm else the_ps%active=.false. end if end if CALL closef(fidrst) IF(samplefactor .gt. 1) THEN ! We increase the number of macro particles CALL upsample(partslist(1), samplefactor) END IF if( mpirank.eq. 0) CALL mv2bk(rstfile, '_start') WRITE(*,'(3x,a)') "Reading from restart file "//TRIM(rstfile)//" completed!" !________________________________________________________________________________ ! 2. Create and write to restart file (DP reals) ! CASE(1) IF( .NOT. nlsave ) RETURN CALL mv2bk(rstfile) CALL creatf(rstfile, fidrst, real_prec='d', desc='Restart file') CALL creatg(fidrst, '/Basic', 'Basic data') CALL attach(fidrst, '/Basic', 'cstep', cstep) CALL attach(fidrst, '/Basic', 'time', time) CALL attach(fidrst, '/Basic', 'jobnum', jobnum) CALL attach(fidrst, '/Basic', 'qsim', partslist(1)%q*partslist(1)%weight) CALL attach(fidrst, '/Basic', 'msim', partslist(1)%m*partslist(1)%weight) CALL attach(fidrst, '/Basic', 'n0', n0) CALL creatg(fidrst, '/Basic/norm', 'Normalisation quantities') CALL attach(fidrst, '/Basic/norm', 'rnorm', 1.0) CALL attach(fidrst, '/Basic/norm', 'bnorm', bnorm) CALL attach(fidrst, '/Basic/norm', 'enorm', enorm) CALL attach(fidrst, '/Basic/norm', 'tnorm', tnorm) CALL attach(fidrst, '/Basic/norm', 'phinorm', phinorm) ! ! 0D variables ! CALL creatg(fidrst, '/var0d', '0D variables') CALL attach(fidrst, '/var0d','etot0', etot0) CALL attach(fidrst, '/var0d','epot', epot) CALL attach(fidrst, '/var0d','ekin', ekin) CALL attach(fidrst, '/var0d','etot', etot) ! ! Parts ! CALL creatg(fidrst, '/Parts', 'Particles data') CALL attach(fidrst, '/Parts', 'nplasma', nplasma) nbspecies=size(partslist,1) CALL attach(fidrst, '/Parts', 'nbspecies', nbspecies) ALLOCATE(charges(nbspecies),masses(nbspecies),weights(nbspecies)) DO i=1,nbspecies charges(i) = partslist(i)%q masses(i) = partslist(i)%m weights(i) = partslist(i)%weight END DO CALL putarr(fidrst, '/Parts/charges', charges) CALL putarr(fidrst, '/Parts/masses', masses ) CALL putarr(fidrst, '/Parts/weights', weights) IF(mpisize .gt. 1) THEN remainingparts=sum(Nplocs_all) ELSE remainingparts=partslist(1)%Nploc END IF CALL attach(fidrst, '/Parts', 'remainingparts', remainingparts) CALL attach(fidrst, '/Parts', 'qmratioscale',partslist(1)%qmRatio/(partslist(1)%q/partslist(1)%m)) CALL putarr(fidrst, '/Parts/Z', partslist(1)%pos(3,:)*rnorm) CALL putarr(fidrst, '/Parts/R', partslist(1)%pos(1,:)*rnorm) CALL putarr(fidrst, '/Parts/THET', partslist(1)%pos(2,:)) CALL putarr(fidrst, '/Parts/UZ', partslist(1)%U(3,:)) CALL putarr(fidrst, '/Parts/UR', partslist(1)%U(1,:)) CALL putarr(fidrst, '/Parts/UTHET', partslist(1)%U(2,:)) CALL putarr(fidrst, '/Parts/GAMMA', partslist(1)%Gamma) - CALL putarr(fidrst, '/Parts/Zindex', partslist(1)%Zindex) - CALL putarr(fidrst, '/Parts/Rindex', partslist(1)%Rindex) + CALL putarr(fidrst, '/Parts/Zindex', partslist(1)%cellindex(3,:)) + CALL putarr(fidrst, '/Parts/Rindex', partslist(1)%cellindex(3,:)) CALL putarr(fidrst, '/Parts/partindex', partslist(1)%partindex) CALL putarr(fidrst, '/Parts/fluidur', partslist(1)%moments(2,:)) CALL putarr(fidrst, '/Parts/fluiduthet', partslist(1)%moments(3,:)) CALL putarr(fidrst, '/Parts/fluiduz', partslist(1)%moments(4,:)) partslist(1)%is_field=.true. partslist(1)%is_test=.false. partslist(1)%calc_moments=.true. CALL attach(fidrst, '/Parts', 'is_field', 1) CALL attach(fidrst, '/Parts', 'calc_moments', 1) CALL attach(fidrst, '/Parts', 'is_test', 0) if(partslist(1)%zero_vel)then CALL attach(fidrst, trim('/Parts'), 'zero_vel', 1) else CALL attach(fidrst, trim('/Parts'), 'zero_vel', 0) end if CALL attach(fidrst, trim('/Parts'), 'iiee_id', partslist(1)%iiee_id) CALL attach(fidrst, trim('/Parts'), 'neuttype_id', partslist(1)%neuttype_id) CALL attach(fidrst, trim('/Parts'), 'material_id', partslist(1)%material_id) IF(nbspecies .gt. 1) THEN DO i=2,nbspecies WRITE(group,'(a,i2)')'/Parts/',i WRITE(specieindex,'(i2)') i CALL creatg(fidrst, trim(group), 'Particles ' // specieindex// ' data') CALL attach(fidrst, trim(group), 'qmratioscale', partslist(i)%qmRatio/(partslist(i)%q/partslist(i)%m)) CALL attach(fidrst, trim(group), 'remainingparts', partslist(i)%Nptot) if(partslist(i)%is_test)then CALL attach(fidrst, trim(group), 'is_test', 1) else CALL attach(fidrst, trim(group), 'is_test', 0) end if if(partslist(i)%is_field)then CALL attach(fidrst, trim(group), 'is_field', 1) else CALL attach(fidrst, trim(group), 'is_field', 0) end if if(partslist(i)%calc_moments)then CALL attach(fidrst, trim(group), 'calc_moments', 1) else CALL attach(fidrst, trim(group), 'calc_moments', 0) end if !------------------------------------------------------------------------- ! IIEE PARAMETERS if(partslist(i)%zero_vel)then CALL attach(fidrst, trim(group), 'zero_vel', 1) else CALL attach(fidrst, trim(group), 'zero_vel', 0) end if CALL attach(fidrst, trim(group), 'iiee_id', partslist(i)%iiee_id) CALL attach(fidrst, trim(group), 'neuttype_id', partslist(i)%neuttype_id) CALL attach(fidrst, trim(group), 'material_id', partslist(i)%material_id) ! END OF IIEE PARAMETERS ! ------------------------------------------------------------------------ IF(partslist(i)%Nptot .gt. 0) THEN CALL putarr(fidrst, trim(group) // '/Z', partslist(i)%pos(3,1:partslist(i)%Nptot)*rnorm) CALL putarr(fidrst, trim(group) // '/R', partslist(i)%pos(1,1:partslist(i)%Nptot)*rnorm) CALL putarr(fidrst, trim(group) // '/THET', partslist(i)%pos(2,1:partslist(i)%Nptot)) CALL putarr(fidrst, trim(group) // '/UZ', partslist(i)%U(3,1:partslist(i)%Nptot)) CALL putarr(fidrst, trim(group) // '/UR', partslist(i)%U(1,1:partslist(i)%Nptot)) CALL putarr(fidrst, trim(group) // '/UTHET', partslist(i)%U(2,1:partslist(i)%Nptot)) CALL putarr(fidrst, trim(group) // '/GAMMA', partslist(i)%Gamma(1:partslist(i)%Nptot)) - CALL putarr(fidrst, trim(group) // '/Zindex', partslist(i)%Zindex(1:partslist(i)%Nptot)) - CALL putarr(fidrst, trim(group) // '/Rindex', partslist(i)%Rindex(1:partslist(i)%Nptot)) + CALL putarr(fidrst, trim(group) // '/Zindex', partslist(i)%cellindex(3,1:partslist(i)%Nptot)) + CALL putarr(fidrst, trim(group) // '/Rindex', partslist(i)%cellindex(1,1:partslist(i)%Nptot)) CALL putarr(fidrst, trim(group) // '/partindex', partslist(i)%partindex(1:partslist(i)%Nptot)) END IF END DO END IF ! ! Fields ! ! ! Power supply status ! CALL creatg(fidrst, '/psupply', 'Power supply status and values') if(the_ps%active) then CALL attach(fidrst, '/psupply','active', 1) else CALL attach(fidrst, '/psupply','active', 0) end if CALL attach(fidrst, '/psupply','bias', the_ps%bias*phinorm) CALL closef(fidrst) WRITE(*,'(3x,a)') "Writing to restart file "//TRIM(rstfile)//" completed!" ! END SELECT ! END SUBROUTINE chkrst diff --git a/src/constants.f90 b/src/constants.f90 index 6221e01..152d23f 100644 --- a/src/constants.f90 +++ b/src/constants.f90 @@ -1,16 +1,17 @@ MODULE constants ! ! Define some constants ! INTEGER, PARAMETER :: dprequestedprec = 15 INTEGER, PARAMETER :: db = SELECTED_REAL_KIND(dprequestedprec) ! REAL(kind=db), PARAMETER :: vlight = 299792458.0_db ! c REAL(kind=db), PARAMETER :: vacimp = 376.73031346177066_db ! \mu_0*c REAL(kind=db), PARAMETER :: eev = 510998.89613320108_db ! m_e*c^2/e REAL(kind=db), PARAMETER :: me = 9.109383E-31 ! electron mass [kg] REAL(kind=db), PARAMETER :: pi = 3.1415926535897931_db REAL(kind=db), PARAMETER :: elchar = 1.60217662E-19_db ! electron charge [C] REAL(kind=db), PARAMETER :: eps_0 = 8.85418781762E-12_db ! electric constant [F/m] + REAL(kind=db), PARAMETER :: mu_0 = 4.0_db*pi*1.0e-7_db ! magnetic constant [H/m] REAL(kind=db), PARAMETER :: kb = 1.38064852E-23_db ! Boltzman constant [J/K] END MODULE constants \ No newline at end of file diff --git a/src/diagnose.f90 b/src/diagnose.f90 index 38c96b1..88bdfeb 100644 --- a/src/diagnose.f90 +++ b/src/diagnose.f90 @@ -1,469 +1,470 @@ SUBROUTINE diagnose(kstep) ! ! Diagnostics ! USE basic USE futils USE hashtable Use maxwsrce Use neutcol USE beam, ONLY : partslist, epot, ekin, etot, etot0, Nplocs_all, collectparts #if USE_X == 1 USE xg, ONLY : initw, updt_xg_var #endif USE fields, ONLY: phi_spline, nbmoments USE celldiag use mpi Use geometry Use splinebound Use weighttypes use psupply use filemanip + use magnet IMPLICIT NONE ! INTEGER, INTENT(in) :: kstep ! ! Local vars and arrays INTEGER, PARAMETER :: BUFSIZE = 20 CHARACTER(len=128) :: str, fname, grpname CHARACTER(len=12):: charspec INTEGER:: Ntotal ! Total number of simulated particles remaining in the simulation INTEGER:: partsrank, partsdim(2) INTEGER:: Nplocs_all_save(64) INTEGER:: i, nbbounds INTEGER, allocatable, save:: partnbBuffer(:,:) REAL(kind=db), ALLOCATABLE :: magr(:), magz(:) REAL(kind=db), ALLOCATABLE :: tempBr(:, :), tempBz(:, :), tempAthet(:, :) INTEGER :: magn(2), magrank, magfid !________________________________________________________________________________ ! 1. Initial diagnostics IF( kstep .EQ. 0 .and. mpirank .eq. 0) THEN ! Only process 0 should save on file ! WRITE(*,'(a)') ' Initial diagnostics' ! ! 1.1 Initial run or when NEWRES set to .TRUE. ! IF( .NOT. nlres .OR. newres) THEN CALL creatf(resfile, fidres, 'FENNECS result file', real_prec='d') WRITE(*,'(3x,a,a)') TRIM(resfile), ' created' ! ! Label the run IF( LEN_TRIM(label1).GT.0 ) CALL attach(fidres, "/", "label1", TRIM(label1)) IF( LEN_TRIM(label2).GT.0 ) CALL attach(fidres, "/", "label2", TRIM(label2)) IF( LEN_TRIM(label3).GT.0 ) CALL attach(fidres, "/", "label3", TRIM(label3)) IF( LEN_TRIM(label4).GT.0 ) CALL attach(fidres, "/", "label4", TRIM(label4)) ! ! Job number jobnum = 0 ! ! Data group CALL creatg(fidres, "/data", "data") CALL creatg(fidres, "/data/var0d", "0d history arrays") CALL creatg(fidres, "/data/var1d","1d history arrays") CALL creatg(fidres, "/data/part", "part phase space") CALL creatg(fidres, "/data/fields", "Electro static potential and Er Ez fields") ! ! File group CALL creatg(fidres, "/files", "files") CALL attach(fidres, "/files", "jobnum", jobnum) CALL putarr(fidres, "/data/var1d/rgrid", rgrid) CALL putarr(fidres, "/data/var1d/zgrid", zgrid) CALL creatd(fidres, 1, (/ 64 /), "/data/var0d/Nplocs_all", "Nplocs_all") CALL creatd(fidres, 1, (/3/), "/data/var0d/nudcol", "nudcol") ! Part and fields vectors ! Initialize time-dependent particle variables CALL creatd(fidres, 1, SHAPE(partslist(1)%pos(1,:)), "/data/part/R", "R") CALL creatd(fidres, 1, SHAPE(partslist(1)%pos(3,:)), "/data/part/Z", "Z") CALL creatd(fidres, 1, SHAPE(partslist(1)%pos(2,:)), "/data/part/THET", "THET") CALL creatd(fidres, 1, SHAPE(partslist(1)%U(1,:)), "/data/part/UR", "UR") CALL creatd(fidres, 1, SHAPE(partslist(1)%U(3,:)), "/data/part/UZ", "UZ") CALL creatd(fidres, 1, SHAPE(partslist(1)%U(2,:)), "/data/part/UTHET", "UTHET") - CALL creatd(fidres, 1, SHAPE(partslist(1)%Rindex), "/data/part/Rindex", "Rindex") - CALL creatd(fidres, 1, SHAPE(partslist(1)%Zindex), "/data/part/Zindex", "Zindex") + CALL creatd(fidres, 1, SHAPE(partslist(1)%partindex), "/data/part/Rindex", "Rindex") + CALL creatd(fidres, 1, SHAPE(partslist(1)%partindex), "/data/part/Zindex", "Zindex") CALL creatd(fidres, 1, SHAPE(partslist(1)%partindex), "/data/part/partindex", "partindex") CALL creatd(fidres, 1, SHAPE(partslist(1)%pot), "/data/part/pot", "pot") CALL creatd(fidres, 0, SHAPE(time), "/data/part/time", "time" ) CALL creatd(fidres, 0, SHAPE(Ntotal), "/data/part/Nparts", "number of remaining parts in the simulation space") CALL creatd(fidres, 1, (/7/), "/data/part/nbchange", "number of added parts, lost parts zm,zp,rm,rp, and collisions per type io, ela") CALL attach(fidres,'/data/part', "q", partslist(1)%q) CALL attach(fidres,'/data/part', "m", partslist(1)%m) CALL attach(fidres,'/data/part', "weight", partslist(1)%weight) CALL creatd(fidres, 1, SHAPE(pot), "/data/fields/pot", "pot") CALL creatd(fidres, 1, SHAPE(Er), "/data/fields/Er", "Er") CALL creatd(fidres, 1, SHAPE(Ez), "/data/fields/Ez", "Ez") CALL creatd(fidres, 1, SHAPE(phi_spline), "/data/fields/phi", "spline form of Phi") CALL creatd(fidres, 2, (/nbmoments,nrank(1)*nrank(2)/), "/data/fields/moments", "moments",compress=.true.,chunking=(/1,nrank(1)*nrank(2)/)) !CALL creatd(fidres, 2, SHAPE(moments), "/data/fields/moments", "moments") CALL creatd(fidres, 0, SHAPE(time), "/data/fields/time", "time" ) CALL putarr(fidres, "/data/fields/Br", Br) CALL putarr(fidres, "/data/fields/Bz", Bz) CALL putarr(fidres, "/data/fields/Athet", Athet) CALL putarr(fidres, "/data/fields/volume", Volume) ! We save the magnetic field as defined by the h5 file - if(len_trim(magnetfile) .gt. 1) then + if(len_trim(magnetfile) .gt. 1 .and. .not. allocated(the_coils) ) then CALL openf(trim(magnetfile), magfid, 'r', real_prec='d') CALL getdims(magfid, '/mag/Athet', magrank, magn) ALLOCATE (magr(magn(2)), magz(magn(1))) ALLOCATE (tempAthet(magn(1), magn(2)), tempBr(magn(1), magn(2)), tempBz(magn(1), magn(2))) ! Read r and z coordinates for the definition of A_\thet, and B CALL getarr(magfid, '/mag/r', magr) CALL getarr(magfid, '/mag/z', magz) CALL getarr(magfid, '/mag/Athet', tempAthet) IF (isdataset(magfid, '/mag/Br') .and. isdataset(magfid, '/mag/Bz')) THEN CALL getarr(magfid, '/mag/Br', tempBr) CALL getarr(magfid, '/mag/Bz', tempBz) end if CALL creatg(fidres, '/data/inputmag') CALL putarr(fidres, '/data/inputmag/r',magr) CALL putarr(fidres, '/data/inputmag/z',magz) CALL putarr(fidres, '/data/inputmag/Athet',tempAthet) CALL putarr(fidres, '/data/inputmag/Br',tempBr) CALL putarr(fidres, '/data/inputmag/Bz',tempBz) call closef(magfid) end if ! ! 1.2 Restart run ! ELSE CALL cp2bk(resfile) ! backup previous result file CALL openf(resfile, fidres, real_prec='d') WRITE(*,'(3x,a,a)') TRIM(resfile), ' open' CALL getatt(fidres, "/files", "jobnum", jobnum) jobnum = jobnum+1 WRITE(*,'(3x,a,i3)') "Current Job Number =", jobnum CALL attach(fidres, "/files", "jobnum", jobnum) !allocate(partnbBuffer(nbspecies,4+size(partslist(1)%nblost,1))) !partnbBuffer=0 END IF ! ! Add input namelist variables as attributes of /data/input WRITE(str,'(a,i2.2)') "/data/input.",jobnum CALL creatg(fidres, TRIM(str)) CALL attach(fidres, TRIM(str), "job_time", job_time) CALL attach(fidres, TRIM(str), "extra_time", extra_time) CALL attach(fidres, TRIM(str), "dt", dt*tnorm) CALL attach(fidres, TRIM(str), "tmax", tmax) CALL attach(fidres, TRIM(str), "nrun", nrun) CALL attach(fidres, TRIM(str), "nlres", nlres) CALL attach(fidres, TRIM(str), "nlsave", nlsave) CALL attach(fidres, TRIM(str), "newres", newres) CALL attach(fidres, TRIM(str), "nz", nz) CALL attach(fidres, TRIM(str), "nr", nr) CALL putarr(fidres, TRIM(str)//"/lz", lz) CALL attach(fidres, TRIM(str), "nplasma", nplasma) CALL attach(fidres, TRIM(str), "potinn", potinn) CALL attach(fidres, TRIM(str), "potout", potout) CALL attach(fidres, TRIM(str), "B0", B0) CALL attach(fidres, TRIM(str), "Rcurv", Rcurv) CALL attach(fidres, TRIM(str), "width", width) CALL attach(fidres, TRIM(str), "n0", n0) CALL attach(fidres, TRIM(str), "temp", partslist(1)%temperature) CALL attach(fidres, TRIM(str), "it0d", it0d) CALL attach(fidres, TRIM(str), "it2d", it2d) CALL attach(fidres, TRIM(str), "itparts", itparts) CALL attach(fidres, TRIM(str), "nlclassical", nlclassical) CALL attach(fidres, TRIM(str), "nlPhis", nlPhis) CALL attach(fidres, TRIM(str), "qsim", partslist(1)%q*partslist(1)%weight) CALL attach(fidres, TRIM(str), "msim", partslist(1)%m*partslist(1)%weight) CALL attach(fidres, TRIM(str), "startstep", cstep) CALL attach(fidres, TRIM(str), "H0", partslist(1)%H0) CALL attach(fidres, TRIM(str), "P0", partslist(1)%P0) CALL putarr(fidres, TRIM(str)//"/femorder", femorder) CALL putarr(fidres, TRIM(str)//"/ngauss", ngauss) CALL putarr(fidres, TRIM(str)//"/nnr", nnr) CALL putarr(fidres, TRIM(str)//"/nnz", nnz) CALL putarr(fidres, TRIM(str)//"/radii", radii) CALL putarr(fidres, TRIM(str)//"/plasmadim", plasmadim) CALL attach(fidres, TRIM(str), "rawparts", .true.) CALL attach(fidres, TRIM(str), "nbspecies", nbspecies) CALL putarr(fidres, TRIM(str)//"/potxt", potxt) CALL putarr(fidres, TRIM(str)//"/Erxt", Erxt) CALL putarr(fidres, TRIM(str)//"/Ezxt", Ezxt) ! Save geometry parameters for non conforming boundary conditions Call geom_diag(fidres,str,rnorm) ! Save geometry parameters for non conforming boundary conditions using b-spline curves call splinebound_diag(fidres, str, the_domain) ! Save Maxwellsource parameters for the ad-hoc source Call maxwsrce_diag(fidres,str,vnorm) ! Save neutcol parameters for the electron collisions with neutrals Call neutcol_diag(fidres,str,vnorm) if(.not. isdataset(fidres,'/data/var0d/nudcol'))then CALL creatd(fidres, 1, (/3/), "/data/var0d/nudcol", "nudcol") end if ! Save psupply parameters for the simulation of realistic power supplies Call psupply_diag(fidres,str) if(.not. isdataset(fidres,'/data/var0d/biases'))then nbbounds=2 if(the_domain%nbsplines .gt. 0) nbbounds=the_domain%nbsplines CALL creatd(fidres, 1, (/nbbounds/), "/data/var0d/biases", "biases") end if ! Save STDIN of this run WRITE(str,'(a,i2.2)') "/files/STDIN.",jobnum INQUIRE(unit=lu_in, name=fname) CALL putfile(fidres, TRIM(str), TRIM(fname)) ! Prepare hdf5 file for storing test particles DO i=2,nbspecies WRITE(grpname,'(a,i2)')'/data/part/',i call create_parts_group(partslist(i),trim(grpname),time) END DO CALL attach(fidres, "/data/part", "nbspecies", nbspecies) ! ! Initialize buffers for 0d history arrays CALL htable_init(hbuf0, BUFSIZE) CALL set_htable_fileid(hbuf0, fidres, "/data/var0d") ! ! Initialize Xgrafix #if USE_X == 1 IF(nlxg) THEN CALL initw END IF #endif END IF IF(kstep .EQ. 0) THEN ! Initialize particle cell diagnostic CALL celldiag_init(lu_in, fidres) CLOSE(lu_in) allocate(partnbBuffer(nbspecies,4+size(partslist(1)%nblost,1))) partnbBuffer=0 END IF !________________________________________________________________________________ ! 2. Periodic diagnostics IF( kstep .NE. -1) THEN IF(modulo(step,ittracer) .eq. 0 .or. nlend) THEN ! We gather the traced particles on the mpi host DO i=1,nbspecies IF(partslist(i)%is_test) CALL collectparts(partslist(i)) END DO END IF IF(modulo(step,itrestart) .eq. 0 .or. modulo(step,itparts) .eq. 0 .or. nlend) THEN ! We gather the traced particles on the mpi host DO i=1,nbspecies CALL collectparts(partslist(i)) END DO END IF do i=1,nbspecies partnbBuffer(i,1)=partnbBuffer(i,1)+partslist(i)%nbadded partnbBuffer(i,2:3)=partnbBuffer(i,2:3)+partslist(i)%nbcolls partnbBuffer(i,4)=partslist(i)%Nploc partnbBuffer(i,5:)=partnbBuffer(i,5:)+partslist(i)%nblost partslist(i)%nbadded=0 partslist(i)%nblost=0 partslist(i)%nbcolls=0 end do IF(modulo(step,ittext) .eq. 0 .or. nlend) THEN ! We gather the number of gained and lost particles on the mpi host IF(mpirank .eq.0 ) THEN CALL MPI_REDUCE(MPI_IN_PLACE, partnbBuffer, nbspecies*(4+size(partslist(1)%nblost,1)), MPI_INTEGER, MPI_SUM, & & 0, MPI_COMM_WORLD, ierr) ELSE CALL MPI_REDUCE(partnbBuffer, partnbBuffer, nbspecies*(4+size(partslist(1)%nblost,1)), MPI_INTEGER, MPI_SUM, & & 0, MPI_COMM_WORLD, ierr) partnbBuffer=0 END IF end if ! ! Only process 0 should save on file IF(mpirank .ne. 0) RETURN ! IF (mpisize .gt. 1) THEN partslist(1)%Nptot=sum(Nplocs_all) END IF ! IF(modulo(step,ittext).eq. 0 .or. nlend) THEN WRITE(*,'(a,1x,i8.8,a1,i8.8,20x,a,1pe10.3)') '*** Timestep (this run/total) =', & & step, '/', cstep, 'Time =', time if( abs(etot).gt. 0) then WRITE(*,'(a,6(1pe12.4),1x,i8.8,a1,i8.8)') 'Epot, Ekin, Etot, Etot0, Eerr, Eerr rel, Nbparts/Ntotal', epot, ekin, etot, etot0, etot-etot0,(etot-etot0)/etot, partslist(1)%Nptot,'/',nplasma else WRITE(*,'(a,4(1pe12.4),1x,i8.8,a1,i8.8)') 'Epot, Ekin, Etot, Eerr, Nbparts/Ntotal', epot, ekin, etot, etot-etot0, partslist(1)%Nptot,'/',nplasma end if IF(mpisize .gt. 1 ) then WRITE(*,'(a,64i10.7)') 'Nbparts per proc', Nplocs_all end if Write(*,'(a)')"speci, added, iocoll, elacoll, tot var, tot, Losses (zmin zmax rmin rmax boundaries(i))" write(charspec,'(a,i02,a)') '(i04,',size(partnbBuffer,2)+1,'i9.7)' do i=1,nbspecies WRITE(*,charspec) i, partnbBuffer(i,1),partnbBuffer(i,2:3), partnbBuffer(i,1)-sum(partnbBuffer(i,5:)), partnbBuffer(i,4),-partnbBuffer(i,5:) partslist(i)%nptot= partnbBuffer(i,4) end do partnbBuffer=0 END IF !________________________________________________________________________________ ! ! 2.1 0d history arrays ! ! if we do a restart, we don't want to save the same data twice IF( kstep .eq. 0 .and. nlres .and. (.not. newres)) return IF(modulo(step,it0d).eq. 0 .or. nlend) THEN CALL add_record(hbuf0, "time", "simulation time", time) CALL add_record(hbuf0, "epot", "potential energy", epot) CALL add_record(hbuf0, "ekin", "kinetic energy", ekin) CALL add_record(hbuf0, "etot", "total energy", etot) CALL add_record(hbuf0, "etot0", "theoretical total energy", etot0) CALL add_record(hbuf0, "nbparts", "number of remaining parts in the simulation space", REAL(partslist(1)%Nptot,kind=db)) CALL add_record(hbuf0,"current", "unscaled current flowing between the electrodes of the power supplies [A]", the_ps%current(1)*qnorm/tnorm) CALL htable_endstep(hbuf0) Nplocs_all_save=0 Nplocs_all_save(1:mpisize)=Nplocs_all(0:mpisize-1) CALL append(fidres, "/data/var0d/Nplocs_all", REAL(Nplocs_all_save,kind=db)) CALL append(fidres, "/data/var0d/nudcol", partslist(1)%nudcol/(dt*tnorm)) CALL append(fidres, "/data/var0d/biases", the_ps%biases*phinorm) END IF ! ! 2.2 2d profiles IF(modulo(step,it2d).eq. 0 .or. nlend) THEN CALL append(fidres, "/data/fields/time", time) CALL append(fidres, "/data/fields/pot", pot*phinorm) CALL append(fidres, "/data/fields/Er", Er*enorm) CALL append(fidres, "/data/fields/Ez", Ez*enorm) CALL append(fidres, "/data/fields/phi", phi_spline*phinorm) CALL append(fidres, "/data/fields/moments", partslist(1)%moments) DO i=2,nbspecies IF ( .not. partslist(i)%calc_moments) CYCLE WRITE(grpname,'(a,i2,a)')'/data/part/',i,'/' CALL append(fidres, trim(grpname) // "moments", partslist(i)%moments) end DO END IF ! ! 2.3 main specie quantities IF(modulo(step,itparts).eq. 0 .or. nlend) THEN !PRINT*, 'write particles to file_____________________' CALL append(fidres, "/data/part/time", time) CALL append(fidres, "/data/part/Nparts", REAL(partslist(1)%Nptot,kind=db)) !CALL append(fidres, "/data/part/nbchange", REAL((/partslist(1)%nbadded,partslist(1)%nblost,partslist(1)%nbcolls/),kind=db)) IF ( isdataset(fidres,'/data/part/R') ) THEN CALL getdims(fidres, '/data/part/R', partsrank, partsdim) partsdim(1)=min(size(partslist(1)%pos,2), partsdim(1)) CALL append(fidres, "/data/part/R", partslist(1)%pos(1,1:partsdim(1))*rnorm) CALL append(fidres, "/data/part/Z", partslist(1)%pos(3,1:partsdim(1))*rnorm) CALL append(fidres, "/data/part/THET", partslist(1)%pos(2,1:partsdim(1))) CALL append(fidres, "/data/part/UZ", 0.5*(partslist(1)%U(3,1:partsdim(1))/partslist(1)%gamma(1:partsdim(1))+partslist(1)%Uold(3,1:partsdim(1))/partslist(1)%gammaold(1:partsdim(1)))) CALL append(fidres, "/data/part/UR", 0.5*(partslist(1)%U(1,1:partsdim(1))/partslist(1)%gamma(1:partsdim(1))+partslist(1)%Uold(1,1:partsdim(1))/partslist(1)%gammaold(1:partsdim(1)))) CALL append(fidres, "/data/part/UTHET", 0.5*(partslist(1)%U(2,1:partsdim(1))/partslist(1)%gamma(1:partsdim(1))+partslist(1)%Uold(2,1:partsdim(1))/partslist(1)%gammaold(1:partsdim(1)))) CALL append(fidres, "/data/part/pot", partslist(1)%pot(1:partsdim(1))*phinorm) - CALL append(fidres, "/data/part/Rindex", REAL(partslist(1)%Rindex(1:partsdim(1)),kind=db)) - CALL append(fidres, "/data/part/Zindex", REAL(partslist(1)%Zindex(1:partsdim(1)),kind=db)) + CALL append(fidres, "/data/part/Rindex", REAL(partslist(1)%cellindex(1,1:partsdim(1)),kind=db)) + CALL append(fidres, "/data/part/Zindex", REAL(partslist(1)%cellindex(3,1:partsdim(1)),kind=db)) CALL append(fidres, "/data/part/partindex", REAL(partslist(1)%partindex(1:partsdim(1)),kind=db)) END IF END IF ! ! 2.4 Tracer quantities IF(modulo(step,ittracer).eq. 0 .or. nlend) THEN !PRINT*, 'write particles to file_____________________' DO i=2,nbspecies IF ( .not. partslist(i)%is_test) CYCLE WRITE(grpname,'(a,i2,a)')'/data/part/',i,'/' CALL append(fidres, trim(grpname) // "time", time) CALL append(fidres, trim(grpname) //"Nparts", REAL(partslist(i)%Nptot,kind=db)) !CALL append(fidres, trim(grpname) //"nbchange", REAL((/partslist(i)%nbadded,partslist(i)%nblost,partslist(i)%nbcolls/),kind=db)) IF ( isdataset(fidres,trim(grpname)//'R') ) THEN CALL getdims(fidres, trim(grpname) // 'R', partsrank, partsdim) partsdim(1)=min(size(partslist(i)%pos,2), partsdim(1)) CALL append(fidres, trim(grpname) // "R", partslist(i)%pos(1,1:partsdim(1))*rnorm) CALL append(fidres, trim(grpname) // "Z", partslist(i)%pos(3,1:partsdim(1))*rnorm) CALL append(fidres, trim(grpname) // "THET", partslist(i)%pos(2,1:partsdim(1))) CALL append(fidres, trim(grpname) // "UZ", 0.5*(partslist(i)%U(3,1:partsdim(1))/partslist(i)%gamma(1:partsdim(1)) + partslist(i)%Uold(3,1:partsdim(1))/partslist(i)%gammaold(1:partsdim(1)))) CALL append(fidres, trim(grpname) // "UR", 0.5*(partslist(i)%U(1,1:partsdim(1))/partslist(i)%gamma(1:partsdim(1)) + partslist(i)%Uold(1,1:partsdim(1))/partslist(i)%gammaold(1:partsdim(1)))) CALL append(fidres, trim(grpname) // "UTHET", 0.5*(partslist(i)%U(2,1:partsdim(1))/partslist(i)%gamma(1:partsdim(1)) + partslist(i)%Uold(2,1:partsdim(1))/partslist(i)%gammaold(1:partsdim(1)))) CALL append(fidres, trim(grpname) // "pot", partslist(i)%pot(1:partsdim(1))*phinorm) - CALL append(fidres, trim(grpname) // "Rindex", REAL(partslist(i)%Rindex(1:partsdim(1)),kind=db)) - CALL append(fidres, trim(grpname) // "Zindex", REAL(partslist(i)%Zindex(1:partsdim(1)),kind=db)) + CALL append(fidres, trim(grpname) // "Rindex", REAL(partslist(i)%cellindex(1,1:partsdim(1)),kind=db)) + CALL append(fidres, trim(grpname) // "Zindex", REAL(partslist(i)%cellindex(3,1:partsdim(1)),kind=db)) CALL append(fidres, trim(grpname) // "partindex", REAL(partslist(i)%partindex(1:partsdim(1)),kind=db)) END IF END DO ! END IF ! 2.5 3d profiles ! ! ! 2.6 Xgrafix ! #if USE_X == 1 IF(nlxg .AND. modulo(kstep,itgraph) .eq. 0) THEN call xgevent CALL updt_xg_var CALL xgupdate END IF #endif !________________________________________________________________________________ ! 3. Final diagnostics ELSE ! Only process 0 should save on file IF(mpirank .ne. 0) RETURN ! ! Flush 0d history array buffers CALL htable_hdf5_flush(hbuf0) ! ! Close all diagnostic files CALL closef(fidres) !________________________________________________________________________________ END IF ! CONTAINS SUBROUTINE create_parts_group(p,grpname, time) USE beam,ONLY: particles type(particles):: p real(kind=db):: time character(len=*):: grpname If(isgroup(fidres, trim(grpname))) return CALL creatg(fidres, grpname, "specific specie phase space") CALL creatd(fidres, 0, SHAPE(time), trim(grpname) // "/time", "time") CALL creatd(fidres, 0, SHAPE(time), trim(grpname) //"/Nparts", "number of remaining parts") CALL creatd(fidres, 1, SHAPE(p%pot), trim(grpname) // "/R", "radial pos") CALL creatd(fidres, 1, SHAPE(p%pot), trim(grpname) // "/Z", "axial pos") CALL creatd(fidres, 1, SHAPE(p%pot), trim(grpname) // "/THET", "azimuthal pos") CALL creatd(fidres, 1, SHAPE(p%pot), trim(grpname) // "/UZ", "axial beta*gamma") CALL creatd(fidres, 1, SHAPE(p%pot), trim(grpname) // "/UR", "radial beta*gamma") CALL creatd(fidres, 1, SHAPE(p%pot), trim(grpname) // "/UTHET", "azimuthal beta*gamma") CALL creatd(fidres, 1, SHAPE(p%pot), trim(grpname) // "/pot", "electric potential") CALL creatd(fidres, 1, SHAPE(p%pot), trim(grpname) // "/Rindex", "radial grid index") CALL creatd(fidres, 1, SHAPE(p%pot), trim(grpname) // "/Zindex", "axial grid index") CALL creatd(fidres, 1, SHAPE(p%pot), trim(grpname) // "/partindex", "particle index") CALL creatd(fidres, 1, (/7/), trim(grpname) // "nbchange", "number of added parts, lost parts zm,zp,rm,rp, and collisions per type io, ela") CALL attach(fidres,trim(grpname), "q", p%q) CALL attach(fidres,trim(grpname), "m", p%m) CALL attach(fidres,trim(grpname), "weight", p%weight) CALL creatd(fidres, 2, (/nbmoments,nrank(1)*nrank(2)/), trim(grpname) // "/moments", "moments") END SUBROUTINE create_parts_group END SUBROUTINE diagnose diff --git a/src/elliptic_mod.f90 b/src/elliptic_mod.f90 new file mode 100644 index 0000000..05edfbe --- /dev/null +++ b/src/elliptic_mod.f90 @@ -0,0 +1,5311 @@ +Module elliptic + + IMPLICIT NONE + +Contains + +function elliptic_ea ( a ) + +!*****************************************************************************80 +! +!! ELLIPTIC_EA evaluates the complete elliptic integral E(A). +! +! Discussion: +! +! The value is computed using Carlson elliptic integrals: +! +! E(a) = RF ( 0, 1-sin^2(a), 1 ) - 1/3 sin^2(a) RD ( 0, 1-sin^2(a), 1 ). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 May 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A, the argument. +! +! Output, real ( kind = 8 ) ELLIPTIC_EA, the function value. +! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) elliptic_ea + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) k + real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00 + !real ( kind = 8 ) rd + !real ( kind = 8 ) rf + real ( kind = 8 ) value + real ( kind = 8 ) x + real ( kind = 8 ) y + real ( kind = 8 ) z + + k = sin ( a * r8_pi / 180.0D+00 ) + + x = 0.0D+00 + y = ( 1.0D+00 - k ) * ( 1.0D+00 + k ) + z = 1.0D+00 + errtol = 1.0D-03 + + value = rf ( x, y, z, errtol, ierr ) & + - k * k * rd ( x, y, z, errtol, ierr ) / 3.0D+00 + + elliptic_ea = value + + return +end + +subroutine elliptic_ea_values ( n_data, x, fx ) + +!*****************************************************************************80 +! +!! ELLIPTIC_EA_VALUES returns values of the complete elliptic integral E(A). +! +! Discussion: +! +! This is one form of what is sometimes called the complete elliptic +! integral of the second kind. +! +! The function is defined by the formula: +! +! E(A) = integral ( 0 <= T <= PI/2 ) +! sqrt ( 1 - sin ( A )^2 * sin ( T )^2 ) dT +! +! In Mathematica, the function can be evaluated by: +! +! EllipticE[(Sin[Pi*a/180])^2] +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 August 2004 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) X, the argument of the function, measured +! in degrees. +! +! Output, real ( kind = 8 ) FX, the value of the function. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 19 + + real ( kind = 8 ) fx + real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & + 1.570796326794897D+00, & + 1.567809073977622D+00, & + 1.558887196601596D+00, & + 1.544150496914673D+00, & + 1.523799205259774D+00, & + 1.498114928422116D+00, & + 1.467462209339427D+00, & + 1.432290969306756D+00, & + 1.393140248523812D+00, & + 1.350643881047676D+00, & + 1.305539094297794D+00, & + 1.258679624779997D+00, & + 1.211056027568459D+00, & + 1.163827964493139D+00, & + 1.118377737969864D+00, & + 1.076405113076403D+00, & + 1.040114395706010D+00, & + 1.012663506234396D+00, & + 1.000000000000000D+00 /) + integer ( kind = 4 ) n_data + real ( kind = 8 ) x + real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & + 0.0D+00, & + 5.0D+00, & + 10.0D+00, & + 15.0D+00, & + 20.0D+00, & + 25.0D+00, & + 30.0D+00, & + 35.0D+00, & + 40.0D+00, & + 45.0D+00, & + 50.0D+00, & + 55.0D+00, & + 60.0D+00, & + 65.0D+00, & + 70.0D+00, & + 75.0D+00, & + 80.0D+00, & + 85.0D+00, & + 90.0D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + x = 0.0D+00 + fx = 0.0D+00 + else + x = x_vec(n_data) + fx = fx_vec(n_data) + end if + + return +end +function elliptic_ek ( k ) + +!*****************************************************************************80 +! +!! ELLIPTIC_EK evaluates the complete elliptic integral E(K). +! +! Discussion: +! +! The value is computed using Carlson elliptic integrals: +! +! E(k) = RF ( 0, 1-k^2, 1 ) - 1/3 k^2 RD ( 0, 1-k^2, 1 ). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 May 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) K, the argument. +! +! Output, real ( kind = 8 ) ELLIPTIC_EK, the function value. +! + implicit none + + real ( kind = 8 ) elliptic_ek + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) k + !real ( kind = 8 ) rd + !real ( kind = 8 ) rf + real ( kind = 8 ) value + real ( kind = 8 ) x + real ( kind = 8 ) y + real ( kind = 8 ) z + + x = 0.0D+00 + y = ( 1.0D+00 - k ) * ( 1.0D+00 + k ) + z = 1.0D+00 + errtol = 1.0D-03 + + value = rf ( x, y, z, errtol, ierr ) & + - k * k * rd ( x, y, z, errtol, ierr ) / 3.0D+00 + + elliptic_ek = value + + return +end +subroutine elliptic_ek_values ( n_data, x, fx ) + +!*****************************************************************************80 +! +!! ELLIPTIC_EK_VALUES returns values of the complete elliptic integral E(K). +! +! Discussion: +! +! This is one form of what is sometimes called the complete elliptic +! integral of the second kind. +! +! The function is defined by the formula: +! +! E(K) = integral ( 0 <= T <= PI/2 ) +! sqrt ( 1 - K^2 * sin ( T )^2 ) dT +! +! In Mathematica, the function can be evaluated by: +! +! EllipticE[m] +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 29 May 2018 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) X, the argument of the function. +! +! Output, real ( kind = 8 ) FX, the value of the function. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 21 + + real ( kind = 8 ) fx + real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & + 1.570796326794897D+00, & + 1.550973351780472D+00, & + 1.530757636897763D+00, & + 1.510121832092819D+00, & + 1.489035058095853D+00, & + 1.467462209339427D+00, & + 1.445363064412665D+00, & + 1.422691133490879D+00, & + 1.399392138897432D+00, & + 1.375401971871116D+00, & + 1.350643881047676D+00, & + 1.325024497958230D+00, & + 1.298428035046913D+00, & + 1.270707479650149D+00, & + 1.241670567945823D+00, & + 1.211056027568459D+00, & + 1.178489924327839D+00, & + 1.143395791883166D+00, & + 1.104774732704073D+00, & + 1.060473727766278D+00, & + 1.000000000000000D+00 /) + integer ( kind = 4 ) n_data + real ( kind = 8 ) x + real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & + 0.0000000000000000D+00, & + 0.2236067977499790D+00, & + 0.3162277660168379D+00, & + 0.3872983346207417D+00, & + 0.4472135954999579D+00, & + 0.5000000000000000D+00, & + 0.5477225575051661D+00, & + 0.5916079783099616D+00, & + 0.6324555320336759D+00, & + 0.6708203932499369D+00, & + 0.7071067811865476D+00, & + 0.7416198487095663D+00, & + 0.7745966692414834D+00, & + 0.8062257748298550D+00, & + 0.8366600265340756D+00, & + 0.8660254037844386D+00, & + 0.8944271909999159D+00, & + 0.9219544457292888D+00, & + 0.9486832980505138D+00, & + 0.9746794344808963D+00, & + 1.0000000000000000D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + x = 0.0D+00 + fx = 0.0D+00 + else + x = x_vec(n_data) + fx = fx_vec(n_data) + end if + + return +end +function elliptic_em ( m ) + +!*****************************************************************************80 +! +!! ELLIPTIC_EM evaluates the complete elliptic integral E(M). +! +! Discussion: +! +! The value is computed using Carlson elliptic integrals: +! +! E(m) = RF ( 0, 1-m, 1 ) - 1/3 m RD ( 0, 1-m, 1 ). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 May 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) M, the argument. +! +! Output, real ( kind = 8 ) ELLIPTIC_EM, the function value. +! + implicit none + + real ( kind = 8 ) elliptic_em + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) m + !real ( kind = 8 ) rd + !real ( kind = 8 ) rf + real ( kind = 8 ) value + real ( kind = 8 ) x + real ( kind = 8 ) y + real ( kind = 8 ) z + + x = 0.0D+00 + y = 1.0D+00 - m + z = 1.0D+00 + errtol = 1.0D-03 + + value = rf ( x, y, z, errtol, ierr ) & + - m * rd ( x, y, z, errtol, ierr ) / 3.0D+00 + + elliptic_em = value + + return +end +subroutine elliptic_em_values ( n_data, x, fx ) + +!*****************************************************************************80 +! +!! ELLIPTIC_EM_VALUES returns values of the complete elliptic integral E(M). +! +! Discussion: +! +! This is one form of what is sometimes called the complete elliptic +! integral of the second kind. +! +! The function is defined by the formula: +! +! E(M) = integral ( 0 <= T <= PI/2 ) +! sqrt ( 1 - M * sin ( T )^2 ) dT +! +! In Mathematica, the function can be evaluated by: +! +! EllipticE[m] +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 14 August 2004 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) X, the argument of the function. +! +! Output, real ( kind = 8 ) FX, the value of the function. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 21 + + real ( kind = 8 ) fx + real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & + 1.570796326794897D+00, & + 1.550973351780472D+00, & + 1.530757636897763D+00, & + 1.510121832092819D+00, & + 1.489035058095853D+00, & + 1.467462209339427D+00, & + 1.445363064412665D+00, & + 1.422691133490879D+00, & + 1.399392138897432D+00, & + 1.375401971871116D+00, & + 1.350643881047676D+00, & + 1.325024497958230D+00, & + 1.298428035046913D+00, & + 1.270707479650149D+00, & + 1.241670567945823D+00, & + 1.211056027568459D+00, & + 1.178489924327839D+00, & + 1.143395791883166D+00, & + 1.104774732704073D+00, & + 1.060473727766278D+00, & + 1.000000000000000D+00 /) + integer ( kind = 4 ) n_data + real ( kind = 8 ) x + real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & + 0.00D+00, & + 0.05D+00, & + 0.10D+00, & + 0.15D+00, & + 0.20D+00, & + 0.25D+00, & + 0.30D+00, & + 0.35D+00, & + 0.40D+00, & + 0.45D+00, & + 0.50D+00, & + 0.55D+00, & + 0.60D+00, & + 0.65D+00, & + 0.70D+00, & + 0.75D+00, & + 0.80D+00, & + 0.85D+00, & + 0.90D+00, & + 0.95D+00, & + 1.00D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + x = 0.0D+00 + fx = 0.0D+00 + else + x = x_vec(n_data) + fx = fx_vec(n_data) + end if + + return +end +function elliptic_fa ( a ) + +!*****************************************************************************80 +! +!! ELLIPTIC_FA evaluates the complete elliptic integral F(A). +! +! Discussion: +! +! The value is computed using Carlson elliptic integrals: +! +! F(a) = RF ( 0, 1-sin^2(a), 1 ). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 29 May 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A, the argument. +! +! Output, real ( kind = 8 ) ELLIPTIC_FA, the function value. +! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) elliptic_fa + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00 + !real ( kind = 8 ) rf + real ( kind = 8 ) value + real ( kind = 8 ) x + real ( kind = 8 ) y + real ( kind = 8 ) z + + x = 0.0D+00 + y = 1.0D+00 - ( sin ( a * r8_pi / 180.0 ) ) ** 2 + z = 1.0D+00 + errtol = 1.0D-03 + + value = rf ( x, y, z, errtol, ierr ) + + elliptic_fa = value + + return +end +subroutine elliptic_fa_values ( n_data, x, fx ) + +!*****************************************************************************80 +! +!! ELLIPTIC_FA_VALUES returns values of the complete elliptic integral F(A). +! +! Discussion: +! +! This is one form of what is sometimes called the complete elliptic integral +! of the first kind. +! +! The function is defined by the formula: +! +! F(A) = integral ( 0 <= T <= PI/2 ) +! dT / sqrt ( 1 - sin ( A )^2 * sin ( T )^2 ) +! +! In Mathematica, the function can be evaluated by: +! +! EllipticK[(Sin[a*Pi/180])^2] +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 August 2004 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) X, the argument of the function, measured +! in degrees. +! +! Output, real ( kind = 8 ) FX, the value of the function. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 18 + + real ( kind = 8 ) fx + real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & + 0.1570796326794897D+01, & + 0.1573792130924768D+01, & + 0.1582842804338351D+01, & + 0.1598142002112540D+01, & + 0.1620025899124204D+01, & + 0.1648995218478530D+01, & + 0.1685750354812596D+01, & + 0.1731245175657058D+01, & + 0.1786769134885021D+01, & + 0.1854074677301372D+01, & + 0.1935581096004722D+01, & + 0.2034715312185791D+01, & + 0.2156515647499643D+01, & + 0.2308786798167196D+01, & + 0.2504550079001634D+01, & + 0.2768063145368768D+01, & + 0.3153385251887839D+01, & + 0.3831741999784146D+01 /) + integer ( kind = 4 ) n_data + real ( kind = 8 ) x + real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & + 0.0D+00, & + 5.0D+00, & + 10.0D+00, & + 15.0D+00, & + 20.0D+00, & + 25.0D+00, & + 30.0D+00, & + 35.0D+00, & + 40.0D+00, & + 45.0D+00, & + 50.0D+00, & + 55.0D+00, & + 60.0D+00, & + 65.0D+00, & + 70.0D+00, & + 75.0D+00, & + 80.0D+00, & + 85.0D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + x = 0.0D+00 + fx = 0.0D+00 + else + x = x_vec(n_data) + fx = fx_vec(n_data) + end if + + return +end +function elliptic_fk ( k ) + +!*****************************************************************************80 +! +!! ELLIPTIC_FK evaluates the complete elliptic integral F(K). +! +! Discussion: +! +! The value is computed using Carlson elliptic integrals: +! +! F(k) = RF ( 0, 1-k^2, 1 ). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 29 May 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) K, the argument. +! +! Output, real ( kind = 8 ) ELLIPTIC_FK, the function value. +! + implicit none + + real ( kind = 8 ) elliptic_fk + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) k + !real ( kind = 8 ) rf + real ( kind = 8 ) value + real ( kind = 8 ) x + real ( kind = 8 ) y + real ( kind = 8 ) z + + x = 0.0D+00 + y = ( 1.0D+00 - k ) * ( 1.0D+00 + k ) + z = 1.0D+00 + errtol = 1.0D-03 + + value = rf ( x, y, z, errtol, ierr ) + + elliptic_fk = value + + return +end +subroutine elliptic_fk_values ( n_data, x, fx ) + +!*****************************************************************************80 +! +!! ELLIPTIC_FK_VALUES returns values of the complete elliptic integral F(K). +! +! Discussion: +! +! This is one form of what is sometimes called the complete elliptic +! integral of the first kind. +! +! The function is defined by the formula: +! +! F(K) = integral ( 0 <= T <= PI/2 ) +! dT / sqrt ( 1 - K^2 * sin ( T )^2 ) +! +! In Mathematica, the function can be evaluated by: +! +! EllipticK[k^2] +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 August 2004 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) X, the argument of the function. +! +! Output, real ( kind = 8 ) FX, the value of the function. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 20 + + real ( kind = 8 ) fx + real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & + 1.570796326794897D+00, & + 1.591003453790792D+00, & + 1.612441348720219D+00, & + 1.635256732264580D+00, & + 1.659623598610528D+00, & + 1.685750354812596D+00, & + 1.713889448178791D+00, & + 1.744350597225613D+00, & + 1.777519371491253D+00, & + 1.813883936816983D+00, & + 1.854074677301372D+00, & + 1.898924910271554D+00, & + 1.949567749806026D+00, & + 2.007598398424376D+00, & + 2.075363135292469D+00, & + 2.156515647499643D+00, & + 2.257205326820854D+00, & + 2.389016486325580D+00, & + 2.578092113348173D+00, & + 2.908337248444552D+00 /) + integer ( kind = 4 ) n_data + real ( kind = 8 ) x + real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & + 0.0000000000000000D+00, & + 0.2236067977499790D+00, & + 0.3162277660168379D+00, & + 0.3872983346207417D+00, & + 0.4472135954999579D+00, & + 0.5000000000000000D+00, & + 0.5477225575051661D+00, & + 0.5916079783099616D+00, & + 0.6324555320336759D+00, & + 0.6708203932499369D+00, & + 0.7071067811865476D+00, & + 0.7416198487095663D+00, & + 0.7745966692414834D+00, & + 0.8062257748298550D+00, & + 0.8366600265340756D+00, & + 0.8660254037844386D+00, & + 0.8944271909999159D+00, & + 0.9219544457292888D+00, & + 0.9486832980505138D+00, & + 0.9746794344808963D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + x = 0.0D+00 + fx = 0.0D+00 + else + x = x_vec(n_data) + fx = fx_vec(n_data) + end if + + return +end +function elliptic_fm ( m ) + +!*****************************************************************************80 +! +!! ELLIPTIC_FM evaluates the complete elliptic integral F(M). +! +! Discussion: +! +! The value is computed using Carlson elliptic integrals: +! +! F(m) = RF ( 0, 1-m, 1 ). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 29 May 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) M, the argument. +! +! Output, real ( kind = 8 ) ELLIPTIC_FM, the function value. +! + implicit none + + real ( kind = 8 ) elliptic_fm + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) m + !real ( kind = 8 ) rf + real ( kind = 8 ) value + real ( kind = 8 ) x + real ( kind = 8 ) y + real ( kind = 8 ) z + + x = 0.0D+00 + y = 1.0D+00 - m + z = 1.0D+00 + errtol = 1.0D-03 + + value = rf ( x, y, z, errtol, ierr ) + + elliptic_fm = value + + return +end +subroutine elliptic_fm_values ( n_data, x, fx ) + +!*****************************************************************************80 +! +!! ELLIPTIC_FM_VALUES returns values of the complete elliptic integral F(M). +! +! Discussion: +! +! This is one form of what is sometimes called the complete elliptic +! integral of the first kind. +! +! The function is defined by the formula: +! +! F(M) = integral ( 0 <= T <= PI/2 ) +! dT / sqrt ( 1 - M * sin ( T )^2 ) +! +! In Mathematica, the function can be evaluated by: +! +! EllipticK[m] +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 August 2004 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) X, the argument of the function. +! +! Output, real ( kind = 8 ) FX, the value of the function. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 20 + + real ( kind = 8 ) fx + real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & + 1.570796326794897D+00, & + 1.591003453790792D+00, & + 1.612441348720219D+00, & + 1.635256732264580D+00, & + 1.659623598610528D+00, & + 1.685750354812596D+00, & + 1.713889448178791D+00, & + 1.744350597225613D+00, & + 1.777519371491253D+00, & + 1.813883936816983D+00, & + 1.854074677301372D+00, & + 1.898924910271554D+00, & + 1.949567749806026D+00, & + 2.007598398424376D+00, & + 2.075363135292469D+00, & + 2.156515647499643D+00, & + 2.257205326820854D+00, & + 2.389016486325580D+00, & + 2.578092113348173D+00, & + 2.908337248444552D+00 /) + integer ( kind = 4 ) n_data + real ( kind = 8 ) x + real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & + 0.00D+00, & + 0.05D+00, & + 0.10D+00, & + 0.15D+00, & + 0.20D+00, & + 0.25D+00, & + 0.30D+00, & + 0.35D+00, & + 0.40D+00, & + 0.45D+00, & + 0.50D+00, & + 0.55D+00, & + 0.60D+00, & + 0.65D+00, & + 0.70D+00, & + 0.75D+00, & + 0.80D+00, & + 0.85D+00, & + 0.90D+00, & + 0.95D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + x = 0.0D+00 + fx = 0.0D+00 + else + x = x_vec(n_data) + fx = fx_vec(n_data) + end if + + return +end +function elliptic_inc_ea ( phi, a ) + +!*****************************************************************************80 +! +!! ELLIPTIC_INC_EA evaluates the incomplete elliptic integral E(PHI,A). +! +! Discussion: +! +! The value is computed using Carlson elliptic integrals: +! +! k = sin ( a * pi / 180 ) +! E(phi,a) = +! sin ( phi ) RF ( cos^2 ( phi ), 1-k^2 sin^2 ( phi ), 1 ) +! - 1/3 k^2 sin^3 ( phi ) RD ( cos^2 ( phi ), 1-k^2 sin^2 ( phi ), 1 ). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 May 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PHI, A, the argument. +! 0 <= PHI <= PI/2. +! 0 <= sin^2 ( A * pi / 180 ) * sin^2(PHI) <= 1. +! +! Output, real ( kind = 8 ) ELLIPTIC_INC_EA, the function value. +! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) cp + real ( kind = 8 ) elliptic_inc_ea + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) k + real ( kind = 8 ) phi + real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00 + !real ( kind = 8 ) rd + !real ( kind = 8 ) rf + real ( kind = 8 ) sp + real ( kind = 8 ) value + real ( kind = 8 ) value1 + real ( kind = 8 ) value2 + real ( kind = 8 ) x + real ( kind = 8 ) y + real ( kind = 8 ) z + + k = sin ( a * r8_pi / 180.0D+00 ) + + cp = cos ( phi ) + sp = sin ( phi ) + x = cp * cp + y = ( 1.0D+00 - k * sp ) * ( 1.0D+00 + k * sp ) + z = 1.0D+00 + errtol = 1.0D-03 + + value1 = rf ( x, y, z, errtol, ierr ) + + if ( ierr /= 0 ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'ELLIPTIC_INC_EA - Fatal error!' + write ( *, '(a,i2)' ) ' RF returned IERR = ', ierr + stop 1 + end if + + value2 = rd ( x, y, z, errtol, ierr ) + + if ( ierr /= 0 ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'ELLIPTIC_INC_EA - Fatal error!' + write ( *, '(a,i2)' ) ' RD returned IERR = ', ierr + stop 1 + end if + + value = sp * value1 - k ** 2 * sp ** 3 * value2 / 3.0D+00 + + elliptic_inc_ea = value + + return +end +subroutine elliptic_inc_ea_values ( n_data, phi, a, ea ) + +!*****************************************************************************80 +! +!! ELLIPTIC_INC_EA_VALUES: values of the incomplete elliptic integral E(PHI,A). +! +! Discussion: +! +! This is one form of the incomplete elliptic integral of the second kind. +! +! E(PHI,A) = integral ( 0 <= T <= PHI ) +! sqrt ( 1 - sin^2 ( A ) * sin^2 ( T ) ) dT +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 24 June 2018 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! US Department of Commerce, 1964. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Wolfram Media / Cambridge University Press, 1999. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) PHI, A, the arguments of the function. +! +! Output, real ( kind = 8 ) EA, the value of the function. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 20 + + real ( kind = 8 ) a + real ( kind = 8 ) ea + integer ( kind = 4 ) n_data + real ( kind = 8 ) phi + + real ( kind = 8 ), save, dimension ( n_max ) :: a_vec = (/ & + 123.0821233267548D+00, & + 11.26931745051486D+00, & + -94.88806452075445D+00, & + -99.71407853545323D+00, & + 57.05881039324191D+00, & + -19.71363287074183D+00, & + 56.31230299738043D+00, & + -91.55605346417718D+00, & + -27.00654574696468D+00, & + -169.2293728595904D+00, & + 61.96859564803047D+00, & + -158.7324398933148D+00, & + 105.0883958999383D+00, & + -48.95883872360177D+00, & + -42.58568835110901D+00, & + 11.65603284687828D+00, & + -8.398113719173338D+00, & + 17.69362213019626D+00, & + 73.8803420626852D+00, & + -69.82492339645128D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: ea_vec = (/ & + 0.3384181367348019D+00, & + 1.292924624509506D+00, & + 0.6074183768796306D+00, & + 0.3939726730783567D+00, & + 0.06880814097089803D+00, & + 0.0969436473376824D+00, & + 0.6025937791452033D+00, & + 0.9500549494837583D+00, & + 1.342783372140486D+00, & + 0.1484915631401388D+00, & + 1.085432887050926D+00, & + 0.1932136916085597D+00, & + 0.3983689593057807D+00, & + 0.1780054133336934D+00, & + 1.164525270273536D+00, & + 1.080167047541845D+00, & + 1.346684963830312D+00, & + 1.402100272685504D+00, & + 0.2928091845544553D+00, & + 0.5889342583405707D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: phi_vec = (/ & + 0.3430906586047127D+00, & + 1.302990057703935D+00, & + 0.6523628380743488D+00, & + 0.4046022501376546D+00, & + 0.06884642871852312D+00, & + 0.0969609046794745D+00, & + 0.630370432896175D+00, & + 1.252375418911598D+00, & + 1.409796082144801D+00, & + 0.1485105463502483D+00, & + 1.349466184634646D+00, & + 0.1933711786970301D+00, & + 0.4088829927466769D+00, & + 0.1785430666405224D+00, & + 1.292588374416351D+00, & + 1.087095515757691D+00, & + 1.352794600489329D+00, & + 1.432530166308616D+00, & + 0.2968093345769761D+00, & + 0.6235880396594726D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + a = 0.0D+00 + ea = 0.0D+00 + phi = 0.0D+00 + else + a = a_vec(n_data) + ea = ea_vec(n_data) + phi = phi_vec(n_data) + end if + + return +end +function elliptic_inc_ek ( phi, k ) + +!*****************************************************************************80 +! +!! ELLIPTIC_INC_EK evaluates the incomplete elliptic integral E(PHI,K). +! +! Discussion: +! +! The value is computed using Carlson elliptic integrals: +! +! E(phi,k) = +! sin ( phi ) RF ( cos^2 ( phi ), 1-k^2 sin^2 ( phi ), 1 ) +! - 1/3 k^2 sin^3 ( phi ) RD ( cos^2 ( phi ), 1-k^2 sin^2 ( phi ), 1 ). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 May 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PHI, K, the argument. +! 0 <= PHI <= PI/2. +! 0 <= K^2 * sin^2(PHI) <= 1. +! +! Output, real ( kind = 8 ) ELLIPTIC_INC_EK, the function value. +! + implicit none + + real ( kind = 8 ) cp + real ( kind = 8 ) elliptic_inc_ek + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) k + real ( kind = 8 ) phi + real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00 + !real ( kind = 8 ) rd + !real ( kind = 8 ) rf + real ( kind = 8 ) sp + real ( kind = 8 ) value + real ( kind = 8 ) value1 + real ( kind = 8 ) value2 + real ( kind = 8 ) x + real ( kind = 8 ) y + real ( kind = 8 ) z + + cp = cos ( phi ) + sp = sin ( phi ) + x = cp * cp + y = ( 1.0D+00 - k * sp ) * ( 1.0D+00 + k * sp ) + z = 1.0D+00 + errtol = 1.0D-03 + + value1 = rf ( x, y, z, errtol, ierr ) + + if ( ierr /= 0 ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'ELLIPTIC_INC_EK - Fatal error!' + write ( *, '(a,i2)' ) ' RF returned IERR = ', ierr + stop 1 + end if + + value2 = rd ( x, y, z, errtol, ierr ) + + if ( ierr /= 0 ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'ELLIPTIC_INC_EK - Fatal error!' + write ( *, '(a,i2)' ) ' RD returned IERR = ', ierr + stop 1 + end if + + value = sp * value1 - k ** 2 * sp ** 3 * value2 / 3.0D+00 + + elliptic_inc_ek = value + + return +end +subroutine elliptic_inc_ek_values ( n_data, phi, k, ek ) + +!*****************************************************************************80 +! +!! ELLIPTIC_INC_EK_VALUES: values of the incomplete elliptic integral E(PHI,K). +! +! Discussion: +! +! This is the incomplete elliptic integral of the second kind. +! +! E(PHI,K) = integral ( 0 <= T <= PHI ) +! sqrt ( 1 - K^2 * sin ( T )^2 ) dT +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 June 2018 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! US Department of Commerce, 1964. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Wolfram Media / Cambridge University Press, 1999. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) PHI, K, the arguments. +! +! Output, real ( kind = 8 ) EK, the function value. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 20 + + real ( kind = 8 ) ek + real ( kind = 8 ) k + integer ( kind = 4 ) n_data + real ( kind = 8 ) phi + + real ( kind = 8 ), save, dimension ( n_max ) :: ek_vec = (/ & + 0.2852345328295404D+00, & + 1.298690225567921D+00, & + 0.5508100202571943D+00, & + 0.3575401358115371D+00, & + 0.06801307805507453D+00, & + 0.09679584980231837D+00, & + 0.6003112504412838D+00, & + 0.8996717721794724D+00, & + 1.380715261453875D+00, & + 0.1191644625202453D+00, & + 1.196994838171557D+00, & + 0.1536260979667945D+00, & + 0.3546768920544152D+00, & + 0.1758756066650882D+00, & + 1.229819109410569D+00, & + 1.08381066114337D+00, & + 1.35023378157378D+00, & + 1.419775884709218D+00, & + 0.2824895528020034D+00, & + 0.5770427720982867D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: k_vec = (/ & + 2.712952582080266D+00, & + 0.1279518954120547D+00, & + -1.429437513650137D+00, & + -1.981659235625333D+00, & + 3.894801879555818D+00, & + -1.042486024983672D+00, & + 0.8641142168759754D+00, & + -1.049058412826877D+00, & + -0.3024062128402472D+00, & + -6.574288841527263D+00, & + 0.6987397421988888D+00, & + -5.12558591600033D+00, & + 2.074947853793764D+00, & + -1.670886158426681D+00, & + -0.4843595000931672D+00, & + 0.1393061679635559D+00, & + -0.0946527302537008D+00, & + 0.1977207111754007D+00, & + 1.788159919089993D+00, & + -1.077780624681256D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: phi_vec = (/ & + 0.3430906586047127D+00, & + 1.302990057703935D+00, & + 0.6523628380743488D+00, & + 0.4046022501376546D+00, & + 0.06884642871852312D+00, & + 0.0969609046794745D+00, & + 0.630370432896175D+00, & + 1.252375418911598D+00, & + 1.409796082144801D+00, & + 0.1485105463502483D+00, & + 1.349466184634646D+00, & + 0.1933711786970301D+00, & + 0.4088829927466769D+00, & + 0.1785430666405224D+00, & + 1.292588374416351D+00, & + 1.087095515757691D+00, & + 1.352794600489329D+00, & + 1.432530166308616D+00, & + 0.2968093345769761D+00, & + 0.6235880396594726D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + ek = 0.0D+00 + k = 0.0D+00 + phi = 0.0D+00 + else + ek = ek_vec(n_data) + k = k_vec(n_data) + phi = phi_vec(n_data) + end if + + return +end +function elliptic_inc_em ( phi, m ) + +!*****************************************************************************80 +! +!! ELLIPTIC_INC_EM evaluates the incomplete elliptic integral E(PHI,M). +! +! Discussion: +! +! The value is computed using Carlson elliptic integrals: +! +! E(phi,m) = +! sin ( phi ) RF ( cos^2 ( phi ), 1-m sin^2 ( phi ), 1 ) +! - 1/3 m sin^3 ( phi ) RD ( cos^2 ( phi ), 1-m sin^2 ( phi ), 1 ). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 May 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PHI, K, the argument. +! 0 <= PHI <= PI/2. +! 0 <= M * sin^2(PHI) <= 1. +! +! Output, real ( kind = 8 ) ELLIPTIC_INC_EM, the function value. +! + implicit none + + real ( kind = 8 ) cp + real ( kind = 8 ) elliptic_inc_em + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) m + real ( kind = 8 ) phi + real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00 + !real ( kind = 8 ) rd + !real ( kind = 8 ) rf + real ( kind = 8 ) sp + real ( kind = 8 ) value + real ( kind = 8 ) value1 + real ( kind = 8 ) value2 + real ( kind = 8 ) x + real ( kind = 8 ) y + real ( kind = 8 ) z + + cp = cos ( phi ) + sp = sin ( phi ) + x = cp * cp + y = 1.0D+00 - m * sp * sp + z = 1.0D+00 + errtol = 1.0D-03 + + value1 = rf ( x, y, z, errtol, ierr ) + + if ( ierr /= 0 ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'ELLIPTIC_INC_EM - Fatal error!' + write ( *, '(a,i2)' ) ' RF returned IERR = ', ierr + stop 1 + end if + + value2 = rd ( x, y, z, errtol, ierr ) + + if ( ierr /= 0 ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'ELLIPTIC_INC_EM - Fatal error!' + write ( *, '(a,i2)' ) ' RD returned IERR = ', ierr + stop 1 + end if + + value = sp * value1 - m * sp ** 3 * value2 / 3.0D+00 + + elliptic_inc_em = value + + return +end +subroutine elliptic_inc_em_values ( n_data, phi, m, em ) + +!*****************************************************************************80 +! +!! ELLIPTIC_INC_EM_VALUES: values of the incomplete elliptic integral E(PHI,M). +! +! Discussion: +! +! This is the incomplete elliptic integral of the second kind. +! +! E(PHI,M) = integral ( 0 <= T <= PHI ) +! sqrt ( 1 - M * sin ( T )^2 ) dT +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 24 June 2018 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! US Department of Commerce, 1964. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Wolfram Media / Cambridge University Press, 1999. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) PHI, M, the arguments. +! +! Output, real ( kind = 8 ) EM, the function value. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 20 + + real ( kind = 8 ) em + real ( kind = 8 ) m + integer ( kind = 4 ) n_data + real ( kind = 8 ) phi + + real ( kind = 8 ), save, dimension ( n_max ) :: em_vec = (/ & + 0.2732317284159052D+00, & + 1.124749725099781D+00, & + 0.6446601913679151D+00, & + 0.3968902354370061D+00, & + 0.06063960799944668D+00, & + 0.08909411577948728D+00, & + 0.532402014802015D+00, & + 1.251888640660265D+00, & + 1.28897116191626D+00, & + 0.1481718153599732D+00, & + 1.038090185639913D+00, & + 0.1931275771541276D+00, & + 0.3304419611986801D+00, & + 0.167394796063963D+00, & + 1.214501175324736D+00, & + 0.9516560179840655D+00, & + 1.203682959526176D+00, & + 1.206426326185419D+00, & + 0.2522791382096692D+00, & + 0.6026499038720986D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: m_vec = (/ & + 8.450689756874594D+00, & + 0.6039878267930615D+00, & + 0.1794126658351454D+00, & + 0.7095689301026752D+00, & + 133.9643389059188D+00, & + 47.96621393936416D+00, & + 2.172070586163255D+00, & + 0.002038130569431913D+00, & + 0.3600036705339421D+00, & + 0.6219544540067304D+00, & + 0.8834215943508453D+00, & + 0.2034290670379481D+00, & + 5.772526076430922D+00, & + 11.14853902343298D+00, & + 0.2889238477277305D+00, & + 0.7166617182589116D+00, & + 0.4760623731559658D+00, & + 0.6094948502068943D+00, & + 8.902276887883076D+00, & + 0.5434439226321253D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: phi_vec = (/ & + 0.3430906586047127D+00, & + 1.302990057703935D+00, & + 0.6523628380743488D+00, & + 0.4046022501376546D+00, & + 0.06884642871852312D+00, & + 0.0969609046794745D+00, & + 0.630370432896175D+00, & + 1.252375418911598D+00, & + 1.409796082144801D+00, & + 0.1485105463502483D+00, & + 1.349466184634646D+00, & + 0.1933711786970301D+00, & + 0.4088829927466769D+00, & + 0.1785430666405224D+00, & + 1.292588374416351D+00, & + 1.087095515757691D+00, & + 1.352794600489329D+00, & + 1.432530166308616D+00, & + 0.2968093345769761D+00, & + 0.6235880396594726D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + em = 0.0D+00 + m = 0.0D+00 + phi = 0.0D+00 + else + em = em_vec(n_data) + m = m_vec(n_data) + phi = phi_vec(n_data) + end if + + return +end +function elliptic_inc_fa ( phi, a ) + +!*****************************************************************************80 +! +!! ELLIPTIC_INC_FA evaluates the incomplete elliptic integral F(PHI,A). +! +! Discussion: +! +! The value is computed using Carlson elliptic integrals: +! +! k = sin ( a * pi / 180 ) +! F(phi,k) = sin(phi) * RF ( cos^2 ( phi ), 1-k^2 sin^2 ( phi ), 1 ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 24 June 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PHI, A, the argument. +! 0 <= PHI <= PI/2. +! 0 <= sin^2 ( A * pi / 180 ) * sin^2(PHI) <= 1. +! +! Output, real ( kind = 8 ) ELLIPTIC_INC_FA, the function value. +! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) cp + real ( kind = 8 ) elliptic_inc_fa + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) k + real ( kind = 8 ) phi + real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00 + !real ( kind = 8 ) rf + real ( kind = 8 ) sp + real ( kind = 8 ) value + real ( kind = 8 ) x + real ( kind = 8 ) y + real ( kind = 8 ) z + + k = sin ( a * r8_pi / 180.0D+00 ) + + cp = cos ( phi ) + sp = sin ( phi ) + x = cp * cp + y = ( 1.0D+00 - k * sp ) * ( 1.0D+00 + k * sp ) + z = 1.0D+00 + errtol = 1.0D-03 + + value = rf ( x, y, z, errtol, ierr ) + + if ( ierr /= 0 ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'ELLIPTIC_INC_FA - Fatal error!' + write ( *, '(a,i2)' ) ' RF returned IERR = ', ierr + stop 1 + end if + + elliptic_inc_fa = sp * value + + return +end +subroutine elliptic_inc_fa_values ( n_data, phi, a, fa ) + +!*****************************************************************************80 +! +!! ELLIPTIC_INC_FA_VALUES: values of the incomplete elliptic integral F(PHI,A). +! +! Discussion: +! +! This is the incomplete elliptic integral of the first kind. +! +! F(PHI,A) = integral ( 0 <= T <= PHI ) +! dT / sqrt ( 1 - sin^2 ( A ) * sin^2 ( T ) ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 June 2018 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! US Department of Commerce, 1964. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Wolfram Media / Cambridge University Press, 1999. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) PHI, A, the arguments. +! +! Output, real ( kind = 8 ) FA, the function value. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 20 + + real ( kind = 8 ) a + real ( kind = 8 ) fa + integer ( kind = 4 ) n_data + real ( kind = 8 ) phi + + real ( kind = 8 ), save, dimension ( n_max ) :: a_vec = (/ & + 123.0821233267548D+00, & + 11.26931745051486D+00, & + -94.88806452075445D+00, & + -99.71407853545323D+00, & + 57.05881039324191D+00, & + -19.71363287074183D+00, & + 56.31230299738043D+00, & + -91.55605346417718D+00, & + -27.00654574696468D+00, & + -169.2293728595904D+00, & + 61.96859564803047D+00, & + -158.7324398933148D+00, & + 105.0883958999383D+00, & + -48.95883872360177D+00, & + -42.58568835110901D+00, & + 11.65603284687828D+00, & + -8.398113719173338D+00, & + 17.69362213019626D+00, & + 73.8803420626852D+00, & + -69.82492339645128D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: fa_vec = (/ & + 0.3478806460316299D+00, & + 1.313180577009584D+00, & + 0.7037956689264326D+00, & + 0.4157626844675118D+00, & + 0.06888475483285136D+00, & + 0.09697816754845832D+00, & + 0.6605394722518515D+00, & + 1.82758346036751D+00, & + 1.482258783392487D+00, & + 0.1485295339221232D+00, & + 1.753800062701494D+00, & + 0.193528896465351D+00, & + 0.4199100508706138D+00, & + 0.1790836490491233D+00, & + 1.446048832279763D+00, & + 1.094097652100984D+00, & + 1.358947908427035D+00, & + 1.46400078231538D+00, & + 0.3009092014525799D+00, & + 0.6621341112075102D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: phi_vec = (/ & + 0.3430906586047127D+00, & + 1.302990057703935D+00, & + 0.6523628380743488D+00, & + 0.4046022501376546D+00, & + 0.06884642871852312D+00, & + 0.0969609046794745D+00, & + 0.630370432896175D+00, & + 1.252375418911598D+00, & + 1.409796082144801D+00, & + 0.1485105463502483D+00, & + 1.349466184634646D+00, & + 0.1933711786970301D+00, & + 0.4088829927466769D+00, & + 0.1785430666405224D+00, & + 1.292588374416351D+00, & + 1.087095515757691D+00, & + 1.352794600489329D+00, & + 1.432530166308616D+00, & + 0.2968093345769761D+00, & + 0.6235880396594726D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + a = 0.0D+00 + fa = 0.0D+00 + phi = 0.0D+00 + else + a = a_vec(n_data) + fa = fa_vec(n_data) + phi = phi_vec(n_data) + end if + + return +end +function elliptic_inc_fk ( phi, k ) + +!*****************************************************************************80 +! +!! ELLIPTIC_INC_FK evaluates the incomplete elliptic integral F(PHI,K). +! +! Discussion: +! +! The value is computed using Carlson elliptic integrals: +! +! F(phi,k) = sin(phi) * RF ( cos^2 ( phi ), 1-k^2 sin^2 ( phi ), 1 ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 24 June 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PHI, K, the argument. +! 0 <= PHI <= PI/2. +! 0 <= K^2 * sin^2(PHI) <= 1. +! +! Output, real ( kind = 8 ) ELLIPTIC_INC_FK, the function value. +! + implicit none + + real ( kind = 8 ) cp + real ( kind = 8 ) elliptic_inc_fk + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) k + real ( kind = 8 ) phi + real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00 + !real ( kind = 8 ) rf + real ( kind = 8 ) sp + real ( kind = 8 ) value + real ( kind = 8 ) x + real ( kind = 8 ) y + real ( kind = 8 ) z + + cp = cos ( phi ) + sp = sin ( phi ) + x = cp * cp + y = ( 1.0D+00 - k * sp ) * ( 1.0D+00 + k * sp ) + z = 1.0D+00 + errtol = 1.0D-03 + + value = rf ( x, y, z, errtol, ierr ) + + if ( ierr /= 0 ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'ELLIPTIC_INC_FK - Fatal error!' + write ( *, '(a,i2)' ) ' RF returned IERR = ', ierr + stop 1 + end if + + elliptic_inc_fk = sp * value + + return +end +subroutine elliptic_inc_fk_values ( n_data, phi, k, fk ) + +!*****************************************************************************80 +! +!! ELLIPTIC_INC_FK_VALUES: values of the incomplete elliptic integral F(PHI,K). +! +! Discussion: +! +! This is the incomplete elliptic integral of the first kind. +! +! F(PHI,K) = integral ( 0 <= T <= PHI ) +! dT / sqrt ( 1 - K^2 * sin ( T )^2 ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 June 2018 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! US Department of Commerce, 1964. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Wolfram Media / Cambridge University Press, 1999. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) PHI, K, the arguments. +! +! Output, real ( kind = 8 ) FK, the value of the function. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 20 + + real ( kind = 8 ) fk + real ( kind = 8 ) k + integer ( kind = 4 ) n_data + real ( kind = 8 ) phi + + real ( kind = 8 ), save, dimension ( n_max ) :: fk_vec = (/ & + 0.4340870330108736D+00, & + 1.307312511398114D+00, & + 0.8005154258533936D+00, & + 0.4656721451084328D+00, & + 0.06969849613441773D+00, & + 0.09712646708750489D+00, & + 0.6632598061016007D+00, & + 2.2308677858579D+00, & + 1.439846282888019D+00, & + 0.2043389243773096D+00, & + 1.537183574881771D+00, & + 0.2749229901565622D+00, & + 0.4828388342828284D+00, & + 0.1812848567886627D+00, & + 1.360729522341841D+00, & + 1.09039680912027D+00, & + 1.355363051581808D+00, & + 1.445462819732441D+00, & + 0.3125355489354676D+00, & + 0.6775731623807174D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: k_vec = (/ & + 2.712952582080266D+00, & + 0.1279518954120547D+00, & + -1.429437513650137D+00, & + -1.981659235625333D+00, & + 3.894801879555818D+00, & + -1.042486024983672D+00, & + 0.8641142168759754D+00, & + -1.049058412826877D+00, & + -0.3024062128402472D+00, & + -6.574288841527263D+00, & + 0.6987397421988888D+00, & + -5.12558591600033D+00, & + 2.074947853793764D+00, & + -1.670886158426681D+00, & + -0.4843595000931672D+00, & + 0.1393061679635559D+00, & + -0.0946527302537008D+00, & + 0.1977207111754007D+00, & + 1.788159919089993D+00, & + -1.077780624681256D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: phi_vec = (/ & + 0.3430906586047127D+00, & + 1.302990057703935D+00, & + 0.6523628380743488D+00, & + 0.4046022501376546D+00, & + 0.06884642871852312D+00, & + 0.0969609046794745D+00, & + 0.630370432896175D+00, & + 1.252375418911598D+00, & + 1.409796082144801D+00, & + 0.1485105463502483D+00, & + 1.349466184634646D+00, & + 0.1933711786970301D+00, & + 0.4088829927466769D+00, & + 0.1785430666405224D+00, & + 1.292588374416351D+00, & + 1.087095515757691D+00, & + 1.352794600489329D+00, & + 1.432530166308616D+00, & + 0.2968093345769761D+00, & + 0.6235880396594726D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + fk = 0.0D+00 + k = 0.0D+00 + phi = 0.0D+00 + else + fk = fk_vec(n_data) + k = k_vec(n_data) + phi = phi_vec(n_data) + end if + + return +end +function elliptic_inc_fm ( phi, m ) + +!*****************************************************************************80 +! +!! ELLIPTIC_INC_FM evaluates the incomplete elliptic integral F(PHI,M). +! +! Discussion: +! +! The value is computed using Carlson elliptic integrals: +! +! F(phi,m) = sin(phi) * RF ( cos^2 ( phi ), 1-m sin^2 ( phi ), 1 ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 24 June 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PHI, M, the argument. +! 0 <= PHI <= PI/2. +! 0 <= M * sin^2(PHI) <= 1. +! +! Output, real ( kind = 8 ) ELLIPTIC_INC_FM, the function value. +! + implicit none + + real ( kind = 8 ) cp + real ( kind = 8 ) elliptic_inc_fm + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) m + real ( kind = 8 ) phi + real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00 + !real ( kind = 8 ) rf + real ( kind = 8 ) sp + real ( kind = 8 ) value + real ( kind = 8 ) x + real ( kind = 8 ) y + real ( kind = 8 ) z + + cp = cos ( phi ) + sp = sin ( phi ) + x = cp * cp + y = 1.0D+00 - m * sp ** 2 + z = 1.0D+00 + errtol = 1.0D-03 + + value = rf ( x, y, z, errtol, ierr ) + + if ( ierr /= 0 ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'ELLIPTIC_INC_FM - Fatal error!' + write ( *, '(a,i2)' ) ' RF returned IERR = ', ierr + stop 1 + end if + + elliptic_inc_fm = sp * value + + return +end +subroutine elliptic_inc_fm_values ( n_data, phi, m, fm ) + +!*****************************************************************************80 +! +!! ELLIPTIC_INC_FM_VALUES: values of the incomplete elliptic integral F(PHI,M). +! +! Discussion: +! +! This is the incomplete elliptic integral of the first kind. +! +! F(PHI,M) = integral ( 0 <= T <= PHI ) +! dT / sqrt ( 1 - M * sin ( T )^2 ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 June 2018 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! US Department of Commerce, 1964. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Wolfram Media / Cambridge University Press, 1999. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) PHI, M, the arguments. +! +! Output, real ( kind = 8 ) FM, the value of the function. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 20 + + real ( kind = 8 ) fm + real ( kind = 8 ) m + integer ( kind = 4 ) n_data + real ( kind = 8 ) phi + + real ( kind = 8 ), save, dimension ( n_max ) :: fm_vec = (/ & + 0.4804314075855023D+00, & + 1.535634981092025D+00, & + 0.6602285297476601D+00, & + 0.4125884303785135D+00, & + 0.07964566007155376D+00, & + 0.1062834070535258D+00, & + 0.7733990864393913D+00, & + 1.252862499892228D+00, & + 1.549988686611532D+00, & + 0.1488506735822822D+00, & + 1.892229900799662D+00, & + 0.1936153327753556D+00, & + 0.5481932935424454D+00, & + 0.1911795073571756D+00, & + 1.379225069349756D+00, & + 1.261282453331402D+00, & + 1.535239838525378D+00, & + 1.739782418156071D+00, & + 0.3616930047198503D+00, & + 0.6458627645916422D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: m_vec = (/ & + 8.450689756874594D+00, & + 0.6039878267930615D+00, & + 0.1794126658351454D+00, & + 0.7095689301026752D+00, & + 133.9643389059188D+00, & + 47.96621393936416D+00, & + 2.172070586163255D+00, & + 0.002038130569431913D+00, & + 0.3600036705339421D+00, & + 0.6219544540067304D+00, & + 0.8834215943508453D+00, & + 0.2034290670379481D+00, & + 5.772526076430922D+00, & + 11.14853902343298D+00, & + 0.2889238477277305D+00, & + 0.7166617182589116D+00, & + 0.4760623731559658D+00, & + 0.6094948502068943D+00, & + 8.902276887883076D+00, & + 0.5434439226321253D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: phi_vec = (/ & + 0.3430906586047127D+00, & + 1.302990057703935D+00, & + 0.6523628380743488D+00, & + 0.4046022501376546D+00, & + 0.06884642871852312D+00, & + 0.0969609046794745D+00, & + 0.630370432896175D+00, & + 1.252375418911598D+00, & + 1.409796082144801D+00, & + 0.1485105463502483D+00, & + 1.349466184634646D+00, & + 0.1933711786970301D+00, & + 0.4088829927466769D+00, & + 0.1785430666405224D+00, & + 1.292588374416351D+00, & + 1.087095515757691D+00, & + 1.352794600489329D+00, & + 1.432530166308616D+00, & + 0.2968093345769761D+00, & + 0.6235880396594726D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + fm = 0.0D+00 + m = 0.0D+00 + phi = 0.0D+00 + else + fm = fm_vec(n_data) + m = m_vec(n_data) + phi = phi_vec(n_data) + end if + + return +end +function elliptic_inc_pia ( phi, n, a ) + +!*****************************************************************************80 +! +!! ELLIPTIC_INC_PIA evaluates the incomplete elliptic integral Pi(PHI,N,A). +! +! Discussion: +! +! The value is computed using Carlson elliptic integrals: +! +! Pi(PHI,N,A) = integral ( 0 <= T <= PHI ) +! dT / (1 - N sin^2(T) ) sqrt ( 1 - sin^2(A*pi/180) * sin ( T )^2 ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 24 June 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PHI, N, A, the arguments. +! +! Output, real ( kind = 8 ) ELLIPTIC_INC_PIA, the function value. +! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) cp + real ( kind = 8 ) elliptic_inc_pia + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) k + real ( kind = 8 ) n + real ( kind = 8 ) p + real ( kind = 8 ) phi + real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00 + !real ( kind = 8 ) rf + !real ( kind = 8 ) rj + real ( kind = 8 ) sp + real ( kind = 8 ) value + real ( kind = 8 ) value1 + real ( kind = 8 ) value2 + real ( kind = 8 ) x + real ( kind = 8 ) y + real ( kind = 8 ) z + + k = sin ( a * r8_pi / 180.0D+00 ) + + cp = cos ( phi ) + sp = sin ( phi ) + x = cp * cp + y = ( 1.0D+00 - k * sp ) * ( 1.0D+00 + k * sp ) + z = 1.0D+00 + p = 1.0D+00 - n * sp ** 2 + errtol = 1.0D-03 + + value1 = rf ( x, y, z, errtol, ierr ) + + if ( ierr /= 0 ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'ELLIPTIC_INC_PIA - Fatal error!' + write ( *, '(a,i2)' ) ' RF returned IERR = ', ierr + stop 1 + end if + + value2 = rj ( x, y, z, p, errtol, ierr ) + + if ( ierr /= 0 ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'ELLIPTIC_INC_PIA - Fatal error!' + write ( *, '(a,i2)' ) ' RJ returned IERR = ', ierr + stop 1 + end if + + value = sp * value1 + n * sp ** 3 * value2 / 3.0D+00 + + elliptic_inc_pia = value + + return +end +subroutine elliptic_inc_pia_values ( n_data, phi, n, a, pia ) + +!*****************************************************************************80 +! +!! ELLIPTIC_INC_PIA_VALUES: values of incomplete elliptic integral Pi(PHI,N,A). +! +! Discussion: +! +! This is the incomplete elliptic integral of the third kind. +! +! Pi(PHI,N,A) = integral ( 0 <= T <= PHI ) +! dT / (1 - N sin^2(T) ) sqrt ( 1 - sin^2(A) * sin ( T )^2 ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 June 2018 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! US Department of Commerce, 1964. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Wolfram Media / Cambridge University Press, 1999. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) PHI, N, A, the arguments of the function. +! +! Output, real ( kind = 8 ) PIA, the value of the function. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 20 + + real ( kind = 8 ) a + real ( kind = 8 ) n + integer ( kind = 4 ) n_data + real ( kind = 8 ) phi + real ( kind = 8 ) pia + + real ( kind = 8 ), save, dimension ( n_max ) :: a_vec = (/ & + 88.87822485052908D+00, & + -86.55208740039521D+00, & + -116.6195703112117D+00, & + -9.742878017582015D+00, & + 65.73480919446207D+00, & + -115.0387719677141D+00, & + 124.9421177735846D+00, & + -89.78704401263703D+00, & + -98.42673771271734D+00, & + -53.74936192418378D+00, & + 68.28047574440727D+00, & + 20.82174673810708D+00, & + -29.1042364797769D+00, & + -37.80176710944693D+00, & + -55.81173355852393D+00, & + -37.66594589748672D+00, & + -80.09408170610219D+00, & + 52.23806528467412D+00, & + 74.30945212430545D+00, & + -17.22920703094039D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: n_vec = (/ & + 8.064681366127422D+00, & + -0.2840588974558835D+00, & + -5.034023488967104D+00, & + -1.244606253942751D+00, & + 1.465981775919188D+00, & + 95338.12857321106D+00, & + -44.43130633436311D+00, & + -0.8029374966926196D+00, & + 5.218883222649502D+00, & + 2.345821782626782D+00, & + 0.157358332363011D+00, & + 1.926593468907062D+00, & + 6.113982855261652D+00, & + 1.805710621498681D+00, & + -0.4072847419780592D+00, & + -0.9416404038595624D+00, & + 0.7009655305226739D+00, & + -1.019830985340273D+00, & + -0.4510798219577842D+00, & + 0.6028821390092596D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: phi_vec = (/ & + 0.3430906586047127D+00, & + 0.8823091382756705D+00, & + 0.4046022501376546D+00, & + 0.9958310121985398D+00, & + 0.630370432896175D+00, & + 0.002887706662908567D+00, & + 0.1485105463502483D+00, & + 1.320800086884777D+00, & + 0.4088829927466769D+00, & + 0.552337007372852D+00, & + 1.087095515757691D+00, & + 0.7128175949111615D+00, & + 0.2968093345769761D+00, & + 0.2910907344062498D+00, & + 0.9695030752034163D+00, & + 1.122288759723523D+00, & + 1.295911610809573D+00, & + 1.116491437736542D+00, & + 1.170719322533712D+00, & + 1.199360682338851D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: pia_vec = (/ & + 0.7099335174334724D+00, & + 0.9601963779142505D+00, & + 0.3362852532098376D+00, & + 0.7785343427543768D+00, & + 0.857889755214478D+00, & + 0.004630772344931844D+00, & + 0.1173842687902911D+00, & + 1.505788070660267D+00, & + 0.7213264194624553D+00, & + 0.8073261799642218D+00, & + 1.402853811110838D+00, & + 1.259245331474513D+00, & + 0.3779079263971614D+00, & + 0.3088493910496766D+00, & + 0.9782829177005183D+00, & + 0.9430491574504173D+00, & + 3.320796277384155D+00, & + 0.9730988737054799D+00, & + 1.301988094953789D+00, & + 1.64558360445259D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + a = 0.0D+00 + n = 0.0D+00 + phi = 0.0D+00 + pia = 0.0D+00 + else + a = a_vec(n_data) + n = n_vec(n_data) + phi = phi_vec(n_data) + pia = pia_vec(n_data) + end if + + return +end +function elliptic_inc_pik ( phi, n, k ) + +!*****************************************************************************80 +! +!! ELLIPTIC_INC_PIK evaluates the incomplete elliptic integral Pi(PHI,N,K). +! +! Discussion: +! +! The value is computed using Carlson elliptic integrals: +! +! Pi(PHI,N,K) = integral ( 0 <= T <= PHI ) +! dT / (1 - N sin^2(T) ) sqrt ( 1 - k^2 * sin ( T )^2 ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 24 June 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PHI, N, K, the arguments. +! +! Output, real ( kind = 8 ) ELLIPTIC_INC_PIK, the function value. +! + implicit none + + real ( kind = 8 ) cp + real ( kind = 8 ) elliptic_inc_pik + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) k + real ( kind = 8 ) n + real ( kind = 8 ) p + real ( kind = 8 ) phi + real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00 + !real ( kind = 8 ) rf + !real ( kind = 8 ) rj + real ( kind = 8 ) sp + real ( kind = 8 ) value + real ( kind = 8 ) value1 + real ( kind = 8 ) value2 + real ( kind = 8 ) x + real ( kind = 8 ) y + real ( kind = 8 ) z + + cp = cos ( phi ) + sp = sin ( phi ) + x = cp * cp + y = ( 1.0D+00 - k * sp ) * ( 1.0D+00 + k * sp ) + z = 1.0D+00 + p = 1.0D+00 - n * sp ** 2 + errtol = 1.0D-03 + + value1 = rf ( x, y, z, errtol, ierr ) + + if ( ierr /= 0 ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'ELLIPTIC_INC_PIK - Fatal error!' + write ( *, '(a,i2)' ) ' RF returned IERR = ', ierr + stop 1 + end if + + value2 = rj ( x, y, z, p, errtol, ierr ) + + if ( ierr /= 0 ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'ELLIPTIC_INC_PIK - Fatal error!' + write ( *, '(a,i2)' ) ' RJ returned IERR = ', ierr + stop 1 + end if + + value = sp * value1 + n * sp ** 3 * value2 / 3.0D+00 + + elliptic_inc_pik = value + + return +end +subroutine elliptic_inc_pik_values ( n_data, phi, n, k, pik ) + +!*****************************************************************************80 +! +!! ELLIPTIC_INC_PIK_VALUES: values of incomplete elliptic integral Pi(PHI,N,K). +! +! Discussion: +! +! This is the incomplete elliptic integral of the third kind. +! +! Pi(PHI,N,K) = integral ( 0 <= T <= PHI ) +! dT / (1 - N sin^2(T) ) sqrt ( 1 - K^2 * sin ( T )^2 ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 23 June 2018 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! US Department of Commerce, 1964. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Wolfram Media / Cambridge University Press, 1999. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) PHI, N, K, the arguments of the function. +! +! Output, real ( kind = 8 ) PIK, the value of the function. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 20 + + real ( kind = 8 ) k + real ( kind = 8 ) n + integer ( kind = 4 ) n_data + real ( kind = 8 ) phi + real ( kind = 8 ) pik + + real ( kind = 8 ), save, dimension ( n_max ) :: k_vec = (/ & + 1.959036804709882D+00, & + -1.123741823223131D+00, & + -2.317629084640271D+00, & + -0.1202582658444815D+00, & + 1.008702896970963D+00, & + -103.3677494756118D+00, & + 4.853800240677973D+00, & + -1.016577251056124D+00, & + -1.94341484065839D+00, & + -0.8876593284500023D+00, & + 0.8160487832898813D+00, & + 0.2994546721661018D+00, & + -0.7044232294525243D+00, & + -0.9266523277404759D+00, & + -0.6962608926846425D+00, & + -0.4453932031991797D+00, & + -0.9104582513322106D+00, & + 0.6187501419936026D+00, & + 0.8672305032589989D+00, & + -0.1996772638241632D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: n_vec = (/ & + 8.064681366127422D+00, & + -0.2840588974558835D+00, & + -5.034023488967104D+00, & + -1.244606253942751D+00, & + 1.465981775919188D+00, & + 95338.12857321106D+00, & + -44.43130633436311D+00, & + -0.8029374966926196D+00, & + 5.218883222649502D+00, & + 2.345821782626782D+00, & + 0.157358332363011D+00, & + 1.926593468907062D+00, & + 6.113982855261652D+00, & + 1.805710621498681D+00, & + -0.4072847419780592D+00, & + -0.9416404038595624D+00, & + 0.7009655305226739D+00, & + -1.019830985340273D+00, & + -0.4510798219577842D+00, & + 0.6028821390092596D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: phi_vec = (/ & + 0.3430906586047127D+00, & + 0.8823091382756705D+00, & + 0.4046022501376546D+00, & + 0.9958310121985398D+00, & + 0.630370432896175D+00, & + 0.002887706662908567D+00, & + 0.1485105463502483D+00, & + 1.320800086884777D+00, & + 0.4088829927466769D+00, & + 0.552337007372852D+00, & + 1.087095515757691D+00, & + 0.7128175949111615D+00, & + 0.2968093345769761D+00, & + 0.2910907344062498D+00, & + 0.9695030752034163D+00, & + 1.122288759723523D+00, & + 1.295911610809573D+00, & + 1.116491437736542D+00, & + 1.170719322533712D+00, & + 1.199360682338851D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: pik_vec = (/ & + 0.7982975462595892D+00, & + 1.024022134726036D+00, & + 0.40158120852642D+00, & + 0.7772649487439858D+00, & + 0.8737159913132074D+00, & + 0.004733334297691273D+00, & + 0.1280656893638068D+00, & + 1.594376037512564D+00, & + 0.8521145133671923D+00, & + 0.8154325229803082D+00, & + 1.31594514075427D+00, & + 1.25394623148424D+00, & + 0.3796503567258643D+00, & + 0.3111034454739552D+00, & + 0.9442477901112342D+00, & + 0.9153111661980959D+00, & + 2.842080644328393D+00, & + 0.9263253777034376D+00, & + 1.212396018757624D+00, & + 1.628083572710471D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + k = 0.0D+00 + n = 0.0D+00 + phi = 0.0D+00 + pik = 0.0D+00 + else + k = k_vec(n_data) + n = n_vec(n_data) + phi = phi_vec(n_data) + pik = pik_vec(n_data) + end if + + return +end +function elliptic_inc_pim ( phi, n, m ) + +!*****************************************************************************80 +! +!! ELLIPTIC_INC_PIM evaluates the incomplete elliptic integral Pi(PHI,N,M). +! +! Discussion: +! +! The value is computed using Carlson elliptic integrals: +! +! Pi(PHI,N,M) = integral ( 0 <= T <= PHI ) +! dT / (1 - N sin^2(T) ) sqrt ( 1 - m * sin ( T )^2 ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 24 June 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) PHI, N, M, the arguments. +! +! Output, real ( kind = 8 ) ELLIPTIC_INC_PIM, the function value. +! + implicit none + + real ( kind = 8 ) cp + real ( kind = 8 ) elliptic_inc_pim + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) m + real ( kind = 8 ) n + real ( kind = 8 ) p + real ( kind = 8 ) phi + real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00 + !real ( kind = 8 ) rf + !real ( kind = 8 ) rj + real ( kind = 8 ) sp + real ( kind = 8 ) value + real ( kind = 8 ) value1 + real ( kind = 8 ) value2 + real ( kind = 8 ) x + real ( kind = 8 ) y + real ( kind = 8 ) z + + cp = cos ( phi ) + sp = sin ( phi ) + x = cp * cp + y = 1.0D+00 - m * sp ** 2 + z = 1.0D+00 + p = 1.0D+00 - n * sp ** 2 + errtol = 1.0D-03 + + value1 = rf ( x, y, z, errtol, ierr ) + + if ( ierr /= 0 ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'ELLIPTIC_INC_PIM - Fatal error!' + write ( *, '(a,i2)' ) ' RF returned IERR = ', ierr + stop 1 + end if + + value2 = rj ( x, y, z, p, errtol, ierr ) + + if ( ierr /= 0 ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'ELLIPTIC_INC_PIM - Fatal error!' + write ( *, '(a,i2)' ) ' RJ returned IERR = ', ierr + stop 1 + end if + + value = sp * value1 + n * sp ** 3 * value2 / 3.0D+00 + + elliptic_inc_pim = value + + return +end +subroutine elliptic_inc_pim_values ( n_data, phi, n, m, pim ) + +!*****************************************************************************80 +! +!! ELLIPTIC_INC_PIM_VALUES: values of incomplete elliptic integral Pi(PHI,N,M). +! +! Discussion: +! +! This is the incomplete elliptic integral of the third kind. +! +! Pi(PHI,N,M) = integral ( 0 <= T <= PHI ) +! dT / (1 - N sin^2(T) ) sqrt ( 1 - M * sin ( T )^2 ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 24 June 2018 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! US Department of Commerce, 1964. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Wolfram Media / Cambridge University Press, 1999. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) PHI, N, M, the arguments of the function. +! +! Output, real ( kind = 8 ) PIM, the value of the function. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 20 + + real ( kind = 8 ) m + real ( kind = 8 ) n + integer ( kind = 4 ) n_data + real ( kind = 8 ) phi + real ( kind = 8 ) pim + + real ( kind = 8 ), save, dimension ( n_max ) :: m_vec = (/ & + 7.330122710928245D+00, & + 0.1108806690614566D+00, & + 0.2828355944410993D+00, & + 0.6382999794812498D+00, & + 2.294718938593894D+00, & + 42062.55329826538D+00, & + 39.2394337789563D+00, & + 0.008002151065098688D+00, & + 0.7190579590867517D+00, & + 0.9703767630929055D+00, & + 1.098881295982823D+00, & + 1.398066725917478D+00, & + 4.641021931654496D+00, & + 4.455969064311461D+00, & + 0.3131448239736511D+00, & + 0.3686443684703166D+00, & + 0.06678210908100803D+00, & + 0.9635538974026796D+00, & + 1.060208762696207D+00, & + 0.4687160847955397D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: n_vec = (/ & + 8.064681366127422D+00, & + -0.2840588974558835D+00, & + -5.034023488967104D+00, & + -1.244606253942751D+00, & + 1.465981775919188D+00, & + 95338.12857321106D+00, & + -44.43130633436311D+00, & + -0.8029374966926196D+00, & + 5.218883222649502D+00, & + 2.345821782626782D+00, & + 0.157358332363011D+00, & + 1.926593468907062D+00, & + 6.113982855261652D+00, & + 1.805710621498681D+00, & + -0.4072847419780592D+00, & + -0.9416404038595624D+00, & + 0.7009655305226739D+00, & + -1.019830985340273D+00, & + -0.4510798219577842D+00, & + 0.6028821390092596D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: phi_vec = (/ & + 0.3430906586047127D+00, & + 0.8823091382756705D+00, & + 0.4046022501376546D+00, & + 0.9958310121985398D+00, & + 0.630370432896175D+00, & + 0.002887706662908567D+00, & + 0.1485105463502483D+00, & + 1.320800086884777D+00, & + 0.4088829927466769D+00, & + 0.552337007372852D+00, & + 1.087095515757691D+00, & + 0.7128175949111615D+00, & + 0.2968093345769761D+00, & + 0.2910907344062498D+00, & + 0.9695030752034163D+00, & + 1.122288759723523D+00, & + 1.295911610809573D+00, & + 1.116491437736542D+00, & + 1.170719322533712D+00, & + 1.199360682338851D+00 /) + + real ( kind = 8 ), save, dimension ( n_max ) :: pim_vec = (/ & + 1.0469349800785D+00, & + 0.842114448140669D+00, & + 0.3321642201520043D+00, & + 0.8483033529960849D+00, & + 1.055753817656772D+00, & + 0.005108896144265593D+00, & + 0.1426848042785896D+00, & + 1.031350958206424D+00, & + 0.7131013701418496D+00, & + 0.8268044665355507D+00, & + 1.57632867896015D+00, & + 1.542817120857211D+00, & + 0.4144629799126912D+00, & + 0.3313231611366746D+00, & + 0.9195822851915201D+00, & + 0.9422320754002217D+00, & + 2.036599002815859D+00, & + 1.076799231499882D+00, & + 1.416084462957852D+00, & + 1.824124922310891D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + m = 0.0D+00 + n = 0.0D+00 + phi = 0.0D+00 + pim = 0.0D+00 + else + m = m_vec(n_data) + n = n_vec(n_data) + phi = phi_vec(n_data) + pim = pim_vec(n_data) + end if + + return +end +function elliptic_pia ( n, a ) + +!*****************************************************************************80 +! +!! ELLIPTIC_PIA evaluates the complete elliptic integral Pi(N,A). +! +! Discussion: +! +! This is one form of what is sometimes called the complete elliptic +! integral of the third kind. +! +! The function is defined by the formula: +! +! Pi(N,A) = integral ( 0 <= T <= PI/2 ) +! dT / (1 - N sin^2(T) ) sqrt ( 1 - sin^2(A) * sin ( T )^2 ) +! +! In MATLAB, the function can be evaluated by: +! +! ellipticPi(n,(sin(a*pi/180)^2) +! +! The value is computed using Carlson elliptic integrals: +! +! k = sin ( a * pi / 180 ) +! Pi(n,k) = RF ( 0, 1 - k^2, 1 ) + 1/3 n RJ ( 0, 1 - k^2, 1, 1 - n ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 May 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) N, A, the arguments. +! +! Output, real ( kind = 8 ) ELLIPTIC_PIA, the function value. +! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) elliptic_pia + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) k + real ( kind = 8 ) n + real ( kind = 8 ) p + real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00 + !real ( kind = 8 ) rf + !real ( kind = 8 ) rj + real ( kind = 8 ) value + real ( kind = 8 ) x + real ( kind = 8 ) y + real ( kind = 8 ) z + + k = sin ( a * r8_pi / 180.0D+00 ) + x = 0.0D+00 + y = ( 1.0D+00 - k ) * ( 1.0D+00 + k ) + z = 1.0D+00 + p = 1.0D+00 - n + errtol = 1.0D-03 + + value = rf ( x, y, z, errtol, ierr ) & + + n * rj ( x, y, z, p, errtol, ierr ) / 3.0D+00 + + elliptic_pia = value + + return +end +subroutine elliptic_pia_values ( n_data, n, a, pia ) + +!*****************************************************************************80 +! +!! ELLIPTIC_PIA_VALUES returns values of the complete elliptic integral Pi(N,A). +! +! Discussion: +! +! This is one form of what is sometimes called the complete elliptic +! integral of the third kind. +! +! The function is defined by the formula: +! +! Pi(N,A) = integral ( 0 <= T <= PI/2 ) +! dT / (1 - N sin^2(T) ) sqrt ( 1 - sin^2(A) * sin ( T )^2 ) +! +! In MATLAB, the function can be evaluated by: +! +! ellipticPi(n,(sin(A*pi/180))^2) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 May 2018 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) N, A, the arguments of the function. +! +! Output, real ( kind = 8 ) PIA, the value of the function. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 20 + + real ( kind = 8 ) a + real ( kind = 8 ), save, dimension ( n_max ) :: a_vec = (/ & + 30.00000000000000D+00, & + 45.00000000000000D+00, & + 60.00000000000000D+00, & + 77.07903361841643D+00, & + 30.00000000000000D+00, & + 45.00000000000000D+00, & + 60.00000000000000D+00, & + 77.07903361841643D+00, & + 30.00000000000000D+00, & + 45.00000000000000D+00, & + 60.00000000000000D+00, & + 77.07903361841643D+00, & + 30.00000000000000D+00, & + 45.00000000000000D+00, & + 60.00000000000000D+00, & + 77.07903361841643D+00, & + 30.00000000000000D+00, & + 45.00000000000000D+00, & + 60.00000000000000D+00, & + 77.07903361841643D+00 /) + real ( kind = 8 ) n + integer ( kind = 4 ) n_data + real ( kind = 8 ), save, dimension ( n_max ) :: n_vec = (/ & + -10.0D+00, & + -10.0D+00, & + -10.0D+00, & + -10.0D+00, & + -3.0D+00, & + -3.0D+00, & + -3.0D+00, & + -3.0D+00, & + -1.0D+00, & + -1.0D+00, & + -1.0D+00, & + -1.0D+00, & + 0.0D+00, & + 0.0D+00, & + 0.0D+00, & + 0.0D+00, & + 0.5D+00, & + 0.5D+00, & + 0.5D+00, & + 0.5D+00 /) + real ( kind = 8 ) pia + real ( kind = 8 ), save, dimension ( n_max ) :: pia_vec = (/ & + 0.4892245275965397D+00, & + 0.5106765677902629D+00, & + 0.5460409271920561D+00, & + 0.6237325893535237D+00, & + 0.823045542660675D+00, & + 0.8760028274011437D+00, & + 0.9660073560143946D+00, & + 1.171952391481798D+00, & + 1.177446843000566D+00, & + 1.273127366749682D+00, & + 1.440034318657551D+00, & + 1.836472172302591D+00, & + 1.685750354812596D+00, & + 1.854074677301372D+00, & + 2.156515647499643D+00, & + 2.908337248444552D+00, & + 2.413671504201195D+00, & + 2.701287762095351D+00, & + 3.234773471249465D+00, & + 4.633308147279891D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + a = 0.0D+00 + n = 0.0D+00 + pia = 0.0D+00 + else + a = a_vec(n_data) + n = n_vec(n_data) + pia = pia_vec(n_data) + end if + + return +end +function elliptic_pik ( n, k ) + +!*****************************************************************************80 +! +!! ELLIPTIC_PIK evaluates the complete elliptic integral Pi(N,K). +! +! Discussion: +! +! This is one form of what is sometimes called the complete elliptic +! integral of the third kind. +! +! The function is defined by the formula: +! +! Pi(N,K) = integral ( 0 <= T <= PI/2 ) +! dT / (1 - N sin^2(T) ) sqrt ( 1 - K^2 * sin ( T )^2 ) +! +! In MATLAB, the function can be evaluated by: +! +! ellipticPi(n,k^2) +! +! The value is computed using Carlson elliptic integrals: +! +! Pi(n,k) = RF ( 0, 1 - k^2, 1 ) + 1/3 n RJ ( 0, 1 - k^2, 1, 1 - n ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 May 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) N, K, the arguments. +! +! Output, real ( kind = 8 ) ELLIPTIC_PIK, the function value. +! + implicit none + + real ( kind = 8 ) elliptic_pik + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) k + real ( kind = 8 ) n + real ( kind = 8 ) p + !real ( kind = 8 ) rf + !real ( kind = 8 ) rj + real ( kind = 8 ) value + real ( kind = 8 ) x + real ( kind = 8 ) y + real ( kind = 8 ) z + + x = 0.0D+00 + y = ( 1.0D+00 - k ) * ( 1.0D+00 + k ) + z = 1.0D+00 + p = 1.0D+00 - n + errtol = 1.0D-03 + + value = rf ( x, y, z, errtol, ierr ) & + + n * rj ( x, y, z, p, errtol, ierr ) / 3.0D+00 + + elliptic_pik = value + + return +end +subroutine elliptic_pik_values ( n_data, n, k, pik ) + +!*****************************************************************************80 +! +!! ELLIPTIC_PIK_VALUES returns values of the complete elliptic integral Pi(N,K). +! +! Discussion: +! +! This is one form of what is sometimes called the complete elliptic +! integral of the third kind. +! +! The function is defined by the formula: +! +! Pi(N,K) = integral ( 0 <= T <= PI/2 ) +! dT / (1 - N sin^2(T) ) sqrt ( 1 - K^2 * sin ( T )^2 ) +! +! In MATLAB, the function can be evaluated by: +! +! ellipticPi(n,k^2) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 May 2018 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) N, K, the arguments of the function. +! +! Output, real ( kind = 8 ) PIK, the value of the function. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 20 + + real ( kind = 8 ) k + real ( kind = 8 ), save, dimension ( n_max ) :: k_vec = (/ & + 0.5000000000000000D+00, & + 0.7071067811865476D+00, & + 0.8660254037844386D+00, & + 0.9746794344808963D+00, & + 0.5000000000000000D+00, & + 0.7071067811865476D+00, & + 0.8660254037844386D+00, & + 0.9746794344808963D+00, & + 0.5000000000000000D+00, & + 0.7071067811865476D+00, & + 0.8660254037844386D+00, & + 0.9746794344808963D+00, & + 0.5000000000000000D+00, & + 0.7071067811865476D+00, & + 0.8660254037844386D+00, & + 0.9746794344808963D+00, & + 0.5000000000000000D+00, & + 0.7071067811865476D+00, & + 0.8660254037844386D+00, & + 0.9746794344808963D+00 /) + real ( kind = 8 ) n + integer ( kind = 4 ) n_data + real ( kind = 8 ), save, dimension ( n_max ) :: n_vec = (/ & + -10.0D+00, & + -10.0D+00, & + -10.0D+00, & + -10.0D+00, & + -3.0D+00, & + -3.0D+00, & + -3.0D+00, & + -3.0D+00, & + -1.0D+00, & + -1.0D+00, & + -1.0D+00, & + -1.0D+00, & + 0.0D+00, & + 0.0D+00, & + 0.0D+00, & + 0.0D+00, & + 0.5D+00, & + 0.5D+00, & + 0.5D+00, & + 0.5D+00 /) + real ( kind = 8 ) pik + real ( kind = 8 ), save, dimension ( n_max ) :: pik_vec = (/ & + 0.4892245275965397D+00, & + 0.5106765677902629D+00, & + 0.5460409271920561D+00, & + 0.6237325893535237D+00, & + 0.823045542660675D+00, & + 0.8760028274011437D+00, & + 0.9660073560143946D+00, & + 1.171952391481798D+00, & + 1.177446843000566D+00, & + 1.273127366749682D+00, & + 1.440034318657551D+00, & + 1.836472172302591D+00, & + 1.685750354812596D+00, & + 1.854074677301372D+00, & + 2.156515647499643D+00, & + 2.908337248444552D+00, & + 2.413671504201195D+00, & + 2.701287762095351D+00, & + 3.234773471249465D+00, & + 4.633308147279891D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + k = 0.0D+00 + n = 0.0D+00 + pik = 0.0D+00 + else + k = k_vec(n_data) + n = n_vec(n_data) + pik = pik_vec(n_data) + end if + + return +end +function elliptic_pim ( n, m ) + +!*****************************************************************************80 +! +!! ELLIPTIC_PIM evaluates the complete elliptic integral Pi(N,M). +! +! Discussion: +! +! This is one form of what is sometimes called the complete elliptic +! integral of the third kind. +! +! The function is defined by the formula: +! +! Pi(N,M) = integral ( 0 <= T <= PI/2 ) +! dT / (1 - N sin^2(T) ) sqrt ( 1 - M * sin ( T )^2 ) +! +! In MATLAB, the function can be evaluated by: +! +! ellipticPi(n,m) +! +! The value is computed using Carlson elliptic integrals: +! +! Pi(n,m) = RF ( 0, 1 - m, 1 ) + 1/3 n RJ ( 0, 1 - m, 1, 1 - n ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 May 2018 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) N, M, the arguments. +! +! Output, real ( kind = 8 ) ELLIPTIC_PIM, the function value. +! + implicit none + + real ( kind = 8 ) elliptic_pim + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) m + real ( kind = 8 ) n + real ( kind = 8 ) p + !real ( kind = 8 ) rf + !real ( kind = 8 ) rj + real ( kind = 8 ) value + real ( kind = 8 ) x + real ( kind = 8 ) y + real ( kind = 8 ) z + + x = 0.0D+00 + y = 1.0D+00 - m + z = 1.0D+00 + p = 1.0D+00 - n + errtol = 1.0D-03 + + value = rf ( x, y, z, errtol, ierr ) & + + n * rj ( x, y, z, p, errtol, ierr ) / 3.0D+00 + + elliptic_pim = value + + return +end +subroutine elliptic_pim_values ( n_data, n, m, pim ) + +!*****************************************************************************80 +! +!! ELLIPTIC_PIM_VALUES returns values of the complete elliptic integral Pi(N,M). +! +! Discussion: +! +! This is one form of what is sometimes called the complete elliptic +! integral of the third kind. +! +! The function is defined by the formula: +! +! Pi(N,M) = integral ( 0 <= T <= PI/2 ) +! dT / (1 - N sin^2(T) ) sqrt ( 1 - M * sin ( T )^2 ) +! +! In MATLAB, the function can be evaluated by: +! +! ellipticPi(n,m) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 May 2018 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) N, M, the arguments of the function. +! +! Output, real ( kind = 8 ) PIM, the value of the function. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 20 + + real ( kind = 8 ) m + real ( kind = 8 ), save, dimension ( n_max ) :: m_vec = (/ & + 0.25D+00, & + 0.50D+00, & + 0.75D+00, & + 0.95D+00, & + 0.25D+00, & + 0.50D+00, & + 0.75D+00, & + 0.95D+00, & + 0.25D+00, & + 0.50D+00, & + 0.75D+00, & + 0.95D+00, & + 0.25D+00, & + 0.50D+00, & + 0.75D+00, & + 0.95D+00, & + 0.25D+00, & + 0.50D+00, & + 0.75D+00, & + 0.95D+00 /) + real ( kind = 8 ) n + integer ( kind = 4 ) n_data + real ( kind = 8 ), save, dimension ( n_max ) :: n_vec = (/ & + -10.0D+00, & + -10.0D+00, & + -10.0D+00, & + -10.0D+00, & + -3.0D+00, & + -3.0D+00, & + -3.0D+00, & + -3.0D+00, & + -1.0D+00, & + -1.0D+00, & + -1.0D+00, & + -1.0D+00, & + 0.0D+00, & + 0.0D+00, & + 0.0D+00, & + 0.0D+00, & + 0.5D+00, & + 0.5D+00, & + 0.5D+00, & + 0.5D+00 /) + real ( kind = 8 ) pim + real ( kind = 8 ), save, dimension ( n_max ) :: pim_vec = (/ & + 0.4892245275965397D+00, & + 0.5106765677902629D+00, & + 0.5460409271920561D+00, & + 0.6237325893535237D+00, & + 0.823045542660675D+00, & + 0.8760028274011437D+00, & + 0.9660073560143946D+00, & + 1.171952391481798D+00, & + 1.177446843000566D+00, & + 1.273127366749682D+00, & + 1.440034318657551D+00, & + 1.836472172302591D+00, & + 1.685750354812596D+00, & + 1.854074677301372D+00, & + 2.156515647499643D+00, & + 2.908337248444552D+00, & + 2.413671504201195D+00, & + 2.701287762095351D+00, & + 3.234773471249465D+00, & + 4.633308147279891D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + m = 0.0D+00 + n = 0.0D+00 + pim = 0.0D+00 + else + m = m_vec(n_data) + n = n_vec(n_data) + pim = pim_vec(n_data) + end if + + return +end +function jacobi_cn ( u, m ) + +!*****************************************************************************80 +! +!! JACOBI_CN evaluates the Jacobi elliptic function CN(U,M). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 25 June 2018 +! +! Author: +! +! Original ALGOL version by Roland Bulirsch. +! FORTRAN90 version by John Burkardt +! +! Reference: +! +! Roland Bulirsch, +! Numerical calculation of elliptic integrals and elliptic functions, +! Numerische Mathematik, +! Volume 7, Number 1, 1965, pages 78-90. +! +! Parameters: +! +! Input, real ( kind = 8 ) U, M, the arguments. +! +! Output, real ( kind = 8 ) JACOBI_CN, the function value. +! + implicit none + + real ( kind = 8 ) cn + real ( kind = 8 ) dn + real ( kind = 8 ) jacobi_cn + real ( kind = 8 ) m + real ( kind = 8 ) sn + real ( kind = 8 ) u + + call sncndn ( u, m, sn, cn, dn ) + + jacobi_cn = cn + + return +end +subroutine jacobi_cn_values ( n_data, u, m, cn ) + +!*****************************************************************************80 +! +!! JACOBI_CN_VALUES returns some values of the Jacobi elliptic function CN(U,M). +! +! Discussion: +! +! In Mathematica, the function can be evaluated by: +! +! JacobiCN[ u, m ] +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 25 June 2018 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) U, the argument of the function. +! +! Output, real ( kind = 8 ) M, the parameter of the function. +! +! Output, real ( kind = 8 ) CN, the value of the function. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 20 + + real ( kind = 8 ) m + real ( kind = 8 ), save, dimension ( n_max ) :: m_vec = (/ & + 0.0D+00, & + 0.0D+00, & + 0.0D+00, & + 0.0D+00, & + 0.0D+00, & + 0.5D+00, & + 0.5D+00, & + 0.5D+00, & + 0.5D+00, & + 0.5D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00 /) + real ( kind = 8 ) cn + real ( kind = 8 ), save, dimension ( n_max ) :: cn_vec = (/ & + 0.9950041652780258D+00, & + 0.9800665778412416D+00, & + 0.8775825618903727D+00, & + 0.5403023058681397D+00, & + -0.4161468365471424D+00, & + 0.9950124626090582D+00, & + 0.9801976276784098D+00, & + 0.8822663948904403D+00, & + 0.5959765676721407D+00, & + -0.1031836155277618D+00, & + 0.9950207489532265D+00, & + 0.9803279976447253D+00, & + 0.8868188839700739D+00, & + 0.6480542736638854D+00, & + 0.2658022288340797D+00, & + 0.3661899347368653D-01, & + 0.9803279976447253D+00, & + 0.8868188839700739D+00, & + 0.6480542736638854D+00, & + 0.2658022288340797D+00 /) + integer ( kind = 4 ) n_data + real ( kind = 8 ) u + real ( kind = 8 ), save, dimension ( n_max ) :: u_vec = (/ & + 0.1D+00, & + 0.2D+00, & + 0.5D+00, & + 1.0D+00, & + 2.0D+00, & + 0.1D+00, & + 0.2D+00, & + 0.5D+00, & + 1.0D+00, & + 2.0D+00, & + 0.1D+00, & + 0.2D+00, & + 0.5D+00, & + 1.0D+00, & + 2.0D+00, & + 4.0D+00, & + -0.2D+00, & + -0.5D+00, & + -1.0D+00, & + -2.0D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + m = 0.0D+00 + u = 0.0D+00 + cn = 0.0D+00 + else + m = m_vec(n_data) + u = u_vec(n_data) + cn = cn_vec(n_data) + end if + + return +end +function jacobi_dn ( u, m ) + +!*****************************************************************************80 +! +!! JACOBI_DN evaluates the Jacobi elliptic function DN(U,M). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 25 June 2018 +! +! Author: +! +! Original ALGOL version by Roland Bulirsch. +! FORTRAN90 version by John Burkardt +! +! Reference: +! +! Roland Bulirsch, +! Numerical calculation of elliptic integrals and elliptic functions, +! Numerische Mathematik, +! Volume 7, Number 1, 1965, pages 78-90. +! +! Parameters: +! +! Input, real ( kind = 8 ) U, M, the arguments. +! +! Output, real ( kind = 8 ) JACOBI_DN, the function value. +! + implicit none + + real ( kind = 8 ) cn + real ( kind = 8 ) dn + real ( kind = 8 ) jacobi_dn + real ( kind = 8 ) m + real ( kind = 8 ) sn + real ( kind = 8 ) u + + call sncndn ( u, m, sn, cn, dn ) + + jacobi_dn = dn + + return +end +subroutine jacobi_dn_values ( n_data, u, m, dn ) + +!*****************************************************************************80 +! +!! JACOBI_DN_VALUES returns some values of the Jacobi elliptic function DN(U,M). +! +! Discussion: +! +! In Mathematica, the function can be evaluated by: +! +! JacobiDN[ u, m ] +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 25 June 2018 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) U, the argument of the function. +! +! Output, real ( kind = 8 ) M, the parameter of the function. +! +! Output, real ( kind = 8 ) DN, the value of the function. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 20 + + real ( kind = 8 ) m + real ( kind = 8 ), save, dimension ( n_max ) :: m_vec = (/ & + 0.0D+00, & + 0.0D+00, & + 0.0D+00, & + 0.0D+00, & + 0.0D+00, & + 0.5D+00, & + 0.5D+00, & + 0.5D+00, & + 0.5D+00, & + 0.5D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00 /) + real ( kind = 8 ) dn + real ( kind = 8 ), save, dimension ( n_max ) :: dn_vec = (/ & + 0.1000000000000000D+01, & + 0.1000000000000000D+01, & + 0.1000000000000000D+01, & + 0.1000000000000000D+01, & + 0.1000000000000000D+01, & + 0.9975093485144243D+00, & + 0.9901483195224800D+00, & + 0.9429724257773857D+00, & + 0.8231610016315963D+00, & + 0.7108610477840873D+00, & + 0.9950207489532265D+00, & + 0.9803279976447253D+00, & + 0.8868188839700739D+00, & + 0.6480542736638854D+00, & + 0.2658022288340797D+00, & + 0.3661899347368653D-01, & + 0.9803279976447253D+00, & + 0.8868188839700739D+00, & + 0.6480542736638854D+00, & + 0.2658022288340797D+00 /) + integer ( kind = 4 ) n_data + real ( kind = 8 ) u + real ( kind = 8 ), save, dimension ( n_max ) :: u_vec = (/ & + 0.1D+00, & + 0.2D+00, & + 0.5D+00, & + 1.0D+00, & + 2.0D+00, & + 0.1D+00, & + 0.2D+00, & + 0.5D+00, & + 1.0D+00, & + 2.0D+00, & + 0.1D+00, & + 0.2D+00, & + 0.5D+00, & + 1.0D+00, & + 2.0D+00, & + 4.0D+00, & + -0.2D+00, & + -0.5D+00, & + -1.0D+00, & + -2.0D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + m = 0.0D+00 + u = 0.0D+00 + dn = 0.0D+00 + else + m = m_vec(n_data) + u = u_vec(n_data) + dn = dn_vec(n_data) + end if + + return +end +function jacobi_sn ( u, m ) + +!*****************************************************************************80 +! +!! JACOBI_SN evaluates the Jacobi elliptic function SN(U,M). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 25 June 2018 +! +! Author: +! +! Original ALGOL version by Roland Bulirsch. +! FORTRAN90 version by John Burkardt +! +! Reference: +! +! Roland Bulirsch, +! Numerical calculation of elliptic integrals and elliptic functions, +! Numerische Mathematik, +! Volume 7, Number 1, 1965, pages 78-90. +! +! Parameters: +! +! Input, real ( kind = 8 ) U, M, the arguments. +! +! Output, real ( kind = 8 ) JACOBI_SN, the function value. +! + implicit none + + real ( kind = 8 ) cn + real ( kind = 8 ) dn + real ( kind = 8 ) jacobi_sn + real ( kind = 8 ) m + real ( kind = 8 ) sn + real ( kind = 8 ) u + + call sncndn ( u, m, sn, cn, dn ) + + jacobi_sn = sn + + return +end + +subroutine jacobi_sn_values ( n_data, u, m, sn ) + +!*****************************************************************************80 +! +!! JACOBI_SN_VALUES returns some values of the Jacobi elliptic function SN(U,M). +! +! Discussion: +! +! In Mathematica, the function can be evaluated by: +! +! JacobiSN[ u, m ] +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 25 June 2018 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, real ( kind = 8 ) U, the argument of the function. +! +! Output, real ( kind = 8 ) M, the parameter of the function. +! +! Output, real ( kind = 8 ) SN, the value of the function. +! + implicit none + + integer ( kind = 4 ), parameter :: n_max = 20 + + real ( kind = 8 ) m + real ( kind = 8 ), save, dimension ( n_max ) :: m_vec = (/ & + 0.0D+00, & + 0.0D+00, & + 0.0D+00, & + 0.0D+00, & + 0.0D+00, & + 0.5D+00, & + 0.5D+00, & + 0.5D+00, & + 0.5D+00, & + 0.5D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00, & + 1.0D+00 /) + real ( kind = 8 ) sn + real ( kind = 8 ), save, dimension ( n_max ) :: sn_vec = (/ & + 0.9983341664682815D-01, & + 0.1986693307950612D+00, & + 0.4794255386042030D+00, & + 0.8414709848078965D+00, & + 0.9092974268256817D+00, & + 0.9975068547462484D-01, & + 0.1980217429819704D+00, & + 0.4707504736556573D+00, & + 0.8030018248956439D+00, & + 0.9946623253580177D+00, & + 0.9966799462495582D-01, & + 0.1973753202249040D+00, & + 0.4621171572600098D+00, & + 0.7615941559557649D+00, & + 0.9640275800758169D+00, & + 0.9993292997390670D+00, & + -0.1973753202249040D+00, & + -0.4621171572600098D+00, & + -0.7615941559557649D+00, & + -0.9640275800758169D+00 /) + integer ( kind = 4 ) n_data + real ( kind = 8 ) u + real ( kind = 8 ), save, dimension ( n_max ) :: u_vec = (/ & + 0.1D+00, & + 0.2D+00, & + 0.5D+00, & + 1.0D+00, & + 2.0D+00, & + 0.1D+00, & + 0.2D+00, & + 0.5D+00, & + 1.0D+00, & + 2.0D+00, & + 0.1D+00, & + 0.2D+00, & + 0.5D+00, & + 1.0D+00, & + 2.0D+00, & + 4.0D+00, & + -0.2D+00, & + -0.5D+00, & + -1.0D+00, & + -2.0D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + m = 0.0D+00 + u = 0.0D+00 + sn = 0.0D+00 + else + m = m_vec(n_data) + u = u_vec(n_data) + sn = sn_vec(n_data) + end if + + return +end + +function rc ( x, y, errtol, ierr ) + +!*****************************************************************************80 +! +!! RC computes the elementary integral RC(X,Y). +! +! Discussion: +! +! This function computes the elementary integral +! +! RC(X,Y) = Integral ( 0 <= T < oo ) +! +! -1/2 -1 +! (1/2)(T+X) (T+Y) DT, +! +! where X is nonnegative and Y is positive. The duplication +! theorem is iterated until the variables are nearly equal, +! and the function is then expanded in Taylor series to fifth +! order. +! +! Logarithmic, inverse circular, and inverse hyperbolic +! functions can be expressed in terms of RC. +! +! Check by addition theorem: +! +! RC(X,X+Z) + RC(Y,Y+Z) = RC(0,Z), +! where X, Y, and Z are positive and X * Y = Z * Z. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 May 2018 +! +! Author: +! +! Original FORTRAN77 version by Bille Carlson, Elaine Notis. +! This FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Bille Carlson, +! Computing Elliptic Integrals by Duplication, +! Numerische Mathematik, +! Volume 33, 1979, pages 1-16. +! +! Bille Carlson, Elaine Notis, +! Algorithm 577, Algorithms for Incomplete Elliptic Integrals, +! ACM Transactions on Mathematical Software, +! Volume 7, Number 3, pages 398-403, September 1981. +! +! Parameters: +! +! Input, real ( kind = 8 ) X, Y, the arguments in the integral. +! +! Input, real ( kind = 8 ) ERRTOL, the error tolerance. +! Relative error due to truncation is less than +! 16 * ERRTOL ^ 6 / (1 - 2 * ERRTOL). +! Sample choices: +! ERRTOL Relative truncation error less than +! 1.D-3 2.D-17 +! 3.D-3 2.D-14 +! 1.D-2 2.D-11 +! 3.D-2 2.D-8 +! 1.D-1 2.D-5 +! +! Output, integer ( kind = 4 ) IERR, the error flag. +! 0, no error occurred. +! 1, abnormal termination. +! + implicit none + + real ( kind = 8 ) c1 + real ( kind = 8 ) c2 + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) lamda + real ( kind = 8 ) lolim + real ( kind = 8 ) mu + real ( kind = 8 ) rc + real ( kind = 8 ) s + real ( kind = 8 ) sn + real ( kind = 8 ) uplim + real ( kind = 8 ) x + real ( kind = 8 ) xn + real ( kind = 8 ) y + real ( kind = 8 ) yn +! +! LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS. +! LOLIM IS NOT LESS THAN THE MACHINE MINIMUM MULTIPLIED BY 5. +! UPLIM IS NOT GREATER THAN THE MACHINE MAXIMUM DIVIDED BY 5. +! + save lolim + save uplim + + data lolim /3.D-78/ + data uplim /1.D+75/ + + if ( & + x < 0.0d0 .or. & + y <= 0.0d0 .or. & + ( x + y ) < lolim .or. & + uplim < x .or. & + uplim < y ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'RC - Error!' + write ( *, '(a)' ) ' Invalid input arguments.' + write ( *, '(a,d23.16)' ) ' X = ', x + write ( *, '(a,d23.16)' ) ' Y = ', y + write ( *, '(a)' ) '' + ierr = 1 + rc = 0.0D+00 + return + end if + + ierr = 0 + xn = x + yn = y + + do + + mu = ( xn + yn + yn ) / 3.0d0 + sn = ( yn + mu ) / mu - 2.0d0 + + if ( abs ( sn ) < errtol ) then + c1 = 1.0d0 / 7.0d0 + c2 = 9.0d0 / 22.0d0 + s = sn * sn * ( 0.3d0 & + + sn * ( c1 + sn * ( 0.375d0 + sn * c2 ) ) ) + rc = ( 1.0d0 + s ) / sqrt ( mu ) + return + end if + + lamda = 2.0d0 * sqrt ( xn ) * sqrt ( yn ) + yn + xn = ( xn + lamda ) * 0.25d0 + yn = ( yn + lamda ) * 0.25d0 + + end do + +end +function rd ( x, y, z, errtol, ierr ) + +!*****************************************************************************80 +! +!! RD computes an incomplete elliptic integral of the second kind, RD(X,Y,Z). +! +! Discussion: +! +! This function computes an incomplete elliptic integral of the second kind. +! +! RD(X,Y,Z) = Integral ( 0 <= T < oo ) +! +! -1/2 -1/2 -3/2 +! (3/2)(T+X) (T+Y) (T+Z) DT, +! +! where X and Y are nonnegative, X + Y is positive, and Z is positive. +! +! If X or Y is zero, the integral is complete. +! +! The duplication theorem is iterated until the variables are +! nearly equal, and the function is then expanded in Taylor +! series to fifth order. +! +! Check: +! +! RD(X,Y,Z) + RD(Y,Z,X) + RD(Z,X,Y) = 3 / sqrt ( X * Y * Z ), +! where X, Y, and Z are positive. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 May 2018 +! +! Author: +! +! Original FORTRAN77 version by Bille Carlson, Elaine Notis. +! This FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Bille Carlson, +! Computing Elliptic Integrals by Duplication, +! Numerische Mathematik, +! Volume 33, 1979, pages 1-16. +! +! Bille Carlson, Elaine Notis, +! Algorithm 577, Algorithms for Incomplete Elliptic Integrals, +! ACM Transactions on Mathematical Software, +! Volume 7, Number 3, pages 398-403, September 1981. +! +! Parameters: +! +! Input, real ( kind = 8 ) X, Y, Z, the arguments in the integral. +! +! Input, real ( kind = 8 ) ERRTOL, the error tolerance. +! The relative error due to truncation is less than +! 3 * ERRTOL ^ 6 / (1-ERRTOL) ^ 3/2. +! Sample choices: +! ERRTOL Relative truncation error less than +! 1.D-3 4.D-18 +! 3.D-3 3.D-15 +! 1.D-2 4.D-12 +! 3.D-2 3.D-9 +! 1.D-1 4.D-6 +! +! Output, integer ( kind = 4 ) IERR, the error flag. +! 0, no error occurred. +! 1, abnormal termination. +! + implicit none + + real ( kind = 8 ) c1 + real ( kind = 8 ) c2 + real ( kind = 8 ) c3 + real ( kind = 8 ) c4 + real ( kind = 8 ) ea + real ( kind = 8 ) eb + real ( kind = 8 ) ec + real ( kind = 8 ) ed + real ( kind = 8 ) ef + real ( kind = 8 ) epslon + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) lamda + real ( kind = 8 ) lolim + real ( kind = 8 ) mu + real ( kind = 8 ) power4 + real ( kind = 8 ) rd + real ( kind = 8 ) sigma + real ( kind = 8 ) s1 + real ( kind = 8 ) s2 + real ( kind = 8 ) uplim + real ( kind = 8 ) x + real ( kind = 8 ) xn + real ( kind = 8 ) xndev + real ( kind = 8 ) xnroot + real ( kind = 8 ) y + real ( kind = 8 ) yn + real ( kind = 8 ) yndev + real ( kind = 8 ) ynroot + real ( kind = 8 ) z + real ( kind = 8 ) zn + real ( kind = 8 ) zndev + real ( kind = 8 ) znroot +! +! LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS. +! LOLIM IS NOT LESS THAN 2 / (MACHINE MAXIMUM) ^ (2/3). +! UPLIM IS NOT GREATER THAN (0.1 * ERRTOL / MACHINE +! MINIMUM) ^ (2/3), WHERE ERRTOL IS DESCRIBED BELOW. +! IN THE FOLLOWING TABLE IT IS ASSUMED THAT ERRTOL WILL +! NEVER BE CHOSEN SMALLER THAN 1.D-5. +! + save lolim + save uplim + + data lolim /6.D-51/ + data uplim /1.D+48/ + + if ( & + x < 0.0D+00 .or. & + y < 0.0D+00 .or. & + x + y < lolim .or. & + z < lolim .or. & + uplim < x .or. & + uplim < y .or. & + uplim < z ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'RD - Error!' + write ( *, '(a)' ) ' Invalid input arguments.' + write ( *, '(a,d23.16)' ) ' X = ', x + write ( *, '(a,d23.16)' ) ' Y = ', y + write ( *, '(a,d23.16)' ) ' Z = ', z + write ( *, '(a)' ) '' + ierr = 1 + rd = 0.0D+00 + return + end if + + ierr = 0 + xn = x + yn = y + zn = z + sigma = 0.0d0 + power4 = 1.0d0 + + do + + mu = ( xn + yn + 3.0d0 * zn ) * 0.2d0 + xndev = ( mu - xn ) / mu + yndev = ( mu - yn ) / mu + zndev = ( mu - zn ) / mu + epslon = max ( abs ( xndev ), abs ( yndev ), abs ( zndev ) ) + + if ( epslon < errtol ) then + c1 = 3.0d0 / 14.0d0 + c2 = 1.0d0 / 6.0d0 + c3 = 9.0d0 / 22.0d0 + c4 = 3.0d0 / 26.0d0 + ea = xndev * yndev + eb = zndev * zndev + ec = ea - eb + ed = ea - 6.0d0 * eb + ef = ed + ec + ec + s1 = ed * ( - c1 + 0.25d0 * c3 * ed - 1.5d0 * c4 * zndev * ef ) + s2 = zndev * ( c2 * ef + zndev * ( - c3 * ec + zndev * c4 * ea ) ) + rd = 3.0d0 * sigma + power4 * ( 1.0d0 + s1 + s2 ) / ( mu * sqrt ( mu ) ) + + return + end if + + xnroot = sqrt ( xn ) + ynroot = sqrt ( yn ) + znroot = sqrt ( zn ) + lamda = xnroot * ( ynroot + znroot ) + ynroot * znroot + sigma = sigma + power4 / ( znroot * ( zn + lamda ) ) + power4 = power4 * 0.25d0 + xn = ( xn + lamda ) * 0.25d0 + yn = ( yn + lamda ) * 0.25d0 + zn = ( zn + lamda ) * 0.25d0 + + end do + +end + +function rf ( x, y, z, errtol, ierr ) + +!*****************************************************************************80 +! +!! RF computes an incomplete elliptic integral of the first kind, RF(X,Y,Z). +! +! Discussion: +! +! This function computes the incomplete elliptic integral of the first kind. +! +! RF(X,Y,Z) = Integral ( 0 <= T < oo ) +! +! -1/2 -1/2 -1/2 +! (1/2)(T+X) (T+Y) (T+Z) DT, +! +! where X, Y, and Z are nonnegative and at most one of them is zero. +! +! If X or Y or Z is zero, the integral is complete. +! +! The duplication theorem is iterated until the variables are +! nearly equal, and the function is then expanded in Taylor +! series to fifth order. +! +! Check by addition theorem: +! +! RF(X,X+Z,X+W) + RF(Y,Y+Z,Y+W) = RF(0,Z,W), +! where X, Y, Z, W are positive and X * Y = Z * W. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 May 2018 +! +! Author: +! +! Original FORTRAN77 version by Bille Carlson, Elaine Notis. +! This FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Bille Carlson, +! Computing Elliptic Integrals by Duplication, +! Numerische Mathematik, +! Volume 33, 1979, pages 1-16. +! +! Bille Carlson, Elaine Notis, +! Algorithm 577, Algorithms for Incomplete Elliptic Integrals, +! ACM Transactions on Mathematical Software, +! Volume 7, Number 3, pages 398-403, September 1981. +! +! Parameters: +! +! Input, real ( kind = 8 ) X, Y, Z, the arguments in the integral. +! +! Input, real ( kind = 8 ) ERRTOL, the error tolerance. +! Relative error due to truncation is less than +! ERRTOL ^ 6 / (4 * (1 - ERRTOL)). +! Sample choices: +! ERRTOL Relative truncation error less than +! 1.D-3 3.D-19 +! 3.D-3 2.D-16 +! 1.D-2 3.D-13 +! 3.D-2 2.D-10 +! 1.D-1 3.D-7 +! +! Output, integer ( kind = 4 ) IERR, the error flag. +! 0, no error occurred. +! 1, abnormal termination. +! + implicit none + + real ( kind = 8 ) c1 + real ( kind = 8 ) c2 + real ( kind = 8 ) c3 + real ( kind = 8 ) e2 + real ( kind = 8 ) e3 + real ( kind = 8 ) epslon + real ( kind = 8 ) errtol + integer ( kind = 4 ) ierr + real ( kind = 8 ) lamda + real ( kind = 8 ) lolim + real ( kind = 8 ) mu + real ( kind = 8 ) rf + real ( kind = 8 ) s + real ( kind = 8 ) uplim + real ( kind = 8 ) x + real ( kind = 8 ) xn + real ( kind = 8 ) xndev + real ( kind = 8 ) xnroot + real ( kind = 8 ) y + real ( kind = 8 ) yn + real ( kind = 8 ) yndev + real ( kind = 8 ) ynroot + real ( kind = 8 ) z + real ( kind = 8 ) zn + real ( kind = 8 ) zndev + real ( kind = 8 ) znroot +! +! LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS. +! LOLIM IS NOT LESS THAN THE MACHINE MINIMUM MULTIPLIED BY 5. +! UPLIM IS NOT GREATER THAN THE MACHINE MAXIMUM DIVIDED BY 5. +! + save lolim + save uplim + + data lolim /3.D-78/ + data uplim /1.D+75/ + + if ( & + x < 0.0D+00 .or. & + y < 0.0D+00 .or. & + z < 0.0D+00 .or. & + x + y < lolim .or. & + x + z < lolim .or. & + y + z < lolim .or. & + uplim <= x .or. & + uplim <= y .or. & + uplim <= z ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'RF - Error!' + write ( *, '(a)' ) ' Invalid input arguments.' + write ( *, '(a,d23.16)' ) ' X = ', x + write ( *, '(a,d23.16)' ) ' Y = ', y + write ( *, '(a,d23.16)' ) ' Z = ', z + write ( *, '(a)' ) '' + ierr = 1 + rf = 0.0D+00 + return + end if + + ierr = 0 + xn = x + yn = y + zn = z + + do + + mu = ( xn + yn + zn ) / 3.0d0 + xndev = 2.0d0 - ( mu + xn ) / mu + yndev = 2.0d0 - ( mu + yn ) / mu + zndev = 2.0d0 - ( mu + zn ) / mu + epslon = max ( abs ( xndev ), abs ( yndev ), abs ( zndev ) ) + + if ( epslon < errtol ) then + c1 = 1.0d0 / 24.0d0 + c2 = 3.0d0 / 44.0d0 + c3 = 1.0d0 / 14.0d0 + e2 = xndev * yndev - zndev * zndev + e3 = xndev * yndev * zndev + s = 1.0d0 + ( c1 * e2 - 0.1d0 - c2 * e3 ) * e2 + c3 * e3 + rf = s / sqrt ( mu ) + return + end if + + xnroot = sqrt ( xn ) + ynroot = sqrt ( yn ) + znroot = sqrt ( zn ) + lamda = xnroot * ( ynroot + znroot ) + ynroot * znroot + xn = ( xn + lamda ) * 0.25d0 + yn = ( yn + lamda ) * 0.25d0 + zn = ( zn + lamda ) * 0.25d0 + + end do + +end + + +function rj ( x, y, z, p, errtol, ierr ) + +!*****************************************************************************80 +! +!! RJ computes an incomplete elliptic integral of the third kind, RJ(X,Y,Z,P). +! +! Discussion: +! +! This function computes an incomplete elliptic integral of the third kind. +! +! RJ(X,Y,Z,P) = Integral ( 0 <= T < oo ) +! +! -1/2 -1/2 -1/2 -1 +! (3/2)(T+X) (T+Y) (T+Z) (T+P) DT, +! +! where X, Y, and Z are nonnegative, at most one of them is +! zero, and P is positive. +! +! If X or Y or Z is zero, then the integral is complete. +! +! The duplication theorem is iterated until the variables are nearly equal, +! and the function is then expanded in Taylor series to fifth order. +! +! Check by addition theorem: +! +! RJ(X,X+Z,X+W,X+P) +! + RJ(Y,Y+Z,Y+W,Y+P) + (A-B) * RJ(A,B,B,A) + 3 / sqrt ( A) +! = RJ(0,Z,W,P), where X,Y,Z,W,P are positive and X * Y +! = Z * W, A = P * P * (X+Y+Z+W), B = P * (P+X) * (P+Y), +! and B - A = P * (P-Z) * (P-W). +! +! The sum of the third and fourth terms on the left side is 3 * RC(A,B). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 May 2018 +! +! Author: +! +! Original FORTRAN77 version by Bille Carlson, Elaine Notis. +! This FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Bille Carlson, +! Computing Elliptic Integrals by Duplication, +! Numerische Mathematik, +! Volume 33, 1979, pages 1-16. +! +! Bille Carlson, Elaine Notis, +! Algorithm 577, Algorithms for Incomplete Elliptic Integrals, +! ACM Transactions on Mathematical Software, +! Volume 7, Number 3, pages 398-403, September 1981. +! +! Parameters: +! +! Input, real ( kind = 8 ) X, Y, Z, P, the arguments in the integral. +! +! Input, real ( kind = 8 ) ERRTOL, the error tolerance. +! Relative error due to truncation of the series for rj +! is less than 3 * ERRTOL ^ 6 / (1 - ERRTOL) ^ 3/2. +! An error tolerance (ETOLRC) will be passed to the subroutine +! for RC to make the truncation error for RC less than for RJ. +! Sample choices: +! ERRTOL Relative truncation error less than +! 1.D-3 4.D-18 +! 3.D-3 3.D-15 +! 1.D-2 4.D-12 +! 3.D-2 3.D-9 +! 1.D-1 4.D-6 +! +! Output, integer ( kind = 4 ) IERR, the error flag. +! 0, no error occurred. +! 1, abnormal termination. +! + implicit none + + real ( kind = 8 ) alfa + real ( kind = 8 ) beta + real ( kind = 8 ) c1 + real ( kind = 8 ) c2 + real ( kind = 8 ) c3 + real ( kind = 8 ) c4 + real ( kind = 8 ) ea + real ( kind = 8 ) eb + real ( kind = 8 ) ec + real ( kind = 8 ) e2 + real ( kind = 8 ) e3 + real ( kind = 8 ) epslon + real ( kind = 8 ) errtol + real ( kind = 8 ) etolrc + integer ( kind = 4 ) ierr + real ( kind = 8 ) lamda + real ( kind = 8 ) lolim + real ( kind = 8 ) mu + real ( kind = 8 ) p + real ( kind = 8 ) pn + real ( kind = 8 ) pndev + real ( kind = 8 ) power4 + !real ( kind = 8 ) rc + real ( kind = 8 ) rj + real ( kind = 8 ) sigma + real ( kind = 8 ) s1 + real ( kind = 8 ) s2 + real ( kind = 8 ) s3 + real ( kind = 8 ) uplim + real ( kind = 8 ) x + real ( kind = 8 ) xn + real ( kind = 8 ) xndev + real ( kind = 8 ) xnroot + real ( kind = 8 ) y + real ( kind = 8 ) yn + real ( kind = 8 ) yndev + real ( kind = 8 ) ynroot + real ( kind = 8 ) z + real ( kind = 8 ) zn + real ( kind = 8 ) zndev + real ( kind = 8 ) znroot +! +! LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS. +! LOLIM IS NOT LESS THAN THE CUBE ROOT OF THE VALUE +! OF LOLIM USED IN THE SUBROUTINE FOR RC. +! UPLIM IS NOT GREATER THAN 0.3 TIMES THE CUBE ROOT OF +! THE VALUE OF UPLIM USED IN THE SUBROUTINE FOR RC. +! + save lolim + save uplim + + data lolim /2.D-26/ + data uplim /3.D+24/ + + if ( & + x < 0.0D+00 .or. & + y < 0.0D+00 .or. & + z < 0.0D+00 .or. & + x + y < lolim .or. & + x + z < lolim .or. & + y + z < lolim .or. & + p < lolim .or. & + uplim < x .or. & + uplim < y .or. & + uplim < z .or. & + uplim < p ) then + write ( *, '(a)' ) '' + write ( *, '(a)' ) 'RJ - Error!' + write ( *, '(a)' ) ' Invalid input arguments.' + write ( *, '(a,d23.16)' ) ' X = ', x + write ( *, '(a,d23.16)' ) ' Y = ', y + write ( *, '(a,d23.16)' ) ' Z = ', z + write ( *, '(a,d23.16)' ) ' P = ', p + write ( *, '(a)' ) '' + ierr = 1 + rj = 0.0D+00 + return + end if + + ierr = 0 + xn = x + yn = y + zn = z + pn = p + sigma = 0.0d0 + power4 = 1.0d0 + etolrc = 0.5d0 * errtol + + do + + mu = ( xn + yn + zn + pn + pn ) * 0.2d0 + xndev = ( mu - xn ) / mu + yndev = ( mu - yn ) / mu + zndev = ( mu - zn ) / mu + pndev = ( mu - pn ) / mu + epslon = max ( abs ( xndev ), abs ( yndev ), abs ( zndev ), abs ( pndev ) ) + + if ( epslon < errtol ) then + c1 = 3.0d0 / 14.0d0 + c2 = 1.0d0 / 3.0d0 + c3 = 3.0d0 / 22.0d0 + c4 = 3.0d0 / 26.0d0 + ea = xndev * ( yndev + zndev ) + yndev * zndev + eb = xndev * yndev * zndev + ec = pndev * pndev + e2 = ea - 3.0d0 * ec + e3 = eb + 2.0d0 * pndev * ( ea - ec ) + s1 = 1.0d0 + e2 * ( - c1 + 0.75d0 * c3 * e2 - 1.5d0 * c4 * e3 ) + s2 = eb * ( 0.5d0 * c2 + pndev * ( - c3 - c3 + pndev * c4 ) ) + s3 = pndev * ea * ( c2 - pndev * c3 ) - c2 * pndev * ec + rj = 3.0d0 * sigma + power4 * ( s1 + s2 + s3 ) / ( mu * sqrt ( mu ) ) + return + end if + + xnroot = sqrt ( xn ) + ynroot = sqrt ( yn ) + znroot = sqrt ( zn ) + lamda = xnroot * ( ynroot + znroot ) + ynroot * znroot + alfa = pn * ( xnroot + ynroot + znroot ) & + + xnroot * ynroot * znroot + alfa = alfa * alfa + beta = pn * ( pn + lamda ) * ( pn + lamda ) + sigma = sigma + power4 * rc ( alfa, beta, etolrc, ierr ) + + if ( ierr /= 0 ) then + rj = 0.0D+00 + return + end if + + power4 = power4 * 0.25d0 + xn = ( xn + lamda ) * 0.25d0 + yn = ( yn + lamda ) * 0.25d0 + zn = ( zn + lamda ) * 0.25d0 + pn = ( pn + lamda ) * 0.25d0 + + end do + +end +subroutine sncndn ( u, m, sn, cn, dn ) + +!*****************************************************************************80 +! +!! SNCNDN evaluates Jacobi elliptic functions. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 24 June 2018 +! +! Author: +! +! Original ALGOL version by Roland Bulirsch. +! FORTRAN90 version by John Burkardt +! +! Reference: +! +! Roland Bulirsch, +! Numerical calculation of elliptic integrals and elliptic functions, +! Numerische Mathematik, +! Volume 7, Number 1, 1965, pages 78-90. +! +! Parameters: +! +! Input, real ( kind = 8 ) U, M, the arguments. +! +! Output, real ( kind = 8 ) SN, CN, DN, the value of the Jacobi +! elliptic functions sn(u,m), cn(u,m), and dn(u,m). +! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + real ( kind = 8 ) c + real ( kind = 8 ) ca + real ( kind = 8 ) cn + real ( kind = 8 ) d + real ( kind = 8 ) dn + real ( kind = 8 ) m_array(25) + real ( kind = 8 ) n_array(25) + integer ( kind = 4 ) i + integer ( kind = 4 ) l + real ( kind = 8 ) m + real ( kind = 8 ) m_comp + real ( kind = 8 ) sn + real ( kind = 8 ) u + real ( kind = 8 ) u_copy + + m_comp = 1.0D+00 - m + u_copy = u + + if ( m_comp == 0.0D+00 ) then + cn = 1.0D+00 / cosh ( u_copy ) + dn = cn + sn = tanh ( u_copy ) + return + end if + + if ( 1.0D+00 < m ) then + d = 1.0D+00 - m_comp + m_comp = - m_comp / d + d = sqrt ( d ) + u_copy = d * u_copy + end if + + ca = sqrt ( epsilon ( ca ) ) + + a = 1.0D+00 + dn = 1.0D+00 + l = 25 + + do i = 1, 25 + + m_array(i) = a + m_comp = sqrt ( m_comp ) + n_array(i) = m_comp + c = 0.5D+00 * ( a + m_comp ) + + if ( abs ( a - m_comp ) <= ca * a ) then + l = i + exit + end if + + m_comp = a * m_comp + a = c + + end do + + u_copy = c * u_copy + sn = sin ( u_copy ) + cn = cos ( u_copy ) + + if ( sn /= 0.0D+00 ) then + + a = cn / sn + c = a * c + + do i = l, 1, -1 + b = m_array(i) + a = c * a + c = dn * c + dn = ( n_array(i) + a ) / ( b + a ) + a = c / b + end do + + a = 1.0D+00 / sqrt ( c * c + 1.0D+00 ) + + if ( sn < 0.0D+00 ) then + sn = - a + else + sn = a + end if + + cn = c * sn + + end if + + if ( 1.0D+00 < m ) then + a = dn + dn = cn + cn = a + sn = sn / d + end if + + return +end + +subroutine timestamp ( ) + +!*****************************************************************************80 +! +!! TIMESTAMP prints the current YMDHMS date as a time stamp. +! +! Example: +! +! 31 May 2001 9:45:54.872 AM +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 May 2013 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! None +! + implicit none + + character ( len = 8 ) ampm + integer ( kind = 4 ) d + integer ( kind = 4 ) h + integer ( kind = 4 ) m + integer ( kind = 4 ) mm + character ( len = 9 ), parameter, dimension(12) :: month = (/ & + 'January ', 'February ', 'March ', 'April ', & + 'May ', 'June ', 'July ', 'August ', & + 'September', 'October ', 'November ', 'December ' /) + integer ( kind = 4 ) n + integer ( kind = 4 ) s + integer ( kind = 4 ) values(8) + integer ( kind = 4 ) y + + call date_and_time ( values = values ) + + y = values(1) + m = values(2) + d = values(3) + h = values(5) + n = values(6) + s = values(7) + mm = values(8) + + if ( h < 12 ) then + ampm = 'AM' + else if ( h == 12 ) then + if ( n == 0 .and. s == 0 ) then + ampm = 'Noon' + else + ampm = 'PM' + end if + else + h = h - 12 + if ( h < 12 ) then + ampm = 'PM' + else if ( h == 12 ) then + if ( n == 0 .and. s == 0 ) then + ampm = 'Midnight' + else + ampm = 'AM' + end if + end if + end if + + write ( *, '(i2.2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & + d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm ) + + return +end + +end module \ No newline at end of file diff --git a/src/fields_mod.f90 b/src/fields_mod.f90 index 86621d6..29cb991 100644 --- a/src/fields_mod.f90 +++ b/src/fields_mod.f90 @@ -1,1586 +1,1424 @@ !------------------------------------------------------------------------------ ! EPFL/Swiss Plasma Center !------------------------------------------------------------------------------ ! -! MODULE: beam +! MODULE: fields ! !> @author !> Patryk Kaminski EPFL/SPC !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> Module responsible for initializing the magnetic field, solving the Poisson equation and computing the moments of the particles distribution function !------------------------------------------------------------------------------ MODULE fields USE constants USE basic, ONLY: nr, nz, zgrid, rgrid, Br, Bz, Er, Ez, femorder, ngauss, nlppform, pot, Athet, & & splrz, splrz_ext, nlperiod, phinorm, nlPhis, nrank, mpirank, mpisize, step, it2d, timera, potxt, erxt, ezxt USE beam, ONLY: partslist USE bsplines USE mumps_bsplines use mpi Use omp_lib Use mpihelper, ONLY: db_type USE particletypes IMPLICIT NONE REAL(kind=db), allocatable, SAVE :: matcoef(:, :), phi_spline(:), vec1(:), vec2(:) REAL(kind=db), allocatable, SAVE :: loc_moments(:, :), loc_rhs(:), gradgtilde(:), fverif(:), ppformwork(:,:,:) INTEGER, SAVE:: loc_zspan TYPE(mumps_mat), SAVE :: femat !< Finite Element Method matrix for the full domain TYPE(mumps_mat), SAVE :: reduccedmat !< Finite Element Method matrix in the redduced web-spline sub-space TYPE(mumps_mat), SAVE :: fematmpi !< Finite Element Method matrix prepared for mpi parallelism INTEGER :: nbmoments = 10 !< number of moments to be calculated and stored INTEGER(kind=omp_lock_kind), Allocatable:: mu_lock(:) !< Stores the lock for fields parallelism CONTAINS SUBROUTINE mag_init - USE basic, ONLY: magnetfile, nr, nz - USE bsplines - USE mumps_bsplines - USE mpihelper - USE geometry + USE basic, ONLY: nr, nz,lu_in,cstep + USE magnet ALLOCATE (Br((nr + 1)*(nz + 1)), Bz((nr + 1)*(nz + 1))) ALLOCATE (Athet((nr + 1)*(nz + 1))) ! Calculate magnetic field mirror components in grid points (Davidson analytical formula employed) ! or load it from magnetfile if present - CALL magnet(magnetfile) + call timera(0, "mag_init") + CALL magnet_init(lu_in,cstep) + call timera(1, "mag_init") end subroutine mag_init !--------------------------------------------------------------------------- !> @author !> Patryk kaminski EPFL/SPC !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Set-up the necessary variables for solving Poisson and computes the magnetic field on the grid ! !--------------------------------------------------------------------------- SUBROUTINE fields_init USE basic, ONLY: pot, nlperiod, nrank, rhs, volume, rgrid USE bsplines USE geometry USE mumps_bsplines USE mpihelper INTEGER :: nrz(2), i, d2, k1, n1 ! Auxiliary vectors ALLOCATE(vec1((nz+1)*(nr+1)),vec2((nr+1)*(nz+1))) DO i=0,nr vec1(i*(nz+1)+1:(i+1)*(nz+1))=zgrid!(0:nz) vec2(i*(nz+1)+1:(i+1)*(nz+1))=rgrid(i) END DO ! Set up 2d spline splrz used in the FEM CALL set_spline(femorder, ngauss, zgrid, rgrid, splrz, nlppform=nlppform, period=nlperiod) ! Set up 2d spline splrz_ext used in the FEM to calculate the external electric field and potential CALL set_spline(femorder, ngauss, zgrid, rgrid, splrz_ext, nlppform=nlppform, period=nlperiod) !Allocate the work buffer to calculate the ppform d2 = splrz%sp2%dim k1 = splrz%sp1%order n1 = splrz%sp1%nints ALLOCATE(ppformwork(d2,k1,n1)) ! Calculate dimension of splines nrz(1) = nz nrz(2) = nr CALL get_dim(splrz, nrank, nrz, femorder) ! Allocate necessary variables ALLOCATE (matcoef(nrank(1), nrank(2))) ALLOCATE (pot((nr + 1)*(nz + 1))) ALLOCATE (potxt((nr + 1)*(nz + 1))) ALLOCATE (Erxt((nr + 1)*(nz + 1))) ALLOCATE (Ezxt((nr + 1)*(nz + 1))) ALLOCATE (rhs(nrank(1)*nrank(2))) ALLOCATE (gradgtilde(nrank(1)*nrank(2))) gradgtilde = 0 ALLOCATE (phi_spline(nrank(1)*nrank(2))) ALLOCATE (volume(nrank(1)*nrank(2))) volume = 0 ALLOCATE (Er((nr + 1)*(nz + 1)), Ez((nr + 1)*(nz + 1))) ALLOCATE (mu_lock(nrank(1)*nrank(2))) do i = 1, nrank(1)*nrank(2) call omp_init_lock(mu_lock(i)) end do end SUBROUTINE fields_init - - !--------------------------------------------------------------------------- +!--------------------------------------------------------------------------- !> @author !> Patryk kaminski EPFL/SPC !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Set-up the geometry definition and read it from the standard input !> Precomputes the LHS matrix to solve Poisson abd the RHS effect of the dirichlet boundaries ! !--------------------------------------------------------------------------- SUBROUTINE fields_start USE geometry USE basic, ONLY: nrank implicit none INTEGER:: i,j, k, ierr DOUBLE PRECISION:: val ! set up the geometry module for setting up non-conforming boundary conditions call timera(0, "geom_init") call geom_init(splrz, vec1, vec2) call timera(1, "geom_init") ! Initialisation of FEM matrix CALL init(nrank(1)*nrank(2), 2, femat) ! Calculate and factorise FEM matrix (depends only on mesh) - CALL fematrix(femat) + CALL fematrixrz(femat) If (walltype .lt. 0) then allocate (fverif(nrank(1)*nrank(2))) fverif = 0 end if ! Compute the volume of the splines and gtilde for solving E using web-splines CALL comp_volume !$OMP PARALLEL Call comp_gradgtilde !$OMP END PARALLEL if (nlweb) then ! Calculate reduced matrix for use of web splines call timera(0, "reduce femat") call Reducematrix(femat, reduccedmat) call timera(1, "reduce femat") call factor(reduccedmat) !call init(reduccedmat%rank,2,fematmpi,comm_in=MPI_COMM_WORLD) !do i=1,reduccedmat%rank ! do k=reduccedmat%irow(i),reduccedmat%irow(i+1)-1 ! j=reduccedmat%cols(k) ! call putele(fematmpi, i, j, reduccedmat%val(k)) ! end do !end do else call factor(femat) !call init(femat%rank,2,fematmpi,comm_in=MPI_COMM_WORLD) !do i=1,femat%rank ! do k=femat%irow(i),femat%irow(i+1)-1 ! j=femat%cols(k) ! call putele(fematmpi, i, j, femat%val(k)) ! end do !end do end if !call factor(fematmpi) - WRITE(*,*) "fematmpi is factorised" + !WRITE(*,*) "fematmpi is factorised" !WRITE(*,*) "Copy and to_mat worked" !CALL MPI_abort(MPI_COMM_WORLD,-1,ierr) call vacuum_field END SUBROUTINE fields_start !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Recomputes the vacuum electric field ! !--------------------------------------------------------------------------- subroutine vacuum_field Use geometry USE basic, ONLY: pot, rhs implicit none INTEGER:: i, iend ! Computes the externally imposed electric field !$OMP PARALLEL private(i) !$OMP DO SIMD do i=1,nrank(1)*nrank(2) rhs(i)=-gradgtilde(i) !rhs = -gradgtilde if (walltype .lt. 0) rhs(i) = rhs(i) + fverif(i) end do !$OMP END DO SIMD !$OMP END PARALLEL call poisson(splrz_ext) !$OMP PARALLEL private(i,iend) call Update_phi(splrz_ext) !$OMP BARRIER !$OMP DO ! On the root process, compute the electric field for diagnostic purposes DO i=1,size(pot),16 iend=min(size(pot),i+15) potxt(i:iend) = pot(i:iend) erxt(i:iend) = Er(i:iend) Ezxt(i:iend) = Ez(i:iend) END DO !$OMP END DO NOWAIT !$OMP END PARALLEL end subroutine !--------------------------------------------------------------------------- !> @author !> Patryk kaminski EPFL/SPC !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Set-up the necessary variables for the communication of moments and rhs grid ! !--------------------------------------------------------------------------- SUBROUTINE fields_comm_init(Zbounds) USE basic, ONLY: nrank USE mpihelper INTEGER:: Zbounds(0:) loc_zspan = Zbounds(mpirank + 1) - Zbounds(mpirank) + femorder(1) if (allocated(loc_moments)) deallocate (loc_moments) ALLOCATE (loc_moments(nbmoments, loc_zspan*nrank(2))) if (allocated(loc_rhs)) deallocate (loc_rhs) ALLOCATE (loc_rhs(loc_zspan*nrank(2))) IF (mpisize .gt. 1) THEN CALL init_overlaps(nrank, femorder, Zbounds(mpirank), Zbounds(mpirank + 1), nbmoments) END IF END SUBROUTINE fields_comm_init !--------------------------------------------------------------------------- !> @author !> Patryk kaminski EPFL/SPC !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Construct the right hand side vector used in the FEM Poisson solver ! !> @param[in] plist list of the particles type storing the desired specie parameters ! !--------------------------------------------------------------------------- SUBROUTINE rhscon(plist) USE bsplines use mpi USE basic, ONLY: rhs, Zbounds USE beam, ONLY: particles USE mpihelper Use geometry Use omp_lib type(particles), INTENT(INOUT):: plist(:) INTEGER:: i,j,k IF (nlphis) then ! We calculate the self-consistent field !$OMP DO SIMD Do i=1,size(loc_rhs) loc_rhs(i)=0 end do !$OMP END DO SIMD ! Assemble rhs for each specie Do i = 1, size(plist, 1) if (plist(i)%is_field) CALL deposit_charge(plist(i), loc_rhs) END Do !$OMP BARRIER !Communicate the overlaps if(mpisize .gt. 1) call rhs_overlap ! Add gradgtilde !$OMP DO SIMD Do i=0,size(loc_rhs)-1 j=(i)/loc_zspan k=mod(i,loc_zspan) loc_rhs(i+1)=loc_rhs(i+1)-gradgtilde((j)*nrank(1)+(k+Zbounds(mpirank)+1)) end do !$OMP END DO SIMD !add the fverif source for test cases if (walltype .lt. 0)then !$OMP DO Do i=0,size(loc_rhs)-1 j=i/loc_zspan k=mod(i,loc_zspan) loc_rhs(i+1)=loc_rhs(i+1)+fverif((j)*nrank(1)+(k+Zbounds(mpirank)+1)) end do !$OMP END DO end if ! If we are using MPI parallelism, reduce the rhs on the root process IF (mpisize .gt. 1) THEN CALL rhs_gather(rhs) ELSE !in serial copy loc_rhs to rhs !$OMP DO Do i=1,size(loc_rhs) rhs(i)=loc_rhs(i) end do !$OMP END DO END IF ELSE ! We only consider the externally imposed field !$OMP DO Do i=1,size(rhs) rhs(i)=-gradgtilde(i) end do !$OMP END DO END IF END SUBROUTINE rhscon !--------------------------------------------------------------------------- !> @author !> Patryk kaminski EPFL/SPC !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Calculate the 0th 1st and 2nd order moments of the particle p and stores it in moment ! !> @param[in] p the particles type storing the desired specie parameters !> @param[out] moment the 2d array storing the calculated moments ! !--------------------------------------------------------------------------- SUBROUTINE momentsdiag(p) USE bsplines use mpi USE beam, ONLY: particles USE mpihelper Use geometry type(particles), INTENT(INOUT):: p !REAL(kind=db), INTENT(INOUT):: moment(:, :) !$OMP SINGLE loc_moments = 0 ! Reset the moments matrix ! Assemble rhs !$OMP END SINGLE IF (p%Nploc .ne. 0) THEN CALL deposit_moments(p, loc_moments) END IF !$OMP SINGLE if(.not. allocated(p%moments))THEN if(mpirank.eq.0)THEN Allocate(p%moments(nbmoments,nrank(1)*nrank(2))) else Allocate(p%moments(0,0)) end if end if !$OMP END SINGLE ! If we are using MPI parallelism, reduce the rhs on the root process IF (mpisize .gt. 1) THEN CALL moments_gather(p%moments) ELSE !$OMP SINGLE p%moments = loc_moments !$OMP END SINGLE NOWAIT END IF END SUBROUTINE momentsdiag !--------------------------------------------------------------------------- !> @author !> Patryk kaminski EPFL/SPC !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Deposit the particles moments (n,v,v^2) from p on the grid ! !> @param[in] p the particles type storing the desired specie parameters !> @param[in] p_loc_moments local tensor used to store the moments of the given specie !--------------------------------------------------------------------------- SUBROUTINE deposit_moments(p, p_loc_moments) USE bsplines use mpi USE basic, ONLY: Zbounds USE beam, ONLY: particles USE mpihelper USE geometry USE omp_lib TYPE(particles), INTENT(IN):: p REAL(kind=db), DIMENSION(:, :), INTENT(INOUT):: p_loc_moments REAL(kind=db), DIMENSION(:, :), Allocatable:: omp_loc_moments INTEGER ::irow, jcol, it, jw, mu, i, k, iend, nbunch INTEGER, DIMENSION(:), ALLOCATABLE::zleft, rleft REAL(kind=db) :: vr, vthet, vz, coeff REAL(kind=db), ALLOCATABLE :: fun(:, :, :), fun2(:, :, :) INTEGER:: num_threads num_threads = omp_get_max_threads() nbunch = p%Nploc/num_threads ! Particle bunch size used when calling basfun nbunch = max(nbunch, 1) ! Particle bunch size used when calling basfun nbunch = min(nbunch, 64) ! Particle bunch size used when calling basfun ! Assemble rhs IF (p%Nploc .gt. 0) THEN !!$OMP PARALLEL DEFAULT(SHARED), PRIVATE(zleft,rleft,jw,it,iend,irow,jcol,mu,k,vr,vz,vthet,coeff,fun,fun2) ALLOCATE (zleft(nbunch), rleft(nbunch)) ALLOCATE (fun(1:femorder(1) + 1, 0:0, nbunch), fun2(1:femorder(2) + 1, 0:0, nbunch)) ! Arrays keeping values of b-splines at gauss node !allocate(omp_loc_moments(size(p_loc_moments,1),size(p_loc_moments,2))) !omp_loc_moments=0 !$OMP DO DO i = 1, p%Nploc, nbunch ! Avoid segmentation fault by accessing non relevant data iend = min(i + nbunch - 1, p%Nploc) k = iend - i + 1 ! Localize the particle !CALL locintv(splrz%sp2, p%R(i:iend), rleft(1:k)) !CALL locintv(splrz%sp1, p%Z(i:iend), zleft(1:k)) - rleft(1:k) = p%rindex(i:iend) - zleft(1:k) = p%zindex(i:iend) + rleft(1:k) = p%cellindex(1,i:iend) + zleft(1:k) = p%cellindex(3,i:iend) ! Compute the value of the splines at the particles positions CALL basfun(p%pos(3,i:iend), splrz%sp1, fun(:, :, 1:k), zleft(1:k) + 1) CALL basfun(p%pos(1,i:iend), splrz%sp2, fun2(:, :, 1:k), rleft(1:k) + 1) DO k = 1, (iend - i + 1) DO jw = 1, (femorder(2) + 1) DO it = 1, (femorder(1) + 1) irow = zleft(k) + it - Zbounds(mpirank) jcol = rleft(k) + jw mu = irow + (jcol - 1)*(loc_zspan) coeff = p%weight*fun(it, 0, k)*fun2(jw, 0, k) ! Add contribution of particle nbunch to rhs grid point mu vr = 0.5*(p%U(1,i + k - 1)/p%Gamma(i + k - 1) + p%Uold(1,i + k - 1)/p%Gammaold(i + k - 1)) vz = 0.5*(p%U(3,i + k - 1)/p%Gamma(i + k - 1) + p%Uold(3,i + k - 1)/p%Gammaold(i + k - 1)) vthet = 0.5*(p%U(2,i + k - 1)/p%Gamma(i + k - 1) + p%Uold(2,i + k - 1)/p%Gammaold(i + k - 1)) call omp_set_lock(mu_lock(mu)) p_loc_moments(1:10,mu)=p_loc_moments(1:10,mu)+coeff*(/1.0_db,vr,vthet,vz, vr*vr, vr*vthet, vr*vz, vthet**2, vthet*vz, vz**2/) call omp_unset_lock(mu_lock(mu)) END DO END DO END DO END DO !!$OMP END PARALLEL DO !$OMP END DO NOWAIT !Do i=1,size(p_loc_moments,2) ! call omp_set_lock(mu_lock(i)) ! p_loc_moments(:,i)=p_loc_moments(:,i)+omp_loc_moments(:,i) ! call omp_unset_lock(mu_lock(i)) !end do !!$OMP END CRITICAL(loc_moments_reduce) DEALLOCATE (fun, fun2, zleft, rleft) END IF END subroutine deposit_moments !--------------------------------------------------------------------------- !> @author !> Patryk kaminski EPFL/SPC !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Deposit the particles charges (q) from p on the grid ! !> @param[in] p the particles type storing the desired specie parameters !> @param[in] p_loc_moments local tensor used to store the moments of the given specie !--------------------------------------------------------------------------- SUBROUTINE deposit_charge(p, p_loc_moments) USE bsplines use mpi USE constants USE basic, ONLY: Zbounds, rnorm, phinorm USE beam, ONLY: particles USE mpihelper USE geometry USE omp_lib TYPE(particles), INTENT(IN):: p REAL(kind=db), DIMENSION(:), INTENT(INOUT):: p_loc_moments REAL(kind=db), DIMENSION(:), allocatable:: omp_loc_moments INTEGER ::irow, jcol, it, jw, mu, i, k, iend, nbunch INTEGER, DIMENSION(:), ALLOCATABLE::zleft, rleft REAL(kind=db), ALLOCATABLE :: fun(:, :, :), fun2(:, :, :) INTEGER:: num_threads, curr_thread real(kind=db):: contrib, chargecoeff num_threads = omp_get_max_threads() nbunch = p%Nploc/num_threads ! Particle bunch size used when calling basfun nbunch = max(nbunch, 1) ! Particle bunch size used when calling basfun nbunch = min(nbunch, 16) ! Particle bunch size used when calling basfun chargecoeff = p%weight*p%q/(2*pi*eps_0*phinorm*rnorm) ! Normalized charge density simulated by each macro particle ! Assemble rhs IF (p%Nploc .gt. 0) THEN !!!$OMP PARALLEL DEFAULT(SHARED), PRIVATE(i,zleft, rleft, jw, it, iend, irow, jcol, mu, k, fun, fun2, contrib) ALLOCATE (zleft(nbunch), rleft(nbunch)) ALLOCATE (fun(1:femorder(1) + 1, 0:0, nbunch), fun2(1:femorder(2) + 1, 0:0, nbunch)) ! Arrays keeping values of b-splines at gauss node !allocate(omp_loc_moments(size(p_loc_moments))) !omp_loc_moments=0 zleft=0 rleft=0 curr_thread=omp_get_thread_num() !$OMP DO DO i = 1, p%Nploc, nbunch ! Avoid segmentation fault by accessing non relevant data iend = min(i + nbunch - 1, p%Nploc) k = iend - i + 1 ! Localize the particle - rleft(1:k) = p%rindex(i:iend) - zleft(1:k) = p%zindex(i:iend) + rleft(1:k) = p%cellindex(1,i:iend) + zleft(1:k) = p%cellindex(3,i:iend) ! Compute the value of the splines at the particles positions CALL basfun(p%pos(3,i:iend), splrz%sp1, fun, zleft(1:k) + 1) CALL basfun(p%pos(1,i:iend), splrz%sp2, fun2, rleft(1:k) + 1) !CALL geom_weight(p%Z(i:iend),p%R(i:iend),wgeom) DO k = 1, (iend - i + 1) DO jw = 1, (femorder(2) + 1) DO it = 1, (femorder(1) + 1) irow = zleft(k) + it - Zbounds(mpirank) jcol = rleft(k) + jw mu = irow + (jcol - 1)*(loc_zspan) ! Add contribution of particle k to rhs grid point mu contrib = fun(it, 0, k)*fun2(jw, 0, k)*p%geomweight(0,i + k - 1)*chargecoeff !$OMP ATOMIC UPDATE p_loc_moments(mu) = p_loc_moments(mu) + contrib !$OMP END ATOMIC END DO END DO END DO END DO !$OMP END DO DEALLOCATE (fun, fun2, zleft, rleft) !Do i=1,size(p_loc_moments) ! !$OMP ATOMIC ! p_loc_moments(i)=p_loc_moments(i)+omp_loc_moments(i) ! !$OMP END ATOMIC !end do END IF END subroutine deposit_charge !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Do the communication of the local moment matrices between mpi workers for the overlap grid points !> ! !--------------------------------------------------------------------------- SUBROUTINE rhs_overlap USE mpihelper USE Basic, ONLY: Zbounds, mpirank, leftproc, rightproc INTEGER:: ierr, i, j !$OMP MASTER !WRITE(*,*) mpirank, "wE communicate overlap rhs" CALL rhsoverlapcomm(mpirank, leftproc, rightproc, loc_rhs, nrank, femorder, loc_zspan - femorder(1)) !$OMP END MASTER !$OMP BARRIER IF (mpirank .gt. 0) THEN !$OMP DO SIMD collapse(2) DO j = 1, femorder(1) DO i = 1, nrank(2) loc_rhs((i - 1)*loc_zspan + j) = loc_rhs((i - 1)*loc_zspan + j)& & + rhsoverlap_buffer(nrank(2)*(j - 1) + i) END DO END DO !$OMP END DO SIMD END IF !$OMP BARRIER END SUBROUTINE rhs_overlap !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Do the communication of the local moment matrices between mpi workers to reduce the result on the host ! !--------------------------------------------------------------------------- SUBROUTINE rhs_gather(rhs) USE mpihelper USE Basic, ONLY: Zbounds, mpirank, leftproc, rightproc REAL(kind=db), DIMENSION(:), INTENT(INOUT):: rhs INTEGER:: ierr, i, j INTEGER:: displs(mpisize), counts(mpisize) INTEGER:: overlap_type INTEGER:: rcvoverlap_type displs = Zbounds(0:mpisize - 1) counts = Zbounds(1:mpisize) - Zbounds(0:mpisize - 1) counts(mpisize) = counts(mpisize) + femorder(1) ! Set communication vector type overlap_type = rhsoverlap_type rcvoverlap_type = rcvrhsoverlap_type !$OMP MASTER IF (mpirank .eq. 0) THEN rhs = 0 END IF CALL MPI_GATHERV(loc_rhs, counts(mpirank + 1), rhsoverlap_type, & & rhs, counts, displs, rcvrhsoverlap_type, 0, MPI_COMM_WORLD, ierr) !$OMP END MASTER !$OMP BARRIER END SUBROUTINE rhs_gather !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Do the communication of the local moment matrices between mpi workers for the overlap grid points !> and reduce the result on the host ! !--------------------------------------------------------------------------- SUBROUTINE moments_gather(moment) USE mpihelper USE Basic, ONLY: Zbounds, mpirank, leftproc, rightproc REAL(kind=db), DIMENSION(:, :), INTENT(INOUT):: moment INTEGER:: ierr, i, j INTEGER:: displs(mpisize), counts(mpisize) displs = Zbounds(0:mpisize - 1) counts = Zbounds(1:mpisize) - Zbounds(0:mpisize - 1) counts(mpisize) = counts(mpisize) + femorder(1) !$OMP MASTER CALL momentsoverlapcomm(mpirank, leftproc, rightproc, loc_moments, nrank, femorder, loc_zspan - femorder(1)) !$OMP END MASTER !$OMP BARRIER IF (mpirank .gt. 0) THEN !!$OMP PARALLEL DO SIMD DEFAULT(SHARED) private(i) !$OMP DO SIMD collapse(2) DO j = 1, femorder(1) DO i = 1, nrank(2) loc_moments(1:nbmoments, (i - 1)*loc_zspan + j) = loc_moments(1:nbmoments, (i - 1)*loc_zspan + j)& & + momentsoverlap_buffer(nbmoments*(nrank(2)*(j - 1) + i - 1) + 1:nbmoments*(nrank(2)*(j - 1) + i)) END DO END DO !$OMP END DO SIMD END IF !$OMP MASTER ! Set communication vector type IF (mpirank .eq. 0) THEN moment = 0 END IF CALL MPI_GATHERV(loc_moments, counts(mpirank + 1), momentsoverlap_type, & & moment, counts, displs, rcvmomentsoverlap_type, 0, MPI_COMM_WORLD, ierr) !$OMP END MASTER !$OMP BARRIER END SUBROUTINE moments_gather !--------------------------------------------------------------------------- !> @author !> Patryk kaminski EPFL/SPC !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Solves Poisson equation using FEM. Distributes the result on all MPI workers. ! !--------------------------------------------------------------------------- SUBROUTINE poisson(splinevar) USE basic, ONLY: rhs, nrank, pot, nlend USE bsplines, ONLY: spline2d, gridval USE mumps_bsplines, ONLY: bsolve, vmx USE futils Use geometry type(spline2d):: splinevar INTEGER:: ierr, i, j, iend real(kind=db), allocatable::reducedrhs(:) real(kind=db), allocatable:: reducedsol(:), tempcol(:) allocate (reducedrhs(nrank(1)*nrank(2))) allocate (reducedsol(nbreducedspline)) allocate (tempcol(nrank(1)*nrank(2))) !$OMP MASTER + !reduccedmat%mumps_par%ICNTL(11)=1 if (nlweb) then ! we use the web-spline reduction for stability if(mpirank.eq.0) then ! Only the root process solves Poisson reducedrhs = vmx(etilde, rhs) - Call bsolve(reduccedmat, reducedrhs(1:nbreducedspline), reducedsol) + Call bsolve(reduccedmat, reducedrhs(1:nbreducedspline), reducedsol,10) + !WRITE(*,*) "Rinfog(10),Rinfog(11) ", reduccedmat%mumps_par%RINFOG(10), reduccedmat%mumps_par%RINFOG(11) end if CALL MPI_Bcast(reducedsol, nbreducedspline, db_type, 0, MPI_COMM_WORLD, ierr) - + tempcol = 0 tempcol(1:nbreducedspline) = reducedsol !phi_spline = 0 phi_spline = vmx(etildet, tempcol) else if(mpirank.eq.0) then CALL bsolve(femat, rhs, phi_spline) end if CALL MPI_Bcast(phi_spline, nrank(1)*nrank(2), db_type, 0, MPI_COMM_WORLD, ierr) end if !$OMP END MASTER !$OMP BARRIER END SUBROUTINE poisson SUBROUTINE poisson_mpi(splinevar) USE basic, ONLY: rhs, nrank, pot, nlend USE bsplines, ONLY: spline2d, gridval USE mumps_bsplines, ONLY: bsolve, vmx USE futils Use geometry type(spline2d):: splinevar INTEGER:: ierr, i, j, iend real(kind=db), allocatable::reducedrhs(:) real(kind=db), allocatable:: reducedsol(:), tempcol(:) allocate (reducedrhs(nrank(1)*nrank(2))) allocate (reducedsol(nbreducedspline)) allocate (tempcol(nrank(1)*nrank(2))) if (nlweb) then ! we use the web-spline reduction for stability reducedrhs = vmx(etilde, rhs) Call bsolve(fematmpi, reducedrhs(1:nbreducedspline), reducedsol) tempcol = 0 tempcol(1:nbreducedspline) = reducedsol !phi_spline = 0 phi_spline = vmx(etildet, tempcol) else CALL bsolve(fematmpi, rhs, phi_spline) !CALL MPI_Bcast(phi_spline, nrank(1)*nrank(2), db_type, 0, MPI_COMM_WORLD, ierr) end if END SUBROUTINE poisson_mpi !--------------------------------------------------------------------------- !> @author !> Patryk kaminski EPFL/SPC !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Updates the splinevar variable with the new phi coefficients and calculates !> Phi Er and Ez on the grid ! !--------------------------------------------------------------------------- SUBROUTINE Update_phi(splinevar) USE basic, ONLY: rhs, nrank, pot, nlend USE bsplines, ONLY: spline2d, gridval USE mumps_bsplines, ONLY: bsolve, vmx USE futils Use geometry type(spline2d):: splinevar INTEGER:: ierr, i, j, iend !$OMP DO SIMD collapse(2) Do j=1,nrank(2) Do i=1,nrank(1) matcoef(i,j) = phi_spline((j-1)*nrank(1)+i) END DO END DO !$OMP END DO SIMD ! update the ppform coefficients CALL updt_ppform2d(splinevar, matcoef) !$OMP BARRIER IF (mpirank .eq. 0 .and. (modulo(step, it2d) .eq. 0 .or. nlend)) THEN !$OMP DO ! On the root process, compute the electric field for diagnostic purposes DO i=1,size(pot),16 iend=min(size(pot),i+15) CALL gridval(splinevar, vec1(i:iend), vec2(i:iend), pot(i:iend), (/0, 0/)) CALL gridval(splinevar, vec1(i:iend), vec2(i:iend), Ez(i:iend), (/1, 0/)) CALL gridval(splinevar, vec1(i:iend), vec2(i:iend), Er(i:iend), (/0, 1/)) Ez(i:iend) = -pot(i:iend)*gridwdir(1,i:iend) - Ez(i:iend)*gridwdir(0,i:iend) - gtilde(1,i:iend) Er(i:iend) = -pot(i:iend)*gridwdir(2,i:iend) - Er(i:iend)*gridwdir(0,i:iend) - gtilde(2,i:iend) pot(i:iend) = pot(i:iend)*gridwdir(0,i:iend) + gtilde(0,i:iend) END DO !$OMP END DO NOWAIT END IF END SUBROUTINE Update_phi !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Computes the electric fields and potential at the particles position for particles !> between positions nstart and nend in the list ! !> @param[in] p the particles type storing the desired specie parameters !> @param[in] nstart starting index for the particle list !> @param[in] nend ending index for the particle list !--------------------------------------------------------------------------- SUBROUTINE EFieldscompatparts(p, nstart, nend) Use beam, ONLY: particles Use geometry Use splinebound TYPE(particles), INTENT(INOUT):: p INTEGER, OPTIONAL::nstart, nend INTEGER:: i, iend, nst, nnd INTEGER:: nbunch INTEGER:: num_threads Real(kind=db), ALLOCATABLE:: erext(:), ezext(:), gtildeloc(:, :) if (.not. present(nstart)) nst = 1 if (.not. present(nend)) nnd = p%Nploc !num_threads = omp_get_max_threads() !nbunch = (nnd - nst + 1)/num_threads ! Particle bunch size used when calling basfun !nbunch = max(nbunch, 1) ! Particle bunch size used when calling basfun nbunch = 64 ! Particle bunch size used when calling basfun Allocate (erext(nbunch), ezext(nbunch), gtildeloc(0:2,0:nbunch - 1)) ! Evaluate the electric potential and field at the particles position !$OMP DO SIMD DO i = nst, nnd, nbunch ! Avoid segmentation fault by accessing non relevant data iend = min(i + nbunch - 1, nnd) - CALL speval(splrz, p%pos(3,i:iend), p%pos(1,i:iend),p%Zindex(i:iend),p%Rindex(i:iend), p%pot(i:iend), p%E(2,i:iend), p%E(1,i:iend)) - CALL speval(splrz_ext, p%pos(3,i:iend), p%pos(1,i:iend),p%Zindex(i:iend),p%Rindex(i:iend), p%potxt(i:iend)) + CALL speval(splrz, p%pos(3,i:iend), p%pos(1,i:iend),p%cellindex(3,i:iend),p%cellindex(1,i:iend), p%pot(i:iend), p%E(2,i:iend), p%E(1,i:iend)) + CALL speval(splrz_ext, p%pos(3,i:iend), p%pos(1,i:iend),p%cellindex(3,i:iend),p%cellindex(1,i:iend), p%potxt(i:iend)) Call total_gtilde(p%pos(3,i:iend), p%pos(1,i:iend), gtildeloc(:,0:iend - i),p%geomweight(:,i:iend)) p%E(2,i:iend) = -p%E(2,i:iend)*p%geomweight(0,i:iend) - p%pot(i:iend)*p%geomweight(1,i:iend) - gtildeloc(1,0:iend - i) p%E(1,i:iend) = -p%E(1,i:iend)*p%geomweight(0,i:iend) - p%pot(i:iend)*p%geomweight(2,i:iend) - gtildeloc(2,0:iend - i) p%pot(i:iend) = p%geomweight(0,i:iend)*p%pot(i:iend) + gtildeloc(0,0:iend - i) p%potxt(i:iend) = p%geomweight(0,i:iend)*p%potxt(i:iend) + gtildeloc(0,0:iend - i) END DO !$OMP END DO SIMD NOWAIT END SUBROUTINE EFieldscompatparts !--------------------------------------------------------------------------- !> @author !> Patryk kaminski EPFL/SPC !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Constucts the FEM matrix using bsplines initialized in fields_init !--------------------------------------------------------------------------- - SUBROUTINE fematrix(mat) + SUBROUTINE fematrixrz(mat) USE bsplines USE geometry USE omp_lib USE sparse type(mumps_mat):: mat REAL(kind=db), ALLOCATABLE :: xgauss(:, :), wgauss(:), wgeom(:, :) INTEGER, ALLOCATABLE :: f(:, :), aux(:) REAL(kind=db), ALLOCATABLE :: coefs(:) REAL(kind=db), ALLOCATABLE :: fun(:, :, :), fun2(:, :, :) REAL(kind=db) :: contrib INTEGER, ALLOCATABLE :: idert(:, :), iderw(:, :), iderg(:, :) integer,allocatable:: iid(:),jid(:) INTEGER :: i, j, jt, iw, irow, jcol, mu, igauss, iterm, irow2, jcol2, mu2, kterms, gausssize kterms=8 If (allocated(fun)) deallocate (fun) If (allocated(fun2)) deallocate (fun2) ALLOCATE (fun(1:femorder(1) + 1, 0:1,3*ngauss(1)*ngauss(2)), fun2(1:femorder(2) + 1, 0:1,3*ngauss(1)*ngauss(2))) If (allocated(wgeom)) deallocate (wgeom) ALLOCATE (wgeom(0:2,3*ngauss(1)*ngauss(2)))!Arrays keeping values of b-splines at gauss node !ALLOCATE(xgauss(ngauss(1)*ngauss(2),2), wgauss(ngauss(1)*ngauss(2)),zg(ngauss(1)),rg(ngauss(2)), wzg(ngauss(1)), wrg(ngauss(2))) !Gaussian nodes and weights arrays ALLOCATE (f((femorder(1) + 1)*(femorder(2) + 1), 2), aux(femorder(1) + 1)) !Auxiliary arrays ordering bsplines ALLOCATE (idert(kterms, 2), iderw(kterms, 2), coefs(kterms), iderg(kterms, 2)) ALLOCATE (iid(3*ngauss(1)*ngauss(2)), jid(3*ngauss(1)*ngauss(2))) !Pointers on the order of derivatives call timera(0, "fematrix") ! Constuction of auxiliary array ordering bsplines in given interval DO i = 1, (femorder(1) + 1) aux(i) = i END DO DO i = 1, (femorder(2) + 1) f((i - 1)*(femorder(1) + 1) + 1:i*(femorder(1) + 1), 1) = aux f((i - 1)*(femorder(1) + 1) + 1:i*(femorder(1) + 1), 2) = i END DO CALL coefeq(splrz%sp2%knots(0:1), idert, iderw, iderg, coefs, kterms) ! Assemble FEM matrix !$OMP PARALLEL DO DEFAULT(SHARED), PRIVATE(j,i,xgauss,wgauss,gausssize,wgeom, igauss,jt,irow,jcol, mu, iw, irow2,jcol2, mu2, contrib, fun, fun2,iid,jid), collapse(2) DO j = 1, nr ! Loop on r position DO i = 1, nz ! Loop on z position !! Computation of gauss weight and position in r and z direction for gaussian integration Call calc_gauss(splrz, ngauss, i, j, xgauss, wgauss, gausssize) iid=i jid=j if (gausssize .gt. 1) then !If (allocated(wgeom)) deallocate (wgeom) !ALLOCATE (wgeom(0:2,gausssize)) CALL geom_weight(xgauss(1:gausssize, 1), xgauss(1:gausssize, 2), wgeom(:,1:gausssize)) CALL basfun(xgauss(1:gausssize, 1), splrz%sp1, fun(:,:,1:gausssize), iid(1:gausssize)) CALL basfun(xgauss(1:gausssize, 2), splrz%sp2, fun2(:,:,1:gausssize), jid(1:gausssize)) End if DO jt = 1, (1 + femorder(1))*(femorder(2) + 1) irow = i + f(jt, 1) - 1; jcol = j + f(jt, 2) - 1 mu = irow + (jcol - 1)*nrank(1) DO iw = 1, (1 + femorder(1))*(femorder(2) + 1) irow2 = i + f(iw, 1) - 1; jcol2 = j + f(iw, 2) - 1 mu2 = irow2 + (jcol2 - 1)*nrank(1) contrib=0.0_db DO igauss = 1, gausssize ! Loop on gaussian weights and positions DO iterm = 1, kterms ! Loop on the two integration dimensions contrib = contrib+wgeom(iderg(iterm, 1),igauss)*wgeom(iderg(iterm, 2),igauss)* & & fun(f(jt, 1), idert(iterm, 1),igauss)*fun(f(iw, 1), idert(iterm, 2),igauss)* & & fun2(f(jt, 2), iderw(iterm, 1),igauss)*fun2(f(iw, 2), iderw(iterm, 2),igauss)* & & wgauss(igauss)*xgauss(igauss, 2) END DO end do call omp_set_lock(mu_lock(mu)) CALL updt_sploc(mat%mat%row(mu), mu2, contrib) call omp_unset_lock(mu_lock(mu)) END DO END DO END DO END DO !$OMP End parallel do DEALLOCATE (f, aux) DEALLOCATE (idert, iderw, coefs, fun, fun2) call timera(1, "fematrix") - END SUBROUTINE fematrix + END SUBROUTINE fematrixrz !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Computes the volume of the splines cells needed to display the density in post-processing !--------------------------------------------------------------------------- SUBROUTINE comp_volume USE bsplines USE geometry USE basic, ONLY: Volume REAL(kind=db), ALLOCATABLE :: xgauss(:, :), wgauss(:), wgeom(:, :) INTEGER, ALLOCATABLE :: f(:, :), aux(:) REAL(kind=db), ALLOCATABLE :: coefs(:) REAL(kind=db), ALLOCATABLE :: fun(:, :), fun2(:, :), ftestpt(:, :) Integer, ALLOCATABLE, Dimension(:) :: idg, idt, idp, idw INTEGER :: i, j, jt, irow, jcol, mu, igauss, gausssize, iterm, nterms Real(kind=db)::newcontrib call timera(0, "comp_volume") ALLOCATE (fun(1:femorder(1) + 1, 0:1), fun2(1:femorder(2) + 1, 0:1))!Arrays keeping values of b-splines at gauss node !ALLOCATE(xgauss(ngauss(1)*ngauss(2),2), wgauss(ngauss(1)*ngauss(2)),zg(ngauss(1)),rg(ngauss(2)), wzg(ngauss(1)), wrg(ngauss(2))) !Gaussian nodes and weights arrays ALLOCATE (f((femorder(1) + 1)*(femorder(2) + 1), 2), aux(femorder(1) + 1)) !Auxiliary arrays ordering bsplines nterms = 4 Allocate (idg(nterms), idt(nterms), idw(nterms), idp(nterms), coefs(nterms)) ! Constuction of auxiliary array ordering bsplines in given interval DO i = 1, (femorder(1) + 1) aux(i) = i END DO DO i = 1, (femorder(2) + 1) f((i - 1)*(femorder(1) + 1) + 1:i*(femorder(1) + 1), 1) = aux f((i - 1)*(femorder(1) + 1) + 1:i*(femorder(1) + 1), 2) = i END DO volume = 0 if (walltype .lt. 0) fverif = 0 ! Assemble Volume matrix !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(j,i,xgauss,wgauss,gausssize,wgeom, igauss, ftestpt, iterm,jt,irow,jcol, mu, idw, idt, idg, idp, coefs, fun, fun2, newcontrib), collapse(2) DO j = 1, nr ! Loop on r position DO i = 1, nz ! Loop on z position ! Computation of gauss weight and position in r and z direction for gaussian integration Call calc_gauss(splrz, ngauss, i, j, xgauss, wgauss, gausssize) If (allocated(wgeom)) deallocate (wgeom) if (gausssize .gt. 0) then ALLOCATE (wgeom(0:2,size(xgauss, 1))) CALL geom_weight(xgauss(:, 1), xgauss(:, 2), wgeom) End if if (walltype .lt. 0) then If (allocated(ftestpt)) deallocate (ftestpt) ALLOCATE (ftestpt(0:0,size(xgauss, 1))) CALL ftest(xgauss(:, 1), xgauss(:, 2), ftestpt) end if DO igauss = 1, gausssize ! Loop on gaussian weights and positions CALL basfun(xgauss(igauss, 1), splrz%sp1, fun, i) CALL basfun(xgauss(igauss, 2), splrz%sp2, fun2, j) !CALL coefeqext(xgauss(igauss, :), idt, idw, idg, idp, coefs) DO jt = 1, (1 + femorder(1))*(femorder(2) + 1) irow = i + f(jt, 1) - 1; jcol = j + f(jt, 2) - 1 mu = irow + (jcol - 1)*nrank(1) newcontrib = 2*pi*fun(f(jt, 1), 0)*fun2(f(jt, 2), 0)*wgauss(igauss)*xgauss(igauss, 2)!*wgeom(igauss,0) !$OMP ATOMIC UPDATE volume(mu) = volume(mu) + newcontrib !$OMP END ATOMIC if (walltype .lt. 0) THEN newcontrib = ftestpt(0,igauss)*fun(f(jt, 1), 0)*fun2(f(jt, 2), 0)& &*wgeom(0,igauss)*wgauss(igauss)*xgauss(igauss, 2) !$OMP ATOMIC UPDATE fverif(mu) = fverif(mu) + newcontrib !$OMP END ATOMIC end if END DO END DO END DO END DO !$OMP END PARALLEL DO !DEALLOCATE(xgauss, wgauss,zg,rg, wzg, wrg) DEALLOCATE (f, aux) DEALLOCATE (fun, fun2) call timera(1, "comp_volume") END SUBROUTINE comp_volume !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Computes the gradient of the gtilde function for the web-spline method needed to correctly apply the dirichlet boundary conditions !--------------------------------------------------------------------------- SUBROUTINE comp_gradgtilde USE bsplines USE geometry REAL(kind=db), ALLOCATABLE :: xgauss(:, :), wgauss(:), wgeom(:, :) INTEGER, ALLOCATABLE :: f(:, :), aux(:) REAL(kind=db), ALLOCATABLE :: coefs(:) REAL(kind=db), ALLOCATABLE :: fun(:, :,:), fun2(:, :,:), gtildeintegr(:, :) Integer, ALLOCATABLE, Dimension(:) :: idg, idt, idp, idw integer,allocatable:: iid(:),jid(:) INTEGER :: i, j, jt, irow, jcol, mu, igauss, gausssize, iterm, nterms Real(kind=db)::newcontrib !call timera(0, "comp_gradgtilde") ALLOCATE (fun(1:femorder(1) + 1, 0:1,3*ngauss(1)*ngauss(2)), fun2(1:femorder(2) + 1, 0:1,3*ngauss(1)*ngauss(2)))!Arrays keeping values of b-splines at gauss node ALLOCATE (wgeom(0:2,3*ngauss(1)*ngauss(2)))!Arrays keeping values of b-splines at gauss node ALLOCATE (f((femorder(1) + 1)*(femorder(2) + 1), 2), aux(femorder(1) + 1)) !Auxiliary arrays ordering bsplines nterms = 4 Allocate (idg(nterms), idt(nterms), idw(nterms), idp(nterms), coefs(nterms)) ALLOCATE (iid(3*ngauss(1)*ngauss(2)), jid(3*ngauss(1)*ngauss(2))) If (allocated(gtildeintegr)) deallocate (gtildeintegr) ALLOCATE (gtildeintegr(0:2,3*ngauss(1)*ngauss(2))) ! Constuction of auxiliary array ordering bsplines in given interval DO i = 1, (femorder(1) + 1) aux(i) = i END DO DO i = 1, (femorder(2) + 1) f((i - 1)*(femorder(1) + 1) + 1:i*(femorder(1) + 1), 1) = aux f((i - 1)*(femorder(1) + 1) + 1:i*(femorder(1) + 1), 2) = i END DO CALL coefeqext(splrz%sp2%knots(0:1), idt, idw, idg, idp, coefs) !$OMP DO SIMD do j=1,size(gradgtilde) gradgtilde(j) = 0 END DO !$OMP END DO SIMD !$OMP BARRIER ! Assemble gradgtilde matrix !$OMP DO collapse(2), schedule(dynamic) DO j = 1, nr ! Loop on r position DO i = 1, nz ! Loop on z position ! Computation of gauss weight and position in r and z direction for gaussian integration Call calc_gauss(splrz, ngauss, i, j, xgauss, wgauss, gausssize) iid=i jid=j if (gausssize .gt. 1) then !If (allocated(wgeom)) deallocate (wgeom) !ALLOCATE (wgeom(0:2,gausssize)) CALL geom_weight(xgauss(1:gausssize, 1), xgauss(1:gausssize, 2), wgeom(:,1:gausssize)) CALL basfun(xgauss(1:gausssize, 1), splrz%sp1, fun(:,:,1:gausssize), iid(1:gausssize)) CALL basfun(xgauss(1:gausssize, 2), splrz%sp2, fun2(:,:,1:gausssize), jid(1:gausssize)) Call total_gtilde(xgauss(1:gausssize, 1), xgauss(1:gausssize, 2), gtildeintegr(:,1:gausssize),wgeom(:,1:gausssize)) End if DO jt = 1, (1 + femorder(1))*(femorder(2) + 1) irow = i + f(jt, 1) - 1; jcol = j + f(jt, 2) - 1 mu = irow + (jcol - 1)*nrank(1) newcontrib = 0.0_db DO igauss = 1, gausssize ! Loop on gaussian weights and positions Do iterm = 1, nterms newcontrib = newcontrib + wgeom( idg(iterm),igauss)*gtildeintegr( idp(iterm),igauss)* & & fun(f(jt, 1), idt(iterm),igauss)*fun2(f(jt, 2), idw(iterm),igauss)* & & wgauss(igauss)*xgauss(igauss, 2) End do end do !$OMP ATOMIC UPDATE gradgtilde(mu) = gradgtilde(mu) + newcontrib !$OMP END ATOMIC END DO END DO END DO !$OMP END DO !DEALLOCATE(xgauss, wgauss,zg,rg, wzg, wrg) DEALLOCATE (f, aux) DEALLOCATE (fun, fun2) !call timera(1, "comp_gradgtilde") END SUBROUTINE comp_gradgtilde !--------------------------------------------------------------------------- !> @author !> Patryk kaminski EPFL/SPC !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Imposes the dirichlet boundary conditions on the FEM matrix for the case where we use regular splines ( not web-splines). !--------------------------------------------------------------------------- SUBROUTINE fe_dirichlet REAL(kind=db), ALLOCATABLE :: arr(:) INTEGER :: i ALLOCATE (arr(nrank(1)*nrank(2))) DO i = 1, nrank(1) IF (rgrid(0) .ne. 0.0_db) THEN arr = 0; arr(i) = 1; CALL putrow(femat, i, arr) END IF arr = 0; arr(nrank(1)*nrank(2) + 1 - i) = 1; CALL putrow(femat, nrank(1)*nrank(2) + 1 - i, arr) END DO DEALLOCATE (arr) END SUBROUTINE fe_dirichlet !________________________________________________________________________________ SUBROUTINE coefeq(x, idt, idw, idg, c, kterms) REAL(kind=db), INTENT(in) :: x(:) INTEGER, INTENT(out) :: idt(:, :), idw(:, :), idg(:, :),kterms REAL(kind=db), INTENT(out) :: c(:) kterms=8 c = x(2) idt(1, 1) = 0 idt(1, 2) = 0 idw(1, 1) = 0 idw(1, 2) = 0 idg(1, 1) = 1 idg(1, 2) = 1 idt(2, 1) = 0 idt(2, 2) = 1 idw(2, 1) = 0 idw(2, 2) = 0 idg(2, 1) = 1 idg(2, 2) = 0 idt(3, 1) = 1 idt(3, 2) = 0 idw(3, 1) = 0 idw(3, 2) = 0 idg(3, 1) = 0 idg(3, 2) = 1 idt(4, 1) = 1 idt(4, 2) = 1 idw(4, 1) = 0 idw(4, 2) = 0 idg(4, 1) = 0 idg(4, 2) = 0 idt(5, 1) = 0 idt(5, 2) = 0 idw(5, 1) = 0 idw(5, 2) = 0 idg(5, 1) = 2 idg(5, 2) = 2 idt(6, 1) = 0 idt(6, 2) = 0 idw(6, 1) = 0 idw(6, 2) = 1 idg(6, 1) = 2 idg(6, 2) = 0 idt(7, 1) = 0 idt(7, 2) = 0 idw(7, 1) = 1 idw(7, 2) = 0 idg(7, 1) = 0 idg(7, 2) = 2 idt(8, 1) = 0 idt(8, 2) = 0 idw(8, 1) = 1 idw(8, 2) = 1 idg(8, 1) = 0 idg(8, 2) = 0 END SUBROUTINE coefeq SUBROUTINE coefeqext(x, idt, idw, idg, idp, c) REAL(kind=db), INTENT(in) :: x(:) INTEGER, INTENT(out) :: idp(:), idt(:), idw(:), idg(:) REAL(kind=db), INTENT(out) :: c(:) c(1) = x(2) idp(1) = 1 idg(1) = 1 idt(1) = 0 idw(1) = 0 c(2) = x(2) idp(2) = 1 idg(2) = 0 idt(2) = 1 idw(2) = 0 c(3) = x(2) idp(3) = 2 idg(3) = 2 idt(3) = 0 idw(3) = 0 c(4) = x(2) idp(4) = 2 idg(4) = 0 idt(4) = 0 idw(4) = 1 END SUBROUTINE coefeqext -!--------------------------------------------------------------------------- -!> @author -!> Patryk kaminski EPFL/SPC -!> Guillaume Le Bars EPFL/SPC -! -! DESCRIPTION: -!> -!> @brief -!> Computes the magnetic field on the grid according to a magnetic mirror, -!> or according to the linear interpolation of the values on the -!> grid saved in h5 file stored at magfile. -!> @param[in] magfile filname of .h5 file containing the definitions of A and B -!--------------------------------------------------------------------------- - SUBROUTINE magnet(magfile) - USE basic, ONLY: B0, Rcurv, rgrid, zgrid, width, rnorm, nr, nz, bnorm - USE constants, ONLY: Pi - CHARACTER(LEN=*), INTENT(IN), OPTIONAL:: magfile - REAL(kind=db) :: rg, zg, halfLz, MirrorRatio - INTEGER :: i, rindex - IF (len_trim(magfile) .lt. 1) THEN - halfLz = (zgrid(nz) + zgrid(0))/2 - MirrorRatio = (Rcurv - 1)/(Rcurv + 1) - DO i = 1, (nr + 1)*(nz + 1) - rindex = (i - 1)/(nz + 1) - rg = rgrid(rindex) - zg = zgrid(i - rindex*(nz + 1) - 1) - halfLz - Br(i) = -B0*MirrorRatio*SIN(2*pi*zg/width*rnorm)*bessi1(2*pi*rg/width*rnorm)/bnorm - Bz(i) = B0*(1 - MirrorRatio*COS(2*pi*zg/width*rnorm)*bessi0(2*pi*rg/width*rnorm))/bnorm - Athet(i) = 0.5*B0*(rg*rnorm - width/pi*MirrorRatio*bessi1(2*pi*rg/width*rnorm)*COS(2*pi*zg/width*rnorm)) - END DO - ELSE - CALL load_mag_from_h5(magfile) - END IF - END SUBROUTINE magnet - -!--------------------------------------------------------------------------- -!> @author -!> Guillaume Le Bars EPFL/SPC -! -! DESCRIPTION: -!> -!> @brief -!> Loads the magnetic field defined in the .h5 file at location magfile -!> @param[in] magfile filname of .h5 file containing the definitions of A and B -!--------------------------------------------------------------------------- - SUBROUTINE load_mag_from_h5(magfile) - USE basic, ONLY: B0, rnorm, bnorm, bscaling - USE constants, ONLY: Pi - USE futils - USE bsplines - CHARACTER(LEN=*), INTENT(IN):: magfile - REAL(kind=db), ALLOCATABLE :: magr(:), magz(:) - REAL(kind=db), ALLOCATABLE :: tempBr(:, :), tempBz(:, :), tempAthet(:, :) - real(kind=db), allocatable:: c(:,:) - type(spline2d):: Maginterpolation - REAL(kind=db) :: maxB - INTEGER :: magfid, dims(2) - LOGICAL:: B_is_saved - INTEGER :: magn(2), magrank - - CALL openf(trim(magfile), magfid, 'r', real_prec='d') - - CALL getdims(magfid, '/mag/Athet', magrank, magn) - - ALLOCATE (magr(magn(2)), magz(magn(1))) - ALLOCATE (tempAthet(magn(1), magn(2)), tempBr(magn(1), magn(2)), tempBz(magn(1), magn(2))) - - ! Read r and z coordinates for the definition of A_\thet, and B - CALL getarr(magfid, '/mag/r', magr) - CALL getarr(magfid, '/mag/z', magz) - CALL getarr(magfid, '/mag/Athet', tempAthet) - - IF (isdataset(magfid, '/mag/Br') .and. isdataset(magfid, '/mag/Bz')) THEN - CALL getarr(magfid, '/mag/Br', tempBr) - CALL getarr(magfid, '/mag/Bz', tempBz) - IF(bscaling .gt. 0) then - maxB=sqrt(maxval(tempBr**2+tempBz**2)) - tempBr=tempBr/maxB*B0 - tempBz=tempBz/maxB*B0 - end if - B_is_saved = .true. - ELSE - B_is_saved = .false. - END IF - - magz=magz/rnorm - magr=magr/rnorm - CALL set_splcoef((/3,3/),magz,magr,Maginterpolation) - call get_dim(Maginterpolation,dims) - - ! Interpolation of the magnetic potential vector - allocate(c(dims(1),dims(2))) - call get_splcoef(Maginterpolation,tempAthet, c) - CALL gridval(Maginterpolation,vec1,vec2, Athet ,(/0,0/),c) - - - - if(B_is_saved == .true.)then - ! Interpolation of the Axial magnetic field - call get_splcoef(Maginterpolation,tempBz, c) - CALL gridval(Maginterpolation,vec1,vec2, Bz ,(/0,0/),c) - - ! Interpolation of the radial magnetic field - call get_splcoef(Maginterpolation,tempBr, c) - CALL gridval(Maginterpolation,vec1,vec2, Br ,(/0,0/),c) - else - CALL gridval(Maginterpolation,vec1,vec2, Br,(/1,0/)) - Br=-Br - CALL gridval(Maginterpolation,vec1,vec2, Bz,(/0,1/)) - Bz=Bz+Athet/vec2 - end if - - - if( bscaling .lt. 0 ) then - maxB = maxval(sqrt(Bz**2 + Br**2)) - - Bz = Bz/maxB*B0 - Br = Br/maxB*B0 - end if - ! We normalize - Br = Br/bnorm - Bz = Bz/bnorm - - CALL closef(magfid) - deallocate(c) - call destroy_SP(Maginterpolation) - END SUBROUTINE load_mag_from_h5 -!________________________________________________________________________________ -!Modified Bessel functions of the first kind of the zero order - FUNCTION bessi0(x) - REAL(kind=db) :: bessi0, x - REAL(kind=db) :: ax - REAL(kind=db) p1, p2, p3, p4, p5, p6, p7, q1, q2, q3, q4, q5, q6, q7, q8, q9, y - SAVE p1, p2, p3, p4, p5, p6, p7, q1, q2, q3, q4, q5, q6, q7, q8, q9 - DATA p1, p2, p3, p4, p5, p6, p7/1.0d0, 3.5156229d0, 3.0899424d0, 1.2067492d0, 0.2659732d0, 0.360768d-1, 0.45813d-2/ - DATA q1, q2, q3, q4, q5, q6, q7, q8, q9/0.39894228d0, 0.1328592d-1, 0.225319d-2, -0.157565d-2, 0.916281d-2, & - & -0.2057706d-1, 0.2635537d-1, -0.1647633d-1, 0.392377d-2/ - if (abs(x) .lt. 3.75) then - y = (x/3.75)**2 - bessi0 = p1 + y*(p2 + y*(p3 + y*(p4 + y*(p5 + y*(p6 + y*p7))))) - else - ax = abs(x) - y = 3.75/ax - bessi0 = (exp(ax)/sqrt(ax))*(q1 + y*(q2 + y*(q3 + y*(q4 + y*(q5 + y*(q6 + y*(q7 + y*(q8 + y*q9)))))))) - end if - return - END FUNCTION bessi0 -!________________________________________________________________________________ -!Modified Bessel functions of the first kind of the first order - FUNCTION bessi1(x) - REAL(kind=db) :: bessi1, x - REAL(kind=db) :: ax - REAL(kind=db) p1, p2, p3, p4, p5, p6, p7, q1, q2, q3, q4, q5, q6, q7, q8, q9, y - SAVE p1, p2, p3, p4, p5, p6, p7, q1, q2, q3, q4, q5, q6, q7, q8, q9 - DATA p1, p2, p3, p4, p5, p6, p7/0.5d0, 0.87890594d0, 0.51498869d0, 0.15084934d0, 0.2658733d-1, 0.301532d-2, 0.32411d-3/ - DATA q1, q2, q3, q4, q5, q6, q7, q8, q9/0.39894228d0, -0.3988024d-1, -0.362018d-2, 0.163801d-2, -0.1031555d-1, & - & 0.2282967d-1, -0.2895312d-1, 0.1787654d-1, -0.420059d-2/ - if (abs(x) .lt. 3.75D0) then - y = (x/3.75D0)**2 - bessi1 = x*(p1 + y*(p2 + y*(p3 + y*(p4 + y*(p5 + y*(p6 + y*p7)))))) - else - ax = abs(x) - y = 3.75D0/ax - bessi1 = (exp(ax)/sqrt(ax))*(q1 + y*(q2 + y*(q3 + y*(q4 + y*(q5 + y*(q6 + y*(q7 + y*(q8 + y*q9)))))))) - if (x .lt. 0.) bessi1 = -bessi1 - end if - return - END FUNCTION bessi1 !--------------------------------------------------------------------------- !> @author !> Patryk kaminski EPFL/SPC !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Free the memory used by the fields module !--------------------------------------------------------------------------- SUBROUTINE clean_fields Use bsplines USE basic, ONLY: rhs INTEGER:: i do i = 1, nrank(1)*nrank(2) call omp_destroy_lock(mu_lock(i)) end do DEALLOCATE (mu_lock) DEALLOCATE (matcoef) DEALLOCATE (pot) DEALLOCATE (rhs) DEALLOCATE (loc_rhs) DEALLOCATE (loc_moments) DEALLOCATE (phi_spline) DEALLOCATE (Br, Bz) DEALLOCATE (Er, Ez) DEALLOCATE (vec1, vec2) Call DESTROY_SP(splrz) Call DESTROY_SP(splrz_ext) END SUBROUTINE clean_fields SUBROUTINE updt_sploc(arow, j, val) ! ! Update element j of row arow or insert it in an increasing "index" ! USE sparse TYPE(sprow), TARGET :: arow INTEGER, INTENT(in) :: j DOUBLE PRECISION, INTENT(in) :: val ! TYPE(elt), TARGET :: pre_root TYPE(elt), POINTER :: t, p ! if(val.eq.0) return pre_root%next => arow%row0 ! pre_root is linked to the head of the list. t => pre_root DO WHILE (ASSOCIATED(t%next)) p => t%next IF (p%index .EQ. j) THEN p%val = p%val + val RETURN END IF IF (p%index .GT. j) EXIT t => t%next END DO ALLOCATE (p) p = elt(j, val, t%next) t%next => p ! arow%nnz = arow%nnz + 1 arow%row0 => pre_root%next ! In case the head is altered END SUBROUTINE updt_sploc SUBROUTINE updt_ppform2d(sp,c) use bsplines TYPE(spline2d), INTENT(inout) :: sp DOUBLE PRECISION, DIMENSION(:,:), INTENT(in) :: c !DOUBLE PRECISION, ALLOCATABLE :: work(:,:,:) INTEGER:: m,mm INTEGER :: d1, d2, k1, k2, n1, n2 d1 = sp%sp1%dim d2 = sp%sp2%dim k1 = sp%sp1%order k2 = sp%sp2%order n1 = sp%sp1%nints n2 = sp%sp2%nints + !$OMP SINGLE + IF( ASSOCIATED(sp%bcoefs) ) DEALLOCATE(sp%bcoefs) + ALLOCATE(sp%bcoefs(SIZE(c,1),SIZE(c,2))) + !$OMP END SINGLE + !ALLOCATE(work(d2,k1,n1)) !$OMP DO DO m=1,SIZE(c,2) CALL topp0(sp%sp1, c(:,m), ppformwork(m,:,:)) + sp%bcoefs(:,m)=c(:,m) END DO !$OMP END DO NOWAIT !$OMP SINGLE IF( ASSOCIATED(sp%ppform) ) DEALLOCATE(sp%ppform) ALLOCATE(sp%ppform(k1,n1,k2,n2)) !$OMP END SINGLE !$OMP DO DO mm=1,SIZE(ppformwork,3) DO m=1,SIZE(ppformwork,2) CALL topp0(sp%sp2, ppformwork(:,m,mm), sp%ppform(m,mm,:,:)) END DO END DO !$OMP END DO !DEALLOCATE(work) end subroutine updt_ppform2d !=========================================================================== SUBROUTINE topp0(sp, c, ppform) ! ! Compute PPFORM of a fuction defined by the spline SP ! and spline coefficients C(1:d) ! use bsplines TYPE(spline1d), INTENT(in) :: sp DOUBLE PRECISION, INTENT(in) :: c(:) DOUBLE PRECISION, INTENT(out) :: ppform(0:,:) INTEGER :: p, nints, i, j, k ! p = sp%order - 1 nints = sp%nints ! ppform = 0.0d0 DO i=1,nints ! on each knot interval DO j=1,p+1 ! all spline in interval i DO k=0,p ! k_th derivatives ppform(k,i) = ppform(k,i) + sp%val0(k,j,i)*c(j+i-1) END DO END DO END DO ! END SUBROUTINE topp0 !+ END MODULE fields diff --git a/src/geometry_mod.f90 b/src/geometry_mod.f90 index d6b025b..44ce409 100644 --- a/src/geometry_mod.f90 +++ b/src/geometry_mod.f90 @@ -1,1264 +1,1475 @@ !------------------------------------------------------------------------------ ! EPFL/Swiss Plasma Center !------------------------------------------------------------------------------ ! ! MODULE: geometry ! !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> Module responsible for handling geometries with non constant radius using b-splines interpolation !> This module defines ways to comupte the weight function needed for weighted extended b-splines and !> can load the definition of the geometry from input files !> This module is based on the theory by K. Hollig and book "Finite element methods with b-splines" !> SIAM Frontiers in applied mathematics !------------------------------------------------------------------------------ MODULE geometry USE constants USE bsplines USE mumps_bsplines USE splinebound use weighttypes IMPLICIT NONE type innerspline Integer, Allocatable:: k(:) ! Index in reduced set real(kind=db), Allocatable:: weight(:) ! geomtric weight at relevant cell end type innerspline type test_params !< parameters defining the manufactured test solutionwhen negative weighttypes is used real(kind=db):: z0 real(kind=db):: r0 real(kind=db):: Lz real(kind=db):: Lr end type Integer, save:: testkr=1, testkz=1 Logical, save:: nlweb=.true. !< use weighted extended b-splines and not only weighted b-splies Integer, save :: walltype = 0 !< type of geometric weight to use (see readgeom) Integer, save, Allocatable:: bsplinetype(:) !< Array containing the inner/outer type for each bspline Integer, save, Allocatable:: gridcelltype(:,:) !< Array containing the inner/outer type for each gridcell Integer, save, Allocatable:: linkedspline(:,:) !< Array containing the lowerleft linked spline in case of boundary spline Real(kind=db), save, allocatable:: gridwdir(:,:) !< Stores the Dirichlet geometric weight at the grid points Real(kind=db), save, allocatable:: gridwdom(:,:) !< Stores the domain weight at the grid points Real(kind=db), save, allocatable:: gtilde(:,:) ! Stores the extension to the domain of the boundary conditions type(mumps_mat):: etilde !> Matrix of extendend web splines definition 4.9 p48 of Hollig's book type(mumps_mat):: etildet ! Transpose of Matrix of extendend web splines integer,save :: nbreducedspline ! Number of splines in the reduced set type(test_params), save:: test_pars PROCEDURE(geom_eval), POINTER:: dirichlet_weight => NULL()!< Function evaluating the weight for Dirichelt boundary conditions PROCEDURE(geomtot_eval), POINTER:: domain_weight => NULL() !< function giving the limits of the simulation domain PROCEDURE(gtilde_eval), POINTER:: total_gtilde => NULL() !< Computes the parameter gtilde used to impose dirichlet boundary conditions with phi=uh+gtilde PUBLIC:: geom_weight, dom_weight ABSTRACT INTERFACE SUBROUTINE gtilde_eval(z,r,g,w) USE constants Real(kind=db), INTENT(IN):: r(:),z(:) Real(kind=db), INTENT(OUT):: g(0:,:) Real(kind=db), INTENT(IN),OPTIONAL::w(0:,:) END SUBROUTINE SUBROUTINE geom_eval(z,r,w,wupper) USE constants Real(kind=db), INTENT(IN) :: r(:),z(:) Real(kind=db), INTENT(OUT):: w(0:,:) Real(kind=db), OPTIONAL :: wupper(0:,:) END SUBROUTINE SUBROUTINE geomtot_eval(z,r,w,idwall) USE constants Real(kind=db), INTENT(IN):: r(:),z(:) Real(kind=db), INTENT(OUT):: w(0:,:) INTEGER, optional, INTENT(OUT):: idwall(:) END SUBROUTINE END INTERFACE INTERFACE geom_weight MODULE PROCEDURE geom_weight0, geom_weight1, geom_weight2 END INTERFACE geom_weight INTERFACE dom_weight MODULE PROCEDURE dom_weight0, dom_weight1, dom_weight2, dom_weight3 END INTERFACE dom_weight NAMELIST /geomparams/ z_0, r_0, z_r, r_r, r_a, r_b, z_a, z_b ,walltype, nlweb, Interior, above1, above2, alpha, r_bLeft, r_bRight, testkr, testkz contains - ! Read the input parameters from the standard input file +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> Read the input parameters to initialize the geometry module from the standard input file +!> @param[in] Fileid Text file id of the input file containing namelists +!> @param[in] rnorm distance normalization constant +!> @param[in] splrz bspline structure used by the FEM comming form bspline library +!> @param[in] Potinn Normalized electric potential on the inner boundary +!> @param[in] Potout Normalized electric potential on the outer boundary + +!--------------------------------------------------------------------------- + SUBROUTINE read_geom(Fileid, rnorm, splrz, Potinn, Potout) use mpi Use bsplines use basic, ONLY: phinorm use weighttypes type(spline2d):: splrz Real(kind=db):: rnorm ! normalisation variable for distances Real(kind=db):: Potinn ! potential at inner electrode from basic Real(kind=db):: Potout ! potential at outer electrode from basic Integer:: Fileid, mpirank, ierr, istat character(len=1000) :: line CALL MPI_COMM_RANK(MPI_COMM_WORLD, mpirank, ierr) Rewind(Fileid) READ(Fileid, geomparams, iostat=istat) if (istat.gt.0) then if(mpirank .eq. 0) then backspace(Fileid) read(Fileid,fmt='(A)') line write(*,'(A)') & 'Invalid line in geomparams: '//trim(line) end if call MPI_Abort(MPI_COMM_WORLD, -1, ierr) stop end if if(mpirank .eq. 0) WRITE(*, geomparams) !! Normalizations and initialization of geometric variables r_a=r_a/rnorm r_b=r_b/rnorm z_a=z_a/rnorm z_b=z_b/rnorm r_bLeft=r_bLeft/rnorm r_bRight=r_bRight/rnorm if(r_a .eq. 0 .and. r_b .eq.0) then !! in case no geom_params have been definedwe take the defaults from the grid limits r_a=splrz%sp2%knots(0) r_b=splrz%sp2%knots(splrz%sp2%nints) end if z_0=z_0/rnorm r_0=r_0/rnorm z_r=z_r/rnorm r_r=r_r/rnorm invr_r=1/r_r invr_z=1/z_r Phidown=Potinn Phiup=Potout SELECT CASE (abs(walltype)) CASE (2) ! coaxial cylinder and top ellipse with cylinder extensions total_gtilde=>gUpDown Dirichlet_weight=>geom_w2 domain_weight=>geom_rvaschtot CASE (3) ! Two ellipses with "parallel" tangents with cylinders total_gtilde=>gUpDown Dirichlet_weight=>geom_w3 domain_weight=>geom_rvaschtot CASE (4) ! Two ellipses with same radii with cylinders total_gtilde=>gUpDown Dirichlet_weight=>geom_w4 domain_weight=>geom_rvaschtot CASE (5) ! Two ellipses with same radii with cylinders and total_gtilde=>gUpDown Dirichlet_weight=>geom_w5 domain_weight=>geom_rvaschtot CASE (6) ! circular coaxial tilted ellipse right Dirichlet total_gtilde=>gUpDown Dirichlet_weight=>geom_w6 domain_weight=>geom_rvaschtot CASE (7) ! circular coaxial tilted ellipse right and left Dirichlet total_gtilde=>gUpDown Dirichlet_weight=>geom_w7 domain_weight=>geom_rvaschtot CASE (8) ! circular coaxial tilted ellipse right and left Dirichlet total_gtilde=>gUpDown Dirichlet_weight=>geom_w8 domain_weight=>geom_rvaschtot CASE (9) ! Geometry defined as a spline curve total_gtilde=>gspline Dirichlet_weight=>geom_spline domain_weight=>geom_splinetot call read_splinebound(Fileid,the_domain, splrz, rnorm, phinorm) CASE (10) ! square section disc total_gtilde=>gUpDown domain_weight=>geom_rvaschtot Dirichlet_weight=>geom_w10 CASE (11) ! square section disc total_gtilde=>gUpDown domain_weight=>geom_rvaschtot Dirichlet_weight=>geom_w11 CASE (12) ! square section disc total_gtilde=>gUpDown domain_weight=>geom_rvaschtot Dirichlet_weight=>geom_w12 CASE DEFAULT ! Ellipse as in gt170 standard weight and straight coaxial configs total_gtilde=>gstd Dirichlet_weight=>geom_weightstd domain_weight=>geom_rvaschtot END SELECT ! If we are lauching a test case, we load the test_pars variable used for the manufactured solution if(walltype.lt.0) then test_pars%Lr=(splrz%sp2%knots(splrz%sp2%nints)-splrz%sp2%knots(0))/testkr test_pars%Lz=(splrz%sp1%knots(splrz%sp1%nints)-splrz%sp1%knots(0))/testkz test_pars%r0=0.5*(splrz%sp2%knots(splrz%sp2%nints)+splrz%sp2%knots(0)) test_pars%z0=0.5*(splrz%sp1%knots(splrz%sp1%nints)+splrz%sp1%knots(0)) total_gtilde=>gtest end if end subroutine read_geom - ! Initialises the module and precomputes the matrix e used for extende splines - ! Classify every grid cell (inner, outer, boundary) +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> Initialises the module and precomputes the matrix e used for extended splines +!> Classify every grid cell (inner, outer, boundary) +!> @param[in] splr2 bspline structure used by the FEM comming form bspline library +!> @param[in] vec1 Axial Meshgrid array to precompute the weigths on the crid points +!> @param[in] vec2 Radial Meshgrid array to precompute the weigths on the crid points +!--------------------------------------------------------------------------- + SUBROUTINE geom_init(spl2, vec1, vec2) type(spline2d):: spl2 real(kind=db):: vec1(:),vec2(:) Real(kind=db), Allocatable:: zgrid(:),rgrid(:) Integer:: nrank(2), nrz(2) Call get_dim(spl2, nrank, nrz) ! Obtain grid data drom the spline structure Allocate(zgrid(1:nrz(1)+1)) Allocate(rgrid(1:nrz(2)+1)) zgrid=spl2%sp1%knots(0:nrz(1)) rgrid=spl2%sp2%knots(0:nrz(2)) ! create a table of the classification for each cell Allocate(gridcelltype(nrz(1),nrz(2))) - Call classifycell(zgrid, rgrid, gridcelltype) + Call classifycells(zgrid, rgrid, gridcelltype) if (nlweb) then ! if we use extended splines, we need to build the e matrix linking inner and outer splines Allocate(bsplinetype(nrank(1)*nrank(2))) Call classifyspline(spl2, gridcelltype, bsplinetype) Call buildetilde(spl2,bsplinetype,gridcelltype) end if ! Precompute the domain and dirichlet weights at the grid/cell positions ALLOCATE(gridwdir(0:2,(nrz(1)+1)*(nrz(2)+1))) gridwdir=0 ALLOCATE(gridwdom(0:2,(nrz(1)+1)*(nrz(2)+1))) gridwdom=0 ALLOCATE(gtilde(0:2,(nrz(1)+1)*(nrz(2)+1))) gtilde=0 Call geom_weight (vec1, vec2, gridwdir) Call dom_weight (vec1, vec2, gridwdom) ! Precompute the gtilde at the grid cell position CALL total_gtilde(vec1, vec2, gtilde, gridwdir) end Subroutine geom_init - ! Save this module run parameters to the h5 result file in the correct group - Subroutine geom_diag(File_handle, str, rnorm) +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> Save this module run parameters to the h5 result file in the correct group +!> @param[in] File_handle h5 file id of the result file +!> @param[in] parentgroup h5 parent group where to save the simulation parameters +!> @param[in] rnorm distance normalization constant +!--------------------------------------------------------------------------- + Subroutine geom_diag(File_handle, parentgroup, rnorm) use mpi Use futils use weighttypes Integer:: File_handle Real(kind=db):: rnorm - Character(len=*):: str + Character(len=*):: parentgroup CHARACTER(len=128):: grpname Integer:: ierr, mpirank CALL MPI_COMM_RANK(MPI_COMM_WORLD, mpirank, ierr) IF(mpirank .eq. 0) THEN - Write(grpname,'(a,a)') trim(str),"/geometry" + Write(grpname,'(a,a)') trim(parentgroup),"/geometry" If(.not. isgroup(File_handle, trim(grpname))) THEN CALL creatg(File_handle, trim(grpname)) END IF Call attach(File_handle, trim(grpname), "r_a", r_a*RNORM) Call attach(File_handle, trim(grpname), "r_b", r_b*RNORM) Call attach(File_handle, trim(grpname), "z_a", z_a*RNORM) Call attach(File_handle, trim(grpname), "z_b", z_b*RNORM) Call attach(File_handle, trim(grpname), "z_0", z_0*RNORM) Call attach(File_handle, trim(grpname), "r_0", r_0*RNORM) Call attach(File_handle, trim(grpname), "r_r", r_r*RNORM) Call attach(File_handle, trim(grpname), "z_r", z_r*RNORM) Call attach(File_handle, trim(grpname), "L_r", test_pars%Lr*RNORM) Call attach(File_handle, trim(grpname), "L_z", test_pars%Lz*RNORM) Call attach(File_handle, trim(grpname), "interior", interior) Call attach(File_handle, trim(grpname), "above1", above1) Call attach(File_handle, trim(grpname), "above2", above2) Call attach(File_handle, trim(grpname), "walltype", walltype) Call putarr(File_handle, trim(grpname)//'/geomweight',transpose(gridwdom)) Call putarr(File_handle, trim(grpname)//'/dirichletweight',transpose(gridwdir)) Call putarr(File_handle, trim(grpname)//'/gtilde',transpose(gtilde)) Call putarr(File_handle, trim(grpname)//'/ctype',gridcelltype) Call putarr(File_handle, trim(grpname)//'/linked_s',linkedspline) Call putarr(File_handle, trim(grpname)//'/bsplinetype',bsplinetype) END IF End subroutine geom_diag - ! Construct the e matrix used to link inner and outer b-splines +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> Construct the e matrix used to link inner and boundary b-splines +!> @param[in] spl2 bi-variate b-spline structure +!> @param[in] bsplinetype 1D array classifying the individual b-splines as inner, boundary, outer +!> @param[in] celltype 2D array classifying the individual grid cells as inner, boundary, outer +!--------------------------------------------------------------------------- Subroutine buildetilde(spl2, bsplinetype, celltype) USE mumps_bsplines Use basic, ONLY: rnorm, mpirank type(spline2d):: spl2 Integer:: bsplinetype(:) Integer:: celltype(1:,1:) Logical, Allocatable:: Ibsplinetype(:) Integer:: i,j,k, icellz, icellr, jcellz, jcellr, nrank(2), nrz(2), norder(2) real(kind=db), allocatable:: zgrid(:), rgrid(:) real(kind=db):: wgeomi, indexdistance, eij integer:: l,m, n, linkedi type(innerspline):: innersplinelist real(kind=db), allocatable:: rgridmesh(:),zgridmesh(:), d(:), hz(:), cz(:), hr(:), cr(:), hmesh(:) integer, allocatable:: igridmesh(:), jgridmesh(:) !if(allocated(etilde)) deallocate(etilde) nbreducedspline=count(bsplinetype .eq. 1) Call get_dim(spl2,nrank,nrz,norder) ! Obtain grid data drom the spline structure Allocate(zgrid(1:nrz(1)+1)) Allocate(rgrid(1:nrz(2)+1)) zgrid=spl2%sp1%knots(0:nrz(1)) rgrid=spl2%sp2%knots(0:nrz(2)) allocate(linkedspline(nrank(1),nrank(2))) allocate(innersplinelist%k(nrank(1)*nrank(2)),innersplinelist%weight(nrank(1)*nrank(2))) allocate(Ibsplinetype(nrank(1)*nrank(2))) allocate(rgridmesh(nrank(1)*nrank(2)), zgridmesh(nrank(1)*nrank(2))) allocate(igridmesh(nrank(1)*nrank(2)), jgridmesh(nrank(1)*nrank(2))) allocate(hmesh(nrank(1)*nrank(2))) allocate(d(size(bsplinetype))) Ibsplinetype=.False. ! Compute the center of the 2D splines for the Lagrange interpolation call calcsplinecenters(spl2%sp1,cz,hz) call calcsplinecenters(spl2%sp2,cr,hr) Do i=0,nrank(2)-1 zgridmesh(i*nrank(1)+1:(i+1)*nrank(1))=cz rgridmesh(i*nrank(1)+1:(i+1)*nrank(1))=cr(i+1) hmesh(i*nrank(1)+1:(i+1)*nrank(1))=hr(i+1)*hz igridmesh(i*nrank(1)+1:(i+1)*nrank(1))=(/ (j,j=0,nrank(1)-1)/) jgridmesh(i*nrank(1)+1:(i+1)*nrank(1))=i End do ! allocate memory for etilde and its transpose call init(nrank(1)*nrank(2),nbreducedspline,etilde) call init(nrank(1)*nrank(2),nbreducedspline,etildet) k=1 ! Compute the terms eii for the inner b-splines Do i=1,nrank(1)*nrank(2) - if(bsplinetype(i) .ne. 1) cycle ! span of this spline is completely outside D - ! one cell of bspline i is completely in D + if(bsplinetype(i) .ne. 1) cycle ! span of this spline is almost completely outside D + ! We consider only splines with + ! one cell of bspline i completely in D icellz=mod(i-1,nrank(1))+1 icellr=(i-1)/(nrank(1))+1 + wgeomi=1 outer: do l=max(1,icellz-norder(1)),min(nrz(1),icellz) do m=max(1,icellr-norder(2)),min(nrz(2),icellr) if (celltype(l,m).eq.1) then call geom_weight((zgrid(l)+zgrid(l+1))/2,(rgrid(m)+rgrid(m+1))/2,wgeomi) EXIT outer end if end do end do outer call putele(etilde,k,i,1/wgeomi) call putele(etildet,i,k,1/wgeomi) innersplinelist%k(i)=k innersplinelist%weight(i)=1/wgeomi k=k+1 linkedspline(icellz,icellr)=i Ibsplinetype(i)=icellz+norder(1) .le. nrank(1) .and. icellr+norder(2) .le. nrank(2) if(.not. Ibsplinetype(i)) cycle do m=0,norder(2) do l=0,norder(1) ! Check if all positive splines in this spline domain are inner splines Ibsplinetype(i)=Ibsplinetype(i) .and. (bsplinetype(i+l+m*nrank(1)) .eq. 1) end do end do end do ! Compute the terms eij for the outer b-splines !!$OMP PARALLEL DO DEFAULT(SHARED), PRIVATE(d,k,icellz,icellr,jcellr,jcellz,indexdistance,n,i,m,l,eij,linkedi) Do j=1,nrank(1)*nrank(2) ! find the closest b-spline fully in D for the web method if(bsplinetype(j) .ne. 0) cycle d=0 where(Ibsplinetype)! calculate distance between center of Interior splines and spline j d=(zgridmesh(j)-zgridmesh)**2+(rgridmesh(j)-rgridmesh)**2 end where k=minloc(d,1,MASK=Ibsplinetype) icellz=mod(k-1,nrank(1)) icellr=(k-1)/(nrank(1)) jcellz=mod(j-1,nrank(1)) jcellr=(j-1)/(nrank(1)) indexdistance=real((jcellz-icellz)**2 + (jcellr-icellr)**2,kind=db) if(d(k) .gt. ((norder(1)+2)**2+(norder(2)+2)**2)*2 .and. mpirank .eq. 0)then Write(*,'(a)') 'Warning on system conditioning, the number of radial or axial points could be too low!' Write(*,'(a,1f6.2,a,2(1pe12.4))') 'Distance found: ', sqrt(indexdistance), ' at (z,r): ',zgridmesh(j)*rnorm, rgridmesh(j)*rnorm !stop end if ! Compute the Lagrange polynomia linking spline i and spline j linkedspline(jcellz+1,jcellr+1)=k do n=0,norder(2) do i=0,norder(1) eij=1 !eij=1 do m=0,norder(2) if(n.eq.m) cycle eij=eij*(rgridmesh(j)-rgridmesh(k+m*nrank(1)))/(rgridmesh(k+n*nrank(1))-rgridmesh(k+m*nrank(1))) !eij=eij*real((jcellr-icellr-m),db)/real((n-m),db) end do do l=0,norder(1) if( i .eq. l ) cycle eij=eij*(zgridmesh(j)-zgridmesh(k+l))/(zgridmesh(k+i)-zgridmesh(k+l)) !eij=eij*real((jcellz-icellz-l),db)/real((i-l),db) end do linkedi=innersplinelist%k(k+i+n*nrank(1)) ! equivalent to findloc, necessary for ifort 17 eij=eij*innersplinelist%weight(k+i+n*nrank(1)) ! add the polynomia to the etilde matrix call putele(etilde,linkedi,j,eij) call putele(etildet,j,linkedi,eij) end do end do end do !!$OMP End parallel do call to_mat(etilde) call to_mat(etildet) end subroutine - ! Routine to compute the center of the 2d b-splines used in Lagrange interpolation + !--------------------------------------------------------------------------- + !> @author + !> Guillaume Le Bars EPFL/SPC + ! + ! DESCRIPTION: + !> + !> @brief + !> Routine to compute the center of the 2d b-splines used in Lagrange interpolation + !> @param[in] spl 1D b-spline structure + !> @param[out] ctrs 1D array of spline centers + !> @param[out] heights 1D array of the maximum amplitude of each spline function + !--------------------------------------------------------------------------- Subroutine calcsplinecenters(spl,ctrs,heights) use bsplines type(spline1d):: spl real(kind=db), allocatable:: ctrs(:), heights(:) integer:: nrank, nx, order, i, left1, j, left2, left3 real(kind=db):: x1, x2, x3 real(kind=db), allocatable:: fun1(:,:), fun2(:,:), fun3(:,:) real(kind=db),allocatable:: init_heights(:) call get_dim(spl, nrank, nx, order) if (allocated(ctrs)) deallocate(ctrs) if (allocated(heights)) deallocate(heights) allocate(heights(nrank)) allocate(ctrs(nrank)) allocate(fun1(1:order+1,0:1), fun2(1:order+1,0:1), fun3(1:order+1,0:1)) allocate(init_heights(nrank)) init_heights=1.0 ctrs(:)=spl%knots(0:nrank-1) call gridval(spl, ctrs, heights, 0, init_heights) if (order .gt.1) then do i=2,nrank-1 - x1=spl%knots(i-order)+1e5*Epsilon(x1) - x2=spl%knots(i-1)-1e5*Epsilon(x2) + x1=spl%knots(i-order)+1e5*Epsilon(spl%knots(i-order)) + x2=spl%knots(i-1)-1e5*Epsilon(spl%knots(i-1)) left1=max(0,i-order) left2=min(nx-2,i-2) call basfun(x1,spl,fun1, left1+1) !Write(*,*) 'i,xpt,xptm,w,wold,',i,xpt,xptm,w,wold call basfun(x2,spl,fun2, left2+1) fun3=1 j=0 Do while( j .le. 300) !Write(*,*) 'i,xpt,xptm,w,wold,',i,xpt,xptm,w,wold x3=(x1+x2)/2 call locintv(spl, x3, left3) call basfun(x3,spl,fun3, left3+1) if( (x2-x1).lt.1e-13) exit if(abs(fun3(i-left3,1)).lt.1e-15) exit if(fun3(i-left3,1)*fun1(i-left1,1).le.0) then fun2=fun3 x2=x3 left2=left3 else fun1=fun3 x1=x3 left1=left3 end if j=j+1 End do ctrs(i)=x3 heights(i)=fun3(i-left3,0) end do end if end subroutine -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - Subroutine classifycell(zgrid,rgrid,gridctype) - Real(kind=db):: zgrid(:),rgrid(:) + +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> Classify each grid cell as inner (1), boundary (0), or outer (-1) cell and store it in the +!> gridctype 2D array +!> @param[in] zgrid array of axial limits of the grid-cells +!> @param[in] rgrid array of radial limits of the grid-cells +!> @param[out] gridctype 2D array classifying the individual grid cells as inner, boundary, outer +!--------------------------------------------------------------------------- + Subroutine classifycells(zgrid,rgrid,gridctype) + Real(kind=db):: zgrid(1:),rgrid(1:) Integer:: gridctype(:,:) Integer::i,j gridctype=-1 !$OMP parallel do private(i,j) Do j=1,size(rgrid,1)-1 Do i=1,size(zgrid,1)-1 ! Determines the type inner/boundary/outer for each cell - Call classification((/zgrid(i),zgrid(i+1)/),(/rgrid(j),rgrid(j+1)/),& + Call classifycell((/zgrid(i),zgrid(i+1)/),(/rgrid(j),rgrid(j+1)/),& & gridctype(i,j)) End Do End do !$OMP end parallel do End subroutine !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! For each spline i determines if its support is inside, partially inside or outside of the simulation domain +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> For each spline i determines if its support is inside(1), partially inside (0) or outside (-1) of the simulation domain +!> @param[in] spl2 structure storing the bi-variate b-splines +!> @param[in] gridctype 2D array classifying the individual grid cells as inner, boundary, outer +!> @param[out] bsptype array of b-spline classification +!--------------------------------------------------------------------------- subroutine classifyspline(spl2,gridctype,bsptype) type(spline2d):: spl2 Integer:: gridctype(:,:) Integer:: bsptype(:) Integer:: nrank(2), nrz(2), ndegree(2) Integer:: i, j, mu, imin, imax, jmin, jmax Integer, Allocatable:: splinespan(:,:) call get_dim(spl2, nrank, nrz, ndegree) ! by default, all splines have part of their support outside the domain D bsptype=0 Allocate(splinespan(ndegree(1)+1,ndegree(2)+1)) Do mu=1,nrank(1)*nrank(2) ! scan the spline space ! obtain the axial spline index i=mod(mu-1,nrank(1))+1 ! obtain the radial spline index j=(mu-1)/nrank(1)+1 ! by default all cells are outside for correct behavior in boundaries splinespan=-1 ! find the axial span of this spline in cell indices imin=max(1,i-ndegree(1)) imax=min(nrz(1),i) ! find the radial span of this spline in cell indices jmin=max(1,j-ndegree(2)) jmax=min(nrz(2),j) ! obtain the cell type on which the spline is defined splinespan(1:(imax-imin+1),1:(jmax-jmin+1))=gridctype(imin:imax,jmin:jmax) if ( ANY( splinespan==1 ) ) then ! if at least one cell is fully in the domain the spline is an inside spline bsptype(mu)=1 else if (.not. ANY( splinespan==0 )) then ! if all the cells are outside, this is an outside spline bsptype(mu)=-1 end if end do End subroutine !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> general placeholder function used in fields_mod to compute the weight for weighted_bsplines !> This functions call the correct subroutine pointed by dirichlet_weight ! +!> @param[in] z axial position +!> @param[in] r radial position +!> @param[out] w geometric weight !--------------------------------------------------------------------------- SUBROUTINE geom_weight0(z,r,w) Real(kind=db), INTENT(IN):: r,z Real(kind=db), INTENT(OUT):: w Real(kind=db):: rtmp(1:1), ztmp(1:1), wtmp(1:1,1:1) ztmp=z rtmp=r call Dirichlet_weight(ztmp,rtmp,wtmp) w=wtmp(1,1) End SUBROUTINE geom_weight0 SUBROUTINE geom_weight1(z,r,w) Real(kind=db), INTENT(IN):: r,z Real(kind=db), INTENT(OUT):: w(0:) Real(kind=db):: rtmp(1:1), ztmp(1:1) Real(kind=db):: wtmp(0:size(w,1)-1,1:1) ztmp=z rtmp=r call Dirichlet_weight(ztmp,rtmp,wtmp) w=wtmp(:,1) End SUBROUTINE geom_weight1 SUBROUTINE geom_weight2(z,r,w) Real(kind=db), INTENT(IN):: r(:),z(:) Real(kind=db), INTENT(OUT):: w(0:,:) call Dirichlet_weight(z,r,w) ! End SUBROUTINE geom_weight2 !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> general placeholder function used in fields_mod to compute the domain weight for weighted_bsplines !> This functions call the correct subroutine pointed by domain_weight !> if the weight is negative return the id of the closest wall. +! +!> @param[in] z axial position +!> @param[in] r radial position +!> @param[out] w geometric weight +!> @param[out] idwall unique identifier of the boundary on which the particle is lost !--------------------------------------------------------------------------- SUBROUTINE dom_weight0(z,r,w,idwall) Real(kind=db), INTENT(IN):: r,z Real(kind=db), INTENT(OUT):: w Real(kind=db):: rtmp(1:1), ztmp(1:1), wtmp(1:1,1:1) INTEGER:: idwalltmp(1:1) INTEGER, optional, INTENT(OUT):: idwall ztmp=z rtmp=r call domain_weight(ztmp,rtmp,wtmp,idwall=idwalltmp) w=wtmp(1,1) if (present(idwall)) idwall=idwalltmp(1) End SUBROUTINE dom_weight0 SUBROUTINE dom_weight1(z,r,w,idwall) Real(kind=db), INTENT(IN):: r,z Real(kind=db), INTENT(OUT):: w(0:) Real(kind=db):: rtmp(1:1), ztmp(1:1) Real(kind=db):: wtmp(0:size(w,1)-1,1:1) INTEGER:: idwalltmp(1:1) INTEGER, optional, INTENT(OUT):: idwall ztmp=z rtmp=r call domain_weight(ztmp,rtmp,wtmp,idwall=idwalltmp) w=wtmp(:,1) if (present(idwall)) idwall=idwalltmp(1) End SUBROUTINE dom_weight1 SUBROUTINE dom_weight2(z,r,w,idwall) Real(kind=db), INTENT(IN):: r(:),z(:) Real(kind=db), INTENT(OUT):: w(0:,:) INTEGER, optional, INTENT(OUT):: idwall(:) call domain_weight(z,r,w,idwall=idwall) ! End SUBROUTINE dom_weight2 SUBROUTINE dom_weight3(z,r,w,idwall) Real(kind=db), INTENT(IN):: r(:),z(:) Real(kind=db), INTENT(OUT):: w(:) Real(kind=db):: wtmp(1:1,size(w,1)) INTEGER, optional, INTENT(OUT):: idwall(:) call domain_weight(z,r,wtmp,idwall=idwall) !Write(*,*) 'wtmp, size', wtmp, size(wtmp) w=wtmp(1,:) ! End SUBROUTINE dom_weight3 SUBROUTINE geom_weightstd(z,r,w,wupper) ! return the geometric weight for a coaxial configuration ! or central conductor + ellipse if walltype ==1 Real(kind=db), INTENT(IN):: r(:),z(:) Real(kind=db), INTENT(OUT):: w(0:,:) Real(kind=db), OPTIONAL:: wupper(0:,:) Real(kind=db):: walltmp(0:size(w,1)-1,size(w,2)), elliptmp(0:size(w,1)-1,size(w,2)) Real(kind=db):: squareroot(size(w,2)), denom(size(w,2)) call cyllweight(z,r,walltmp, r_a, above1) SELECT CASE (walltype) CASE (0) call cyllweight(z,r,elliptmp, r_b, above2) CASE DEFAULT call ellipseweight(z,r,elliptmp,r_0, z_0, invr_z, invr_r, Interior) END SELECT if (present(wupper))then w=walltmp wupper=elliptmp return end if if(interior.eq.0 .and. above2.eq.0) then w=walltmp(:,:) else if (above1 .eq. 0) then w=elliptmp(:,:) else denom=walltmp(0,:)**2+elliptmp(0,:)**2 squareroot=sqrt(denom) w(0,:)=walltmp(0,:)+elliptmp(0,:)-squareroot ! weight at position r,z If(size(w,2) .gt. 1) then ! first derivative w(1,:)=walltmp(1,:)+elliptmp(1,:)-(elliptmp(1,:)*elliptmp(0,:)+walltmp(1,:)*walltmp(0,:))/& & squareroot ! z derivative of w w(2,:)=walltmp(2,:)+elliptmp(2,:)-(elliptmp(2,:)*elliptmp(0,:)+walltmp(2,:)*walltmp(0,:))/& & squareroot ! r derivative of w End If End if End SUBROUTINE geom_weightstd - SUBROUTINE classification(z, r, ctype) +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> Classify each grid cell as inner (1), boundary (0), or outer (-1) cell and store it in the +!> gridctype 2D array +!> @param[in] zgrid array of axial limits of the grid-cells +!> @param[in] rgrid array of radial limits of the grid-cells +!> @param[out] ctype classification of the cell +!--------------------------------------------------------------------------- + SUBROUTINE classifycell(z, r, ctype) ! classify if cell is fully inside, outside or on the boundary of the domain ! by calculating the weight on each corner and the cell. ! It is assumed that the cells are sufficiently small such that there is no sharp edge entering the cell ! where an inner portion of only one cell edge is outside of the domain real(kind=db), INTENT(IN):: r(2), z(2) INTEGER, INTENT(OUT):: ctype Real(kind=db)::weights(1:1,5) Real(kind=db):: zeval(5),reval(5) zeval=(/ z(1),z(2),z(1),z(2), (z(2)+z(1))/2 /) reval=(/ r(1),r(1),r(2),r(2), (r(2)+r(1))/2 /) CAll dom_weight(zeval,reval,weights) ctype=int(sign(1.0_db,weights(1,5))) If(weights(1,1)*weights(1,2) .le. 0 ) then ctype=0 return End If If(weights(1,1)*weights(1,3) .le. 0 ) then ctype=0 return End If If(weights(1,2)*weights(1,4) .le. 0 ) then ctype=0 return End If If(weights(1,3)*weights(1,4) .le. 0 ) then ctype=0 return End If + If(weights(1,3)*weights(1,2) .le. 0 ) then + ctype=0 + return + End If + If(weights(1,1)*weights(1,4) .le. 0 ) then + ctype=0 + return + End If end subroutine ! ################################################################## +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> calculates the gauss quadrature integration points for the FEM method for any cell type +!> takes care of boundary cells as well and limit the integration boundaries accordingly +!> returns the gauss quadrature points and weights for cell (i,j) +!> @param[in] spl2 structure storing the bi-variate b-spline +!> @param[in] ngauss 2D array of number of gauss ponts in z and r +!> @param[in] i axial cell index +!> @param[in] j radial cell index +!> @param[out] xgauss 2D array of evaluation points z=xgauss(:,1), r=xgauss(:,2) +!> @param[out] xgauss 1D array of evaluation weights +!> @param[out] gausssize total number of gauss points for this cell +!> @param[out] celltype return the type of the cell inner (1), boundary (0), outer(-1) +!--------------------------------------------------------------------------- Subroutine calc_gauss(spl2, ngauss, i, j, xgauss, wgauss, gausssize, celltype) - ! calculates the gauss integration points for the FEM method for any cell type - ! takes care of boundary cells as well and limit the integration boundaries accordingly + type(spline2d), INTENT(IN):: spl2 Integer, Intent(out):: gausssize INTEGER, Intent(out), Optional :: celltype Real(kind=db), Allocatable::rgrid(:),zgrid(:) Real(kind=db), ALLOCATABLE, intent(out)::xgauss(:,:), wgauss(:) Integer:: i,j, ngauss(2) Real(kind=db),Allocatable:: zpoints(:) Real(kind=db):: zg(ngauss(1)),rg(ngauss(2)), wzg(ngauss(1)), wrg(ngauss(2)) Integer:: k, l, directiondown, directionup, nbzpoints, direction, ctype Logical:: hasmaxpoint Real(kind=db):: xptup, xptdown,wlu,wld, rmin, rmax type(spline1d):: splz, splr splz=spl2%sp1 splr=spl2%sp2 Allocate(zgrid(1:splz%nints+1)) Allocate(rgrid(1:splr%nints+1)) zgrid=splz%knots(0:splz%nints) rgrid=splr%knots(0:splr%nints) hasmaxpoint=.false. If(allocated(xgauss)) deallocate(xgauss) if(allocated(wgauss)) deallocate(wgauss) !Call classification((/zgrid(i),zgrid(i+1)/),(/rgrid(j),rgrid(j+1)/),ctype) ctype=gridcelltype(i,j) If (ctype .ge. 1) then ! we have a normal internal cell Allocate(xgauss(ngauss(1)*ngauss(2),2)) Allocate(wgauss(ngauss(1)*ngauss(2))) gausssize=ngauss(1)*ngauss(2) !Computation of gauss weight and position in r and z direction for gaussian integration CALL get_gauss(spl2%sp1, ngauss(1), i, zg, wzg) CALL get_gauss(spl2%sp2, ngauss(2), j, rg, wrg) ! Construction of matrix xgauss and wgauss storing the weight and position for 2d gaussian integration DO k=1,ngauss(2) xgauss((k-1)*ngauss(1)+1:k*ngauss(1),1)=zg xgauss((k-1)*ngauss(1)+1:k*ngauss(1),2)=rg(k) wgauss((k-1)*ngauss(1)+1:k*ngauss(1))=wrg(k)*wzg END DO Else If(ctype.eq.0) then ! we have a boundary cell directiondown=1 directionup=1 ! We check if the boundary goes through the cell upper and lower limit Call Find_crosspointdico((/zgrid(i),zgrid(i+1)/),rgrid(j),xptdown,directiondown) Call Find_crosspointdico((/zgrid(i),zgrid(i+1)/),rgrid(j+1),xptup,directionup) call dom_weight(zgrid(i),rgrid(j),wld) call dom_weight(zgrid(i),rgrid(j+1),wlu) select case ( directionup+directiondown) Case (0) ! The intersections are only on the left and right cell boundaries ! or the upper and lower limits are full boundaries nbzpoints=2 Allocate(zpoints(nbzpoints)) zpoints=(/zgrid(i),zgrid(i+1)/) Case(1) if(directiondown.eq.1)then if( wlu .gt. 0) then ! the lower left corner is inside nbzpoints=3 Allocate(zpoints(nbzpoints)) zpoints=(/zgrid(i), xptdown,zgrid(i+1)/) else nbzpoints=2 Allocate(zpoints(nbzpoints)) if(wld.gt.0)then ! the upper left corner is inside zpoints=(/zgrid(i),xptdown/) else zpoints=(/xptdown,zgrid(i+1)/) end if end if else if(wld .gt. 0) then ! the lower left corner is inside nbzpoints=3 Allocate(zpoints(nbzpoints)) zpoints=(/zgrid(i), xptup,zgrid(i+1)/) else nbzpoints=2 Allocate(zpoints(nbzpoints)) if(wlu.gt.0)then ! the upper left corner is inside zpoints=(/zgrid(i),xptup/) else zpoints=(/xptup,zgrid(i+1)/) end if end if end if Case(2) nbzpoints=4 Allocate(zpoints(nbzpoints)) zpoints=(/zgrid(i),min(xptdown,xptup),max(xptdown,xptup), zgrid(i+1) /) !If(wld.lt.0) zpoints=(/min(xptdown,xptup),max(xptdown,xptup), zgrid(i+1) /) !else ! nbzpoints=2 ! Allocate(zpoints(nbzpoints)) ! If(wld.ge.0) zpoints=(/zgrid(i),min(xptdown,xptup) /) ! If(wld.lt.0) zpoints=(/max(xptdown,xptup), zgrid(i+1) /) !end if End select Allocate(xgauss(ngauss(1)*ngauss(2)*(nbzpoints-1),2)) Allocate(wgauss(ngauss(1)*ngauss(2)*(nbzpoints-1))) gausssize=ngauss(1)*ngauss(2)*(nbzpoints-1) ! Compute gauss points Do l=1,nbzpoints-1 !CALL get_gauss(spl2%sp1, ngauss(1), i, zg, wzg) Call gauleg(zpoints(l),zpoints(l+1),zg,wzg,ngauss(1)) - - ! We test if the lower or upper side is in the domain - call dom_weight(zg(1),rgrid(j),wld) - rmin=rgrid(j) - if (wld .le. 0) rmin = rgrid(j+1) - + Do k=1,ngauss(1) + ! We test if the lower or upper side is in the domain + call dom_weight(zg(k),rgrid(j),wld) + rmin=rgrid(j) + if (wld .lt. 0) rmin = rgrid(j+1) + direction=2 Call Find_crosspointdico((/rgrid(j),rgrid(j+1)/),zg(k),rmax,direction) ! We compute the radial limits at each z position Call gauleg(min(rmin,rmax),max(rmin,rmax),rg,wrg,ngauss(2)) ! We obtain the gauss w and pos for these boundaries if(direction .eq. 0.and. wld .lt. 0) then wrg=0 end if xgauss(k+(l-1)*ngauss(1)*ngauss(2) : l*ngauss(2)*ngauss(1) : ngauss(1),1) = zg(k) xgauss(k+(l-1)*ngauss(1)*ngauss(2) : l*ngauss(2)*ngauss(1) : ngauss(1),2) = rg wgauss(k+(l-1)*ngauss(1)*ngauss(2) : l*ngauss(2)*ngauss(1) : ngauss(1)) = wrg*wzg(k) End do End Do Else gausssize=0 Allocate(xgauss(1:1,2)) Allocate(wgauss(1:1)) - !Computation of gauss weight and position in r and z direction for gaussian integration - CALL get_gauss(spl2%sp1, ngauss(1), i, zg, wzg) - CALL get_gauss(spl2%sp2, ngauss(2), j, rg, wrg) ! Construction of matrix xgauss and wgauss storing the weight and position for 2d gaussian integration - xgauss(1,1)=(zg(1)+zg(ngauss(1)))*0.5 - xgauss(1,2)=(rg(1)+rg(ngauss(2)))*0.5 + xgauss(1,1)=(zgrid(i)+zgrid(i+1))*0.5 + xgauss(1,2)=(rgrid(j)+rgrid(j+1))*0.5 wgauss(1)=0 End If If(PRESENT(celltype)) celltype=ctype End Subroutine calc_gauss +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> computes quickly if a particle is inside the domain D and returns the id of the closest boundary +!> if the particle is outside the domain +!> @param[in] z axial particle position +!> @param[in] r radial particle position +!> @param[in] i axial cell index +!> @param[in] j radial cell index +!> @param[out] idwall id of the closest boundary if the particle is outside the domain +!> @param[out] inside .true. if the particle is inside D +!--------------------------------------------------------------------------- subroutine is_insidegeom(z,r,i,j,idwall,inside) REAL(kind=db), intent(in):: z,r INTEGER,INTENT(in):: i,j INTEGER:: idwall logical:: inside Real(kind=db):: weight if(i.gt.size(gridcelltype,1)-1.or. i.lt.0 .or. j.gt.size(gridcelltype,2)-1.or. j.lt.0 )then inside=.false. idwall=0 return end if select case(gridcelltype(i+1,j+1)) case(-1) inside=.false. idwall=0 case(1) inside=.true. idwall=0 case(0) call dom_weight(z, r, weight, idwall=idwall) inside=weight.gt.0 end select end subroutine is_insidegeom +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> calculates the boundary limit between x(1) and x(2) using Newton's method +!> @param[in] x axial/radial initial guesses for the boundary position +!> @param[in] y radial/axial position at which the boundary is searched +!> @param[out] xpt position of the boundary found +!> @param[inout] direction (1) searches boundary along z, (2) searches boundary along r (0) no boundary found between x(1) and x(2) +!--------------------------------------------------------------------------- Subroutine Find_crosspoint(x,y,xpt, direction) - ! calculates the boundary limit between x(1) and x(2) using Newton's method + ! Real(kind=db):: x(2), y Real(kind=db):: xptm, xpt, temp Real(kind=db):: w, wold Integer, Intent(INOUT):: direction Integer:: i ! calculates the position of the boundary ( where the weight changes sign ) ! between x(1) and x(2) at 2nd coordinate y xptm=x(1) xpt=x(2) i=0 ! direction=1 finds cross-point along z if(direction .eq.1) Call dom_weight(xptm,y,wold) ! direction=2 finds cross-point along r if(direction .eq.2) Call dom_weight(y,xptm,wold) if(direction .eq.1) Call dom_weight(xpt,y,w) if(direction .eq.2) Call dom_weight(y,xpt,w) ! if the weight doesn't change sign there is no cross point if(w*wold.gt.0) then direction=0 return End If ! Find the cross-point Do while( i .le.100 .and. abs(w).gt.1e-9) !Write(*,*) 'i,xpt,xptm,w,wold,',i,xpt,xptm,w,wold xptm=xpt-w*(xpt-xptm)/(w-wold) wold=w temp=xptm xptm=xpt xpt=temp i=i+1 if(direction .eq.1) Call dom_weight(xpt,y,w) if(direction .eq.2) Call dom_weight(y,xpt,w) End do if(xpt .ge. x(2) .or. xpt .le. x(1) ) direction=0 End Subroutine - +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> calculates the boundary limit between x(1) and x(2) using dichotomy method +!> @param[in] x axial/radial initial guesses for the boundary position +!> @param[in] y radial/axial position at which the boundary is searched +!> @param[out] xpt position of the boundary found +!> @param[inout] direction (1) searches boundary along z, (2) searches boundary along r (0) no boundary found between x(1) and x(2) +!--------------------------------------------------------------------------- Subroutine Find_crosspointdico(x,y,xpt, direction) ! calculates the boundary limit between x(1) and x(2) using dichotomy method Real(kind=db):: x(2), y Real(kind=db):: xpt Real(kind=db):: w1, w2, w3 Real(kind=db):: x1, x2, x3 Integer, Intent(INOUT):: direction Integer:: i ! calculates the position of the boundary ( where the weight changes sign ) ! between x(1) and x(2) at 2nd coordinate y x1=x(1) x2=x(2) i=0 select case(direction) case(1) ! direction=1 finds cross-point along z Call dom_weight(x1,y,w1) Call dom_weight(x2,y,w2) case(2) ! direction=2 finds cross-point along r Call dom_weight(y,x1,w1) Call dom_weight(y,x2,w2) end select ! if the weight doesn't change sign there is no cross point if(w1*w2.gt.0) then direction=0 xpt=x2 return End If ! Find the cross-point - Do while( i .le. 500 .and. abs(x2-x1).gt.1e-13) + Do while( i .le. 1000 .and. abs((x2-x1)/(x(2)-x(1))).gt.1e-14) x3=0.5*(x1+x2) i=i+1 select case(direction) case(1) ! direction=1 finds cross-point along z Call dom_weight(x3,y,w3) case(2) ! direction=2 finds cross-point along r Call dom_weight(y,x3,w3) end select if(w1*w3.gt.0)then! we are in a region were there is no change of sign x1=x3 w1=w3 else x2=x3 w2=w3 end if !if(abs(w3).lt.1e-14.and. w3 .ge.0)Exit End do xpt=x3 - if(xpt .ge. x(2) .or. xpt .le. x(1) ) direction=0 + if(xpt .gt. x(2) .or. xpt .lt. x(1) ) direction=0 End Subroutine - +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> returns the total weight which is the same as the Dirichlet weight for a boundary +!> defined with Rvaschev functions +!> @param[in] z axial position +!> @param[in] r radial position +!> @param[out] w dirichlet weight +!> @param[out] idwall id of the closest boundary if the particle is outside the domain +!--------------------------------------------------------------------------- SUBROUTINE geom_rvaschtot(z,r,w,idwall) ! returns the total weight which is the same as the Dirichlet weight for a boundary ! defined with Rvaschev functions Use splinebound, ONLY: spline_w Real(kind=db), INTENT(IN):: r(:),z(:) Real(kind=db), INTENT(OUT):: w(0:,:) Real(kind=db), allocatable:: w2(:,:) Real(kind=db), allocatable:: w3(:,:) INTEGER, optional, INTENT(OUT):: idwall(:) INTEGER:: sw2 sw2=size(w,2) if(present(idwall)) then idwall=0 allocate(w2(1:size(w,1),1:size(w,2))) allocate(w3(1:size(w,1),1:size(w,2))) call Dirichlet_weight(z,r,w2,w3) ! gives total weight where(w2(1,:).le.0) idwall=1 where(w3(1,:).le.0) idwall=2 call Combine(w2, w3, w, -1) else call Dirichlet_weight(z,r,w) end if End SUBROUTINE geom_rvaschtot Subroutine gstd(z,r,gtilde,w) ! g tilde function added to rhs of poisson solver for the standard coaxial configuration ! for the default weight function Real(kind=db), INTENT(IN):: r(:),z(:) Real(kind=db), INTENT(OUT):: gtilde(0:,:) Real(kind=db), INTENT(IN),OPTIONAL::w(0:,:) Real(kind=db):: belowtmp(0:size(gtilde,1)-1,size(r,1)), abovetmp(0:size(gtilde,1)-1,size(r,1)) Real(kind=db):: denom(size(r,1)) if (above1.eq.0) then gtilde=0 gtilde(0,:)=Phiup RETURN end if ! Weight functions necessary for calculation of g ! coaxial insert call cyllweight(z,r,belowtmp, r_a, above1) SELECT CASE (walltype) CASE (0) ! top cylinder call cyllweight(z,r,abovetmp, r_b, above2) CASE DEFAULT ! Ellipse as in gt170 call ellipseweight(z,r,abovetmp,r_0,z_0,invr_z,invr_r,Interior) END SELECT ! Extension to the whole domain of the boundary conditions ! constructed by weight multiplied with boundary value gtilde(0,:)=(Phidown*abovetmp(0,:) + Phiup*belowtmp(0,:) ) / & & (abovetmp(0,:)+belowtmp(0,:)) If(size(gtilde,1) .gt. 2) then ! first derivative denom=(abovetmp(0,:)+belowtmp(0,:))**2 gtilde(1,:)=(Phiup-Phidown)*(belowtmp(1,:)*abovetmp(0,:)-belowtmp(0,:)*abovetmp(1,:)) / & & denom ! Axial derivative gtilde(2,:)=(Phiup-Phidown)*(belowtmp(2,:)*abovetmp(0,:)-belowtmp(0,:)*abovetmp(2,:)) / & & denom ! Radial derivative End If End subroutine SUBROUTINE gUpDown(z,r,gtilde,w) ! g tilde function added to rhs of poisson solver by combining two boundaries set at different potentials Real(kind=db), INTENT(IN):: r(:),z(:) Real(kind=db), INTENT(OUT):: gtilde(0:,:) Real(kind=db), INTENT(IN),OPTIONAL::w(0:,:) Real(kind=db):: belowtmp(0:size(gtilde,1)-1,size(r,1)), abovetmp(0:size(gtilde,1)-1,size(r,1)) Real(kind=db):: denom(size(r,1)) ! Weight functions necessary for calculation of g call Dirichlet_weight(z,r,belowtmp,abovetmp) ! Extension to the whole domain of the boundary conditions ! constructed by weight multiplied with boundary value gtilde(0,:)=(Phidown*abovetmp(0,:) + Phiup*belowtmp(0,:) ) / & & (abovetmp(0,:)+belowtmp(0,:)) - If(size(gtilde,2) .gt. 2) then ! first derivative + If(size(gtilde,1) .gt. 2) then ! first derivative denom=(abovetmp(0,:)+belowtmp(0,:))**2 gtilde(1,:)=(Phiup-Phidown)*(belowtmp(1,:)*abovetmp(0,:)-belowtmp(0,:)*abovetmp(1,:)) / & & denom ! Axial derivative gtilde(2,:)=(Phiup-Phidown)*(belowtmp(2,:)*abovetmp(0,:)-belowtmp(0,:)*abovetmp(2,:)) / & & denom ! Radial derivative End If END SUBROUTINE gUpDown Subroutine gtest(z,r,gtilde,w) ! calculates the Poisson gtilde term for testing the solver on a new geometry ! This uses a manufactured solution of the form phi=sin(pi(z-z0)/Lz)sin(pi(r-r0)/Lr)+2 Real(kind=db), INTENT(IN):: r(:),z(:) Real(kind=db), INTENT(OUT):: gtilde(0:,:) Real(kind=db), INTENT(IN),OPTIONAL::w(0:,:) Real(kind=db):: wtmp(0:size(gtilde,1)-1,size(gtilde,2)) ! !gtilde=0 !return if(present(w)) then wtmp=w else call Dirichlet_weight(z,r,wtmp) end if gtilde(0,:)=(sin(pi*(z-test_pars%z0)/(test_pars%Lz))*sin(pi*(r-test_pars%r0)/(test_pars%Lr))+2) - If(size(gtilde,2) .gt. 1) then ! first derivative + If(size(gtilde,1) .gt. 1) then ! first derivative gtilde(1,:)=pi/(test_pars%Lz)*cos(pi*(z-test_pars%z0)/(test_pars%Lz))*sin(pi*(r-test_pars%r0)/(test_pars%Lr))*(1-wtmp(0,:))-wtmp(1,:)*gtilde(0,:) gtilde(2,:)=pi/(test_pars%Lr)*sin(pi*(z-test_pars%z0)/(test_pars%Lz))*cos(pi*(r-test_pars%r0)/(test_pars%Lr))*(1-wtmp(0,:))-wtmp(2,:)*gtilde(0,:) End If gtilde(0,:)=gtilde(0,:)*(1-wtmp(0,:)) End subroutine Subroutine ftest(z,r,f) ! calculates the Poisson source term for testing the solver on a new geometry ! This uses a manufactured solution of the form phi=sin(pi(z-z0)/Lz)sin(pi(r-r0)/Lr)+2 Real(kind=db), INTENT(IN):: r(:),z(:) Real(kind=db), INTENT(OUT)::f(0:,:) !f(0,:)=1 !return ! f(0,:)=(pi/test_pars%Lz)**2*sin(pi*(z-test_pars%z0)/(test_pars%Lz))*sin(pi*(r-test_pars%r0)/(test_pars%Lr))& & + (pi/test_pars%Lr)*sin(pi*(z-test_pars%z0)/(test_pars%Lz))& & *( -1/r*(cos(pi*(r-test_pars%r0)/(test_pars%Lr))) + (pi/test_pars%Lr)*sin(pi*(r-test_pars%r0)/(test_pars%Lr))) End Subroutine ftest + +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> Reduce the Finite element matrix in the LHS from full spline space to reduced web-spline space +!> If A is the standard FEM matrix on the full grid space then the web-spline FEM matrix is etilde A etildet +!> with etildet the transposed etilde matrix +!> @param[in] full full FEM matrix on the weighted b-spline domain +!> @param[out] reduced reduced matrix on the web-spline space +!--------------------------------------------------------------------------- subroutine Reducematrix(full,reduced) - ! Reduce the Finite element matrix in the LHS from full spline space to reduced web-spline space - ! If A is the standard FEM matrix on the full grid space then the web-spline FEM matrix is etilde A etildet - ! with etildet the transposed etilde matrix + ! use mumps_bsplines type(mumps_mat):: full, reduced, tempmat1, tempmat2 Integer:: fullrank, reducedrank Integer:: i,j, k Real(kind=db):: val logical:: error call to_mat(full) fullrank=full%rank reducedrank=nbreducedspline !WRITE(*,*) "# web-splines", nbreducedspline !WRITE(*,*) "# splines", fullrank - call init(reducedrank,2,reduced) + call init(reducedrank,2,reduced,nlpos=.false.) call init(fullrank,2,tempmat1) call init(reducedrank,2,tempmat2) tempmat1=mmx_mumps_mat_loc(full,etildet,(/fullrank,fullrank/),(/fullrank,reducedrank/),.false.) tempmat2=mmx_mumps_mat_loc(etildet,tempmat1,(/fullrank,reducedrank/),(/fullrank,reducedrank/),.true.) do i=1,reducedrank do k=tempmat2%irow(i),tempmat2%irow(i+1)-1 j=tempmat2%cols(k) call putele(reduced, i, j, tempmat2%val(k)) end do end do call to_mat(reduced) end subroutine !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> Com putes the sparse matrix matrix multiplication using MKL A B=C +!> @param[in] mata sparse matrix A in csr representation +!> @param[in] matb sparse matrix B in csr representation +!> @param[in] ranka Rank of matrix A +!> @param[in] rankb Rank of matrix B +!> @param[in] transpose Is A transposed +!> @param[out] matc sparse matrix C in csr representation +!--------------------------------------------------------------------------- FUNCTION mmx_mumps_mat_loc(mata, matb, ranka, rankb, transpose) RESULT(matc) ! ! Return product matc=mata*matb ! All matrices are represented in csr sparse representation ! Use mumps_bsplines TYPE(mumps_mat) :: mata,matb,matc INTEGER:: ranka(2), rankb(2) ! nb of (rows,columns) for each matrix INTEGER :: n, info, m, request, sort LOGICAL:: transpose Character(1):: T ! m=ranka(1) n=ranka(2) T='N' if (transpose)then T='T' m=ranka(2) n=ranka(1) end if !#ifdef MKL ! if(associated(matc%val)) deallocate(matc%val) if(associated(matc%cols)) deallocate(matc%cols) if(associated(matc%irow)) deallocate(matc%irow) allocate(matc%irow(m+1)) allocate(matc%cols(1)) allocate(matc%val(1)) ! Compute the size of the resulting matrix and the indices of the non-zero elements request=1 sort=7 CALL mkl_dcsrmultcsr(T, request, sort, ranka(1), ranka(2), rankb(2), & & mata%val, mata%cols, mata%irow, & & matb%val, matb%cols, matb%irow, & & matc%val, matc%cols, matc%irow, & & 1, info) if(info .gt. 0) WRITE(*,'(a,i4)') " Error in mmx_mumps_mat_loc: ", info if(associated(matc%val)) deallocate(matc%val) if(associated(matc%cols)) deallocate(matc%cols) allocate(matc%val(matc%irow(m+1)-1)) allocate(matc%cols(matc%irow(m+1)-1)) matc%val=0 request=2 ! Do the actual matrix matrix multiplication CALL mkl_dcsrmultcsr(T, request, sort, ranka(1), ranka(2), rankb(2), & & mata%val, mata%cols, mata%irow, & & matb%val, matb%cols, matb%irow, & & matc%val, matc%cols, matc%irow, & & 1, info) if(info .ne. 0) WRITE(*,'(a,i4)') " Error in mmx_mumps_mat_loc: ", info if (transpose)then matc%rank=ranka(2) else matc%rank=ranka(1) end if ! END FUNCTION mmx_mumps_mat_loc END MODULE geometry diff --git a/src/intel_spcpc607.mk b/src/intel_spcpc607.mk index 138a83c..4540398 100644 --- a/src/intel_spcpc607.mk +++ b/src/intel_spcpc607.mk @@ -1,23 +1,23 @@ CC = icc CFLAGS = FC = mpiifort # #PARMETIS=$(PARMETIS_ROOT) #MUMPSLIBS= -ldmumps -lzmumps -lmumps_common -lpord #XGRAFIX=$(HOME)/lib/intel/xgrafix #MUMPS=$(MUMPS_ROOT) #HDF5=$(HDF5_ROOT) # RELEASEFLAGS = -fpp -mkl=cluster -qopenmp -qopenmp-simd -O3 -xHost -warn all -FFLAGS = -fpp -g -traceback -check bounds -mkl=cluster -O3 +FFLAGS = -fpp -g -traceback -mkl=cluster -O3 DEBUGFLAGS = -fpp -g -O0 -xHost -qopenmp -qopenmp-simd -traceback -mkl=cluster\ -check all -check bounds -check noarg_temp_created \ -warn all -ftrapuv -fpe0 -debug extended \ -check uninit -debug all -diag-enable=all -PROFILEFLAGS= -g -traceback -O3 +PROFILEFLAGS= -g -traceback -O3 -qopt-report=3 -vec F90 = $(FC) F90FLAGS= $(RELEASEFLAGS) -I/home/lebars/libs/SISL/include \ -I/home/lebars/libs/forSISLomp/include LDFLAGS = LIBS = /home/lebars/libs/forSISLomp/lib/forsisl.a /home/lebars/libs/SISL/lib/libsisl.a diff --git a/src/ion_induced_mod.f90 b/src/ion_induced_mod.f90 index 62b58f8..8444e67 100644 --- a/src/ion_induced_mod.f90 +++ b/src/ion_induced_mod.f90 @@ -1,452 +1,452 @@ !------------------------------------------------------------------------------ ! EPFL/Swiss Plasma Center !------------------------------------------------------------------------------ ! ! MODULE: IIEE ! !> @author !> S. Guinchard - EPFL/SPC ! !> Last modif. !> 11/28 2022 ! ! DESCRIPTION: !> Module handling ion induced electron emissions (IIEE) !> following Schou's model (for Kinetic emissions) and Auger neutralisation !> for potential emissions !------------------------------------------------------------------------------ MODULE iiee USE particletypes USE constants USE basic USE materials !#include "mkl_vsl.f90" ! for random # generators using MKL intel library IMPLICIT NONE CONTAINS !--------------------------------------------------------------------------- ! SUBROUTINE ion_induced(pion, losthole, pelec, nblostparts) ! ! ! DESCRIPTION !> function to determine the number of electrons !> to add to a given species as a function of th number !> of lost ions ! !-------------------------------------------------------------------------- SUBROUTINE ion_induced(pion, losthole, pelec, nblostparts) USE geometry TYPE(particles), INTENT(INOUT):: pion, pelec !< ion and electrons parts REAL(KIND = db), DIMENSION(3) :: last_pos !< last position for lost ion (revert push) REAL(KIND = db), DIMENSION(3) :: normal_dir !< normal direction vector (normalised) INTEGER, DIMENSION(pion%Nploc):: losthole !< indices of lost ions INTEGER ::i,j, nblostparts, Nploc, Nploc_old, Nploc_init!< loop indices and #lost particles INTEGER :: parts_size_increase, nbadded INTEGER :: neuttype_id !< neutral gas type_id INTEGER :: material_id !< electrode material type_id INTEGER :: gen_el, kmax !< # of electrons generated, max# possibly gen. elec. REAL(KIND = db) :: lambda !< Poisson param. to gen elec. (yield) REAL(KIND = db) :: kappa, theta, Emax !< gamma distribution parameters REAL(KIND = db) :: Ekin, Eem !< kinetic energy of lost particles (yield param) and of emitted electrons kmax = 12 !> Max num. elec. to be generated (Poisson) kappa = 4.0 !> kappa param. (Gamma) theta = 0.5 !> theta param. (Gamma) Emax = 25 !> Max value for el. (Gamma) neuttype_id = pion%neuttype_id !> temporarily stored in particle type material_id = pion%material_id !> temporarily stored in particle type IF(pelec%Nploc + 2*nblostparts .gt. size(pelec%pos,2)) THEN parts_size_increase=Max(floor(0.1*size(pelec%pos,2)),2*nblostparts) CALL change_parts_allocation(pelec, parts_size_increase) END IF Nploc_init = pelec%Nploc DO i=1,nblostparts Ekin = compute_Ekin( pion%U(:,losthole(i)), pion) IF (pion%neuttype_id == 1) THEN ! Yield for H2 lambda = 2.0*compute_yield(Ekin/2.0, neuttype_id, material_id) ! computed from yield by protons ELSE ! Yield for other neutral lambda = compute_yield(Ekin, neuttype_id, material_id) ! needs to be changed for other gases END IF nbadded = gen_elec(lambda, kmax) Nploc_old = pelec%Nploc pelec%Nploc = pelec%Nploc + nbadded Nploc = pelec%Nploc last_pos = revert_push(pion, losthole(i)) pelec%nbadded = pelec%nbadded+nbadded normal_dir = find_normal(last_pos) DO j=1,nbadded pelec%pos(1,Nploc_old+j) = last_pos(1) pelec%pos(2,Nploc_old+j) = last_pos(2) pelec%pos(3,Nploc_old+j) = last_pos(3) pelec%newindex = pelec%newindex + 1 pelec%partindex(Nploc_old+j) = pelec%newindex IF(pelec%zero_vel == .false.) THEN Eem = gen_E_gamma(kappa, theta, Emax) !> generate an energy value following gamma distribution pelec%U(1,Nploc_old+j) = compute_Vnorm(Eem, pelec)* normal_dir(1) !> Vr pelec%U(3,Nploc_old+j) = compute_Vnorm(Eem, pelec)* normal_dir(3) !> Vz pelec%U(2,Nploc_old+j) = compute_Vnorm(Eem, pelec)* normal_dir(2) !> Vthet ELSE pelec%U(1,Nploc_old+j) = 0.0 pelec%U(3,Nploc_old+j) = 0.0 pelec%U(2,Nploc_old+j) = 0.0 END IF END DO END DO if (pelec%Nploc-Nploc_init .ge. 1) then call geom_weight(pelec%pos(3,Nploc_init+1:pelec%Nploc), pelec%pos(1,Nploc_init+1:pelec%Nploc), pelec%geomweight(:,Nploc_init+1:pelec%Nploc)) end if END SUBROUTINE ion_induced !--------------------------------------------------------------------------- ! FUNCTION compute_Ekin(velocity, p) ! ! ! DESCRIPTION - !> Computes the kinetic energy of a particle given its 3-vel. components + !> Computes the kinetic energy in MeV of a particle given its 3-vel. components !-------------------------------------------------------------------------- FUNCTION compute_Ekin(velocity, p) RESULT(Ekin) TYPE(particles), INTENT(INOUT):: p REAL(KIND = db), DIMENSION(3) :: velocity REAL(KIND = db) :: Ekin Ekin = 5E-7 * p%m * vlight**2 /elchar * (velocity(1)**2 + velocity(2)**2 + velocity(3)**2) END FUNCTION compute_Ekin !--------------------------------------------------------------------------- ! FUNCTION compute_Vnorm(Ekin,p) ! ! ! DESCRIPTION !> Computes the normal velocity of an incident electron emitted !> with energy Ekin !-------------------------------------------------------------------------- FUNCTION compute_Vnorm(Ekin, p) RESULT(Vnorm) REAL(KIND = db) :: Ekin, Vnorm !> Ekin of emitted electron, Normal. corres. veloc. TYPE(particles) :: p !> electrons Vnorm = sqrt(2/p%m * Ekin * elchar) / vlight !> * elchar to get the enery in J and Vnorm in m/s END FUNCTION compute_Vnorm !--------------------------------------------------------------------------- ! FUNCTION fin_normal(last_position) ! ! ! DESCRIPTION !> Computes the normal velocity of an incident electron emitted !> with energy Ekin !-------------------------------------------------------------------------- FUNCTION find_normal(last_position) RESULT(normal_dir) USE geometry REAL(KIND = db), DIMENSION(3) :: last_position !> Last pos. to eval. geom. weight at REAL(KIND = db), DIMENSION(3) :: normal_dir !> Normal direction vector (Result) REAL(KIND = db), DIMENSION(3) :: weight !> Geom. weight at last pos. REAL(KIND = db) :: norm !> To normalise normal vect. call geom_weight(last_position(3), last_position(1), weight) norm = sqrt(weight(2)**2 + weight(3)**2) normal_dir(1) = 1/norm * weight(3) !> Normal along r normal_dir(2) = 0.0 !> Normal along theta normal_dir(3) = 1/norm * weight(2) !> Normal along z END FUNCTION find_normal !--------------------------------------------------------------------------- ! FUNCTION revert_push(pion, partid) ! ! ! DESCRIPTION !> reverts Buneman algorithm over one time step !> to obtain ion position right before recapture !> and hence new electron positions ! !-------------------------------------------------------------------------- FUNCTION revert_push(pion, partid) USE basic, ONLY: dt, tnorm REAL(KIND=db), DIMENSION(3):: revert_push TYPE(particles), INTENT(INOUT):: pion !> species: ions INTEGER :: partid !> id of particle to reverse position revert_push(1) = pion%pos(1,partid) - pion%U(1,partid)*dt revert_push(2) = pion%pos(2,partid) -1/pion%pos(1,partid)* pion%U(2,partid)*dt revert_push(3) = pion%pos(3,partid) -pion%U(3,partid)*dt END FUNCTION revert_push !--------------------------------------------------------------------------- ! FUNCTION eval_polynomial(coefficients, valeur) ! ! ! DESCRIPTION !> Evaluate a polynomial at a given point !> with its coefficients provided in an array !> s.t lowest order coeff = 1st element ! !-------------------------------------------------------------------------- REAL(KIND = db) FUNCTION eval_polynomial(coefficients, valeur) REAL(KIND = db), DIMENSION(:) :: coefficients !< polynomial (e.g fitted yield) coeffs REAL(KIND = db) :: valeur !< point where to evaluate polyn INTEGER :: ii eval_polynomial = 0 DO ii=1, size(coefficients) eval_polynomial = eval_polynomial+coefficients(ii)*valeur**(ii-1) END DO END FUNCTION eval_polynomial !--------------------------------------------------------------------------- ! FUNCTION compute_yield(energy, neuttype_id, material_id) ! ! ! DESCRIPTION !> Gives the theoretical value for the electron yield !> as a function of the energy of the incident ion and !> the type of neutral gas ! !-------------------------------------------------------------------------- REAL(KIND = db) FUNCTION compute_yield(energy, neuttype_id, material_id) !add material id asap REAL(KIND = db) :: energy INTEGER :: neuttype_id, material_id REAL(KIND = db) :: Lambda_exp Lambda_exp = 1E-3 SELECT CASE(material_id) CASE(1) !304 stainless steel IF(energy.le. 1E-3 ) THEN SELECT CASE(neuttype_id) CASE(1) compute_yield = eval_polynomial(coefficients_1H_SS, energy) CASE(2) compute_yield = eval_polynomial(coefficients_1He_SS, energy) CASE(3) compute_yield = eval_polynomial(coefficients_1Ne_SS, energy) CASE DEFAULT compute_yield = eval_polynomial(coefficients_1H_SS, energy) END SELECT ELSE IF(energy.gt. 1E-3 .and. energy.le. 1E-2) THEN compute_yield = Lambda_exp * eval_polynomial(coefficients_2_SS,energy) ELSE IF(energy.gt. 1E-2 .and. energy.le. 2E-2 ) THEN compute_yield = Lambda_exp * eval_polynomial(coefficients_3_SS,energy) ELSE IF(energy.gt. 2E-2 .and. energy.le. 3E-2) THEN compute_yield = Lambda_exp * eval_polynomial(coefficients_4_SS,energy) ELSE IF(energy.gt. 3E-2 .and. energy.le. 5E-2) THEN compute_yield = Lambda_exp * eval_polynomial(coefficients_5_SS,energy) END IF CASE(2) ! Copper IF(energy.le. 1E-3 ) THEN SELECT CASE(neuttype_id) CASE(1) compute_yield = eval_polynomial(coefficients_1H_Cu, energy) CASE(2) compute_yield = eval_polynomial(coefficients_1He_Cu, energy) CASE(3) compute_yield = eval_polynomial(coefficients_1Ne_Cu, energy) CASE DEFAULT compute_yield = eval_polynomial(coefficients_1H_Cu, energy) END SELECT ELSE IF(energy.gt. 1E-3 .and. energy.le. 1E-2) THEN compute_yield = Lambda_exp * eval_polynomial(coefficients_2_Cu,energy) ELSE IF(energy.gt. 1E-2 .and. energy.le. 2E-2 ) THEN compute_yield = Lambda_exp * eval_polynomial(coefficients_3_Cu,energy) ELSE IF(energy.gt. 2E-2 .and. energy.le. 3E-2) THEN compute_yield = Lambda_exp * eval_polynomial(coefficients_4_Cu,energy) ELSE IF(energy.gt. 3E-2 .and. energy.le. 5E-2) THEN compute_yield = Lambda_exp * eval_polynomial(coefficients_5_Cu,energy) END IF CASE(3) ! Alumium IF(energy.le. 1E-3 ) THEN SELECT CASE(neuttype_id) CASE(1) compute_yield = eval_polynomial(coefficients_1H_Al, energy) CASE(2) compute_yield = eval_polynomial(coefficients_1He_Al, energy) CASE(3) compute_yield = eval_polynomial(coefficients_1Ne_Al, energy) CASE DEFAULT compute_yield = eval_polynomial(coefficients_1H_Al, energy) END SELECT ELSE IF(energy.gt. 1E-3 .and. energy.le. 1E-2) THEN compute_yield = Lambda_exp * eval_polynomial(coefficients_2_Al,energy) ELSE IF(energy.gt. 1E-2 .and. energy.le. 2E-2 ) THEN compute_yield = Lambda_exp * eval_polynomial(coefficients_3_Al,energy) ELSE IF(energy.gt. 2E-2 .and. energy.le. 3E-2) THEN compute_yield = Lambda_exp * eval_polynomial(coefficients_4_Al,energy) ELSE IF(energy.gt. 3E-2 .and. energy.le. 5E-2) THEN compute_yield = Lambda_exp * eval_polynomial(coefficients_5_Al,energy) END IF END SELECT END FUNCTION compute_yield !--------------------------------------------------------------------------- ! FUNCTION gen_elec(lambda, kmax) ! ! ! DESCRIPTION !> Gives random values distributed !> following a Poisson distrib. of parameter !> lambda = yield(E) for incomin ion energy E !-------------------------------------------------------------------------- INTEGER FUNCTION gen_elec(lambda, kmax) USE random REAL(KIND = db) :: lambda !< Lambda parameter for Poisson distribution REAL(KIND = db) :: nb_alea(1:1) !< random number unif. generated in [0,1] INTEGER :: kmax !< max number possible from Poisson REAL(KIND = db) :: CumulPoisson !< Flag to ensure CDF ~ 1 INTEGER :: i, ii !< loop indices REAL(KIND = db), DIMENSION(kmax) :: vect, SumPart !< terms, partial sums for CDF !> Compute probabilities for each int. value and CDF values DO i = 1,kmax vect(i) = exp(-lambda)*lambda**(i-1)/factorial_fun(i-1); SumPart(i) = sum(vect(1:i)); END DO !> CDF expected to sum to 1 CumulPoisson = sum(vect) !> Generate poisson distrib. int. (see Matlab. code for convg.) call random_array(nb_alea,1,ran_index(1),ran_array(:,1)) DO ii = 1,size(SumPart)-1 IF (nb_alea(1) .lt. SumPart(1)) THEN gen_elec = 0 ELSE IF ((SumPart(ii).le.nb_alea(1)) .and. (nb_alea(1) .lt. SumPart(ii+1))) THEN gen_elec = ii END IF END DO ! Below: see Intel oneAPI Math Kernel Library - Fortran ! to optimise running speed when generating random numbers ! TO DO : change if enough time !----------------------------------------------------------- ! ! INTEGER, INTENT(IN) :: method ! TYPE (VSL_STREAM_STATE), INTENT(IN) :: stream ! INTEGER, INTENT(IN) :: n = 1 ! INTEGER, INTENT(IN) :: r ! status = virngpoisson( method, stream, n, r, lambda ) ! gen_elec = r ! !------------------------------------------------------------ END FUNCTION gen_elec !--------------------------------------------------------------------------- ! FUNCTION gen_E_gamma(kappa, theta, Emax) ! ! ! DESCRIPTION !> Gives random values distributed !> following a Gamma distrib. of parameters (kappa, theta) !> in [0, Emax] eV and peaked at E=2eV !-------------------------------------------------------------------------- FUNCTION gen_E_gamma(kappa, theta, Emax) RESULT(E_el) USE random USE incomplete_gamma REAL(KIND = db) :: E_el, Emin, Emax REAL(KIND = db) :: kappa, theta !> parameters to shape Gamma_distr REAL(KIND = db) :: nb_alea(1:1) REAL(KIND = db), DIMENSION(1000) :: Einc, CDF, Diff INTEGER :: ii !> loop index INTEGER :: ifault INTEGER :: posid Emin = 0.00 Emax = 25.0 kappa = 4.0 theta = 0.5 DO ii= 1,size(Einc) Einc(ii) = ( Emin + (ii-1)*(Emax-Emin)/(size(Einc)-1) ) CDF(ii) = gamain(Einc(ii)/theta, kappa, ifault) END DO !> Generate Gamma distrib. int. (see Matlab. code for convg.) call random_array(nb_alea,1,ran_index(1),ran_array(:,1)) Diff = abs(nb_alea(1) - CDF) posid = minloc(Diff, dim = 1) E_el = Einc(posid) END FUNCTION gen_E_gamma !--------------------------------------------------------------------------- ! FUNCTION factorial_fun(n) ! ! ! DESCRIPTION !> Gives the factorial of an integer !-------------------------------------------------------------------------- INTEGER FUNCTION factorial_fun(n) INTEGER :: ii INTEGER :: n factorial_fun = 1 IF (n .lt. 0) THEN RETURN ELSE IF (n == 0) THEN factorial_fun = 1 ELSE DO ii=1,n factorial_fun = factorial_fun*ii END DO END IF END FUNCTION factorial_fun END MODULE iiee diff --git a/src/magnet_mod.f90 b/src/magnet_mod.f90 new file mode 100644 index 0000000..f032881 --- /dev/null +++ b/src/magnet_mod.f90 @@ -0,0 +1,402 @@ +module magnet + use constants + IMPLICIT NONE + + type elongatedcoil + real(kind=db):: axialdims(2) + real(kind=db):: radialdims(2) + real(kind=db):: center(2) + integer:: nbsubcoils(2) + real(kind=db):: current + real(kind=db):: Nturns + end type elongatedcoil + + type(elongatedcoil), allocatable:: the_coils(:) + + contains + + +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> Initialize the magnetic field from the standard input +!> @param[in] fileid file identifier of the input corresponding to the run parameters +!> @param[in] cstep current simulation step number +!--------------------------------------------------------------------------- + subroutine magnet_init(fileid,cstep) + use basic, ONLY:B0,rnorm,bnorm,rgrid,zgrid,width,Rcurv,mpirank,Athet,Br,Bz,bscaling,magnetfile + use mpi + IMPLICIT NONE + integer:: fileid, cstep, istat, ierr + integer :: magfiletype = 0 + character(256):: line='' + + NAMELIST /magnetparams/ magnetfile, magfiletype, bscaling + + ! read the input parameters from file + Rewind(fileid) + READ(fileid, magnetparams, iostat=istat) + + ! save the parameters on output + IF(mpirank .eq. 0) THEN + WRITE(*, magnetparams) + END IF + + if (istat.gt.0) then + backspace(fileid) + read(fileid,fmt='(A)') line + write(*,'(A)') & + 'Invalid line in magnetparams: '//trim(line) + call MPI_Abort(MPI_COMM_WORLD, -1, ierr) + stop + end if + + if(magfiletype .eq. 1)then + call read_magfile_txt(magnetfile,the_coils) + call compute_B_on_grid(Athet,Br,Bz,rgrid*rnorm,zgrid*rnorm) + else if(magfiletype .eq. 0 .and. len_trim(magnetfile) .lt. 1)then + call magmirror(Athet,Br,Bz,rgrid,zgrid,rnorm,B0,Rcurv,width) + else + CALL load_mag_from_h5(magnetfile,Athet,Br,Bz,rgrid,zgrid, B0, rnorm,bscaling) + end if + + ! We normalise the magnetic fields + Br=Br/bnorm + Bz=Bz/bnorm + + + + + end subroutine + +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> Loads the magnetic field defined in the .h5 file at location magfile +!> @param[in] magfile filname of .h5 file containing the definitions of A and B +!--------------------------------------------------------------------------- + SUBROUTINE load_mag_from_h5(magfile, Athet,Br,Bz,rgrid,zgrid, B0, rnorm,bscaling) + USE constants, ONLY: Pi + USE futils + USE bsplines + CHARACTER(LEN=*), INTENT(IN):: magfile + REAL(kind=db), ALLOCATABLE :: magr(:), magz(:) + REAL(kind=db), ALLOCATABLE :: tempBr(:, :), tempBz(:, :), tempAthet(:, :) + real(kind=db), allocatable:: c(:,:) + real(kind=db)::B0,rnorm + Integer:: bscaling, nr, nz,i + real(kind=db):: Athet(:), Br(:), Bz(:) + Real(kind=db):: zgrid(0:), rgrid(0:) + Real(kind=db), ALLOCATABLE:: vec1(:), vec2(:) + type(spline2d):: Maginterpolation + REAL(kind=db) :: maxB + INTEGER :: magfid, dims(2) + LOGICAL:: B_is_saved + INTEGER :: magn(2), magrank + + CALL openf(trim(magfile), magfid, 'r', real_prec='d') + + CALL getdims(magfid, '/mag/Athet', magrank, magn) + + nr=size(rgrid,1)-1 + nz=size(zgrid,1)-1 + + ! Auxiliary vectors + ALLOCATE(vec1((nz+1)*(nr+1)),vec2((nr+1)*(nz+1))) + DO i=0,nr + vec1(i*(nz+1)+1:(i+1)*(nz+1))=zgrid!(0:nz) + vec2(i*(nz+1)+1:(i+1)*(nz+1))=rgrid(i) + END DO + + ALLOCATE (magr(magn(2)), magz(magn(1))) + ALLOCATE (tempAthet(magn(1), magn(2)), tempBr(magn(1), magn(2)), tempBz(magn(1), magn(2))) + + ! Read r and z coordinates for the definition of A_\thet, and B + CALL getarr(magfid, '/mag/r', magr) + CALL getarr(magfid, '/mag/z', magz) + CALL getarr(magfid, '/mag/Athet', tempAthet) + + IF (isdataset(magfid, '/mag/Br') .and. isdataset(magfid, '/mag/Bz')) THEN + CALL getarr(magfid, '/mag/Br', tempBr) + CALL getarr(magfid, '/mag/Bz', tempBz) + IF(bscaling .gt. 0) then + maxB=sqrt(maxval(tempBr**2+tempBz**2)) + tempBr=tempBr/maxB*B0 + tempBz=tempBz/maxB*B0 + end if + B_is_saved = .true. + ELSE + B_is_saved = .false. + END IF + + magz=magz/rnorm + magr=magr/rnorm + CALL set_splcoef((/3,3/),magz,magr,Maginterpolation) + call get_dim(Maginterpolation,dims) + + ! Interpolation of the magnetic potential vector + allocate(c(dims(1),dims(2))) + call get_splcoef(Maginterpolation,tempAthet, c) + CALL gridval(Maginterpolation,vec1,vec2, Athet ,(/0,0/),c) + + + + if(B_is_saved == .true.)then + ! Interpolation of the Axial magnetic field + call get_splcoef(Maginterpolation,tempBz, c) + CALL gridval(Maginterpolation,vec1,vec2, Bz ,(/0,0/),c) + + ! Interpolation of the radial magnetic field + call get_splcoef(Maginterpolation,tempBr, c) + CALL gridval(Maginterpolation,vec1,vec2, Br ,(/0,0/),c) + else + CALL gridval(Maginterpolation,vec1,vec2, Br,(/1,0/)) + Br=-Br + CALL gridval(Maginterpolation,vec1,vec2, Bz,(/0,1/)) + Bz=Bz+Athet/vec2 + end if + + + if( bscaling .lt. 0 ) then + maxB = maxval(sqrt(Bz**2 + Br**2)) + + Bz = Bz/maxB*B0 + Br = Br/maxB*B0 + end if + + CALL closef(magfid) + deallocate(c) + call destroy_SP(Maginterpolation) + END SUBROUTINE load_mag_from_h5 + + +!--------------------------------------------------------------------------- +!> @author +!> Patryk kaminski EPFL/SPC +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> Computes the magnetic field on the grid according to a magnetic mirror +!> @param[out] Athet magnetic potential vector +!> @param[out] Br radial magnetic field on the grid +!> @param[out] Bz Axial magnetic field on the grid +!> @param[in] rgrid radial grid points +!> @param[in] zgrid axial grid points +!> @param[in] rnorm normalisation distance constant +!> @param[in] B0 maximum mag field amplitude on axis +!> @param[in] Rcurv magnetic mirror R=max(B)/min(B) parameter +!> @param[in] width distance between the two mirror coils [m] +!> +!--------------------------------------------------------------------------- + subroutine magmirror(Athet,Br,Bz,rgrid,zgrid,rnorm,B0,Rcurv,width) + USE constants, ONLY: Pi + real(kind=db):: Athet(:), Br(:), Bz(:) + REAL(kind=db) :: rg, zg, halfLz, rnorm, Rcurv, MirrorRatio, width, B0 + Real(kind=db):: zgrid(:), rgrid(:) + INTEGER :: i, rindex, nr, nz + nr=size(rgrid,1)-1 + nz=size(zgrid,1)-1 + halfLz = (zgrid(nz) + zgrid(0))/2 + MirrorRatio = (Rcurv - 1)/(Rcurv + 1) + DO i = 1, (nr + 1)*(nz + 1) + rindex = (i - 1)/(nz + 1) + rg = rgrid(rindex) + zg = zgrid(i - rindex*(nz + 1) - 1) - halfLz + Br(i) = -B0*MirrorRatio*SIN(2*pi*zg/width*rnorm)*bessi1(2*pi*rg/width*rnorm) + Bz(i) = B0*(1 - MirrorRatio*COS(2*pi*zg/width*rnorm)*bessi0(2*pi*rg/width*rnorm)) + Athet(i) = 0.5*B0*(rg*rnorm - width/pi*MirrorRatio*bessi1(2*pi*rg/width*rnorm)*COS(2*pi*zg/width*rnorm)) + END DO + + end subroutine + + !________________________________________________________________________________ +!Modified Bessel functions of the first kind of the zero order + FUNCTION bessi0(x) + REAL(kind=db) :: bessi0, x + REAL(kind=db) :: ax + REAL(kind=db) p1, p2, p3, p4, p5, p6, p7, q1, q2, q3, q4, q5, q6, q7, q8, q9, y + SAVE p1, p2, p3, p4, p5, p6, p7, q1, q2, q3, q4, q5, q6, q7, q8, q9 + DATA p1, p2, p3, p4, p5, p6, p7/1.0d0, 3.5156229d0, 3.0899424d0, 1.2067492d0, 0.2659732d0, 0.360768d-1, 0.45813d-2/ + DATA q1, q2, q3, q4, q5, q6, q7, q8, q9/0.39894228d0, 0.1328592d-1, 0.225319d-2, -0.157565d-2, 0.916281d-2, & + & -0.2057706d-1, 0.2635537d-1, -0.1647633d-1, 0.392377d-2/ + if (abs(x) .lt. 3.75) then + y = (x/3.75)**2 + bessi0 = p1 + y*(p2 + y*(p3 + y*(p4 + y*(p5 + y*(p6 + y*p7))))) + else + ax = abs(x) + y = 3.75/ax + bessi0 = (exp(ax)/sqrt(ax))*(q1 + y*(q2 + y*(q3 + y*(q4 + y*(q5 + y*(q6 + y*(q7 + y*(q8 + y*q9)))))))) + end if + return + END FUNCTION bessi0 +!________________________________________________________________________________ +!Modified Bessel functions of the first kind of the first order + FUNCTION bessi1(x) + REAL(kind=db) :: bessi1, x + REAL(kind=db) :: ax + REAL(kind=db) p1, p2, p3, p4, p5, p6, p7, q1, q2, q3, q4, q5, q6, q7, q8, q9, y + SAVE p1, p2, p3, p4, p5, p6, p7, q1, q2, q3, q4, q5, q6, q7, q8, q9 + DATA p1, p2, p3, p4, p5, p6, p7/0.5d0, 0.87890594d0, 0.51498869d0, 0.15084934d0, 0.2658733d-1, 0.301532d-2, 0.32411d-3/ + DATA q1, q2, q3, q4, q5, q6, q7, q8, q9/0.39894228d0, -0.3988024d-1, -0.362018d-2, 0.163801d-2, -0.1031555d-1, & + & 0.2282967d-1, -0.2895312d-1, 0.1787654d-1, -0.420059d-2/ + if (abs(x) .lt. 3.75D0) then + y = (x/3.75D0)**2 + bessi1 = x*(p1 + y*(p2 + y*(p3 + y*(p4 + y*(p5 + y*(p6 + y*p7)))))) + else + ax = abs(x) + y = 3.75D0/ax + bessi1 = (exp(ax)/sqrt(ax))*(q1 + y*(q2 + y*(q3 + y*(q4 + y*(q5 + y*(q6 + y*(q7 + y*(q8 + y*q9)))))))) + if (x .lt. 0.) bessi1 = -bessi1 + end if + return + END FUNCTION bessi1 + + ! calculation of the magnetic potential vector and magnetic fields + ! using elliptic integrals + ! see Smythe "static and dynamic electricity" McGraw-Hill, third edition p.290 + subroutine compute_B_on_grid(A,Br,Bz,r,z) + use elliptic + use constants + implicit none + real(kind=db):: A(:), Br(:), Bz(:) + real(kind=db):: r(:), z(:) + integer:: i,j,k, l, n,linindex, nr,nz, ncoils + Real(kind=db):: kappa2, rho, distz, dr, dz + Real(kind=db):: r_wire, z_wire + Real(kind=db):: r_cen, z_cen, u, v, w, t + Real(kind=db):: EE, EK + Real(kind=db):: Isubcoil, coilsurf, Itot, currfac + nr=size(r,1) + nz=size(z,1) + ncoils=size(the_coils,1) + + !$OMP PARALLEL DO PRIVATE(j,i,linindex,k,dr,dz,z_cen,r_cen,coilsurf,Itot,Isubcoil,l,z_wire,n,r_wire,kappa2,EE,EK, u,v,w,t,distz, currfac) + Do j=1,nr + Do i=1,nz + linindex=i+(j-1)*size(z,1) + A(linindex)=0.0_db + Bz(linindex)=0.0_db + Br(linindex)=0.0_db + Do k=1,ncoils + dr = (the_coils(k)%radialdims(2)-the_coils(k)%radialdims(1)) + dz = (the_coils(k)%axialdims(2)-the_coils(k)%axialdims(1)) + r_cen = (the_coils(k)%radialdims(2)+the_coils(k)%radialdims(1))/2 + z_cen = (the_coils(k)%axialdims(2)+the_coils(k)%axialdims(1))/2 + coilsurf = dr * dz; + Itot = the_coils(k)%current*the_coils(k)%Nturns + Isubcoil = Itot/(the_coils(k)%nbsubcoils(1)*the_coils(k)%nbsubcoils(2)) + currfac = mu_0*Isubcoil/pi + Do l=1,the_coils(k)%nbsubcoils(1) + z_wire = (z_cen - dz/2) + (dz/the_coils(k)%nbsubcoils(1))*(l-0.5) + distz = (z(i)-z_wire) + Do n=1,the_coils(k)%nbsubcoils(2) + + r_wire=(r_cen - dr/2) + (dr/the_coils(k)%nbsubcoils(2))*(n-0.5); + + u=(r_wire+r(j))**2+distz**2 + v=(r_wire-r(j))**2+distz**2 + w=r_wire**2+r(j)**2+distz**2 + t=r_wire**2-r(j)**2-distz**2 + kappa2=4*r_wire*r(j)/u + + EK=elliptic_fk(sqrt(kappa2)) ! complete Elliptic integral of the first kind + EE=elliptic_ek(sqrt(kappa2)) ! complete Elliptic integral of the second kind + + if(r(j).gt.0.0_db)then + A(linindex)=A(linindex)+currfac*sqrt(r_wire/(r(j)*kappa2))*& + & ((1-kappa2/2)*EK-EE) + + Br(linindex)=Br(linindex)+currfac/2* & + & distz/(r(j)*sqrt(u))*(-EK+w/v*EE) + end if + + Bz(linindex)=Bz(linindex)+currfac/2* & + & 1/sqrt(u)*(EK+t/v*EE) + end do + end do + end do + end do + !WRITE(*,*)"id done",j,'over',nr + end do + !$OMP END PARALLEL DO + + + + end subroutine + + + subroutine read_magfile_txt(magnetfile,the_coils) + type(elongatedcoil), allocatable:: the_coils(:) + character(128):: magnetfile + INTEGER:: nb_coils + INTEGER :: lu_magfile=999 + INTEGER:: i, openerr, reason + CHARACTER(len=256) :: header + real(kind=db):: z1,z2, r1, r2, current + integer:: Nr, Nz + real(kind=db):: Nturns + + if(allocated(the_coils)) deallocate(the_coils) + + nb_coils=0 + + OPEN(UNIT=lu_magfile,FILE=trim(magnetfile),ACTION='READ',IOSTAT=openerr) + header=' ' + IF(openerr .ne. 0) THEN + CLOSE(unit=lu_magfile) + RETURN + END IF + + ! The magnet table is defined as a 8 column (zmin zmax rmin rmax nturns Nz Nr current) + DO WHILE(.true.) + READ(lu_magfile,'(a)',IOSTAT=reason) header + header=adjustl(header) + if(reason .lt. 0 ) exit ! We reached end of file + if( header(1:1) .ne. '!'.and. len_trim(header) .gt. 1) then + READ(header,*,IOSTAT=reason) z1,z2, r1, r2, nturns, Nz, Nr, current + if(reason .lt. 0 ) then + WRITE(*,*) "Error in magnet definition of file: ",magnetfile,"\n with input ", header + exit + end if + nb_coils=nb_coils+1 + end if + END DO + allocate(the_coils(nb_coils)) + REWIND(lu_magfile) + + ! The magnet table is defined as a 8 column (zmin zmax rmin rmax nturns Nz Nr current) + i=1 + write(*,*) "number of found coils", nb_coils + DO WHILE(i .le. nb_coils) + READ(lu_magfile,'(a)',IOSTAT=reason) header + header=adjustl(header) + !Write(*,*) i,' ',trim(header) + if(reason .lt. 0 ) exit ! We reached end of file + if( header(1:1) .ne. '!' .and. len_trim(header) .gt. 1) then + READ(header,*,IOSTAT=reason) z1,z2, r1, r2, nturns, Nz, Nr, current + the_coils(i)%axialdims=(/z1,z2/) + the_coils(i)%radialdims=(/r1,r2/) + the_coils(i)%Nturns=nturns + the_coils(i)%nbsubcoils=(/Nz,Nr/) + the_coils(i)%current=current + !Write(*,*) i,' ',the_coils(i)%axialdims, the_coils(i)%radialdims, the_coils(i)%Nturns,the_coils(i)%nbsubcoils,the_coils(i)%current + i=i+1 + end if + + END DO + CLOSE(unit=lu_magfile) + + end subroutine + + +end module magnet \ No newline at end of file diff --git a/src/mpihelper_mod.f90 b/src/mpihelper_mod.f90 index 7fc9df0..55afb20 100644 --- a/src/mpihelper_mod.f90 +++ b/src/mpihelper_mod.f90 @@ -1,364 +1,366 @@ !------------------------------------------------------------------------------ ! EPFL/Swiss Plasma Center !------------------------------------------------------------------------------ ! ! MODULE: mpihelper ! !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> Module responsible for setting up the MPI variables used in the communications. !------------------------------------------------------------------------------ MODULE mpihelper USE constants use mpi USE particletypes IMPLICIT NONE INTEGER, SAVE :: basicdata_type=MPI_DATATYPE_NULL !< Stores the MPI data type used for communicating basicdata INTEGER, SAVE :: particle_type=MPI_DATATYPE_NULL !< Stores the MPI data type used for particles communication between nodes !INTEGER, SAVE :: particles_type=MPI_DATATYPE_NULL !< Stores the MPI data type used for particles gathering on node 0 and broadcast from node 0 INTEGER, SAVE :: rhsoverlap_type=MPI_DATATYPE_NULL !< Stores the MPI data type used for the communication of a rhs column INTEGER, SAVE :: db_type=MPI_DATATYPE_NULL !< Stores the MPI data type used for the communication of a REAL(kind=db) INTEGER, SAVE :: momentsoverlap_type=MPI_DATATYPE_NULL !< Stores the MPI data type used for the communication of a column of a grid variable INTEGER, SAVE :: rcvrhsoverlap_type=MPI_DATATYPE_NULL !< Stores the MPI data type used for the receive communication of a rhs column INTEGER, SAVE :: rcvmomentsoverlap_type=MPI_DATATYPE_NULL !< Stores the MPI data type used for the receive communication of a column of a grid variable INTEGER, SAVE:: db_sum_op !< Store the MPI sum operation for db_type REAL(kind=db), ALLOCATABLE, SAVE:: rhsoverlap_buffer(:) !< buffer used for storing the rhs ghost cells !< received from the left or right MPI process REAL(kind=db), ALLOCATABLE, SAVE:: momentsoverlap_buffer(:) !< buffer used for storing the moments ghost cells !< received from the left or right MPI process !INTEGER, SAVE:: momentsoverlap_requests(2) = MPI_REQUEST_NULL !INTEGER, SAVE:: rhsoverlap_requests(2) = MPI_REQUEST_NULL INTEGER:: rhsoverlap_tag= 200 INTEGER:: momentsoverlap_tag= 300 INTEGER:: partsgather_tag= 500 INTEGER:: partsexchange_tag=600 INTEGER:: nbpartsexchange_tag=700 CONTAINS !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Initialize the MPI types used for inter process communications ! !--------------------------------------------------------------------------- SUBROUTINE mpitypes_init IMPLICIT NONE INTEGER:: ierr ! Initialize db_type to use real(kind=db) in MPI and the sum operator for reduce CALL MPI_TYPE_CREATE_F90_REAL(dprequestedprec,MPI_UNDEFINED,db_type,ierr) CALL MPI_Type_commit(db_type,ierr) CALL MPI_Op_Create(DB_sum, .true., db_sum_op, ierr) CALL init_particlempi END SUBROUTINE mpitypes_init !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Computes the sum in MPI_Reduce operations involving Real(kinc=db) ! !--------------------------------------------------------------------------- SUBROUTINE DB_sum(INVEC, INOUTVEC, LEN, TYPE)bind(c) !REAL(kind=db):: INVEC(0:LEN-1), INOUTVEC(0:LEN-1) use, intrinsic:: iso_c_binding, ONLY: c_ptr,c_f_pointer use mpi implicit none TYPE(C_PTR), VALUE:: invec, inoutvec real(kind=db),pointer:: ivec(:), iovec(:) INTEGER:: LEN INTEGER:: TYPE INTEGER:: i call c_f_pointer(INVEC,ivec, (/len/)) call c_f_pointer(inoutvec,iovec, (/len/)) Do i=1,LEN IOVEC(i)=IVEC(i)+IOVEC(i) END DO END SUBROUTINE DB_sum !-------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Initialize the MPI communicators used for allreduce between neighbors ! !> @param[in] nrank ranks of the FEM array in (1) z direction and (2) r direction !> @param[in] femorder finite element method order in z and r direction !> @param[in] zlimleft z index delimiting the mpi local left boundary !> @param[in] zlimright z index delimiting the mpi local right boundary !> @param[in] nbmoments number of moments calculated and stored. ! !--------------------------------------------------------------------------- SUBROUTINE init_overlaps(nrank, femorder, zlimleft, zlimright, nbmoments) INTEGER, INTENT(IN):: nrank(:), femorder(:), zlimright, zlimleft, nbmoments IF(ALLOCATED(rhsoverlap_buffer)) DEALLOCATE(rhsoverlap_buffer) IF(ALLOCATED(momentsoverlap_buffer)) DEALLOCATE(momentsoverlap_buffer) ALLOCATE(rhsoverlap_buffer(nrank(2)*femorder(1))) ALLOCATE(momentsoverlap_buffer(nbmoments*nrank(2)*femorder(1))) ! Initialize the MPI column overlap type for rhs CALL init_coltypempi(nrank(2), zlimright-zlimleft+femorder(1), 1, 1, db_type, rhsoverlap_type) ! Initialize the MPI grid col type CALL init_coltypempi(nrank(2), zlimright-zlimleft+femorder(1), nbmoments, 1, db_type, momentsoverlap_type) ! Initialize the MPI receive column overlap type for rhs CALL init_coltypempi(nrank(2), nrank(1), 1, 1, db_type, rcvrhsoverlap_type) ! Initialize the MPI receive grid col type CALL init_coltypempi(nrank(2), nrank(1), nbmoments, 1, db_type, rcvmomentsoverlap_type) END SUBROUTINE init_overlaps SUBROUTINE start_persistentcomm(requests, mpirank, leftproc, rightproc) INTEGER,INTENT(INOUT):: requests(:) INTEGER, INTENT(IN):: mpirank, leftproc, rightproc INTEGER:: ierr INTEGER:: stats(MPI_STATUS_SIZE,2) LOGICAL:: completed=.false. IF(leftproc .lt. mpirank) THEN ! Start to receive CALL MPI_START(requests(2),ierr) IF(IERR .ne. MPI_SUCCESS) WRITE(*,*) "error in recv_init" END IF IF(rightproc .gt. mpirank) THEN ! Start to send CALL MPI_START(requests(1),ierr) IF(IERR .ne. MPI_SUCCESS) WRITE(*,*) "error in send_init" END IF IF(leftproc .lt. mpirank) THEN ! Start to receive completed=.FALSE. DO WHILE(.not. completed) CALL MPI_TEST(requests(2), completed,stats(:,2),ierr) END DO WRITE(*,*)"status 2", completed, stats(:,2) !CALL MPI_WAIT(requests(2),stats(:,2),ierr) !WRITE(*,*)"status 2", stats(:,2) IF(IERR .ne. MPI_SUCCESS) WRITE(*,*) "error in recv_init" END IF IF(rightproc .gt. mpirank) THEN ! Start to send completed=.FALSE. DO WHILE(.not. completed) CALL MPI_TEST(requests(1), completed,stats(:,1),ierr) END DO !CALL MPI_WAIT(requests(1),stats(:,1),ierr) IF(IERR .ne. MPI_SUCCESS) WRITE(*,*) "error in send_init" END IF END SUBROUTINE start_persistentcomm SUBROUTINE rhsoverlapcomm(mpirank, leftproc, rightproc, moments, nrank, femorder, zlimright) INTEGER, INTENT(IN):: mpirank, leftproc, rightproc REAL(kind=db), DIMENSION(:), INTENT(INOUT):: moments INTEGER, INTENT(IN):: nrank(2), femorder(2), zlimright INTEGER, SAVE:: rhsoverlap_requests(2) = MPI_REQUEST_NULL INTEGER:: ierr INTEGER:: stats(MPI_STATUS_SIZE,2) rhsoverlap_requests=MPI_REQUEST_NULL rhsoverlap_buffer=0 IF(rightproc .gt. mpirank .and. rightproc .ge. 0) THEN CALL MPI_ISEND(moments(zlimright+1), femorder(1), rhsoverlap_type, rightproc, rhsoverlap_tag, & & MPI_COMM_WORLD, rhsoverlap_requests(1), ierr ) END IF ! If the processor on the left has actually lower z positions IF(leftproc .lt. mpirank .and. leftproc .ge. 0) THEN CALL MPI_IRECV(rhsoverlap_buffer, nrank(2)*(femorder(1)), db_type, leftproc, rhsoverlap_tag, & & MPI_COMM_WORLD, rhsoverlap_requests(2), ierr ) END IF CALL MPI_WAITALL(2,rhsoverlap_requests,stats, ierr) END SUBROUTINE rhsoverlapcomm SUBROUTINE momentsoverlapcomm(mpirank, leftproc, rightproc, moments, nrank, femorder, zlimright) INTEGER, INTENT(IN):: mpirank, leftproc, rightproc REAL(kind=db), DIMENSION(:,:), INTENT(INOUT):: moments INTEGER, INTENT(IN):: nrank(2), femorder(2), zlimright INTEGER, SAVE:: momentsoverlap_requests(2) = MPI_REQUEST_NULL INTEGER:: ierr INTEGER:: stats(MPI_STATUS_SIZE,2) momentsoverlap_requests=MPI_REQUEST_NULL momentsoverlap_buffer=0 IF(rightproc .gt. mpirank .and. rightproc .ge. 0) THEN CALL MPI_ISEND(moments(1,zlimright+1), femorder(1), momentsoverlap_type, rightproc, momentsoverlap_tag, & & MPI_COMM_WORLD, momentsoverlap_requests(1), ierr ) END IF ! If the processor on the left has actually lower z positions IF(leftproc .lt. mpirank .and. leftproc .ge. 0) THEN CALL MPI_IRECV(momentsoverlap_buffer, 10*nrank(2)*(femorder(1)), db_type, leftproc, momentsoverlap_tag, & & MPI_COMM_WORLD, momentsoverlap_requests(2), ierr ) END IF CALL MPI_WAITALL(2,momentsoverlap_requests,stats, ierr) END SUBROUTINE momentsoverlapcomm !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Initialize the particle MPI type used for inter process communications and publish it to !> the process in the communicator ! !--------------------------------------------------------------------------- SUBROUTINE init_particlempi() INTEGER :: nblock = 5 INTEGER:: blocklength(5) INTEGER(kind=MPI_ADDRESS_KIND):: displs(5), displ0 INTEGER:: types(5) TYPE(particle) :: part INTEGER:: ierr CALL mpi_get_address(part%partindex, displs(1), ierr) types(1)=MPI_INTEGER CALL mpi_get_address(part%pos, displs(2), ierr) CALL mpi_get_address(part%U, displs(3), ierr) CALL mpi_get_address(part%GAMMA, displs(4), ierr) CALL mpi_get_address(part%pot, displs(5), ierr) types(2:5)=db_type blocklength(1:5) = 1 blocklength(2:3)=3 CALL mpi_get_address(part, displ0, ierr) displs=displs-displ0 CALL MPI_Type_create_struct(nblock, blocklength, displs, types, particle_type, ierr) CALL MPI_Type_commit(particle_type,ierr) END SUBROUTINE init_particlempi !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Initialize the particles MPI type used for gathering particles to the root and broadcast them and publish it to !> the process in the communicator ! !--------------------------------------------------------------------------- SUBROUTINE init_particles_gather_mpi(p,idstart,nsend,mpi_particles_type) INTEGER:: mpi_particles_type INTEGER:: nsend INTEGER:: idstart - INTEGER :: nblock = 9 - INTEGER:: blocklength(9) - INTEGER(kind=MPI_ADDRESS_KIND):: displs(9), displ0 - INTEGER:: types(9) + INTEGER :: nblock = 8 + INTEGER:: blocklength(8) + INTEGER(kind=MPI_ADDRESS_KIND):: displs(8), displ0 + INTEGER:: types(8) TYPE(particles), INTENT(INOUT):: p INTEGER:: ierr INTEGER:: temptype IF(nsend .lt. 1) RETURN temptype=MPI_DATATYPE_NULL IF( mpi_particles_type .ne. MPI_DATATYPE_NULL) CALL MPI_TYPE_FREE(mpi_particles_type,ierr) - CALL mpi_get_address(p%Rindex(idstart), displs(1), ierr) - CALL mpi_get_address(p%Zindex(idstart), displs(2), ierr) - CALL mpi_get_address(p%partindex(idstart), displs(3), ierr) - types(1:3)=MPI_INTEGER - CALL mpi_get_address(p%pos(1,idstart), displs(4), ierr) + !CALL mpi_get_address(p%Rindex(idstart), displs(1), ierr) + !CALL mpi_get_address(p%Zindex(idstart), displs(2), ierr) + CALL mpi_get_address(p%cellindex(1,idstart), displs(1), ierr) + CALL mpi_get_address(p%partindex(idstart), displs(2), ierr) + types(1:2)=MPI_INTEGER + CALL mpi_get_address(p%pos(1,idstart), displs(3), ierr) !CALL mpi_get_address(p%Z(idstart), displs(5), ierr) !CALL mpi_get_address(p%THET(idstart), displs(6), ierr) - CALL mpi_get_address(p%pot(idstart), displs(5), ierr) - CALL mpi_get_address(p%U(1,idstart), displs(6), ierr) - CALL mpi_get_address(p%Uold(1,idstart), displs(7), ierr) + CALL mpi_get_address(p%pot(idstart), displs(4), ierr) + CALL mpi_get_address(p%U(1,idstart), displs(5), ierr) + CALL mpi_get_address(p%Uold(1,idstart), displs(6), ierr) !CALL mpi_get_address(p%UTHET(idstart), displs(10), ierr) !CALL mpi_get_address(p%UTHETold(idstart), displs(11), ierr) !CALL mpi_get_address(p%UZ(idstart), displs(12), ierr) !CALL mpi_get_address(p%UZold(idstart), displs(13), ierr) - CALL mpi_get_address(p%GAMMA(idstart), displs(8), ierr) - CALL mpi_get_address(p%GAMMAold(idstart), displs(9), ierr) - types(4:9)=db_type + CALL mpi_get_address(p%GAMMA(idstart), displs(7), ierr) + CALL mpi_get_address(p%GAMMAold(idstart), displs(8), ierr) + types(3:8)=db_type blocklength = nsend - blocklength(4)=3*nsend - blocklength(6:7)=3*nsend + blocklength(1)=3*nsend + blocklength(3)=3*nsend + blocklength(5:6)=3*nsend CALL mpi_get_address(p, displ0, ierr) displs=displs-displ0 CALL MPI_Type_create_struct(nblock, blocklength, displs, types, mpi_particles_type, ierr) CALL MPI_TYPE_COMMIT(mpi_particles_type, ierr) END SUBROUTINE init_particles_gather_mpi !--------------------------------------------------------------------------- !> @author Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> @brief Initialize the column MPI type used for inter process communications and publish it to !> the processes in the communicator (can be rhs or grid quantities) ! !> @param[in] nr number of elements in the r direction !> @param[in] nz number of elements in the z direction !> @param[in] init_type MPI type of the initial data !> @param[inout] mpi_coltype final type usable in communications !--------------------------------------------------------------------------- SUBROUTINE init_coltypempi(nr, nz, block_size, stride, init_type, mpi_coltype) INTEGER, INTENT(IN) :: nr INTEGER, INTENT(IN) :: nz INTEGER, INTENT(IN) :: block_size INTEGER, INTENT(IN) :: stride INTEGER, INTENT(IN) :: init_type INTEGER, INTENT(OUT) :: mpi_coltype INTEGER :: temp_mpi_coltype INTEGER:: ierr INTEGER(KIND=MPI_ADDRESS_KIND):: init_type_lb, init_type_extent !(nrank(2), nrank(1), 1, 10, db_type, rhsoverlap_type) ! if mpi_coltype was used, we free it first IF( mpi_coltype .ne. MPI_DATATYPE_NULL) CALL MPI_TYPE_FREE(mpi_coltype,ierr) ! Create vector type of length nx CALL MPI_TYPE_VECTOR(nr, block_size, stride*block_size*nz, init_type, temp_mpi_coltype, ierr) CALL MPI_TYPE_COMMIT(temp_mpi_coltype, ierr) ! Get the size in bytes of the initial type CALL MPI_TYPE_GET_EXTENT(init_type, init_type_lb, init_type_extent, ierr) if(mpi_coltype .ne. MPI_DATATYPE_NULL) CALL MPI_TYPE_FREE(mpi_coltype,ierr) ! Resize temp_mpi_coltype such that the next item to read is at j+1 CALL MPI_TYPE_CREATE_RESIZED(temp_mpi_coltype, init_type_lb, stride*block_size*init_type_extent ,& & mpi_coltype, ierr) CALL MPI_TYPE_COMMIT(mpi_coltype, ierr) CALL MPI_TYPE_FREE(temp_mpi_coltype,ierr) END SUBROUTINE init_coltypempi END MODULE mpihelper diff --git a/src/neutcol_mod.f90 b/src/neutcol_mod.f90 index a3cb13f..2d7321b 100644 --- a/src/neutcol_mod.f90 +++ b/src/neutcol_mod.f90 @@ -1,526 +1,546 @@ !------------------------------------------------------------------------------ ! EPFL/Swiss Plasma Center !------------------------------------------------------------------------------ ! ! MODULE: neutcol ! !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> Module responsible for handling the electron-neutral collisions and creating electrons !> by ionisation Based on the paper by Birdsall 1991 and Sengupta et al. !------------------------------------------------------------------------------ module neutcol USE constants IMPLICIT NONE private LOGICAL, SAVE :: nlcol=.false. !< Flag to activate or not electron neutral collisions LOGICAL :: nlmaxwellio=.false. !< Flag to define how ionised electrons are created (physically or according to maxwellian) INTEGER :: itcol = 1 !< number of dt between each evaluation of neutcol_step Real(kind=db) :: neutdens=2.4e16 !< Neutral particle density in m-3 Real(kind=db) :: neuttemp=300 !< Neutral particle temperature in K Real(kind=db) :: neutpressure !< Neutral particle pressure in mbar Real(kind=db) :: scatter_fac = 24.2 !< Energy scattering factor for the considered gas (here for Ne) [eV] see Opal 1971 https://doi.org/10.1063/1.1676707 real(kind=db) :: Eion = 21.56 !< Ionisation energy (eV) (here for Ne) Real(kind=db) :: E0 = 27.21 !< Atomic unit of energy used for calculation of deviation angles [eV] + Real(kind=db) :: dE = 1 !< resolution for the computation of the cross-sections + Real(kind=db) :: Emax = 1 !< resolution for the computation of the cross-sections real(kind=db) :: collfactor !< Normalised collision factor (n_n \delta t) INTEGER :: nb_io_cross=0 Real(kind=db), ALLOCATABLE :: io_cross_sec(:,:) !< Ionisation cross-section table + Real(kind=db), ALLOCATABLE :: io_cross_sec_lin(:,:) !< Ionisation cross-section table for linear interpolation Real(kind=db), ALLOCATABLE :: io_growth_cross_sec(:) !< Ionisation exponential fitting factor INTEGER :: nb_ela_cross=0 Real(kind=db), ALLOCATABLE :: ela_cross_sec(:,:) !< Elastic collision cross section table + Real(kind=db), ALLOCATABLE :: ela_cross_sec_lin(:,:) !< Elastic collision cross section table for linear interpolation Real(kind=db), ALLOCATABLE :: ela_growth_cross_sec(:) !< Elastic collision exponential fitting factor Real(kind=db) :: Escale !< Energy normalisation factor used to reduce computation costs CHARACTER(len=128) :: io_cross_sec_file='' CHARACTER(len=128) :: ela_cross_sec_file='' Real(kind=db) :: etemp=22000 !< In case of nlmaxwelio, defines the temperature of created electrons [K] Real(kind=db) :: vth !< In case of nlmaxwelio, defines the normalised thermal velocity of created electrons LOGICAL :: nldragio=.true. !< Set if inpinging electrons are affected by ionising collisions INTEGER :: species(2) !< species(1) contains the specie index in plist which stores the colliding particles, species(2) stores the specie index for the released ion. LOGICAL :: isotropic = .false. !< is the scattering angle isotropic NAMELIST /neutcolparams/ neutdens, Eion, & & scatter_fac, nlcol, io_cross_sec_file, ela_cross_sec_file, nlmaxwellio, etemp, & & nldragio, itcol, species, isotropic PUBLIC:: neutcol_init, neutcol_step, neutcol_diag, itcol, neutdens PROCEDURE(rotate_vel), POINTER:: change_dir => NULL()!< Function evaluating the weight for Dirichelt boundary conditions ABSTRACT INTERFACE SUBROUTINE rotate_vel(Ur, Uthet, Uz, coschi, thet) use constants real(kind=db), INTENT(INOUT):: Ur, uthet, uz, coschi, thet END SUBROUTINE end interface CONTAINS subroutine neutcol_init(lu_in, p) use mpi Use basic, only: mpirank, dt, nlclassical,rnorm, vnorm Use beam, only: particles Use constants implicit none INTEGER, INTENT(IN) :: lu_in TYPE(particles) :: p INTEGER:: ierr, istat, i character(len=1000) :: line real(kind=db):: xsi species(1)=1 species(2)=-1 Rewind(lu_in) READ(lu_in, neutcolparams, iostat=istat) if (istat.gt.0) then backspace(lu_in) read(lu_in,fmt='(A)') line write(*,'(A)') & 'Invalid line in neutcolparams: '//trim(line) call MPI_Abort(MPI_COMM_WORLD, -1, ierr) stop end if IF(mpirank .eq. 0) THEN WRITE(*, neutcolparams) END IF if(.not. nlcol) return if(nlclassical)THEN Escale=0.5*p%m/elchar*vlight**2 else Escale=p%m*vlight**2/elchar end if if (nlmaxwellio) vth=sqrt(kb*etemp/p%m)/vnorm if(io_cross_sec_file .ne.'') then call read_cross_sec(io_cross_sec_file,io_cross_sec, nb_io_cross) if(nb_io_cross .gt. 0) then allocate(io_growth_cross_sec(nb_io_cross-1)) ! Normalisations io_cross_sec(:,2)=io_cross_sec(:,2)/rnorm**2 ! Precomputing of exponential fitting factor for faster execution io_growth_cross_sec=log(io_cross_sec(2:nb_io_cross,2)/io_cross_sec(1:nb_io_cross-1,2))/ & & log(io_cross_sec(2:nb_io_cross,1)/io_cross_sec(1:nb_io_cross-1,1)) end if end if if(ela_cross_sec_file .ne.'') then call read_cross_sec(ela_cross_sec_file,ela_cross_sec, nb_ela_cross) if(nb_ela_cross .gt. 0) then allocate(ela_growth_cross_sec(nb_ela_cross-1)) ! Normalisations ela_cross_sec(:,2)=ela_cross_sec(:,2)/rnorm**2 if(.not. isotropic) then do i=1,nb_ela_cross xsi=ela_cross_sec(i,1)/(0.25*E0+ela_cross_sec(i,1)) ela_cross_sec(i,2)=ela_cross_sec(i,2)*(2*xsi**2)/((1-xsi)*((1+xsi)*log((1+xsi)/(1-xsi))-2*xsi)) end do end if ! Precomputing of exponential fitting factor for faster execution ela_growth_cross_sec=log(ela_cross_sec(2:nb_ela_cross,2)/ela_cross_sec(1:nb_ela_cross-1,2))/ & & log(ela_cross_sec(2:nb_ela_cross,1)/ela_cross_sec(1:nb_ela_cross-1,1)) end if END IF nlcol=nlcol .and. (allocated(io_cross_sec) .or. allocated(ela_cross_sec)) ! Collision factor depending on neutral gas parameters collfactor=neutdens*dt*rnorm**3*itcol neutpressure=neutdens*kb*300/100 if (.not. isotropic)then change_dir=> rotate else change_dir=> scatter end if end subroutine neutcol_init Subroutine neutcol_diag(File_handle, str, vnorm) use mpi Use futils Integer:: File_handle Real(kind=db):: vnorm Character(len=*):: str CHARACTER(len=256):: grpname Integer:: ierr, mpirank,i Real(kind=db)::xsi Real(kind=db),allocatable:: nonisotropic_rescale(:,:) CALL MPI_COMM_RANK(MPI_COMM_WORLD, mpirank, ierr) IF(mpirank .eq. 0 .and. nlcol) THEN Write(grpname,'(a,a)') trim(str),"/neutcol" If(.not. isgroup(File_handle, trim(grpname))) THEN CALL creatg(File_handle, trim(grpname)) END IF Call attach(File_handle, trim(grpname), "neutdens", neutdens) Call attach(File_handle, trim(grpname), "neuttemp", neuttemp) Call attach(File_handle, trim(grpname), "neutpressure", neutpressure) Call attach(File_handle, trim(grpname), "scatter_fac", scatter_fac) Call attach(File_handle, trim(grpname), "Eion", Eion) Call attach(File_handle, trim(grpname), "E0", E0) Call attach(File_handle, trim(grpname), "Escale", Escale) Call putarr(File_handle,trim(grpname)//"species", species) if (allocated(io_cross_sec)) Call putarr(File_handle, trim(grpname)//"/io_cross_sec", io_cross_sec) + allocate(nonisotropic_rescale(nb_ela_cross,2)) + nonisotropic_rescale=1 + if(.not. isotropic) then - allocate(nonisotropic_rescale(nb_ela_cross,2)) - nonisotropic_rescale=1 do i=1,nb_ela_cross xsi=ela_cross_sec(i,1)/(0.25*E0+ela_cross_sec(i,1)) nonisotropic_rescale(i,2)=(2*xsi**2)/((1-xsi)*((1+xsi)*log((1+xsi)/(1-xsi))-2*xsi)) end do end if if (allocated(ela_cross_sec)) Call putarr(File_handle, trim(grpname)//"/ela_cross_sec", ela_cross_sec/nonisotropic_rescale) END IF End subroutine neutcol_diag !------------------------------------------------------------- !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Simulates the elastic and ionising collisions for each particles in plist(species(1)) ! !> @param [inout] plist list of particle species considered in the code !--------------------------------------------------------------------------- SUBROUTINE neutcol_step(plist) ! USE random USE beam USE omp_lib USE basic, ONLY: nlclassical USE distrib, ONLY: lodgaus type(particles), TARGET::plist(:) type(particles),pointer::p INTEGER:: i, omp_thread, num_threads, j, nbcolls_ela, nbcolls_io real(kind=db):: Rand(5) real(kind=db):: v2, v, ek, Everif, es, cosChi, thet, sig_io, sig_ela, vfact, xsi type(linked_part_row):: ins_p type(linked_part), POINTER:: created real(kind=db):: collisionfact,nucol(3),vinit(3),vend(3) p=>plist(species(1)) if(.not. nlcol .or. p%nploc .le. 0) return num_threads=omp_get_max_threads() nbcolls_ela=0 nbcolls_io=0 nucol=0 !!$OMP private(collisionfact,i,omp_thread,Rand,v2,ek,sig_io,sig_ela,es,coschi,thet,vfact, created, v, everif,xsi,vinit,vend)!, reduction(+:nbcolls_ela,nbcolls_io, nucol) omp_thread=omp_get_thread_num()+1 !omp_thread=1 allocate(ins_p%start) ins_p%n=0 created=>ins_p%start !$OMP DO schedule(dynamic) DO i=1,p%Nploc !for each particle CALL random_array(Rand,1,ran_index(omp_thread),ran_array(:,omp_thread)) ! we calculate the kinetic energy and norm of the velocity v2=(p%U(1,i)**2+p%U(2,i)**2+p%U(3,i)**2) if(nlclassical) THEN ek=v2*escale v=sqrt(v2) vinit=p%U(:,i) ! (/p%UR(i),p%UTHET(i),p%UZ(i)/) ELSE ek=(p%gamma(i)-1)*escale v=sqrt(v2)/p%gamma(i) vinit=p%U(:,i)/p%gamma(i)!(/p%UR(i),p%UTHET(i),p%UZ(i)/)/p%gamma(i) end if sig_io=0 sig_ela=0 ! computes the ionisation and elastic collision cross-sections at this kinetic energy ! The ionisation event can only occur if the incoming electron energy is above the binding energy if (ek .gt. Eion .and. nb_io_cross .gt. 1) then sig_io=sig_fit(io_cross_sec,io_growth_cross_sec,ek, nb_io_cross) end if if (nb_ela_cross .gt. 1) then sig_ela=sig_fit(ela_cross_sec,ela_growth_cross_sec,ek, nb_ela_cross) end if collisionfact=1-exp(-collfactor*(sig_io+sig_ela)*v) ! If we have a collision event if (Rand(1) .lt.collisionfact) THEN CALL random_array(Rand,1,ran_index(omp_thread),ran_array(:,omp_thread)) ! Check if elastic or ionising event is happening IF(Rand(1).gt. sig_ela/(sig_io+sig_ela)) THEN ! An ionisation collision happened and we create the necessary electron ! prepare the memory for the released electron ins_p%n=ins_p%n+1 allocate(created%next) created%next%prev=>created ! Fill created particle new position created%p%pos=p%pos(:,i)!(/p%R(i), p%THET(i), p%Z(i)/) IF( nlmaxwellio ) THEN ! the new electron velocity is defined according to a Maxwellian CALL lodgaus(0, Rand(1:3)) ! get random velocity created%p%U=vth*Rand(1:3) ELSE CALL random_array(Rand,3,ran_index(omp_thread),ran_array(:,omp_thread)) ! Compute created electron energy Es=scatter_fac*tan(Rand(1)*atan((Ek-Eion)/(2*scatter_fac))) ! Compute scattering angles for created electron if (isotropic) then coschi=cos(Rand(2)*pi) else cosChi=1-2*Rand(2)/(1+8*Es/E0*(1-Rand(2))) end if thet=Rand(3)*2*pi if(nlclassical)THEN ! new velocity factor for created particle vfact=sqrt(Es/Ek) ELSE ! new velocity factor for created particle vfact=sqrt(Es*(Es+2*Escale)/(Ek*(Ek+2*Escale))) END IF ! Fill created particle velocity created%p%U=vfact*p%U(:,i)!(/p%UR(i),p%UTHET(i),p%UZ(i)/) ! rotate the velocity vector due to the collision call change_dir(created%p%U(1),created%p%U(2), created%p%U(3), coschi, thet) END IF vend=created%p%U if(nlclassical)THEN ! Lorentz factor for created particle created%p%gamma=1.0 ELSE ! Lorentz factor for created particle created%p%gamma=sqrt(1+created%p%U(1)**2+created%p%U(2)**2+created%p%U(3)**2) vend=vend/created%p%gamma END IF ! We prepare the next created particle ins_p%end=>created created=>created%next ! We keep track of what changed nbcolls_io=nbcolls_io+1 nucol=nucol-vend/vinit ! If we want the incoming electron to be scattered, we need to compute ! its new kinetic energy if (nldragio) THEN ! We store the lossed energy in pot for keeping track of energy conservation created%prev%p%pot=Eion+Es CALL random_array(Rand,2,ran_index(omp_thread),ran_array(:,omp_thread)) Es=Ek-Eion-Es if(nlclassical)THEN ! new velocity factor for scattered particle vfact=sqrt(Es/Ek) ELSE ! new velocity factor for scattered particle vfact=sqrt(Es*(Es+2*Escale)/(Ek*(Ek+2*Escale))) END IF ELSE CYCLE END IF ELSE ! An elastic collision event happens CALL random_array(Rand,2,ran_index(omp_thread),ran_array(:,omp_thread)) Es=Ek vfact=1.0 nbcolls_ela=nbcolls_ela+1 END IF ! We calculate the scattered velocity angle for the scattered electron if (isotropic) then coschi=cos(Rand(1)*pi) else cosChi=1-2*Rand(1)/(1+8*Es/E0*(1-Rand(1))) end if thet=Rand(2)*2*pi ! Change the incident electron velocity direction and amplitude if necessary p%U(:,i)=p%U(:,i)*vfact !p%UTHET(i)=p%UTHET(i)*vfact !p%UZ(i)=p%UZ(i)*vfact call change_dir(p%U(1,i),p%U(2,i), p%U(3,i), coschi, thet) if(nlclassical) THEN vend=p%U(:,i)!(/p%UR(i),p%UTHET(i),p%UZ(i)/) ELSE p%gamma(i)=sqrt(1+p%U(1,i)**2+p%U(2,i)**2+p%U(3,i)**2) vend=p%U(:,i)/p%gamma(i)!(/p%UR(i),p%UTHET(i),p%UZ(i)/)/p%gamma(i) END IF nucol=nucol+1-vend/vinit END IF END DO !$OMP END DO NOWAIT !$OMP BARRIER ! clean up the memory after the loop if(associated(created%prev)) then created=>created%prev ins_p%end=>created deallocate(created%next) else deallocate(ins_p%start) end if !!$OMP END PARALLEL ! We collect all created particules into one linked list for easier insertion in plist !Do i=1,num_threads !$OMP CRITICAL (insertions) if(species(2).gt.0.and.ins_p%n .gt.0) then CALL add_created_part(plist(species(2)), ins_p, .false.,.true.) end if !$OMP END CRITICAL (insertions) !$OMP CRITICAL (insertelectrons) if(ins_p%n .gt.0) then CALL add_created_part(plist(species(1)),ins_p,.true.,.false.) !exit end if !$OMP END CRITICAL (insertelectrons) !end do !$OMP CRITICAL(addcolls) p%nbcolls=p%nbcolls+(/nbcolls_io, nbcolls_ela/) p%nudcol=p%nudcol+nucol !$OMP END CRITICAL(addcolls) !Write(*,*)"mpirank: ", mpirank, " Nb colls ela, io: ",nbcolls_ela, nbcolls_io ! END SUBROUTINE neutcol_step FUNCTION sig_fit(sig_vec,growth_vec,ek,nb_cross) use distrib, ONLY: closest real(kind=db)::sig_fit, ek real(kind=db):: sig_vec(:,:), growth_vec(:) Integer:: k, nb_cross sig_fit=0 k=closest(sig_vec(:,1),ek, nb_cross-1) if(k.lt.1) return !sig_fit=(sig_vec(k,1)-sig_vec(k-1,1))/(sig_vec(k,2)-sig_vec(k-1,2))*(sig_vec(k,2)-ek)+sig_vec(k-1,1) ! Exponential fitting relevant at high energies sig_fit=sig_vec(k,2)*(ek/sig_vec(k,1))**growth_vec(k) END FUNCTION sig_fit + + FUNCTION sig_fit_lin(sig_vec,growth_vec,ek,nb_cross) + use distrib, ONLY: closest + real(kind=db)::sig_fit_lin, ek + real(kind=db):: sig_vec(:,:), growth_vec(:) + Integer:: k, nb_cross + sig_fit_lin=0 + k=(k-sig_vec(k,1))/dE + if(k.lt.1) return + + !sig_fit=(sig_vec(k,1)-sig_vec(k-1,1))/(sig_vec(k,2)-sig_vec(k-1,2))*(sig_vec(k,2)-ek)+sig_vec(k-1,1) + ! Exponential fitting relevant at high energies + sig_fit_lin=sig_vec(k,2)+(ek-sig_vec(k,1))/(sig_vec(k+1,1)-sig_vec(k,1))*(sig_vec(k+1,2)-sig_vec(k,2)) + END FUNCTION sig_fit_lin + SUBROUTINE rotate(Ur, Uthet, Uz, coschi, thet) real(kind=db), INTENT(INOUT):: Ur, uthet, uz, coschi, thet real(kind=db):: norm, perp(3), U(3), U0(3) real(kind=db):: sinchi, sinthet, costhet Integer :: iperp1,iperp2 U0=(/Ur,Uthet,Uz/) norm=sqrt(sum(U0**2)) U=U0/norm ! Find a vector perpendicular to U for chi rotation ! find the direction with maximum amplitude perp=(/1,1,1/) iperp1=maxloc(abs(U),1) ! find second direction with next max amplitude perp(iperp1)=0 iperp2=maxloc(abs(perp*U),1) perp=0 perp(iperp2)=U(iperp1) perp(iperp1)=-U(iperp2) ! Normalise the rotation vector perp=perp/sqrt(sum(perp**2)) ! Compute sinus and cosinus for rotation sinchi=sqrt(1-coschi**2) costhet=cos(thet) sinthet=sin(thet) ! Rotation of angle chi around perp Ur = (coschi+perp(1)**2*(1-coschi))*U0(1) + (perp(1)*perp(2)*(1-coschi)-perp(3)*sinchi)*U0(2) + (perp(1)*perp(3)*(1-coschi) + perp(2)*sinchi)*U0(3) Uthet = (perp(1)*perp(2)*(1-coschi)+perp(3)*sinchi)*U0(1) + (coschi + perp(2)**2*(1-coschi))*U0(2) +(perp(2)*perp(3)*(1-coschi)-perp(1)*sinchi)*U0(3) Uz = (perp(1)*perp(3)*(1-coschi)-perp(2)*sinchi)*U0(1) +(perp(3)*perp(2)*(1-coschi)+perp(1)*sinchi)*U0(2) +( coschi+perp(3)**2*(1-coschi))*U0(3) U0 =(/Ur,Uthet,Uz/) ! second rotation according to uniform distribution ! Rotation of angle theta around U Ur = (costhet+U(1)**2*(1-costhet))*U0(1) + (U(1)*U(2)*(1-costhet) - U(3)*sinthet)*U0(2) + (U(1)*U(3)*(1-costhet)+U(2)*sinthet)*U0(3) Uthet = (U(2)*U(1)*(1-costhet)+U(3)*sinthet)*U0(1) + (costhet + U(2)**2*(1-costhet))*U0(2) + (U(2)*U(3)*(1-costhet)-U(1)*sinthet)*U0(3) Uz = (U(3)*U(1)*(1-costhet) - U(2)*sinthet)*U0(1) + (U(3)*U(2)*(1-costhet)+U(1)*sinthet)*U0(2) + (costhet +U(3)**2*(1-costhet))*U0(3) !normf=sqrt(Ur**2+Uthet**2+Uz**2) !if(abs(norm-normf)/norm .gt. 1e-14) WRITE(*,*) "Error in rotate the norm of v changed" END SUBROUTINE rotate SUBROUTINE scatter(Ur, Uthet, Uz, coschi, thet) real(kind=db), INTENT(INOUT):: Ur, uthet, uz, coschi, thet real(kind=db):: norm real(kind=db):: sinchi, sinthet, costhet norm=sqrt(Ur**2+Uz**2+Uthet**2) ! Compute sinus and cosinus for rotation sinchi=sqrt(1-coschi**2) costhet=cos(thet) sinthet=sin(thet) Ur=norm*sinchi*costhet Uthet=norm*sinchi*sinthet Uz=norm*coschi END SUBROUTINE scatter SUBROUTINE read_cross_sec(filename,cross_sec, nb_cross) CHARACTER(len=*) ::filename Real(kind=db), ALLOCATABLE :: cross_sec(:,:) INTEGER:: nb_cross INTEGER :: lu_cross_sec=9999 INTEGER:: i, openerr, reason CHARACTER(len=256) :: header real(kind=db):: t1,t2 nb_cross=0 OPEN(UNIT=lu_cross_sec,FILE=trim(filename),ACTION='READ',IOSTAT=openerr) header=' ' IF(openerr .ne. 0) THEN CLOSE(unit=lu_cross_sec) RETURN END IF ! The cross section table is defined as a two column energy and cross_section DO WHILE(.true.) READ(lu_cross_sec,'(a)',IOSTAT=reason) header header=adjustl(header) if(reason .lt. 0 ) exit ! We reached end of file if( header(1:1) .ne. '!') then READ(header,*) t1, t2 if(t1 .ne. 0 .and. t2.ne. 0) nb_cross=nb_cross+1 end if END DO if (allocated(cross_sec)) deallocate(cross_sec) allocate(cross_sec(nb_cross,2)) REWIND(lu_cross_sec) ! The cross section table is defined as a two column energy and cross_section i=1 DO WHILE(i .le. nb_cross) READ(lu_cross_sec,'(a)',IOSTAT=reason) header header=adjustl(header) if(reason .lt. 0 ) exit ! We reached end of file if( header(1:1) .ne. '!') then READ(header,*) cross_sec(i,1), cross_sec(i,2) if(cross_sec(i,1) .ne. 0 .and. cross_sec(i,2).ne. 0) i=i+1 end if END DO CLOSE(unit=lu_cross_sec) END subroutine read_cross_sec end module neutcol diff --git a/src/particletypes_mod.f90 b/src/particletypes_mod.f90 index add711d..477c2b4 100644 --- a/src/particletypes_mod.f90 +++ b/src/particletypes_mod.f90 @@ -1,611 +1,639 @@ !------------------------------------------------------------------------------ ! EPFL/Swiss Plasma Center !------------------------------------------------------------------------------ ! ! MODULE: particletypes ! !> @author !> Guillaume Le Bars EPFL/SPC !> Patryk Kaminski EPFL/SPC !> Trach Minh Tran EPFL/SPC ! ! DESCRIPTION: !> Module responsible for defining the particle types and defining some subroutines to change their size, !> initialize them or delete them !------------------------------------------------------------------------------ MODULE particletypes USE constants ! IMPLICIT NONE !> Stores the particles properties for the run. TYPE particles INTEGER :: Nploc !< Local number of simulated particles INTEGER :: Nptot !< Total number of simulated particles INTEGER :: Newindex !< Stores the higher partindex for the creation of new particles REAL(kind=db) :: m !< Particle mass REAL(kind=db) :: q !< Particle charge REAL(kind=db) :: weight !< Number of particles represented by one macro-particle REAL(kind=db) :: qmRatio !< Charge over mass ratio REAL(kind=db) :: nudcol(3) !< Effective momentum drag frequency REAL(kind=db) :: H0 REAL(kind=db) :: P0 REAL(kind=db) :: temperature LOGICAL :: Davidson=.false. LOGICAL :: is_test= .false. !< determines if particle is saved on ittracer LOGICAL :: is_field= .true. !< determines if particle contributes to Poisson solver LOGICAL :: calc_moments=.false. INTEGER, allocatable :: nblost(:) !< number of particles lost in domain boundaries at current timestep INTEGER :: nbadded !< number of particles added by source since last gather INTEGER, DIMENSION(2) :: nbcolls !< number of particles collisions with neutrals ionisation, elastic) - INTEGER, DIMENSION(:), ALLOCATABLE :: Rindex !< Index in the electric potential grid for the R direction - INTEGER, DIMENSION(:), ALLOCATABLE :: Zindex !< Index in the electric potential grid for the Z direction + !INTEGER, DIMENSION(:), ALLOCATABLE :: Rindex !< Index in the electric potential grid for the R direction + !INTEGER, DIMENSION(:), ALLOCATABLE :: Zindex !< Index in the electric potential grid for the Z direction + INTEGER, DIMENSION(:,:), ALLOCATABLE :: Cellindex !< Index in the electric potential grid for the (r,theta,z) direction INTEGER, DIMENSION(:), ALLOCATABLE :: partindex !< Index of the particle to be able to follow it when it goes from one MPI host to the other INTEGER :: iiee_id=-1 !< Index defining whether or not ion induced ee are considered INTEGER :: neuttype_id=1 !< Index defining which type of neutral gas is used to produce the ions INTEGER :: material_id=1 !< Index defining the type of material for the electrodes (1=304SS) LOGICAL :: zero_vel=.true.!< Defines wether or not the electrons are gen. with init. vel !REAL(kind=db), DIMENSION(:), ALLOCATABLE :: Z !< radial coordinates of the particles REAL(kind=db), DIMENSION(:,:), ALLOCATABLE :: pos !< (radial,azimuthal,longitudinal) coordinates of the particles !REAL(kind=db), DIMENSION(:), ALLOCATABLE :: THET !< azimuthal coordinates of the particles REAL(kind=db), DIMENSION(:,:), ALLOCATABLE :: B !< radial, axial Magnetic field REAL(kind=db), DIMENSION(:), ALLOCATABLE :: pot !< Electric potential REAL(kind=db), DIMENSION(:), ALLOCATABLE :: potxt !< External electric potential REAL(kind=db), DIMENSION(:,:), ALLOCATABLE :: E !< Radial Axial Electric field REAL(kind=db), DIMENSION(:,:), CONTIGUOUS, POINTER:: U !< normalized (radial, azimuthal, axial) velocity at the current time step REAL(kind=db), DIMENSION(:,:), CONTIGUOUS, POINTER:: Uold !< normalized (radial, azimuthal, axial) velocity at the previous time step REAL(kind=db), DIMENSION(:), CONTIGUOUS, POINTER:: Gamma !< Lorentz factor at the current time step REAL(kind=db), DIMENSION(:), CONTIGUOUS, POINTER:: Gammaold !< Lorentz factor at the previous time step Real(kind=db), Dimension(:,:),ALLOCATABLE:: geomweight !< geometric weight at the particle position Real(kind=db), Dimension(:,:),ALLOCATABLE:: moments !< stores the moment matrix INTEGER, DIMENSION(:), ALLOCATABLE :: losthole INTEGER, DIMENSION(:), ALLOCATABLE :: sendhole INTEGER:: nbsendandlost(3)=0 LOGICAL:: collected !< Stores if the particles data have been collected to MPI root process during this timestep INTEGER, DIMENSION(:), ALLOCATABLE:: addedlist END TYPE particles !> Structure containing a single particle position and velocity used in MPI communications. TYPE particle INTEGER :: partindex =0 REAL(kind=db) :: Pos(3) =0 REAL(kind=db) :: U(3) =0 REAL(kind=db) :: Gamma =0 REAL(kind=db) :: pot =0 END TYPE particle TYPE linked_part type(particle) p type(linked_part), POINTER:: next=> NULL() type(linked_part), POINTER:: prev=> NULL() END TYPE linked_part TYPE linked_part_row INTEGER :: n = 0 type(linked_part), POINTER:: start=>NULL() type(linked_part), POINTER:: end=>NULL() END TYPE linked_part_row CONTAINS !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Allocate the memory for the particles variable storing the particles quantities. ! !> @param[inout] p the particles variable needing to be allocated. !> @param[in] nparts the maximum number of particles that will be stored in this variable !--------------------------------------------------------------------------- SUBROUTINE creat_parts(p, nparts) TYPE(particles) :: p INTEGER, INTENT(in) :: nparts IF (.NOT. ALLOCATED(p%pos) ) THEN p%Nploc = nparts p%Nptot = nparts ALLOCATE(p%pos(3,nparts)) !ALLOCATE(p%R(nparts)) !ALLOCATE(p%THET(nparts)) ALLOCATE(p%B(2,nparts)) ALLOCATE(p%U(3,nparts)) !ALLOCATE(p%UZ(nparts)) !ALLOCATE(p%UTHET(nparts)) ALLOCATE(p%Uold(3,nparts)) !ALLOCATE(p%UZold(nparts)) !ALLOCATE(p%UTHETold(nparts)) ALLOCATE(p%Gamma(nparts)) - ALLOCATE(p%Rindex(nparts)) - ALLOCATE(p%Zindex(nparts)) + Allocate(p%Cellindex(3,nparts)) + !ALLOCATE(p%Rindex(nparts)) + !ALLOCATE(p%Zindex(nparts)) ALLOCATE(p%partindex(nparts)) ALLOCATE(p%pot(nparts)) ALLOCATE(p%potxt(nparts)) ALLOCATE(p%E(2,nparts)) ALLOCATE(p%GAMMAold(nparts)) Allocate(p%geomweight(0:2,nparts)) Allocate(p%losthole(nparts)) Allocate(p%sendhole(nparts)) if(.not.allocated(p%nblost)) allocate(p%nblost(4)) p%newindex=0 p%nblost=0 p%nbadded=0 p%partindex=-1 p%Uold=0 !p%UZold=0 !p%UTHETold=0 p%iiee_id=-1 p%neuttype_id=1 p%material_id=1 p%zero_vel=.true. - p%rindex=0 - p%zindex=0 + !p%rindex=0 + !p%zindex=0 + p%cellindex=0 p%B=0 p%U=0 !p%UZ=0 !p%UTHET=0 p%pos=0 !p%R=0 !p%THET=0 p%Gamma=1 p%E=0 p%pot=0 p%potxt=0 p%gammaold=1 p%collected=.false. p%Davidson=.false. p%is_test=.false. p%is_field=.true. p%calc_moments=.true. p%m=me p%q=-elchar p%qmRatio=p%q/p%m p%weight=1.0_db p%H0=0 p%P0=0 p%temperature=0 p%geomweight=0 p%losthole=0 p%sendhole=0 END IF END SUBROUTINE creat_parts !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Copy one particle from the receive buffers to the local simulation variable parts. ! !> @param [in] part particle parameters to copy from !> @param [in] partsindex destination particle index in the local parts variable !--------------------------------------------------------------------------- SUBROUTINE Insertincomingpart(p, part, partsindex) TYPE(particles), INTENT(INOUT):: p INTEGER, INTENT(in) :: partsindex TYPE(particle), INTENT(in) :: part p%partindex(partsindex) = part%partindex p%pos(1:3,partsindex) = part%Pos(1:3) !p%THET(partsindex) = part%Pos(2) !p%Z(partsindex) = part%Pos(3) !p%UZ(partsindex) = part%U(3) p%U(1:3,partsindex) = part%U(1:3) !p%UTHET(partsindex) = part%U(2) p%Gamma(partsindex) = part%Gamma p%pot(partsindex) = part%pot ! END SUBROUTINE Insertincomingpart !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Copy one particle from the local parts variable to the send buffer. ! !> @param [in] buffer send buffer to copy to !> @param [in] bufferindex particle index in the send buffer !> @param [in] partsindex origin particle index in the local parts variable !--------------------------------------------------------------------------- SUBROUTINE Insertsentpart(p, buffer, bufferindex, partsindex) TYPE(particles), INTENT(INOUT):: p INTEGER, INTENT(in) :: bufferindex, partsindex TYPE(particle), DIMENSION(:), INTENT(inout) :: buffer buffer(bufferindex)%partindex = p%partindex(partsindex) buffer(bufferindex)%Pos(1:3) = p%pos(1:3,partsindex) !buffer(bufferindex)%Pos(2) = p%THET(partsindex) !buffer(bufferindex)%Pos(3) = p%Z(partsindex) !buffer(bufferindex)%U(3) = p%UZ(partsindex) buffer(bufferindex)%U(1:3) = p%U(1:3,partsindex) !buffer(bufferindex)%U(2) = p%UTHET(partsindex) buffer(bufferindex)%Gamma = p%Gamma(partsindex) buffer(bufferindex)%pot = p%pot(partsindex) ! END SUBROUTINE Insertsentpart !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> @brief Exchange two particles in the parts variable. ! !> @param [in] index1 index in parts of the first particle to exchange. !> @param [in] index2 index in parts of the second particle to exchange. !--------------------------------------------------------------------------- SUBROUTINE exchange_parts(p, index1, index2) TYPE(particles), INTENT(INOUT):: p INTEGER, INTENT(IN) :: index1, index2 REAL(kind=db):: pos(3), U(3), Gamma, geomweight(0:2),pot - INTEGER :: Rindex, Zindex, partindex + INTEGER :: Rindex, Zindex, partindex, cellindex(3) !! Exchange particle at index1 with particle at index2 ! Store part at index1 in temporary value partindex = p%partindex(index1) Gamma = p%Gamma(index1) pot = p%pot(index1) pos = p%pos(:,index1) !Z = p%Z(index1) !THET = p%THET(index1) U = p%U(:,index1) !UTHET = p%UTHET(index1) !UZ = p%UZ(index1) - Rindex = p%Rindex(index1) - Zindex = p%Zindex(index1) + !Rindex = p%Rindex(index1) + !Zindex = p%Zindex(index1) + cellindex = p%cellindex(:,index1) geomweight = p%geomweight(:,index1) ! Move part at index2 in part at index 1 p%partindex(index1) = p%partindex(index2) p%Gamma(index1) = p%Gamma(index2) p%pot(index1) = p%pot(index2) p%pos(:,index1) = p%pos(:,index2) !p%Z(index1) = p%Z(index2) !p%THET(index1) = p%THET(index2) p%U(:,index1) = p%U(:,index2) !p%UTHET(index1) = p%UTHET(index2) !p%UZ(index1) = p%UZ(index2) - p%Rindex(index1) = p%Rindex(index2) - p%Zindex(index1) = p%Zindex(index2) + !p%Rindex(index1) = p%Rindex(index2) + !p%Zindex(index1) = p%Zindex(index2) + p%cellindex(:,index1) = p%cellindex(:,index2) p%geomweight(:,index1) = p%geomweight(:,index2) ! Move temporary values from part(index1) to part(index2) p%partindex(index2) = partindex p%Gamma(index2) = Gamma p%pot(index2) = pot p%pos(:,index2) = pos !p%Z(index2) = Z !p%THET(index2) = THET p%U(:,index2) = U !p%UTHET(index2) = UTHET !p%UZ(index2) = UZ - p%Rindex(index2) = Rindex - p%Zindex(index2) = Zindex + !p%Rindex(index2) = Rindex + !p%Zindex(index2) = Zindex p%geomweight(:,index2) = geomweight + p%cellindex(:,index2) = cellindex END SUBROUTINE exchange_parts SUBROUTINE change_parts_allocation(p, sizedifference) implicit none TYPE(particles), INTENT(INOUT):: p INTEGER,INTENT(IN) :: sizedifference - CALL change_array_size_int(p%Rindex, sizedifference) - CALL change_array_size_int(p%Zindex, sizedifference) + !CALL change_array_size_int(p%Rindex, sizedifference) + !CALL change_array_size_int(p%Zindex, sizedifference) CALL change_array_size_int(p%partindex, sizedifference) + CALL change_array_size_int2(p%cellindex, sizedifference) CALL change_array_size_int(p%losthole, sizedifference) CALL change_array_size_int(p%sendhole, sizedifference) CALL change_array_size_dp12(p%E,sizedifference) CALL change_array_size_dp(p%pot,sizedifference) CALL change_array_size_dp(p%potxt,sizedifference) !CALL change_array_size_dp(p%R,sizedifference) CALL change_array_size_dp12(p%pos,sizedifference) !CALL change_array_size_dp(p%THET,sizedifference) CALL change_array_size_dp12(p%B,sizedifference) CALL change_array_size_dp012(p%geomweight,sizedifference) CALL change_array_size_dp_ptr12(p%U,sizedifference) CALL change_array_size_dp_ptr12(p%Uold,sizedifference) !CALL change_array_size_dp_ptr(p%UZ,sizedifference) !CALL change_array_size_dp_ptr(p%UZold,sizedifference) !CALL change_array_size_dp_ptr(p%UTHET,sizedifference) !CALL change_array_size_dp_ptr(p%UTHETold,sizedifference) CALL change_array_size_dp_ptr(p%Gamma,sizedifference) CALL change_array_size_dp_ptr(p%Gammaold,sizedifference) p%Nploc=MIN(p%Nploc,size(p%pos,2)) END SUBROUTINE change_parts_allocation SUBROUTINE change_array_size_dp(arr, sizedifference) implicit none REAL(kind=db), ALLOCATABLE, INTENT(INOUT):: arr(:) INTEGER, INTENT(IN):: sizedifference REAL(kind=db), ALLOCATABLE:: temp(:) INTEGER:: current_size, new_size, i if(allocated(arr)) THEN current_size=size(arr) new_size=current_size+sizedifference ALLOCATE(temp(new_size)) Do i=1,min(current_size,new_size) temp(i)=arr(i) end do DEALLOCATE(arr) CALL move_alloc(temp, arr) END IF END SUBROUTINE change_array_size_dp SUBROUTINE change_array_size_dp2(arr, sizedifference) implicit none REAL(kind=db), ALLOCATABLE, INTENT(INOUT):: arr(:,:) INTEGER, INTENT(IN):: sizedifference REAL(kind=db), ALLOCATABLE:: temp(:,:) INTEGER:: current_size, new_size, i if(allocated(arr)) THEN current_size=size(arr,1) new_size=current_size+sizedifference ALLOCATE(temp(new_size,0:size(arr,2)-1)) Do i=1,min(current_size,new_size) temp(i,:)=arr(i,:) end do DEALLOCATE(arr) CALL move_alloc(temp, arr) END IF END SUBROUTINE change_array_size_dp2 SUBROUTINE change_array_size_dp12(arr, sizedifference) implicit none REAL(kind=db), ALLOCATABLE, INTENT(INOUT):: arr(:,:) INTEGER, INTENT(IN):: sizedifference REAL(kind=db), ALLOCATABLE:: temp(:,:) INTEGER:: current_size, new_size, i if(allocated(arr)) THEN current_size=size(arr,2) new_size=current_size+sizedifference ALLOCATE(temp(size(arr,1),new_size)) Do i=1,min(current_size,new_size) temp(:,i)=arr(:,i) end do DEALLOCATE(arr) CALL move_alloc(temp, arr) END IF END SUBROUTINE change_array_size_dp12 SUBROUTINE change_array_size_dp012(arr, sizedifference) implicit none REAL(kind=db), ALLOCATABLE, INTENT(INOUT):: arr(:,:) INTEGER, INTENT(IN):: sizedifference REAL(kind=db), ALLOCATABLE:: temp(:,:) INTEGER:: current_size, new_size, i if(allocated(arr)) THEN current_size=size(arr,2) new_size=current_size+sizedifference ALLOCATE(temp(0:size(arr,1)-1,new_size)) Do i=1,min(current_size,new_size) temp(:,i)=arr(:,i) end do DEALLOCATE(arr) CALL move_alloc(temp, arr) END IF END SUBROUTINE change_array_size_dp012 SUBROUTINE change_array_size_dp_ptr12(arr, sizedifference) implicit none REAL(kind=db), POINTER, INTENT(INOUT):: arr(:,:) INTEGER, INTENT(IN):: sizedifference REAL(kind=db), POINTER:: temp(:,:) INTEGER:: current_size, new_size, i if(associated(arr)) THEN current_size=size(arr,2) new_size=current_size+sizedifference ALLOCATE(temp(size(arr,1),new_size)) !WRITE(*,*)"increase pointer size: ", current_size, new_size, "temp: ", size(temp,1),size(temp,2), "arr: ", size(arr,1),size(arr,2) Do i=1,min(current_size,new_size) temp(:,i)=arr(:,i) end do !WRITE(*,*)"copy done" DEALLOCATE(arr) arr=> temp END IF END SUBROUTINE change_array_size_dp_ptr12 SUBROUTINE change_array_size_dp_ptr(arr, sizedifference) implicit none REAL(kind=db), POINTER, INTENT(INOUT):: arr(:) INTEGER, INTENT(IN):: sizedifference REAL(kind=db), CONTIGUOUS, POINTER:: temp(:) INTEGER:: current_size, new_size,i if(associated(arr)) THEN current_size=size(arr) new_size=current_size+sizedifference ALLOCATE(temp(new_size)) Do i=1,min(current_size,new_size) temp(i)=arr(i) end do !temp(1:min(current_size,new_size))=arr(1:min(current_size,new_size)) DEALLOCATE(arr) arr=> temp END IF END SUBROUTINE change_array_size_dp_ptr SUBROUTINE change_array_size_int(arr, sizedifference) implicit none INTEGER, ALLOCATABLE, INTENT(INOUT):: arr(:) INTEGER, INTENT(IN):: sizedifference INTEGER, ALLOCATABLE:: temp(:) INTEGER:: current_size, new_size,i if(allocated(arr)) THEN current_size=size(arr) new_size=current_size+sizedifference ALLOCATE(temp(new_size)) Do i=1,min(current_size,new_size) temp(i)=arr(i) end do DEALLOCATE(arr) CALL move_alloc(temp,arr) END IF END SUBROUTINE change_array_size_int + SUBROUTINE change_array_size_int2(arr, sizedifference) + implicit none + INTEGER, ALLOCATABLE, INTENT(INOUT):: arr(:,:) + INTEGER, INTENT(IN):: sizedifference + INTEGER, ALLOCATABLE:: temp(:,:) + INTEGER:: current_size, new_size,i + + if(allocated(arr)) THEN + current_size=size(arr,2) + new_size=current_size+sizedifference + ALLOCATE(temp(size(arr,1),new_size)) + Do i=1,min(current_size,new_size) + temp(:,i)=arr(:,i) + end do + DEALLOCATE(arr) + CALL move_alloc(temp,arr) + END IF + END SUBROUTINE change_array_size_int2 + !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Move particle with index sourceindex to particle with index destindex. !> !WARNING! This will overwrite particle at destindex. ! !> @param [in] sourceindex index in parts of the particle to move. !> @param [in] destindex index in parts of the moved particle destination. !--------------------------------------------------------------------------- SUBROUTINE move_part(p, sourceindex, destindex) !! This will destroy particle at destindex INTEGER, INTENT(IN) :: destindex, sourceindex TYPE(particles), INTENT(INOUT)::p IF(sourceindex .eq. destindex) RETURN IF(sourceindex .le. 0 .or. destindex .le. 0) RETURN ! Move part at sourceindex in part at destindex Call copy_part(p,sourceindex,destindex,p) END SUBROUTINE move_part !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Copy particle with index sourceindex in particles sourcep to particle with index destindex in particles destp. !> !WARNING! This will overwrite particle at destp(destindex). ! !> @param [inout] sourcep Structure of source particles. !> @param [in] sourceindex index in parts of the particle to move. !> @param [in] destindex index in parts of the moved particle destination. !> @param [inout] destp Structure of source particles. !--------------------------------------------------------------------------- SUBROUTINE copy_part(sourcep, sourceindex, destindex, destp) !! This will destroy particle at destindex INTEGER, INTENT(IN) :: destindex, sourceindex TYPE(particles), INTENT(IN)::sourcep TYPE(particles), INTENT(INOUT)::destp IF(sourceindex .le. 0 .or. destindex .le. 0) RETURN IF( destindex .gt. size(destp%pos,2)) RETURN ! Move part at sourceindex in part at destindex destp%partindex(destindex) = sourcep%partindex(sourceindex) destp%Gamma(destindex) = sourcep%Gamma(sourceindex) destp%Gammaold(destindex) = sourcep%Gammaold(sourceindex) destp%pos(:,destindex) = sourcep%pos(:,sourceindex) !destp%Z(destindex) = sourcep%Z(sourceindex) !destp%THET(destindex) = sourcep%THET(sourceindex) destp%U(:,destindex) = sourcep%U(:,sourceindex) !destp%UTHET(destindex) = sourcep%UTHET(sourceindex) !destp%UZ(destindex) = sourcep%UZ(sourceindex) destp%Uold(:,destindex) = sourcep%Uold(:,sourceindex) !destp%UTHETold(destindex) = sourcep%UTHETold(sourceindex) !destp%UZold(destindex) = sourcep%UZold(sourceindex) - destp%Rindex(destindex) = sourcep%Rindex(sourceindex) - destp%Zindex(destindex) = sourcep%Zindex(sourceindex) + !destp%Rindex(destindex) = sourcep%Rindex(sourceindex) + !destp%Zindex(destindex) = sourcep%Zindex(sourceindex) + destp%cellindex(:,destindex) = sourcep%cellindex(:,sourceindex) destp%geomweight(:,destindex) = sourcep%geomweight(:,sourceindex) destp%pot(destindex) = sourcep%pot(sourceindex) destp%potxt(destindex) = sourcep%potxt(sourceindex) END SUBROUTINE copy_part !________________________________________________________________________________ SUBROUTINE destroy_parts(p) TYPE(particles) :: p p%Nploc=0 IF(ALLOCATED(p%pos)) DEALLOCATE(p%pos) !IF(ALLOCATED(p%R)) DEALLOCATE(p%R) !IF(ALLOCATED(p%THET)) DEALLOCATE(p%THET) IF(ALLOCATED(p%B)) DEALLOCATE(p%B) IF(ALLOCATED(p%E)) DEALLOCATE(p%E) IF(ASSOCIATED(p%U)) DEALLOCATE(p%U) IF(Associated(p%Uold)) DEALLOCATE(p%Uold) !IF(Associated(p%UZ)) DEALLOCATE(p%UZ) !IF(Associated(p%UZold)) DEALLOCATE(p%UZold) !IF(Associated(p%UTHET)) DEALLOCATE(p%UTHET) !IF(Associated(p%UTHETold)) DEALLOCATE(p%UTHETold) IF(Associated(p%Gamma)) DEALLOCATE(p%Gamma) IF(Associated(p%Gammaold)) DEALLOCATE(p%Gammaold) - IF(ALLOCATED(p%Rindex)) DEALLOCATE(p%Rindex) - IF(ALLOCATED(p%Zindex)) DEALLOCATE(p%Zindex) + !IF(ALLOCATED(p%Rindex)) DEALLOCATE(p%Rindex) + !IF(ALLOCATED(p%Zindex)) DEALLOCATE(p%Zindex) + IF(ALLOCATED(p%cellindex)) DEALLOCATE(p%cellindex) IF(ALLOCATED(p%losthole)) DEALLOCATE(p%losthole) IF(ALLOCATED(p%sendhole)) DEALLOCATE(p%sendhole) IF(ALLOCATED(p%partindex)) DEALLOCATE(p%partindex) if(allocated(p%geomweight)) Deallocate(p%geomweight) if(allocated(p%moments)) Deallocate(p%moments) END SUBROUTINE !________________________________________________________________________________ SUBROUTINE clean_beam(partslist) ! INTEGER:: i type(particles):: partslist(:) Do i=1,size(partslist,1) CALL destroy_parts(partslist(i)) END DO ! END SUBROUTINE clean_beam !________________________________________________________________________________ SUBROUTINE swappointer( pointer1, pointer2) REAL(kind=db), DIMENSION(:), POINTER, INTENT(inout):: pointer1, pointer2 REAL(kind=db), DIMENSION(:), POINTER:: temppointer temppointer=>pointer1 pointer1=>pointer2 pointer2=>temppointer END SUBROUTINE swappointer SUBROUTINE swappointer2( pointer1, pointer2) REAL(kind=db), DIMENSION(:,:), POINTER, INTENT(inout):: pointer1, pointer2 REAL(kind=db), DIMENSION(:,:), POINTER:: temppointer temppointer=>pointer1 pointer1=>pointer2 pointer2=>temppointer END SUBROUTINE swappointer2 !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Deallocate recursively a linked_paticle linked list ! !> @param [in] l_p linked_part particle to be dallocated. !--------------------------------------------------------------------------- RECURSIVE SUBROUTINE destroy_linked_parts(l_p) TYPE(linked_part), POINTER :: l_p IF(associated(l_p%next)) call destroy_linked_parts(l_p%next) deallocate(l_p) END subroutine destroy_linked_parts !-------------------------------------------------------------------------- !> @author !> S.Guinchard EPFL/SPC !> Last modified on: 11/15/2022 ! !DESCRIPTION !> Function giving particle energy for a given partindex ! !------------------------------------------------------------------------- REAL(KIND=db) FUNCTION eKin_part(p, partind) TYPE(particles), INTENT(INOUT):: p INTEGER :: partind eKin_part = 0.5* p%m * (p%U(1,partind)**2 + p%U(2,partind)**2 + p%U(3,partind)**2 ) END FUNCTION eKin_part END MODULE particletypes diff --git a/src/psupply_mod.f90 b/src/psupply_mod.f90 index 750665c..edd688f 100644 --- a/src/psupply_mod.f90 +++ b/src/psupply_mod.f90 @@ -1,342 +1,440 @@ +!------------------------------------------------------------------------------ +! EPFL/Swiss Plasma Center +!------------------------------------------------------------------------------ +! +! MODULE: psupply +! +!> @author +!> G. Le Bars - EPFL/SPC +! +!> Last modif. +!> 06/07 2023 +! +! DESCRIPTION: +!> Module handling the non-ideal power supply effects and the time evolution of the applied bias. +!------------------------------------------------------------------------------ module psupply use constants implicit none type power_supply logical :: active = .false. ! is the power supply active real(kind=db):: geomcapacitor = 1 ! capacitance of the metalic vessel normalised to the neutral density in vessel used in the neutcol module real(kind=db):: PSresistor = 1 ! internal resistance of the power supply normalised to the actual neutral density in vessel real(kind=db):: targetbias = 0 ! Set voltage on the power supply real(kind=db):: bias = 0 ! current voltage on the power supply integer :: nbbounds = 2 ! number of boundaries defined in the geometry integer :: lststp = 0 ! previous step on which the bias was updated real(kind=db):: current(3) = 0 ! current collected on the boundaries normalised to the simulated collision neutral density set in neutcol module ! 1 is at time i-2nbhdt, 2 is at time i-nbhdt and 3 is at time i integer, allocatable:: bdpos(:) ! sign of each boundary for collected charge to determine direction of current real(kind=db),allocatable:: charge(:) ! Charge collected on each boundary and per nbdt real(kind=db),allocatable:: biases(:) ! Actual potentials at each boundary integer :: nbhdt = 10 ! half of the number of time steps between each calls to RK4 real(kind=db):: expdens ! [m-3] experimental neutral density real(kind=db):: neutcoldens ! [m-3] neutral density used in neutcol module real(kind=db):: frequency ! [Hz] frequency of an imposed oscillation in bias real(kind=db):: deltabias ! [V] Amplitude of the oscillations around targetbias end type type(power_supply):: the_ps contains - ! read the input parameters from the input file and setup the necesary variables for the module to work +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> Reads a non-ideal power supply parameters from the namelist. Needs to be called for the initialization of the module +!> @param[in] Fileid Text file id of the input file containing namelists +!> @param[in] cstep current time-step +!> @param[in] nbbounds number of simulated boundaries in the system +!> @param[in] neutcoldens simulated neutral gas density used in neutcol module +!> @param[in] rstbias Initialize the bias from a saved value during restart +!--------------------------------------------------------------------------- subroutine psupply_init(fileid,cstep,nbbounds,neutcoldens,rstbias) use splinebound use basic, only: phinorm, tnorm, mpirank, qnorm, potinn, potout, dt use constants use mpi use geometry use weighttypes use fields integer:: fileid, cstep, nbbounds, istat, nbhdt, ierr,i real(kind=db),OPTIONAL, INTENT(IN):: rstbias real(kind=db):: neutcoldens ! [m-3] real(kind=db):: expneutdens = 1 ! [m-3] real(kind=db):: PsResistor = 1 ! [Ohm] real(kind=db):: geomcapacitor = 1 ! [F] real(kind=db):: targetbias = 0 ! [V] real(kind=db):: frequency = 0 ! [Hz] real(kind=db):: deltabias = 0 ! [V] integer, allocatable:: bdpos(:) character(len=1000) :: line logical :: active = .false. NAMELIST /psupplyparams/ expneutdens, PsResistor, geomcapacitor, targetbias, nbhdt, active, bdpos, frequency, deltabias the_ps%lststp=cstep the_ps%nbbounds=nbbounds allocate(the_ps%bdpos(nbbounds),bdpos(nbbounds)) allocate(the_ps%charge(nbbounds),the_ps%biases(nbbounds)) the_ps%bdpos=0 bdpos=0 the_ps%charge=0 the_ps%biases=0 the_ps%current=0 ! read the input parameters from file Rewind(fileid) READ(fileid, psupplyparams, iostat=istat) if (istat.gt.0) then backspace(fileid) read(fileid,fmt='(A)') line write(*,'(A)') & 'Invalid line in pssupplyparams: '//trim(line) call MPI_Abort(MPI_COMM_WORLD, -1, ierr) stop end if ! save the parameters on output IF(mpirank .eq. 0) THEN WRITE(*, psupplyparams) END IF IF(.not. active) THEN return end IF ! rescale the targetbias set on the power supply the_ps%targetbias=abs(targetbias)/phinorm the_ps%bdpos=bdpos the_ps%frequency=frequency*tnorm*2*pi the_ps%deltabias=deltabias/phinorm ! save the experimental neutral density the_ps%expdens=expneutdens ! save the neutral collision density the_ps%neutcoldens=neutcoldens if(present(rstbias))then ! Initialize the current bias from the restart value the_ps%bias=rstbias else ! initialize with the file input parameters if (the_domain%nbsplines.gt.0) then do i=1,the_ps%nbbounds if(the_ps%bdpos(i) .lt. 0)then the_ps%bias=-the_domain%boundaries(i)%Dirichlet_val exit end if end do else the_ps%bias=(potout-potinn) end if end if - ! set the initial bias + ! set the initial bias only for the selected boundaries where(the_ps%bdpos .lt. 0) the_ps%biases=-the_ps%bias end where ! Normalise resistor and capacitor to adapt to experimental pressure the_ps%PSresistor = PSresistor*the_ps%expdens/the_ps%neutcoldens*qnorm/(tnorm*phinorm) the_ps%geomcapacitor = geomcapacitor*phinorm/qnorm the_ps%nbhdt = nbhdt the_ps%active = active if( .not. the_ps%active) return ! Initialize the biases if (the_domain%nbsplines.gt.0) then do i=1,the_ps%nbbounds the_domain%boundaries(i)%Dirichlet_val=the_ps%biases(i)+the_ps%deltabias*sin(the_ps%frequency*cstep*dt) end do else potinn=the_ps%biases(1)+the_ps%deltabias*sin(the_ps%frequency*cstep*dt) Potout=0 Phidown=Potinn Phiup=Potout end if ! recalculate gtilde to adapt for the new biases CALL total_gtilde(vec1, vec2, gtilde, gridwdir) !$OMP PARALLEL call comp_gradgtilde !$OMP END PARALLEL ! Recompute the vacuum field call vacuum_field end subroutine - ! save to the result file the parameters of this module read from the input - Subroutine psupply_diag(File_handle, str) +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> Saves the non-ideal power supply parameters to the h5 result file +!> @param[in] File_handle Integer id of the h5 result file +!> @param[in] parentgroup h5 group into which save the PS module parameters +!--------------------------------------------------------------------------- + Subroutine psupply_diag(File_handle, parentgroup) use mpi Use futils use basic, only: tnorm, phinorm, qnorm implicit none Integer:: File_handle - Character(len=*):: str + Character(len=*):: parentgroup CHARACTER(len=256):: grpname Integer:: ierr, mpirank CALL MPI_COMM_RANK(MPI_COMM_WORLD, mpirank, ierr) IF(mpirank .eq. 0 .and. the_ps%active) THEN - Write(grpname,'(a,a)') trim(str),"/psupply" + Write(grpname,'(a,a)') trim(parentgroup),"/psupply" If(.not. isgroup(File_handle, trim(grpname))) THEN CALL creatg(File_handle, trim(grpname)) END IF Call attach(File_handle, trim(grpname), "expdens", the_ps%expdens) Call attach(File_handle, trim(grpname), "targetbias", the_ps%targetbias*phinorm) Call attach(File_handle, trim(grpname), "PSresistor", the_ps%PSresistor/the_ps%expdens*the_ps%neutcoldens/qnorm*(tnorm*phinorm)) Call attach(File_handle, trim(grpname), "geomcapacitor", the_ps%geomcapacitor/phinorm*qnorm) Call attach(File_handle, trim(grpname), "nbhdt", the_ps%nbhdt) Call putarr(File_handle,trim(grpname)//"/bdpos", the_ps%bdpos) END IF End subroutine psupply_diag - ! gneral routine called from stepon to update the psupply bias +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> General routine called from stepon to update the psupply bias. It calculates the incoming currents +!> and advances in time the applied bias if necessary. +!> @param[in] ps Power supply structure +!> @param[in] p Simulated particles structure +!> @param[in] cstep Current time step number +!--------------------------------------------------------------------------- + subroutine psupply_step(ps,p,cstep) use particletypes use geometry use weighttypes use fields use basic, only: Potinn, potout type(power_supply):: ps type(particles):: p(:) integer:: cstep, i if (.not. ps%active ) return ! calculate the charge collected on each boundary due to the contribution of each specie call add_charge(ps,p) ! calculate the current flowing between the electrodes due to the cloud call calc_current(ps,cstep) ! calculate the bias at the new time step call updt_bias(ps,cstep) if(mod(cstep-ps%lststp,2*ps%nbhdt) .ne. 0) return ! update the bias on the geometry for the Dirichlet b.c. if (the_domain%nbsplines.gt.0) then do i=1,ps%nbbounds the_domain%boundaries(i)%Dirichlet_val=ps%biases(i) end do else potinn=ps%biases(1) Potout=0 Phidown=Potinn Phiup=Potout end if !$OMP PARALLEL !$OMP DO Do i=0,nr ! recalculate gtilde to adapt for the new biases CALL total_gtilde(vec1(i*(nz+1)+1:(i+1)*(nz+1)), vec2(i*(nz+1)+1:(i+1)*(nz+1)), gtilde(:,i*(nz+1)+1:(i+1)*(nz+1)), gridwdir(:,i*(nz+1)+1:(i+1)*(nz+1))) end do !$OMP END DO call comp_gradgtilde !$OMP END PARALLEL call vacuum_field end subroutine - ! calculates the current flowing between the electrodes due to the cloud +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> calculates the current flowing between the electrodes due to the clouds +!> @param[in] ps Power supply structure +!> @param[in] cstep Current time step number +!--------------------------------------------------------------------------- subroutine calc_current(ps,cstep) use geometry use basic, only: phinorm, dt use fields type(power_supply):: ps integer:: cstep if(mod(cstep-ps%lststp,ps%nbhdt).eq.0) then ! communicate the charge accumulation in this timestep call reduce_charge(ps) if(mod(cstep-ps%lststp,ps%nbhdt*2).eq.0)then ! calculates the current by adding the contribution of each boundary if (mpirank .eq. 0)then ps%current(3)=sum(-ps%charge*ps%bdpos)/(ps%nbhdt*dt) end if ps%lststp=cstep else ! calculates the current by adding the contribution of each boundary if (mpirank .eq. 0)then ps%current(2)=sum(-ps%charge*ps%bdpos)/(ps%nbhdt*dt) end if end if ps%charge=0 end if end subroutine - ! calculate the charge deposited by each specie on the electrodes (used to calculate the resulting current) +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> calculate the charge deposited by each specie on the electrodes (used to calculate the resulting current) +!> @param[in] ps Power supply structure +!> @param[in] p Simulated particles structure +!--------------------------------------------------------------------------- subroutine add_charge(ps,p) use particletypes use basic, only: qnorm type(power_supply):: ps type(particles):: p(:) integer:: i do i=1,size(p,1) if(.not. p(i)%is_field) cycle !Add the normalised contribution of each specie ps%charge=ps%charge+p(i)%nblost(5:)*p(i)%weight*p(i)%q/qnorm end do end subroutine - ! Time integrate the ODE of the actual bias between the accelerating electrodes - ! and broadcast it to all the workers +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> Time integrate the ODE of the actual bias between the accelerating electrodes +!> and broadcast it to all the workers +!> @param[in] ps Power supply structure +!> @param[in] cstep Current time-step number +!--------------------------------------------------------------------------- subroutine updt_bias(ps,cstep) use basic, only: dt implicit none type(power_supply):: ps integer:: cstep real(kind=db):: bias,k1,k2,k3,k4, hdeltat if(mod(cstep-ps%lststp,2*ps%nbhdt) .ne. 0) return ! half delta t if (ps%PSresistor.gt.0)then hdeltat=dt*ps%nbhdt/(ps%PSresistor*ps%geomcapacitor) bias=ps%bias ! we update the bias using RK4 k1=-(bias+ps%current(1)*ps%PSresistor-ps%targetbias) k2=-(bias+hdeltat*k1+ps%current(2)*ps%PSresistor-ps%targetbias) k3=-(bias+hdeltat*k2+ps%current(2)*ps%PSresistor-ps%targetbias) k4=-(bias+2*hdeltat*k3+ps%current(3)*ps%PSresistor-ps%targetbias) ps%bias=bias+(k1+2*k2+2*k3+k4)*2*hdeltat/6 end if !Write(*,*) " new bias ", ps%bias*phinorm where (ps%bdpos .lt. 0) ps%biases=-ps%bias+ps%deltabias*sin(ps%frequency*cstep*dt) end where where (ps%bdpos .eq. 2) ps%biases=ps%deltabias*sin(ps%frequency*cstep*dt) end where ! broadcast the bias to all the mpi processes call bcast_bias(ps) ps%current(1)=ps%current(3) end subroutine updt_bias - - ! gather on node 0 the collected charge on each metallic boundary +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> gather on node 0 the collected charge on each metallic boundary +!> @param[in] ps Power supply structure +!--------------------------------------------------------------------------- subroutine reduce_charge(ps) use mpi use mpihelper use basic, ONLY: mpirank type(power_supply):: ps integer:: ierr if(mpirank .eq. 0) then call MPI_REDUCE(MPI_IN_PLACE,ps%charge,ps%nbbounds,db_type,db_sum_op,0,MPI_COMM_WORLD,ierr) !Write(*,*) "curr charge ", ps%charge else call MPI_REDUCE(ps%charge,ps%charge,ps%nbbounds,db_type,db_sum_op,0,MPI_COMM_WORLD,ierr) end if end subroutine - ! broadcast to all the nodes the new bias imposed by the power supply on the electrodes +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> broadcast to all the nodes the new bias imposed by the power supply on the electrodes +!> @param[in] ps Power supply structure +!--------------------------------------------------------------------------- ! subroutine bcast_bias(ps) use mpi use mpihelper type(power_supply):: ps integer:: ierr call MPI_BCAST(ps%biases,ps%nbbounds,db_type,0,MPI_COMM_WORLD,ierr) end subroutine end module psupply diff --git a/src/sort_mod.f90 b/src/sort_mod.f90 index f3426df..3f728aa 100644 --- a/src/sort_mod.f90 +++ b/src/sort_mod.f90 @@ -1,133 +1,133 @@ !------------------------------------------------------------------------------ ! EPFL/Swiss Plasma Center !------------------------------------------------------------------------------ ! ! MODULE: sort ! !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> Module containing particle sorting algorithms. !------------------------------------------------------------------------------ MODULE sort IMPLICIT NONE CONTAINS !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Sorts the particles according to their Z position using quick sort algorithm ! !> @param[inout] p the particles array that need to be sorted !> @param[in] leftlimit the left limit index for the sub array considered. !> @param[in] rightlimit the right limit index for the sub array considered. !--------------------------------------------------------------------------- RECURSIVE SUBROUTINE quicksortparts(p, leftlimit, rightlimit) Use beam, ONLY: particles, exchange_parts USE constants TYPE(particles), INTENT(INOUT):: p INTEGER,INTENT(IN):: leftlimit, rightlimit REAL(kind=db):: pivot INTEGER::i, cnt, mid IF(leftlimit .ge. rightlimit) RETURN ! Impossible indices, return mid=(leftlimit+rightlimit)/2 ! Compute middle index IF(p%pos(3,mid) .lt.p%pos(3,leftlimit)) CALL exchange_parts(p,leftlimit,mid) IF(p%pos(3,rightlimit).lt.p%pos(3,leftlimit)) CALL exchange_parts(p,leftlimit,rightlimit) IF(p%pos(3,mid) .lt.p%pos(3,rightlimit)) CALL exchange_parts(p,rightlimit,mid) ! Store the pivot point for comparison pivot=p%pos(3,rightlimit) cnt=leftlimit ! Move all parts with Z smaller than pivot to the left of pivot DO i=leftlimit, rightlimit IF(p%pos(3,i) .le. pivot) THEN CALL exchange_parts(p, i,cnt) cnt=cnt+1 END IF END DO ! Quicksort the sub-arrays CALL quicksortparts(p, leftlimit,cnt-2) CALL quicksortparts(p, cnt,rightlimit) END SUBROUTINE quicksortparts !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Sorts the particles according to their linear index in the poisson solver grid. ! !> @param[inout] p the particles array that need to be sorted !> @param[in] leftlimit the left limit index for the sub array considered. !> @param[in] rightlimit the right limit index for the sub array considered. !--------------------------------------------------------------------------- RECURSIVE SUBROUTINE gridsort(p, leftlimit, rightlimit) Use beam, ONLY: particles, exchange_parts USE constants TYPE(particles), INTENT(INOUT):: p INTEGER,INTENT(IN):: leftlimit, rightlimit REAL(kind=db):: pivot INTEGER::i, cnt, mid IF(leftlimit .ge. rightlimit) RETURN ! Impossible indices, return mid=(leftlimit+rightlimit)/2 ! Compute middle index IF(linindex(p,mid).lt.linindex(p,leftlimit)) CALL exchange_parts(p,leftlimit,mid) IF(linindex(p,rightlimit).lt.linindex(p,leftlimit)) CALL exchange_parts(p,leftlimit,rightlimit) IF(linindex(p,mid).lt.linindex(p,rightlimit)) CALL exchange_parts(p,rightlimit,mid) ! Store the pivot point for comparison pivot=linindex(p,rightlimit) cnt=leftlimit ! Move all parts with Z smaller than pivot to the left of pivot DO i=leftlimit, rightlimit IF(linindex(p,i) .le. pivot) THEN CALL exchange_parts(p, i,cnt) cnt=cnt+1 END IF END DO ! Quicksort the sub-arrays CALL gridsort(p, leftlimit,cnt-2) CALL gridsort(p, cnt,rightlimit) END SUBROUTINE gridsort !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief Computes the linear index of a given particle in the Poisson solver 2D grid ! !> @param[in] p the particles array where the particle is stored !> @param[in] pid the index in the particle array of the particle of interest !> @param[out] linindex the computed linear index. !--------------------------------------------------------------------------- FUNCTION linindex(p,pid) USE beam, ONLY: particles USE basic, ONLY: nz INTEGER :: linindex, pid TYPE(particles):: p - linindex=p%Zindex(pid)+p%rindex(pid)*nz + linindex=p%cellindex(3,pid)+p%cellindex(1,pid)*nz END FUNCTION linindex END MODULE sort diff --git a/src/splinebound_mod.f90 b/src/splinebound_mod.f90 index 8dd7809..89f0e6c 100644 --- a/src/splinebound_mod.f90 +++ b/src/splinebound_mod.f90 @@ -1,1034 +1,1113 @@ +!------------------------------------------------------------------------------ +! EPFL/Swiss Plasma Center +!------------------------------------------------------------------------------ +! +! MODULE: splinebound +! +!> @author +!> G. Le Bars - EPFL/SPC +! +!> Last modif. +!> 06/07 2023 +! +! DESCRIPTION: +!> Module handling domain boundaries defined by NURBS curves +!------------------------------------------------------------------------------ MODULE splinebound USE constants USE bsplines USE forSISL, only: newCurve, freeCurve, freeIntCurve, writeSISLcurve, writeSISLpoints Use forSISLdata IMPLICIT NONE INTEGER, PARAMETER :: bd=-1, bd_Dirichletconst=0, bd_Dirichletvar=1, bd_Neumann=2 logical:: nlexact type cellkind integer:: spldirkind=0 !< -1 outside (return -1) no dist to calculate; 0 boundary calculate dist with linked boundaries; 1 inside (return 1) no dist to calculate integer:: spltotkind=0 !< -1 outside (return -1) no dist to calculate; 0 boundary calculate dist with linked boundaries; 1 inside (return 1) no dist to calculate integer:: linkedboundaries(2)=0 !< stores the spline curve indices in the spline_domain of the spline boundaries that are the closest and at a distance lower than dist_extent (1) !< (1) is for dirichlet boundaries !< (2) is for domain boundaries integer:: leftknot(4)=0 !< knots pointer for s1424 in wtot then wdir real(kind=db):: lguess(2)=-1 !< Spline parameter left limit as start guess real(kind=db):: rguess(2)=-1 !< Spline parameter right limit as start guess real(kind=db),allocatable:: slims(:,:) !< Spline parameter limits for boundary i in the cell real(kind=db),allocatable:: blen(:) !< curve length boundary i in the cell end type cellkind TYPE spline_boundary ! all curves assume right handedness to set which side of the curve is inside or outside type(SISLCurve):: curve Real(kind=db):: Dirichlet_val !< Value for the dirichlet boundary condition created by this boundary Real(kind=db):: epsge=1.0e-5 !< geometric resolution used for calculating distances Real(kind=db):: epsce=1.0e-9 !< value of weight below which it is 0 INTEGER(kind(bd)):: type=bd_Dirichletconst !< type of boundary conditions END TYPE spline_boundary type spline_domain integer:: nbsplines = 0 !< number of spline boundaries in the domain type(spline_boundary), allocatable:: boundaries(:) !< List of boundaries in the domain Real(kind=db):: dist_extent=0.1 !< distance used for the merging with the plateau function for the weight type(cellkind), ALLOCATABLE:: cellk(:,:) !< Precomputed parameters at each cell for faster weight computation type(spline2d), pointer:: splrz => null() !< Pointer to the main spline grid used for the FEM solver Integer:: nb1 !< Number of grid points in the 1st dimension Integer:: nb2 !< Number of grid points in the 2nd dimension real(kind=db), ALLOCATABLE:: x1(:) !< Grid points in first direction for weight interpolation real(kind=db), ALLOCATABLE:: x2(:) !< Grid points in 2nd direction for weight interpolation real(kind=db), ALLOCATABLE:: dx1(:) !< inverse cell width in first direction for weight interpolation real(kind=db), ALLOCATABLE:: dx2(:) !< inverse cell width in 2nd direction for weight interpolation !type(SISLsurf):: Dirdomweight !< structure storing precalculated geometric weight for faster evaluation !type(SISLsurf):: totdomweight !< structure storing precalculated total weight for faster evaluation type(spline2d):: Dirdomweightspl !< structure storing precalculated geometric weight for faster evaluation type(spline2d):: totdomweightspl !< structure storing precalculated total weight for faster evaluation end type spline_domain CONTAINS !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Reads a spline domain from the namelist or from a h5 file. Needs to be called for the initialization of the module !> @param[in] Fileid Text file id of the input file containing namelists !> @param[out] spldom spline domain !> @param[in] splrz bspline structure used by the FEM comming form bspline library !> @param[in] rnorm distance normalization constant !> @param[in] phinorm electric potential normalization constant !--------------------------------------------------------------------------- subroutine read_splinebound(Fileid, spldom, splrz, rnorm, Phinorm) use mpi Integer:: Fileid type(spline_domain):: spldom type(spline2d):: splrz real(kind=db):: rnorm, phinorm - Integer:: nbsplines, istat, mpirank, ierr - real(kind=db):: dist_extent - Character(len=128):: h5fname="", line + Integer:: istat, mpirank, ierr + real(kind=db):: dist_extent ! distance in [m] over which the w goes from 1 to 0 + Character(len=128):: h5fname="" ! name of the h5 file storing the geometry + Character(len=128):: line real(kind=db) :: Dvals(30)=0 integer:: i - namelist /spldomain/ nbsplines, dist_extent, h5fname, Dvals, nlexact + namelist /spldomain/ dist_extent, h5fname, Dvals, nlexact CALL MPI_COMM_RANK(MPI_COMM_WORLD, mpirank, ierr) REWIND(fileid) READ(fileid,spldomain, iostat=istat) if (istat.gt.0) then if(mpirank .eq. 0) then backspace(fileid) read(fileid,fmt='(A)') line write(*,'(A)') & 'Invalid line in geomparams: '//trim(line) end if call MPI_Abort(MPI_COMM_WORLD, -1, ierr) stop end if if(mpirank .eq. 0) WRITE(*, spldomain) Dvals=Dvals/phinorm dist_extent=dist_extent/rnorm if (.not. trim(h5fname)=='' ) then call setspline_domain(spldom, splrz, dist_extent, 0) call splinebound_readh5domain(h5fname,spldom, rnorm, phinorm) - call classifycells(spldom) + call precomputecells(spldom) do i=1,spldom%nbsplines spldom%boundaries(i)%Dirichlet_val=Dvals(i) end do return else WRITE(*,*) "Error the filename h5fname is not defined. No boundary has been set!" call mpi_Abort(MPI_COMM_WORLD, -1, ierr) end if end subroutine !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Saves the spline boundaries to the result file !> @param[in] File_handle futils h5 file id !> @param[in] curr_grp groupname under which the boundaries must be saved !> @param[in] spldom spline domain !--------------------------------------------------------------------------- Subroutine splinebound_diag(File_handle, curr_grp, spldom) use mpi Use futils Use basic, ONLY: rnorm, phinorm Integer:: File_handle type(spline_domain):: spldom Character(len=*):: curr_grp CHARACTER(len=128):: grpname Integer:: ierr, mpirank, i CALL MPI_COMM_RANK(MPI_COMM_WORLD, mpirank, ierr) IF(mpirank .eq. 0) THEN Write(grpname,'(a,a)') trim(curr_grp),"/geometry_spl" If(.not. isgroup(File_handle, trim(grpname))) THEN CALL creatg(File_handle, trim(grpname)) END IF Call attach(File_handle, trim(grpname), "dist_extent",spldom%dist_extent) Call attach(File_handle, trim(grpname), "nbsplines", spldom%nbsplines) do i=1,spldom%nbsplines Write(grpname,'(a,a,i2.2)') trim(curr_grp),"/geometry_spl/",i If(.not. isgroup(File_handle, trim(grpname))) THEN CALL creatg(File_handle, trim(grpname)) END IF Call attach(File_handle, trim(grpname), "Dirichlet_val", spldom%boundaries(i)%Dirichlet_val*phinorm) Call attach(File_handle, trim(grpname), "order", spldom%boundaries(i)%curve%ik) Call attach(File_handle, trim(grpname), "kind", spldom%boundaries(i)%curve%ikind) Call attach(File_handle, trim(grpname), "type", spldom%boundaries(i)%type) Call attach(File_handle, trim(grpname), "dim", spldom%boundaries(i)%curve%idim) CALL putarr(File_handle, TRIM(grpname)//"/pos", spldom%boundaries(i)%curve%ecoef*rnorm) CALL putarr(File_handle, TRIM(grpname)//"/knots", spldom%boundaries(i)%curve%et) end do END IF End subroutine splinebound_diag !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Read a spline boundary domain from an h5 file structure !> @param[out] spldom new spline domain !> @param[in] filename filename of the h5 file !> @param[in] rnorm distance normalization constant !> @param[in] phinorm electric potential normalization constant !--------------------------------------------------------------------------- subroutine splinebound_readh5domain(filename, spldom, rnorm, phinorm) use futils use forSISL implicit none Character(len=*),intent(in) :: filename type(spline_domain),intent(inout) :: spldom integer:: h5id, i real(kind=db):: rnorm, phinorm CHARACTER(len=128):: grpname integer:: periodic integer:: order, dim, bdtype INTEGER:: posrank, posdim(2), err real(kind=db):: Dval, epsge, epsce real(kind=db),allocatable:: points(:,:) call openf(filename, h5id,'r','d') call getatt(h5id, '/geometry_spl/','nbsplines', spldom%nbsplines) ! prepare memory if (allocated(spldom%boundaries)) then do i=1,size(spldom%boundaries,1) call free_bsplinecurve(spldom%boundaries(i)) end do DEALLOCATE(spldom%boundaries) end if allocate(spldom%boundaries(spldom%nbsplines)) ! Read each boundary curve individually do i=1,spldom%nbsplines Write(grpname,'(a,i2.2)') "/geometry_spl/",i If(.not. isgroup(h5id, trim(grpname))) THEN Write(*,*) "Error the geometry definition file is invalid" END IF periodic=0 Call getatt(h5id, trim(grpname), "Dirichlet_val", Dval) Call getatt(h5id, trim(grpname), "epsge", epsge) Call getatt(h5id, trim(grpname), "epsce", epsce) Call getatt(h5id, trim(grpname), "order", order) Call getatt(h5id, trim(grpname), "dim", dim) err=0 Call getatt(h5id, trim(grpname), "periodic", periodic,err) if(err .lt.0) periodic=0 CALL getdims(h5id, TRIM(grpname)//"/pos", posrank, posdim) allocate(points(posdim(1),posdim(2))) CALL getarr(h5id, TRIM(grpname)//"/pos", points) points=points/rnorm Call setspline_boundary(spldom%boundaries(i),transpose(points), order-1, Dval/phinorm, epsge,epsce, periodic) bdtype=bd err=0 Call getatt(h5id, trim(grpname), "type", bdtype,err) if(err.ge.0) spldom%boundaries(i)%type=bdtype deallocate(points) end do call closef(h5id) end subroutine splinebound_readh5domain !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> initialize a spline domain and allocate the necessary memory !> @param[out] spldom new spline domain !> @param[in] splrz bspline structure used by the FEM comming form bspline library !> @param[in] dist_extent normalized characteristic fall lenght of the weight !> @param[in] nb_splines number of boundary splines to allocate !--------------------------------------------------------------------------- subroutine setspline_domain(spldom,splrz,dist_extent, nb_splines) type(spline_domain):: spldom type(spline2d), TARGET:: splrz real(kind=db):: dist_extent integer:: nb_splines, nb1, nb2 ! Store the grid parameters to speed-up calculations nb1=splrz%sp1%nints nb2=splrz%sp2%nints spldom%nb1=nb1 spldom%nb2=nb2 spldom%splrz=>splrz allocate(spldom%cellk(0:nb1-1,0:nb2-1)) allocate(spldom%x1(0:nb1)) allocate(spldom%x2(0:nb2)) allocate(spldom%dx1(0:nb1-1)) allocate(spldom%dx2(0:nb2-1)) spldom%x1(0:)=splrz%sp1%knots(0:nb1) spldom%x2(0:)=splrz%sp2%knots(0:nb2) spldom%dx1(0:)=1/(spldom%x1(1:nb1)-spldom%x1(0:nb1-1)) spldom%dx2(0:)=1/(spldom%x2(1:nb2)-spldom%x2(0:nb2-1)) !Prepare structures to host singular spline boundaries spldom%nbsplines=nb_splines if(spldom%nbsplines.gt. 0) allocate(spldom%boundaries(nb_splines)) spldom%dist_extent=dist_extent end subroutine setspline_domain !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief initialize a spline boundary and allocate the necessary memory !> @param[out] b_curve new spline boundary !> @param[in] cpoints control points at the node positions !> @param[in] degree degree of the spline polynomia defining the boundary curve !> @param[in] D_val Normalized value of the Dirichlet boundary condition for this curve !> @param[in] epsge geometric precision used by SISL !> @param[in] epsce arithmetic precision used by SISL !> @param[in] periodic set if the spline curve is periodic !--------------------------------------------------------------------------- subroutine setspline_boundary(b_curve, cpoints, degree, D_val, epsge, epsce, periodic) Use bsplines use forSISL,ONLY: newcurve, s1630 use mpi type(spline_boundary):: b_curve Real(kind=db):: cpoints(:,:) Real(REAL64),ALLOCATABLE:: points(:) Real(REAL64):: astpar integer:: degree integer, optional:: periodic Integer:: order, ierr, i,j Real(kind=db):: D_val ,dist Real(kind=db),OPTIONAL :: epsge, epsce Integer:: nbpoints, dim, jstat, bsptype integer:: period period=0 if(present(periodic))period=periodic nbpoints= size(cpoints,2) dim=size(cpoints,1) order=degree+1 if(nbpoints .lt. order) then WRITE(*,'(a,i3,a,i5)') "Error: the number of points", nbpoints, " is insuficient for the required order ", order CALL mpi_finalize(ierr) call EXIT(-1) end if allocate(points(dim*nbpoints)) j=1 points(1:2)=cpoints(:,1) do i=2,nbpoints dist=sum((points(2*(j-1)+1:2*(j-1)+2)-cpoints(:,i))**2) if(dist.lt.1e-12) cycle points(2*j+1:2*j+2)=cpoints(:,i) j=j+1 end do !points=reshape(cpoints,(/dim*nbpoints/)) bsptype=1 ! open boundaries b-spline if(period.gt.0) bsptype=-1 ! closed periodic curve astpar=0.0_db ! starting parameter for the knots vector ! initialize a new curve using SISL CALL s1630(points, j, astpar, bsptype, dim, order, b_curve%curve, jstat) if (jstat > 0 ) WRITE(*,*) "Warning ", jstat," in curve initialisation s1630 for splineweight" if (jstat < 0 ) WRITE(*,*) "Error ", jstat," in curve initialisation s1630 for splineweight" b_curve%Dirichlet_val=D_val if(present(epsge)) b_curve%epsge=epsge if(present(epsce)) b_curve%epsce=epsce end subroutine setspline_boundary !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Calculates the Dirichlet boundary weight from a given spline domain !> @param[in] spldom spline domain containing the information on the boundary conditions !> @param[in] x1(:) array of axial positions where the weights are evaluated !> @param[in] x2(:) array of radial positions where the weights are evaluated !> @param[out] w(:,0:) matrix of weights with first index corresponding to the position and second index to the derivative !--------------------------------------------------------------------------- SUBROUTINE spline_w(spldom,x1,x2,w) use bsplines type(spline_domain):: spldom Real(kind=db), INTENT(IN):: x2(:),x1(:) Real(kind=db), INTENT(OUT):: w(0:,:) Integer,allocatable::i(:),j(:) Integer:: k,l allocate(i(size(x2,1)),j(size(x2,1))) call getindex(x1, x2, spldom, i, j) if (nlexact) then do k=1,size(x1) l=spldom%cellk(i(k),j(k))%linkedboundaries(1) if(l.eq.0)then w(:,k)=0 w(0,k)=spldom%cellk(i(k),j(k))%spldirkind else call splineweight(spldom%boundaries(l),x1(k),x2(k),w(:,k),spldom%dist_extent) end if end do return end if if (size(w,1).gt.1) then CALL speval(spldom%Dirdomweightspl, x1, x2, i, j, w(0,:), w(1,:), w(2,:)) else CALL speval(spldom%Dirdomweightspl, x1, x2, i, j, w(0,:)) end if End SUBROUTINE spline_w !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Calculates the total geometric weight from a given spline domain !> @param[in] spldom spline domain containing the information on the boundary conditions !> @param[in] x1(:) array of axial positions where the weights are evaluated !> @param[in] x2(:) array of radial positions where the weights are evaluated !> @param[out] w(:,0:) matrix of weights with first index corresponding to the position and second index to the derivative !--------------------------------------------------------------------------- SUBROUTINE spline_wtot(spldom,x1,x2,w,idwall) use forSISL,ONLY: s1424 use bsplines type(spline_domain):: spldom Real(kind=db), INTENT(IN):: x2(:),x1(:) Real(kind=db), INTENT(OUT):: w(0:,:) INTEGER, optional, INTENT(OUT):: idwall(:) Integer:: k,l Integer,allocatable::i(:),j(:) allocate(i(size(x2,1)),j(size(x2,1))) call getindex(x1, x2, spldom, i, j) if(present(idwall)) then Do k=1,size(x2,1) idwall(k)=spldom%cellk(i(k),j(k))%linkedboundaries(2) END DO end if if (nlexact) then do k=1,size(x1) l=spldom%cellk(i(k),j(k))%linkedboundaries(2) if(l.eq.0)then w(:,k)=0 w(0,k)=spldom%cellk(i(k),j(k))%spltotkind else call splineweight(spldom%boundaries(l),x1(k),x2(k),w(:,k),spldom%dist_extent) end if end do return end if if (size(w,1).gt.1) then CALL speval(spldom%totdomweightspl, x1, x2, i, j, w(0,:), w(1,:), w(2,:)) else CALL speval(spldom%totdomweightspl, x1, x2, i, j, w(0,:)) end if End SUBROUTINE spline_wtot !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Calculates the interpolation in the domain of the Dirichlet boundary conditions from a given spline domain !> @param[in] spldom spline domain containing the information on the boundary conditions !> @param[in] z(:) array of axial positions where the weights are evaluated !> @param[in] r(:) array of radial positions where the weights are evaluated !> @param[out] g(:,0:) matrix of boundary interpolations g with first index corresponding to the position and second index to the derivative !--------------------------------------------------------------------------- SUBROUTINE spline_g(spldom,x1,x2,g,w) use forSISL,ONLY: s1424 use bsplines type(spline_domain):: spldom Real(kind=db), INTENT(IN):: x2(:),x1(:) Real(kind=db), INTENT(OUT):: g(0:,:) Real(kind=db), INTENT(IN),OPTIONAL::w(0:,:) REAL(real64),allocatable:: gtmp(:,:) Integer:: k,l Integer,allocatable::i(:),j(:) !type(cellkind):: cellk allocate(gtmp(0:size(g,1)-1,size(x2,1))) allocate(i(size(x2,1)),j(size(x2,1))) call getindex(x1, x2, spldom, i, j) if(present(w)) then gtmp=w else if (nlexact) then do k=1,size(x1) l=spldom%cellk(i(k),j(k))%linkedboundaries(2) call splineweight(spldom%boundaries(l),x1(k),x2(k),gtmp(:,k),spldom%dist_extent) end do else CALL speval(spldom%Dirdomweightspl, x1, x2,i,j, gtmp(0,:), gtmp(1,:), gtmp(2,:)) end if end if Do k=1,size(x2,1) if(spldom%cellk(i(k),j(k))%spldirkind.eq.0)then if(gtmp(0,k) .ge. 0) then if(size(g,1) .gt. 1) then g(1:2,k)=-gtmp(1:2,k)*spldom%boundaries(spldom%cellk(i(k),j(k))%linkedboundaries(1))%Dirichlet_val end if g(0,k)=(1-gtmp(0,k))*spldom%boundaries(spldom%cellk(i(k),j(k))%linkedboundaries(1))%Dirichlet_val else g(0,k)=spldom%boundaries(spldom%cellk(i(k),j(k))%linkedboundaries(1))%Dirichlet_val if(size(g,1).gt. 1) then g(1:2,k)=0 end if end if else g(:,k)=0 end if end DO End SUBROUTINE spline_g !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Evaluates the geometric weight induced by the spline curve defined by b_curve at position (z,r) !> @param[in] b_curve spline_boundary containing the spline curve parameters !> @param[in] z axial position where the weight is evaluated !> @param[in] r radial position where the weight is evaluated !> @param[out] weight(:) weight index defines the order of derivation by r or z !> @param[in] h distance from the spline at which the weight is 1 !> @param[out] distance unscaled distance between evaluation point and spline b_curve !> @param[inout] leftknot initial guess for the closest spline knot of the points (r,z) !--------------------------------------------------------------------------- subroutine splineweight(b_curve, z, r, weight, h, distance, guess, lguess, rguess) Use forSISL, ONLY: s1227,s1221, s1774 type(spline_boundary):: b_curve Real(kind=db)::r,z Real(kind=db):: weight(0:) Real(kind=db),OPTIONAL:: distance real(kind=db),OPTIONAL:: guess real(kind=db),OPTIONAL:: lguess real(kind=db),OPTIONAL:: rguess integer:: sstatus, der, left,siz real(kind=db):: h, d, tpos, proj, norm real(kind=real64):: curvepos(2*b_curve%curve%idim) real(kind=db):: leftpar, rightpar,guesspar weight=0 der=1 sstatus=-1 guesspar=-1.0_db if(present(lguess) .and. present(rguess)) then leftpar=lguess rightpar=rguess guesspar=(lguess+rguess)/2 call s1774(b_curve%curve,(/z,r/),b_curve%curve%idim,b_curve%epsge,leftpar,rightpar,guesspar,tpos,sstatus) if (sstatus < 0 ) WRITE(*,*) "Error ",sstatus," in distance calculation s1774 for splineweight at ", z, r else call dist(b_curve,(/z,r/),d,tpos) end if ! position and derivative wrt r,z call s1227(b_curve%curve,der,tpos,left,curvepos,sstatus) if (sstatus > 0 ) WRITE(*,*) "Warning ",sstatus," in distance calculation s1227 for splineweight at ", z, r if (sstatus < 0 ) WRITE(*,*) "Error ",sstatus," in distance calculation s1227 for splineweight at ", z, r d=sqrt((curvepos(1)-z)**2+(curvepos(2)-r)**2) weight(0)=1-max((h-d)/h,0.0_db)**3 norm=sqrt(curvepos(3)**2+curvepos(4)**2) if(norm.gt.0) curvepos(3:4)=curvepos(3:4)/norm ! if the projection of the distance vector on the normal is negative, the weight is negative proj=(-(z-curvepos(1))*curvepos(4)+(r-curvepos(2))*curvepos(3)) !if (proj .lt. 0 .or. abs(abs(proj) -sqrt((z-curvepos(1))**2+(r-curvepos(2))**2)).gt.1e-8) weight(0)=-weight(0) if (proj .lt. 0)then weight(0)=-weight(0) end if !if (proj .lt. 0 ) weight(0)=-weight(0) siz=size(weight,1) if (size(weight,1).gt.1 .and. abs(weight(0)) .lt. 1) then weight(1)=-3*curvepos(4)*abs((h-d))/h**3 weight(2)=+3*curvepos(3)*abs((h-d))/h**3 end if if(present(distance)) distance=d if(present(guess)) guess=tpos end subroutine !--------------------------------------------------------------------------- !> @author !> Guillaume Le Bars EPFL/SPC ! ! DESCRIPTION: !> !> @brief !> Calculates the closest distance between the point and the selected spline b_curve !> @param[in] b_curve spline_boundary containing the spline curve parameters !> @param[in] point(:) array containing the position from which to calculate the distance !> @param[out] distance distance from the point to the spline !> @param[in] pos parameter value of the closest point on the spline !--------------------------------------------------------------------------- subroutine dist(b_curve, point, distance, pos) Use forSISL, ONLY: s1957,s1953, s1221,s1227 type(spline_boundary):: b_curve Real(kind=db):: point(:) real(kind=db):: distance Real(kind=db),optional::pos REAL(real64):: posres, epsco, epsge,curvepos(2),d,distmin REAL(real64),allocatable::intpar(:) integer:: numintpt, numintcu,i,left,sstatus type(SISLIntCurve),ALLOCATABLE:: intcurve(:) epsco=1.0e-15 epsge=1.0e-15 !epsco=0 !epsge=b_curve%epsge numintpt=0 sstatus=0 distmin=HUGE(d) !call s1957(b_curve%curve,point,b_curve%curve%idim,epsco,epsge,posres,distance,sstatus) ! !if(sstatus.eq.0) then ! if (present(pos)) pos=posres ! return !end if ! !!if (sstatus > 0 ) WRITE(*,*) "Warning ",sstatus," in distance calculation s1953 for splineweight at ", point(1), point(2) !if (sstatus < 0 ) WRITE(*,*) "Error ",sstatus," in distance calculation s1953 for splineweight at ",point(1), point(2) ! call s1953(b_curve%curve,point,b_curve%curve%idim,epsco,epsge,numintpt,intpar,numintcu,intcurve,sstatus) if (sstatus > 0 ) WRITE(*,*) "Warning ",sstatus," in distance calculation s1953 for splineweight at ", point(1), point(2) if (sstatus < 0 ) WRITE(*,*) "Error ",sstatus," in distance calculation s1953 for splineweight at ",point(1), point(2) if(numintpt .gt. 1) then Do i=1,numintpt call s1227(b_curve%curve,0,intpar(i),left,curvepos,sstatus) if (sstatus > 0 ) WRITE(*,*) "Warning ",sstatus," in distance calculation s1221 for splineweight at ", point(1), point(2) if (sstatus < 0 ) WRITE(*,*) "Error ",sstatus," in distance calculation s1221 for splineweight at ",point(1), point(2) d=(curvepos(1)-point(1))**2+(curvepos(2)-point(2))**2 if(d .lt. distmin) then distmin=d posres=intpar(i) end if end do else if(numintpt .gt. 0) then posres=intpar(1) end if distance=distmin if(numintcu.ge.1) then posres=0.5*(intcurve(1)%epar1(1)+intcurve(1)%epar1(2)) end if call s1227(b_curve%curve,0,posres,left,curvepos,sstatus) if (sstatus > 0 ) WRITE(*,*) "Warning ",sstatus," in distance calculation s1227 for splineweight at ", point(1), point(2) if (sstatus < 0 ) WRITE(*,*) "Error ",sstatus," in distance calculation s1227 for splineweight at ", point(1), point(2) distance=sqrt((curvepos(1)-point(1))**2+(curvepos(2)-point(2))**2) if (present(pos)) pos=posres END subroutine +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> evaluate the cell limited by x1 and x2 and classify if this is an inner outer or boundary spline +!> in addition, for boundary cells, it stores the closest spline curve for the evaluation of the boundary and the +!> dirichlet weight +!> @param[in] x1 axial limits of the cell +!> @param[in] x2 radial limits of the cell +!> @param[in] cellk structure storing the parameters of this cell +!> @param[in] spldom structure defining the domain boundaries +!> @param[out] wpredir dirichletweight at the center of the cell +!> @param[out] wpretot totweight at the center of the cell +!--------------------------------------------------------------------------- SUBROUTINE classify(x1, x2, cellk, spldom, wpredir, wpretot) Use forSISL, ONLY: s1227 real(kind=db), INTENT(IN):: x2(2), x1(2) type(cellkind), intent(INOUT):: cellk type(spline_domain)::spldom Real(kind=db):: zeval(4),reval(4), wpretot, wpredir real(kind=db), allocatable:: guess(:,:), w(:,:,:) Real(kind=db):: dmin, insidedir, insidetot, distance integer:: i,k, left, sstatus logical:: isboundarycell real(kind=db):: curvepos1(2), curvepos2(2) allocate(guess(spldom%nbsplines,4)) allocate(w(0:2,spldom%nbsplines,4)) w=0 cellk%spldirkind=0 guess=-1.0_db dmin=HUGE(spldom%dist_extent) cellk%linkedboundaries=0 allocate(cellk%blen(spldom%nbsplines),cellk%slims(2,spldom%nbsplines)) cellk%blen=0 cellk%slims=0 ! we define the evaluation positions ! ! x(4)------x(3) ! | | ! | | ! x(1)------x(2) zeval=(/ x1(1),x1(2),x1(2),x1(1) /) reval=(/ x2(1),x2(1),x2(2),x2(2) /) insidedir=1 insidetot=1 do i=1,spldom%nbsplines isboundarycell=.false. do k=1,4 ! calculate the weight for each spline boundaries at each cell corner call splineweight(spldom%boundaries(i),zeval(k),reval(k),w(:,i,k),spldom%dist_extent,distance,guess(i,k)) ! We find the closest boundary to this point if(distance .lt. dmin) then ! If we are close enough we check if we are below dist_extent and need to calculate the distance each time if(distance .lt. spldom%dist_extent) then if(spldom%boundaries(i)%type .eq. bd_Dirichletconst .or. spldom%boundaries(i)%type .eq.bd_Dirichletvar) then cellk%linkedboundaries(1)=i cellk%spldirkind=0 end if cellk%linkedboundaries(2)=i cellk%spltotkind=0 end if dmin=distance ! Otherwise we define the interior by the closest spline if(spldom%boundaries(i)%type .eq. bd_Dirichletconst .or. spldom%boundaries(i)%type .eq.bd_Dirichletvar) then insidedir=w(0,i,k) end if insidetot=w(0,i,k) end if ! The neumann boundaries take precedence over the dirichlet boundaries ! this is important when they define what is outside of the simulation domain. if(spldom%boundaries(i)%type.eq. bd_Neumann.and. w(0,i,k).lt.0)then insidetot=w(0,i,k) if(distance.lt.spldom%dist_extent)then cellk%linkedboundaries(2) =i else cellk%linkedboundaries(2) =0 end if end if end do !If(w(0,i,1)*w(0,i,2) .le. 0 ) then ! isboundarycell=.true. !End If !If(w(0,i,2)*w(0,i,3) .le. 0 ) then ! isboundarycell=.true. !End If !If(w(0,i,3)*w(0,i,4) .le. 0 ) then ! isboundarycell=.true. !End If !If(w(0,i,4)*w(0,i,1) .le. 0 ) then ! isboundarycell=.true. !End If !if(isboundarycell)then ! cellk%slims(1,i)=minval(guess(i,:)) ! cellk%slims(2,i)=maxval(guess(i,:)) ! call s1227(spldom%boundaries(i)%curve,0,cellk%slims(1,i),left,curvepos1,sstatus) ! call s1227(spldom%boundaries(i)%curve,0,cellk%slims(2,i),left,curvepos2,sstatus) ! cellk%blen(i)=sqrt(sum((curvepos1-curvepos2)**2)) ! sstatus=0 !end if end do if(cellk%linkedboundaries(1) .gt. 0) then i=cellk%linkedboundaries(1) cellk%lguess(1)=minval(guess(i,:),1,guess(i,:).ge.0) cellk%rguess(1)=maxval(guess(i,:),1) wpredir=w(0,i,1) else cellk%spldirkind=sign(1,int(insidedir)) wpredir=insidedir end if if(cellk%linkedboundaries(2) .gt. 0) then i=cellk%linkedboundaries(2) wpretot=w(0,i,1) else cellk%spltotkind=sign(1,int(insidetot)) wpretot=insidetot end if end subroutine - subroutine classifycells(spldom) +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> evaluate all the cells of the FEM and classify if they are an inner outer or boundary spline +!> in addition, for boundary cells, it stores the closest spline curve for the evaluation of the boundary and the +!> dirichlet weight +!> This function also prepare the bivariate spline interpolant for quickly evaluating +!> the dirichletweight and the total weight +!> @param[in] spldom structure defining the domain boundaries +!--------------------------------------------------------------------------- + + subroutine precomputecells(spldom) use forSISL, ONLY: s1537, s1424 use bsplines type(spline_domain):: spldom integer:: i,j, dims(2), nbeval1, nbeval2,k,l real(kind=db)::val type(cellkind):: cellk real(kind=db), allocatable:: wpretot(:,:,:), wpredir(:,:,:), c(:,:), x1(:), x2(:) allocate(wpretot(1:1,0:spldom%nb1,0:spldom%nb2)) allocate(wpredir(1:1,0:spldom%nb1,0:spldom%nb2)) nbeval1=spldom%nb1+3 nbeval2=spldom%nb2+3 ! We set the interpolation points such that the spline interpolation of the weight uses the same knots as the spline interpolation of the electric potential allocate(x1(0:nbeval1-1),x2(0:nbeval2-1)) x1(0)=spldom%x1(0) x1(1)=(spldom%x1(0)+spldom%x1(1))/2.0_db j=0 do i=2,spldom%nb1 j=j+1 x1(i)=spldom%x1(j) !x1(i)=2*spldom%x1(j)-x1(i-1) end do x1(nbeval1-2)=(spldom%x1(spldom%nb1-1)+3*spldom%x1(spldom%nb1))/2.0_db x1(nbeval1-1)=spldom%x1(spldom%nb1) !write(*,*)"x1", x1 ! We do the same for x2 x2(0)=spldom%x2(0) x2(1)=(spldom%x2(0)+spldom%x2(1))/2.0_db j=0 do i=2,spldom%nb2 j=j+1 x2(i)=spldom%x2(j) !x2(i)=2*spldom%x2(j)-x2(i-1) end do x2(nbeval2-2)=(spldom%x2(spldom%nb2-1)+spldom%x2(spldom%nb2))/2.0_db x2(nbeval2-1)=spldom%x2(spldom%nb2) !write(*,*)"x2", x2 wpretot=0 wpredir=0 !$OMP PARALLEL DO private(i,j) collapse(2) do i=0,spldom%nb1-1 do j=0,spldom%nb2-1 call classify(spldom%x1(i:i+1),spldom%x2(j:j+1),spldom%cellk(i,j),spldom, wpredir(1,i,j),wpretot(1,i,j)) end do end do !$OMP END PARALLEL DO deallocate(wpretot) deallocate(wpredir) allocate(wpretot(1:1,0:nbeval1-1,0:nbeval2-1)) allocate(wpredir(1:1,0:nbeval1-1,0:nbeval2-1)) !$OMP PARALLEL DO private(i,j,cellk,k,l) collapse(2) do i=0,nbeval1-1 do j=0,nbeval2-1 call locintv(spldom%splrz%sp1,x1(i),k) call locintv(spldom%splrz%sp2,x2(j),l) cellk=spldom%cellk(k,l) If(abs(cellk%spldirkind) .eq. 1) Then wpredir(1,i,j)=cellk%spldirkind else call splineweight(spldom%boundaries(cellk%linkedboundaries(1)), x1(i),x2(j), wpredir(:,i,j),spldom%dist_extent) end IF If(abs(cellk%spltotkind) .eq. 1) Then wpretot(1,i,j)=cellk%spltotkind else call splineweight(spldom%boundaries(cellk%linkedboundaries(2)), x1(i),x2(j), wpretot(:,i,j),spldom%dist_extent) end IF end do end do !$OMP END PARALLEL DO ! Set the approximated spline weight for the Dirichlet boundary conditions CALL set_splcoef((/3,3/),x1,x2,spldom%Dirdomweightspl) call get_dim(spldom%Dirdomweightspl,dims) !Write(*,*) "size x1, x2 knots", size(x1),size(x2),dims, size(wpredir) allocate(c(dims(1),dims(2))) call get_splcoef(spldom%Dirdomweightspl, wpredir(1,:,:), c) CALL gridval(spldom%Dirdomweightspl,spldom%x1(1),spldom%x2(1), val ,(/0,0/),c) !write(*,*)"x2", x2 !write(*,*)"konot1", spldom%x1 !write(*,*)"konots1 interp", spldom%Dirdomweightspl%sp1% ! Set the approximated spline weight for the Neumann boundary conditions CALL set_splcoef((/3,3/),x1,x2,spldom%totdomweightspl) call get_splcoef(spldom%totdomweightspl, wpretot(1,:,:), c) CALL gridval(spldom%totdomweightspl,spldom%x1(1),spldom%x2(1), val ,(/0,0/),c) deallocate(c) end subroutine - +!--------------------------------------------------------------------------- +!> @author +!> Guillaume Le Bars EPFL/SPC +! +! DESCRIPTION: +!> +!> @brief +!> evaluate the FEM cell index for the quick evaluation of the dirichletweight and the totalweight +!> using the bivariated b-spline interpolant +!> @param[in] x1 array of axial positions +!> @param[in] x2 array of radial positions +!> @param[in] spldom structure defining the domain boundaries +!> @param[out] i array of axial cell indices +!> @param[out] j array of radial cell indices +!--------------------------------------------------------------------------- subroutine getindex(x1,x2,spldom, i, j) use distrib, ONLY: closest type(spline_domain):: spldom real(kind=db):: x1(:), x2(:) integer:: i(:),j(:) call locintv(spldom%splrz%sp1,x1, i) call locintv(spldom%splrz%sp2,x2, j) end subroutine +!--------------------------------------------------------------------------- +!> @author +!> adapted from spclibs +! +! DESCRIPTION: +!> +!> @brief +!> modified function from spclibs to evaluate bivariate b-splines and its derivatives at the positions xp,yp +!> @param[in] sp spline2d structure storing the bivariate b-spline interpolant data +!> @param[in] xp array of axial positions +!> @param[in] yp array of radial positions +!> @param[in] leftx array of axial cell indices for xp +!> @param[in] lefty array of radial cell indices for yp +!> @param[out] f00 array of evaluated function at xp, yp +!> @param[out] f10 array of axial derivative of the evaluated function at xp, yp +!> @param[out] f01 array of radial derivative of the evaluated function at xp, yp +!--------------------------------------------------------------------------- SUBROUTINE speval(sp, xp, yp, leftx, lefty, f00, f10, f01) ! ! Compute the function f00 and its derivatives ! f10 = d/dx f ! f01 = d/dy f ! assuming that its PPFORM/BCOEFSC was already computed! ! TYPE(spline2d), INTENT(inout) :: sp DOUBLE PRECISION, DIMENSION(:), INTENT(in) :: xp, yp INTEGER, DIMENSION(:), INTENT(in) :: leftx, lefty DOUBLE PRECISION, DIMENSION(:), INTENT(out) :: f00 DOUBLE PRECISION, DIMENSION(:), INTENT(out), OPTIONAL :: f10, f01 ! INTEGER :: np DOUBLE PRECISION :: x(SIZE(xp)), y(SIZE(yp)) INTEGER :: i, nidbas(2) DOUBLE PRECISION :: temp0(SIZE(xp),sp%sp2%order), temp1(SIZE(xp),sp%sp2%order) LOGICAL :: nlppform ! ! Apply periodicity if required ! np = SIZE(xp) nidbas(1) = sp%sp1%order-1 nidbas(2) = sp%sp2%order-1 nlppform = sp%sp1%nlppform .OR. sp%sp2%nlppform ! ! Locate the interval containing x, y ! x(:) = xp(:) - sp%sp1%knots(leftx(:)) y(:) = yp(:) - sp%sp2%knots(lefty(:)) ! ! Compute function/derivatives ! ! Using PPFORM !---------- DO i=1,np CALL my_ppval1(nidbas(1), x(i), sp%ppform(:,leftx(i)+1,:,lefty(i)+1), & & temp0(i,:), temp1(i,:)) END DO ! CALL my_ppval0(nidbas(2), y, temp0, 0, f00) if(present(f01))then CALL my_ppval0(nidbas(2), y, temp0, 1, f01) end if if(present(f10))then CALL my_ppval0(nidbas(2), y, temp1, 0, f10) end if !----------- CONTAINS !+++ SUBROUTINE my_ppval0(p, x, ppform, jder, f) ! ! Compute function and derivatives from the PP representation ! for many points x(:) INTEGER, INTENT(in) :: p DOUBLE PRECISION, INTENT(in) :: x(:) DOUBLE PRECISION, INTENT(in) :: ppform(:,:) INTEGER, INTENT(in) :: jder DOUBLE PRECISION, INTENT(out) :: f(:) DOUBLE PRECISION :: fact INTEGER :: j SELECT CASE (jder) CASE(0) ! function value SELECT CASE(p) CASE(1) f(:) = ppform(:,1) + x(:)*ppform(:,2) CASE(2) f(:) = ppform(:,1) + x(:)*(ppform(:,2)+x(:)*ppform(:,3)) !!$ CASE(3) !!$ f(:) = ppform(:,1) + x(:)*(ppform(:,2)+x(:)*(ppform(:,3)+x(:)*ppform(:,4))) CASE(3:) f(:) = ppform(:,p+1) DO j=p,1,-1 f(:) = f(:)*x(:) + ppform(:,j) END DO END SELECT CASE(1) ! 1st derivative SELECT CASE(p) CASE(1) f(:) = ppform(:,2) CASE(2) f(:) = ppform(:,2) + x(:)*2.d0*ppform(:,3) !!$ CASE(3) !!$ f(:) = ppform(:,2) + x(:)*(2.d0*ppform(:,3)+x(:)*3.0d0*ppform(:,4)) CASE(3:) f(:) = p*ppform(:,p+1) DO j=p-1,1,-1 f(:) = f(:)*x(:) + j*ppform(:,j+1) END DO END SELECT CASE default ! 2nd and higher derivatives f(:) = ppform(:,p+1) fact = p-jder DO j=p,jder+1,-1 f(:) = f(:)/fact*j*x(:) + ppform(:,j) fact = fact-1.0d0 END DO DO j=2,jder f(:) = f(:)*j END DO END SELECT END SUBROUTINE my_ppval0 !+++ SUBROUTINE my_ppval1(p, x, ppform, f0, f1) ! ! Compute function and first derivative from the PP representation INTEGER, INTENT(in) :: p DOUBLE PRECISION, INTENT(in) :: x DOUBLE PRECISION, INTENT(in) :: ppform(:,:) DOUBLE PRECISION, INTENT(out) :: f0(:) DOUBLE PRECISION, INTENT(out) :: f1(:) DOUBLE PRECISION :: fact INTEGER :: j SELECT CASE(p) CASE(1) f0(:) = ppform(1,:) + x*ppform(2,:) f1(:) = ppform(2,:) CASE(2) f0(:) = ppform(1,:) + x*(ppform(2,:)+x*ppform(3,:)) f1(:) = ppform(2,:) + x*2.d0*ppform(3,:) CASE(3) f0(:) = ppform(1,:) + x*(ppform(2,:)+x*(ppform(3,:)+x*ppform(4,:))) f1(:) = ppform(2,:) + x*(2.d0*ppform(3,:)+x*3.0d0*ppform(4,:)) CASE(4:) f0 = ppform(p+1,:) f1 = f0 DO j=p,2,-1 f0(:) = ppform(j,:) + x*f0(:) f1(:) = f0(:) + x*f1(:) END DO f0(:) = ppform(1,:) + x*f0(:) END SELECT END SUBROUTINE my_ppval1 !+++ END SUBROUTINE speval subroutine free_bsplinecurve(b_curve) type(spline_boundary):: b_curve call freeCurve(b_curve%curve) !call freeIntCurve(b_curve%intcurve) end subroutine END MODULE splinebound