diff --git a/.gitignore b/.gitignore
index 578e4cd..9ef7797 100644
--- a/.gitignore
+++ b/.gitignore
@@ -7,7 +7,7 @@
*.[oa]
*.mod
-*.F90
+*_m.F90
*.pyc
*.log
*.h5
@@ -20,6 +20,8 @@
.project
bin/
-Old/
docs/
-pyfocus/
+
+examples/d3d_RMPx/
+examples/rotating_ellipse/
+examples/lhd/
diff --git a/README.md b/README.md
index c065ab9..65a59c9 100644
--- a/README.md
+++ b/README.md
@@ -1,4 +1,4 @@
-# 
Flexible Optimized Coils Using Space curves
+# 
Flexible Optimized Coils Using Space curves
**FOCUS** is a nonlinear optimization code for designing 3D coils.
@@ -11,10 +11,11 @@ There are several branches available. Please use the correct one.
- **master:** the basic branch for the latest stable version.
- **develop:** the develop branch including the newest features.
+- **dipole:** branch for designing permanent magnets.
- **old:** the old branch that was originally developped (require NAG library).
- **gh-pages:** the branch hosting GitHub pages for the offcicial website.
- **others:** task-oriented branches.
-*Photo credit: iStockphoto.com*
+*Photo credit: internet*
diff --git a/examples/d3d_RMP/d3d.input b/examples/d3d_RMP/d3d.input
index db5a1e1..a156e13 100644
--- a/examples/d3d_RMP/d3d.input
+++ b/examples/d3d_RMP/d3d.input
@@ -2,14 +2,18 @@
IsQuiet = -1 ! -2 verbose and including unconstrained cost functions; -1: verbose; 0: normal; 1: concise
IsSymmetric = 0 ! 0: no stellarator symmetry enforced; 1: plasm periodicity enforced; 2: coil periodicity enforced
+ input_surf = 'plasma.boundary' ! specify the filename of plasma surface
+ input_harm = 'target.harmonics' ! specify the filename of target Bn harmonics
+ input_coils = 'none' ! specify the filename of input coils
+
case_surface = 0 ! 0: general VMEC-like format (Rbc, Rbs, Zbc, Zbs); 1: read axis for knots
knotsurf = 0.200D-00 ! minor plasma radius for knototrans, only valid for case surface = 1
ellipticity = 0.000D+00 ! ellipticity of plasma for knototrans, only valid for case surface = 1
Nteta = 256 ! poloidal number for discretizing the surface
Nzeta = 64 ! toroidal number for discretizing the surface
- case_init = -1 ! -1: read coils.ext file; 0: read ext.focus file; 1: initialize with circular coils
- case_coils = 1 ! 0: using piecewise linear representation; (not ready); 1: using Fourier series representation
+ case_init = -1 ! -1: read coils.ext file; 0: read ext.focus file; 1: initialize with circular coils; 2: initialize dipoles
+ case_coils = 1 ! 1: using Fourier series representation
Ncoils = 16 ! number of coils; only valid when case_init = 1
init_current = 1.000D+06 ! initial coil currents (Amper); only valid when case_init = 1
init_radius = 0.500D+00 ! initial coil radius (meter); only valid when case_init = 1
@@ -23,19 +27,20 @@
case_bnormal = 0 ! 0: keep raw Bn error; 1: Bn residue normalized to local |B|
case_length = 2 ! 1: quadratic format, converging the target length; 2: exponential format, as short as possible
weight_bnorm = 0.000D+00 ! weight for real space Bn errors
- weight_bharm = 1.000D+00 ! weight for Bnm harmonic errors
- weight_tflux = 0.000D+00 ! weight for toroidal flux error
- target_tflux = 0.000D+00 ! target for the toroidal flux
+ weight_bharm = 1.000D+00 ! weight for Bmn harmonic errors
+ bharm_jsurf = 0 ! 0: no weightes; 1: weighted with area square; 2: weighted with area
+ weight_tflux = 0.000D+00 ! weight for toroidal flux error, specified by target_tflux
+ target_tflux = 0.000D+00 ! target for the toroidal flux, 0: the present value
weight_ttlen = 0.000D+00 ! weight for coil length error
weight_cssep = 1.000D+00 ! weight for coil surface separation constraint
cssep_factor = 3.00D+00 ! exponential factor for cssep
target_length = 0.000D+00 ! target value (or for normalization) of the coils length, if zero, automatically set to initial actual length
- weight_specw = 0.000D+00 ! weight for spectral condensation error (not ready)
weight_ccsep = 0.000D+00 ! weight for coil-coil separation constraint (not ready)
- weight_inorm = 1.000D+00 ! weight for normalization of current. Larger weight makes the derivatives more important.
- weight_gnorm = 1.000D+00 ! weight for normalization of geometric coefficients. Larger weight makes the derivatives more important.
+ weight_inorm = 1.000D+00 ! weight for normalization of current. Larger weight makes the derivatives more important.
+ weight_gnorm = 1.000D+00 ! weight for normalization of geometric coefficients. Larger weight makes the derivatives more important.
+ weight_mnorm = 1.0 ! weight for normalization of magnetic moment
- case_optimize = 1 ! -2: check the 2nd derivatives (not ready); -1: check the 1st derivatives; 0: no optimizations performed; 1: optimizing with algorithms using the gradient (DF and/or CG); 2: optimizing with algorithms using the Hessian (HT and/or NT)
+ case_optimize = 1 ! -1: check the 1st derivatives; 0: no optimizations; 1: optimizing with algorithms using the gradient;
exit_tol = 1.000D-04 ! Exit the optimizer if the percent change in the cost function over the last 5 steps is below this threshold
DF_maxiter = 100 ! maximum iterations allowed for using Differential Flow (DF)
@@ -45,21 +50,27 @@
CG_maxiter = 0 ! maximum iterations allowed for using Conjugate Gradient (CG)
CG_xtol = 1.000D-08 ! the stopping criteria of finding minimum; if |dχ2/dX| < CG xtol, exit the optimization
- CG_wolfe_c1 = 1.000D-04 ! c1 value in the strong wolfe condition for line search;
- CG_wolfe_c2 = 0.1 ! c2 value in the strong wolfe condition for line search; if one CG step takes too long, try to increase c2, but remember 0 < c1 < c2 < 1
-
- HN_maxiter = 0
- HN_xtol = 1.000D-08
- HN_factor = 100.0
+ CG_wolfe_c1 = 0.1 ! c1 value in the strong wolfe condition for line search, (0.0, 0.5)
+ CG_wolfe_c2 = 0.9 ! c2 value in the strong wolfe condition for line search; 0 < c1 < c2 < 1
- TN_maxiter = 0
- TN_xtol = 1.000D-08
- TN_reorder = 0
- TN_cr = 0.1
+ LM_MAXITER = 0 ! maximum iterations for levenberg-marquardt (LM) method
+ LM_XTOL = 1.0000E-008 ! relative tolerance desired in approximated solution
+ LM_FTOL = 1.00000000E-008 ! relative tolerance desired in sum of squares
+ LM_FACTOR = 100.000000000000 ! initial step bound for line search
- case_postproc = 0 ! 0: no extra post-processing; 1: evaluate the current coils; 2: write mgrid file (not ready)
+ case_postproc = 0 ! 0: no post-processing; 1: coil diagnos; 2: write SPEC interface; 3: fieldline tracing; 4: Boozer spectrum; 5: write mgrid
save_freq = 1 ! frequency for writing output files; should be positive
save_coils = 1 ! flag for indicating whether write example.focus and example.coils
save_harmonics = 1 ! flag for indicating whether write example.harmonics
save_filaments = 0 ! flag for indicating whether write .example.filaments.xxxxxx
+ update_plasma = 0 ! write ext.plamsa file with present Bn info
+
+ pp_phi = 0.000000 ! (*pi) toroidal angle for fieldline tracing
+ pp_raxis = 0.000000 ! initial guess r position for finding magnetic axis
+ pp_zaxis = 0.000000 ! initial guess z position for finding magnetic axis
+ pp_rmax = 0.000000 ! upper bound r position for fieldline tracing
+ pp_zmax = 0.000000 ! upper bound z position for fieldline tracing
+ pp_ns = 10 ! number of fieldlines traced
+ pp_maxiter = 1000 ! number of toroidal periods for each fieldline
+ pp_xtol = 1.000000E-006 ! ODE tolarence for fieldline tracing
/
diff --git a/examples/lhd/lhd.focus b/examples/lhd/lhd.focus
deleted file mode 100644
index bdfde86..0000000
--- a/examples/lhd/lhd.focus
+++ /dev/null
@@ -1,114 +0,0 @@
- # Total number of coils
- 8
- #----------------- 1 ---------------------------
- #coil_type coil_name
- 1 HC1
- #Nseg current Ifree Length Lfree target_length
- 256 -5.400000000000000E+06 0 3.974462158514986E+01 1 1.000000000000000E+00
- #NFcoil
- 6
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- 1.801028462169698E-16 3.850062473963758E+00 -2.763221750178167E-16 -2.368475785867001E-16 4.993752603624194E-01 1.184237892933500E-16 4.993752603624194E-01
- 0.000000000000000E+00 -2.235094825269673E-16 -5.551115123125783E-17 -4.965164082351395E-16 2.716962457485453E-16 -2.405483220021173E-16 -5.618962085741764E-16
- 1.045460014855356E-16 1.225871256356944E-16 1.796402532900427E-16 -2.320674516751195E-17 -1.312992924261557E-16 3.927413949611491E-16 -4.596631717232766E-16
- 0.000000000000000E+00 3.850062473963758E+00 1.310439025810813E-16 2.626901397024324E-16 -4.993752603624201E-01 -8.638441042732284E-17 4.993752603624196E-01
- 7.632783294297952E-18 1.202741610010586E-17 6.908054375445419E-17 5.566534887356688E-17 7.709882115452476E-20 -4.107825191113079E-16 1.865791471939499E-17
- 0.000000000000000E+00 1.806039885544743E-17 2.833381677428785E-18 -1.261047593508696E-17 -9.030199427723713E-17 -9.962526034072401E-01 8.545440589714638E-17
- #----------------- 2 ---------------------------
- #coil_type coil_name
- 1 HC2
- #Nseg current Ifree Length Lfree target_length
- 256 -5.400000000000000E+06 0 3.974462158514986E+01 1 1.000000000000000E+00
- #NFcoil
- 6
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- -1.739349405246079E-16 3.850062473963757E+00 -5.575786745895231E-16 -4.292862361883939E-16 -4.993752603624201E-01 3.454027187722709E-17 -4.993752603624204E-01
- 0.000000000000000E+00 -3.975600712833069E-16 8.753029165673197E-16 -6.013708050052931E-18 -1.480297366166875E-17 -1.144146505933148E-16 1.122558836009880E-16
- 1.024450586090748E-16 3.455569164145800E-16 5.049972785621372E-18 -6.522560269672795E-17 7.316678127564400E-17 1.895860012189764E-16 -5.759281940243000E-16
- 0.000000000000000E+00 3.850062473963758E+00 -5.601024563132533E-16 1.492006749629719E-16 4.993752603624194E-01 -9.946229796565911E-17 -4.993752603624199E-01
- -2.532696274926139E-17 -1.393175698262263E-16 -1.912050764632214E-17 -1.006910604278093E-16 -6.499430623326438E-17 2.096316947191528E-16 -1.193489751472043E-16
- 0.000000000000000E+00 1.789294985325244E-17 -8.921779210475162E-18 2.957703526540456E-17 1.113981592156440E-16 9.962526034072401E-01 -2.396809602641288E-17
- #----------------- 3 ---------------------------
- #coil_type coil_name
- 1 OV
- #Nseg current Ifree Length Lfree target_length
- 256 2.824400000000000E+06 0 3.487167845484684E+01 1 1.000000000000000E+00
- #NFcoil
- 6
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- -2.713878504639272E-16 5.550000000000002E+00 -7.253457094217689E-16 -1.430954120627980E-16 -2.960594732333751E-16 6.414621920056461E-17 -6.414621920056460E-16
- 0.000000000000000E+00 -5.751572058127547E-16 -6.059967342745647E-17 5.242719838507684E-17 4.786294817272897E-16 -2.097087935403073E-17 -9.806970050855550E-17
- 2.224300990308039E-17 2.079355206537533E-16 -3.858795998783964E-16 -3.227356653528407E-16 5.512565712548520E-17 4.751600347753361E-16 -7.392234972295834E-16
- 0.000000000000000E+00 5.550000000000002E+00 -4.511437519857016E-16 3.228754069661832E-16 -2.913178957323718E-16 -1.267890113886160E-16 1.395777783476228E-16
- 1.550000000000005E+00 -1.097887213240432E-16 -1.085551401855709E-16 -4.317533984653387E-17 -1.924386576016938E-16 -1.541976423090495E-16 1.381610875089084E-16
- 0.000000000000000E+00 -2.512843328478848E-16 1.561251128379126E-17 -1.047001991278446E-16 1.009994557124274E-17 8.804685375846728E-17 -2.066248406941264E-16
- #----------------- 4 ---------------------------
- #coil_type coil_name
- 1 OV
- #Nseg current Ifree Length Lfree target_length
- 256 2.824400000000000E+06 0 3.487167845484684E+01 1 1.000000000000000E+00
- #NFcoil
- 6
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- -2.713878504639272E-16 5.550000000000002E+00 -7.253457094217689E-16 -1.430954120627980E-16 -2.960594732333751E-16 6.414621920056461E-17 -6.414621920056460E-16
- 0.000000000000000E+00 -5.751572058127547E-16 -6.059967342745647E-17 5.242719838507684E-17 4.786294817272897E-16 -2.097087935403073E-17 -9.806970050855550E-17
- 2.224300990308039E-17 2.079355206537533E-16 -3.858795998783964E-16 -3.227356653528407E-16 5.512565712548520E-17 4.751600347753361E-16 -7.392234972295834E-16
- 0.000000000000000E+00 5.550000000000002E+00 -4.511437519857016E-16 3.228754069661832E-16 -2.913178957323718E-16 -1.267890113886160E-16 1.395777783476228E-16
- -1.550000000000005E+00 1.097887213240432E-16 1.085551401855709E-16 4.317533984653387E-17 1.924386576016938E-16 1.541976423090495E-16 -1.381610875089084E-16
- 0.000000000000000E+00 2.512843328478848E-16 -1.561251128379126E-17 1.047001991278446E-16 -1.009994557124274E-17 -8.804685375846728E-17 2.066248406941264E-16
- #----------------- 5 ---------------------------
- #coil_type coil_name
- 1 IS
- #Nseg current Ifree Length Lfree target_length
- 256 6.822000000000000E+05 0 1.771858256624639E+01 1 1.000000000000000E+00
- #NFcoil
- 6
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- -2.713878504639272E-17 2.819999999999999E+00 -5.600458368664678E-16 -1.258252761241844E-16 -2.343804163097553E-16 1.036208156316813E-16 -3.503370433261605E-16
- 0.000000000000000E+00 -2.684195458494780E-16 8.172475042379625E-18 -4.163336342344337E-18 2.231239884211947E-16 -3.156425738066244E-16 -2.454826465560069E-16
- -6.599659090827319E-17 2.118290111220568E-16 1.732410511342171E-16 -2.046202713441087E-16 8.211024452956887E-18 1.266733631568842E-16 -3.808296270927750E-16
- 0.000000000000000E+00 2.819999999999999E+00 -8.529779891667625E-17 1.568455049480752E-16 -2.663137842966950E-16 -1.209487756861607E-17 9.724088818114436E-17
- 2.000000000000000E+00 -1.184237892933500E-16 -1.838035896323870E-16 -8.388351741612294E-17 -2.565848768022584E-16 -1.344603440934912E-16 1.480297366166876E-16
- 0.000000000000000E+00 -7.416906595065283E-17 -2.632924742427020E-16 -3.179555384412601E-16 1.159566270164052E-16 3.750086660956084E-16 -3.062365176257723E-16
- #----------------- 6 ---------------------------
- #coil_type coil_name
- 1 IS
- #Nseg current Ifree Length Lfree target_length
- 256 6.822000000000000E+05 0 1.771858256624639E+01 1 1.000000000000000E+00
- #NFcoil
- 6
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- -2.713878504639272E-17 2.819999999999999E+00 -5.600458368664678E-16 -1.258252761241844E-16 -2.343804163097553E-16 1.036208156316813E-16 -3.503370433261605E-16
- 0.000000000000000E+00 -2.684195458494780E-16 8.172475042379625E-18 -4.163336342344337E-18 2.231239884211947E-16 -3.156425738066244E-16 -2.454826465560069E-16
- -6.599659090827319E-17 2.118290111220568E-16 1.732410511342171E-16 -2.046202713441087E-16 8.211024452956887E-18 1.266733631568842E-16 -3.808296270927750E-16
- 0.000000000000000E+00 2.819999999999999E+00 -8.529779891667625E-17 1.568455049480752E-16 -2.663137842966950E-16 -1.209487756861607E-17 9.724088818114436E-17
- -2.000000000000000E+00 1.184237892933500E-16 1.838035896323870E-16 8.388351741612294E-17 2.565848768022584E-16 1.344603440934912E-16 -1.480297366166876E-16
- 0.000000000000000E+00 7.416906595065283E-17 2.632924742427020E-16 3.179555384412601E-16 -1.159566270164052E-16 -3.750086660956084E-16 3.062365176257723E-16
- #----------------- 7 ---------------------------
- #coil_type coil_name
- 1 IV
- #Nseg current Ifree Length Lfree target_length
- 256 -2.940000000000000E+06 0 1.130973355292326E+01 1 1.000000000000000E+00
- #NFcoil
- 6
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- 4.872645496965965E-17 1.800000000000000E+00 -2.097087935403073E-17 -1.850371707708594E-16 -1.517304800321047E-16 6.291263806209220E-17 -2.035408878479454E-16
- 0.000000000000000E+00 -2.153755568951649E-16 2.636779683484747E-17 -1.145688482356238E-16 9.298117831235686E-17 -8.650487733537678E-17 -9.621932880084690E-17
- 5.780484116060494E-17 3.908910232534406E-17 1.070517131730576E-16 3.473301893011340E-17 3.550400714165866E-17 9.922618282587337E-17 -2.476221388430449E-16
- 0.000000000000000E+00 1.800000000000000E+00 4.176708169138325E-17 1.946612720552891E-16 -1.105018854197226E-16 -4.499920883447060E-17 5.895891413976174E-17
- 7.999999999999994E-01 -7.709882115452476E-17 -3.330669073875469E-17 -4.317533984653387E-17 -1.215077421395310E-16 -6.537980033903700E-17 6.414621920056461E-17
- 0.000000000000000E+00 8.719876672576750E-17 -7.603871236365005E-17 -5.736152293896643E-17 4.348373513115196E-17 8.550259266036796E-17 -1.276756478318930E-16
- #----------------- 8 ---------------------------
- #coil_type coil_name
- 1 IV
- #Nseg current Ifree Length Lfree target_length
- 256 -2.940000000000000E+06 0 1.130973355292326E+01 1 1.000000000000000E+00
- #NFcoil
- 6
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- 4.872645496965965E-17 1.800000000000000E+00 -2.097087935403073E-17 -1.850371707708594E-16 -1.517304800321047E-16 6.291263806209220E-17 -2.035408878479454E-16
- 0.000000000000000E+00 -2.153755568951649E-16 2.636779683484747E-17 -1.145688482356238E-16 9.298117831235686E-17 -8.650487733537678E-17 -9.621932880084690E-17
- 5.780484116060494E-17 3.908910232534406E-17 1.070517131730576E-16 3.473301893011340E-17 3.550400714165866E-17 9.922618282587337E-17 -2.476221388430449E-16
- 0.000000000000000E+00 1.800000000000000E+00 4.176708169138325E-17 1.946612720552891E-16 -1.105018854197226E-16 -4.499920883447060E-17 5.895891413976174E-17
- -7.999999999999994E-01 7.709882115452476E-17 3.330669073875469E-17 4.317533984653387E-17 1.215077421395310E-16 6.537980033903700E-17 -6.414621920056461E-17
- 0.000000000000000E+00 -8.719876672576750E-17 7.603871236365005E-17 5.736152293896643E-17 -4.348373513115196E-17 -8.550259266036796E-17 1.276756478318930E-16
diff --git a/examples/lhd/lhd.input b/examples/lhd/lhd.input
index b63c826..f7787a5 100644
--- a/examples/lhd/lhd.input
+++ b/examples/lhd/lhd.input
@@ -1,20 +1,20 @@
&focusin
IsQuiet = -1 ! -2 verbose and including unconstrained cost functions; -1: verbose; 0: normal; 1: concise
- IsSymmetric = 1 ! 0: no stellarator symmetry enforced; 1: plasma periodicity enforced; 2: coil periodicity enforced
+ IsSymmetric = 0 ! 0: no stellarator symmetry enforced; 1: plasma periodicity enforced; 2: coil periodicity enforced
case_surface = 0 ! 0: general VMEC-like format (Rbc, Rbs, Zbc, Zbs); 1: read axis for knots
knotsurf = 0.200D-00 ! minor plasma radius for knototrans, only valid for case surface = 1
ellipticity = 0.000D+00 ! ellipticity of plasma for knototrans, only valid for case surface = 1
Nteta = 64 ! poloidal number for discretizing the surface
- Nzeta = 64 ! toroidal number for discretizing the surface
+ Nzeta = 360 ! toroidal number for discretizing the surface
case_init = -1 ! -1: read coils.ext file; 0: read ext.focus file; 1: initialize with circular coils
case_coils = 1 ! 0: using piecewise linear representation; (not ready); 1: using Fourier series representation
Ncoils = 16 ! number of coils; only valid when case_init = 1
init_current = 1.000D+06 ! initial coil currents (Amper); only valid when case_init = 1
init_radius = 0.500D+00 ! initial coil currents (Amper); only valid when case_init = 1
- IsVaryCurrent = 1 ! 0: all the currents fixed; 1: currents can be changed; overwritten by ext.focus
- IsVaryGeometry = 0 ! 0: all the geometries fixed; 1: geometries can be changed; overwritten by ext.focus
+ IsVaryCurrent = 0 ! 0: all the currents fixed; 1: currents can be changed; overwritten by ext.focus
+ IsVaryGeometry = 1 ! 0: all the geometries fixed; 1: geometries can be changed; overwritten by ext.focus
NFcoil = 8 ! number of Fourier harmonics representing the coils; overwritten by ext.focus
Nseg = 256 ! number of coil segments for discretizing; overwritten by ext.focus
@@ -36,15 +36,15 @@
case_optimize = 1 ! -2: check the 2nd derivatives (not ready); -1: check the 1st derivatives; 0: no optimizations performed; 1: optimizing with algorithms using the gradient (DF and/or CG); 2: optimizing with algorithms using the Hessian (HT and/or NT)
exit_tol = 1.000D-04 ! Exit the optimizer if the percent change in the cost function over the last 5 steps is below this threshold
- DF_maxiter = 100 ! maximum iterations allowed for using Differential Flow (DF)
+ DF_maxiter = 0 ! maximum iterations allowed for using Differential Flow (DF)
DF_xtol = 1.000D-08 ! relative error for ODE solver
DF_tausta = 0.000D+00 ! starting value of τ. Usually 0.0 is a good idea
DF_tauend = 1.000D-04 ! ending value of τ. The larger value of τend − τsta, the more optimized
- CG_maxiter = 0 ! maximum iterations allowed for using Conjugate Gradient (CG)
+ CG_maxiter = 100 ! maximum iterations allowed for using Conjugate Gradient (CG)
CG_xtol = 1.000D-08 ! the stopping criteria of finding minimum; if |dχ2/dX| < CG xtol, exit the optimization
CG_wolfe_c1 = 1.000D-04 ! c1 value in the strong wolfe condition for line search;
- CG_wolfe_c2 = 0.1 ! c2 value in the strong wolfe condition for line search; if one CG step takes too long, try to increase c2, but remember 0 < c1 < c2 < 1
+ CG_wolfe_c2 = 0.9 ! c2 value in the strong wolfe condition for line search; if one CG step takes too long, try to increase c2, but remember 0 < c1 < c2 < 1
HN_maxiter = 0
HN_xtol = 1.000D-08
@@ -55,7 +55,7 @@
TN_reorder = 0
TN_cr = 0.1
- case_postproc = 1 ! 0: no extra post-processing; 1: evaluate the current coils; 2: write mgrid file (not ready)
+ case_postproc = 3 ! 0: no extra post-processing; 1: evaluate the current coils; 2: write mgrid file (not ready)
save_freq = 1 ! frequency for writing output files; should be positive
save_coils = 1 ! flag for indicating whether write example.focus and example.coils
save_harmonics = 0 ! flag for indicating whether write example.harmonics
diff --git a/examples/limiter_surface/ellipse.boundary b/examples/limiter_surface/ellipse.boundary
new file mode 100644
index 0000000..8be57fc
--- /dev/null
+++ b/examples/limiter_surface/ellipse.boundary
@@ -0,0 +1,13 @@
+#bmn bNfp nbf
+4 2 0
+#plasma boundary
+# n m Rbc Rbs Zbc Zbs
+0 0 3.00 0.0 0.0 0.00
+0 1 0.30 0.0 0.0 -0.30
+1 0 0.00 0.0 0.0 -0.06
+1 1 -0.06 0.0 0.0 -0.06
+#Bn harmonics
+# n m bnc bns
+0 0 1.0 0.0
+0 1 0.5 0.25
+1 0 0.5 0.0
\ No newline at end of file
diff --git a/examples/limiter_surface/ellipse.limiter b/examples/limiter_surface/ellipse.limiter
new file mode 100644
index 0000000..700aaea
--- /dev/null
+++ b/examples/limiter_surface/ellipse.limiter
@@ -0,0 +1,13 @@
+#bmn bNfp nbf
+4 2 0
+#plasma boundary
+# n m Rbc Rbs Zbc Zbs
+0 0 3.00 0.0 0.0 0.00
+0 1 0.50 0.0 0.0 -0.50
+1 0 0.00 0.0 0.0 -0.06
+1 1 -0.06 0.0 0.0 -0.06
+#Bn harmonics
+# n m bnc bns
+0 0 1.0 0.0
+0 1 0.5 0.25
+1 0 0.5 0.0
\ No newline at end of file
diff --git a/examples/limiter_surface/limiter.input b/examples/limiter_surface/limiter.input
new file mode 100644
index 0000000..732dff6
--- /dev/null
+++ b/examples/limiter_surface/limiter.input
@@ -0,0 +1,75 @@
+ &FOCUSIN
+ ISQUIET = -1,
+ ISSYMMETRIC = 0,
+ INPUT_SURF = 'ellipse.boundary',
+ !LIMITER_SURF = 'ellipse.limiter',
+ INPUT_HARM = 'target.harmonics',
+ INPUT_COILS = 'none',
+ CASE_SURFACE = 0,
+ KNOTSURF = 0.200000000000000 ,
+ ELLIPTICITY = 0.000000000000000E+000,
+ NTETA = 64,
+ NZETA = 64,
+ CASE_INIT = 1,
+ CASE_COILS = 1,
+ NCOILS = 16,
+ INIT_CURRENT = 1000000.00000000 ,
+ INIT_RADIUS = 0.60000000000000 ,
+ ISVARYCURRENT = 0,
+ ISVARYGEOMETRY = 1,
+ NFCOIL = 4,
+ NSEG = 128,
+ ISNORMALIZE = 1,
+ ISNORMWEIGHT = 0,
+ CASE_BNORMAL = 0,
+ CASE_LENGTH = 1,
+ WEIGHT_BNORM = 1.00000000000000 ,
+ BHARM_JSURF = 0,
+ WEIGHT_BHARM = 0.000000000000000E+000,
+ WEIGHT_TFLUX = 0.000000000000000E+000,
+ TARGET_TFLUX = 0.000000000000000E+000,
+ WEIGHT_TTLEN = 1.000000000000000E-003,
+ TARGET_LENGTH = 5.000000000000000E+000,
+ WEIGHT_CSSEP = 0.000000000000000E-004,
+ CSSEP_FACTOR = 1.00000000000000 ,
+ WEIGHT_SPECW = 0.000000000000000E+000,
+ WEIGHT_CCSEP = 0.000000000000000E+000,
+ WEIGHT_INORM = 1.00000000000000 ,
+ WEIGHT_GNORM = 1.00000000000000 ,
+ WEIGHT_MNORM = 1.00000000000000 ,
+ CASE_OPTIMIZE = 1,
+ EXIT_TOL = 1.000000000000000E-004,
+ DF_MAXITER = 0,
+ DF_XTOL = 1.000000000000000E-008,
+ DF_TAUSTA = 0.000000000000000E+000,
+ DF_TAUEND = 1.00000000000000 ,
+ CG_MAXITER = 20,
+ CG_XTOL = 1.000000000000000E-008,
+ CG_WOLFE_C1 = 0.100000001490116 ,
+ CG_WOLFE_C2 = 0.899999976158142 ,
+ LM_MAXITER = 0,
+ LM_XTOL = 1.000000000000000E-008,
+ LM_FTOL = 1.000000000000000E-008,
+ LM_FACTOR = 100.000000000000 ,
+ HN_MAXITER = 0,
+ HN_XTOL = 1.000000000000000E-008,
+ HN_FACTOR = 100.000000000000 ,
+ TN_MAXITER = 0,
+ TN_REORDER = 0,
+ TN_XTOL = 1.000000000000000E-008,
+ TN_CR = 0.100000001490116 ,
+ CASE_POSTPROC = 3,
+ SAVE_FREQ = 1,
+ SAVE_COILS = 1,
+ SAVE_HARMONICS = 0,
+ SAVE_FILAMENTS = 0,
+ UPDATE_PLASMA = 0,
+ PP_PHI = 0.000000000000000E+000,
+ PP_RAXIS = 0.000000000000000E+000,
+ PP_ZAXIS = 0.000000000000000E+000,
+ PP_RMAX = 0.000000000000000E+000,
+ PP_ZMAX = 0.000000000000000E+000,
+ PP_NS = 10,
+ PP_MAXITER = 1000,
+ PP_XTOL = 1.000000000000000E-006
+ /
diff --git a/examples/rotating_ellipse/ellipse.focus b/examples/rotating_ellipse/ellipse.focus
deleted file mode 100644
index 7066c89..0000000
--- a/examples/rotating_ellipse/ellipse.focus
+++ /dev/null
@@ -1,226 +0,0 @@
- # Total number of coils
- 16
- #--------------------------------------------
- #coil_type coil_name
- 1 Mod_001
- #Nseg current Ifree Length Lfree target_length
- 128 9.844910899889484E+05 1 5.889288927667147E+00 1 1.000000000000000E+00
- #NFcoil
- 4
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- 3.044612087666170E+00 8.531153655332238E-01 4.194525679767678E-02 2.139790853335835E-02 3.243811555342430E-03
- 0.000000000000000E+00 3.542408058492299E-16 -9.108712738922674E-16 1.841880477639364E-16 -1.172175996642087E-16
- -4.456021385977147E-15 8.545613874434043E-16 -3.133154295448265E-16 1.764367073160815E-16 -1.187904023667544E-16
- 0.000000000000000E+00 -5.425716121023922E-02 -8.986316303345250E-02 -2.946386365076052E-03 -4.487052148209031E-03
- -4.293247278325474E-17 -1.303273952226587E-15 7.710821807870230E-16 -3.156539892466338E-16 9.395672288215928E-17
- 0.000000000000000E+00 9.997301975562740E-01 2.929938238054118E-02 2.436889176706748E-02 1.013941937492003E-03
- #--------------------------------------------
- #coil_type coil_name
- 1 Mod_002
- #Nseg current Ifree Length Lfree target_length
- 128 9.825939193150387E+05 1 5.885523786092040E+00 1 1.000000000000000E+00
- #NFcoil
- 4
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- 2.782723530238699E+00 8.188524402610835E-01 1.015627966887937E-01 3.423108106958181E-03 1.043676727968852E-03
- 0.000000000000000E+00 7.247174059689016E-02 5.189148393383358E-02 -2.786138051989135E-02 -3.138947714342256E-03
- 1.142844202833405E+00 3.343456505400222E-01 -2.370606586536125E-02 -3.077659528299475E-03 -4.929958141009566E-03
- 0.000000000000000E+00 -6.889974421415429E-03 -4.627570410582279E-02 -2.386049487393956E-02 4.454871233820858E-03
- 1.080877113054363E-02 9.397062545279147E-02 -5.113628370077195E-02 4.019968101031725E-02 -2.123260904719736E-04
- 0.000000000000000E+00 9.531696397783556E-01 7.516427937127484E-02 2.299214621026078E-03 -4.621870077987078E-04
- #--------------------------------------------
- #coil_type coil_name
- 1 Mod_003
- #Nseg current Ifree Length Lfree target_length
- 128 9.832393043417728E+05 1 5.887953196305714E+00 1 1.000000000000000E+00
- #NFcoil
- 4
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- 2.115314961365337E+00 6.734656308267452E-01 1.383637868936977E-01 -7.327077556181946E-03 -4.088839817924770E-03
- 0.000000000000000E+00 6.425694895304412E-02 1.823876577199216E-02 -2.350240267797100E-02 -5.666387840646102E-03
- 2.095397239139587E+00 6.715823169694797E-01 2.089283517905467E-02 -3.057002908374958E-02 4.349043278845081E-03
- 0.000000000000000E+00 6.260467088085638E-02 1.612881812435624E-02 -2.985521462129145E-02 4.858279502820251E-03
- 3.504795100694917E-02 1.028222095882263E-01 -5.127102410497052E-02 4.392232934098032E-02 -1.170055177359795E-03
- 0.000000000000000E+00 8.723420859147240E-01 1.288319700628106E-01 -3.272037185914849E-02 7.444587061583237E-04
- #--------------------------------------------
- #coil_type coil_name
- 1 Mod_004
- #Nseg current Ifree Length Lfree target_length
- 128 9.893062047381703E+05 1 5.902044412599992E+00 1 1.000000000000000E+00
- #NFcoil
- 4
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- 1.153279341210233E+00 3.839351000912973E-01 9.370469672963777E-02 -1.073976140939980E-02 -9.705191390130589E-03
- 0.000000000000000E+00 1.799347255173012E-03 -5.372521021132499E-02 -1.857749572754666E-02 1.603175426999459E-03
- 2.758561057693074E+00 9.320556574942391E-01 6.636284254294306E-02 -4.432294103114913E-02 3.053930340673586E-03
- 0.000000000000000E+00 7.986633593798817E-02 2.024479545845153E-02 -2.213912000632457E-02 -3.382339718066103E-03
- 5.630821079228619E-02 4.024688208981179E-02 -4.096234633987603E-04 2.562130898418030E-02 3.257616268484508E-03
- 0.000000000000000E+00 8.280561324748386E-01 1.199133101065296E-01 -5.093996632871012E-02 8.798511090517195E-04
- #--------------------------------------------
- #coil_type coil_name
- 1 Mod_005
- #Nseg current Ifree Length Lfree target_length
- 128 9.936998575666990E+05 1 5.912220619716821E+00 1 1.000000000000000E+00
- #NFcoil
- 4
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- 1.095542685246406E-15 5.296264044184343E-16 2.064659971500610E-16 6.703968997180234E-16 7.881284697760508E-18
- 0.000000000000000E+00 -3.960999097417946E-02 -8.463524634129940E-02 -5.143673327580391E-03 1.043151915207185E-02
- 3.012320674611275E+00 1.032185815346890E+00 7.725640730606291E-02 -5.448359725908782E-02 -3.213601062953441E-03
- 0.000000000000000E+00 4.806554284756180E-16 1.559408741530255E-15 -1.316515174208468E-16 7.788579477338355E-17
- -1.240953916913024E-15 2.876517992094798E-16 -2.272599276151899E-15 3.627556814089238E-16 -8.946051894087629E-17
- 0.000000000000000E+00 8.174762102110396E-01 9.004542320601831E-02 -5.566721593859935E-02 -3.801301882686477E-03
- #--------------------------------------------
- #coil_type coil_name
- 1 Mod_006
- #Nseg current Ifree Length Lfree target_length
- 128 9.893062047381705E+05 1 5.902044412599991E+00 1 1.000000000000000E+00
- #NFcoil
- 4
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- -1.153279341210230E+00 -3.839351000912948E-01 -9.370469672963856E-02 1.073976140939876E-02 9.705191390130156E-03
- 0.000000000000000E+00 1.799347255172598E-03 -5.372521021132557E-02 -1.857749572754719E-02 1.603175426999149E-03
- 2.758561057693074E+00 9.320556574942380E-01 6.636284254294574E-02 -4.432294103114796E-02 3.053930340673876E-03
- 0.000000000000000E+00 -7.986633593798621E-02 -2.024479545845140E-02 2.213912000632409E-02 3.382339718066167E-03
- -5.630821079228826E-02 -4.024688208981221E-02 4.096234633984780E-04 -2.562130898417996E-02 -3.257616268484675E-03
- 0.000000000000000E+00 8.280561324748393E-01 1.199133101065324E-01 -5.093996632870837E-02 8.798511090521912E-04
- #--------------------------------------------
- #coil_type coil_name
- 1 Mod_007
- #Nseg current Ifree Length Lfree target_length
- 128 9.832393043417730E+05 1 5.887953196305707E+00 1 1.000000000000000E+00
- #NFcoil
- 4
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- -2.115314961365334E+00 -6.734656308267433E-01 -1.383637868936977E-01 7.327077556180765E-03 4.088839817924469E-03
- 0.000000000000000E+00 6.425694895304439E-02 1.823876577199323E-02 -2.350240267797037E-02 -5.666387840645857E-03
- 2.095397239139590E+00 6.715823169694786E-01 2.089283517905522E-02 -3.057002908374837E-02 4.349043278844838E-03
- 0.000000000000000E+00 -6.260467088085681E-02 -1.612881812435750E-02 2.985521462129117E-02 -4.858279502820373E-03
- -3.504795100694644E-02 -1.028222095882256E-01 5.127102410497195E-02 -4.392232934097949E-02 1.170055177359796E-03
- 0.000000000000000E+00 8.723420859147251E-01 1.288319700628102E-01 -3.272037185914656E-02 7.444587061582115E-04
- #--------------------------------------------
- #coil_type coil_name
- 1 Mod_008
- #Nseg current Ifree Length Lfree target_length
- 128 9.825939193150393E+05 1 5.885523786092041E+00 1 1.000000000000000E+00
- #NFcoil
- 4
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- -2.782723530238698E+00 -8.188524402610826E-01 -1.015627966887925E-01 -3.423108106959205E-03 -1.043676727969051E-03
- 0.000000000000000E+00 7.247174059689121E-02 5.189148393383459E-02 -2.786138051989096E-02 -3.138947714342247E-03
- 1.142844202833409E+00 3.343456505400238E-01 -2.370606586536158E-02 -3.077659528298735E-03 -4.929958141009641E-03
- 0.000000000000000E+00 6.889974421415525E-03 4.627570410582223E-02 2.386049487393978E-02 -4.454871233820674E-03
- -1.080877113054374E-02 -9.397062545278986E-02 5.113628370077263E-02 -4.019968101031668E-02 2.123260904719445E-04
- 0.000000000000000E+00 9.531696397783573E-01 7.516427937127285E-02 2.299214621027461E-03 -4.621870077985499E-04
- #--------------------------------------------
- #coil_type coil_name
- 1 Mod_009
- #Nseg current Ifree Length Lfree target_length
- 128 9.844910899889485E+05 1 5.889288927667151E+00 1 1.000000000000000E+00
- #NFcoil
- 4
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- -3.044612087666165E+00 -8.531153655332240E-01 -4.194525679768322E-02 -2.139790853335865E-02 -3.243811555342124E-03
- 0.000000000000000E+00 -1.280601996834128E-16 -2.568013130264053E-15 1.118452007203463E-15 1.761157189862816E-17
- -6.297289382605896E-16 8.887143243094215E-16 -9.207699102326174E-18 -2.359162160823750E-16 2.254791239505026E-16
- 0.000000000000000E+00 5.425716121023926E-02 8.986316303345229E-02 2.946386365077663E-03 4.487052148208801E-03
- -2.233522643815287E-15 2.369496290216599E-15 -2.459156968972293E-15 1.111210286913772E-15 -7.587966730862343E-17
- 0.000000000000000E+00 9.997301975562742E-01 2.929938238054714E-02 2.436889176706779E-02 1.013941937491709E-03
- #--------------------------------------------
- #coil_type coil_name
- 1 Mod_010
- #Nseg current Ifree Length Lfree target_length
- 128 9.825939193150395E+05 1 5.885523786092045E+00 1 1.000000000000000E+00
- #NFcoil
- 4
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- -2.782723530238696E+00 -8.188524402610817E-01 -1.015627966887938E-01 -3.423108106959047E-03 -1.043676727969315E-03
- 0.000000000000000E+00 -7.247174059689021E-02 -5.189148393383772E-02 2.786138051989222E-02 3.138947714342107E-03
- -1.142844202833410E+00 -3.343456505400210E-01 2.370606586536093E-02 3.077659528298494E-03 4.929958141009796E-03
- 0.000000000000000E+00 6.889974421415193E-03 4.627570410582079E-02 2.386049487394025E-02 -4.454871233820705E-03
- 1.080877113054069E-02 9.397062545279444E-02 -5.113628370077713E-02 4.019968101031814E-02 -2.123260904720409E-04
- 0.000000000000000E+00 9.531696397783578E-01 7.516427937127323E-02 2.299214621028059E-03 -4.621870077984231E-04
- #--------------------------------------------
- #coil_type coil_name
- 1 Mod_011
- #Nseg current Ifree Length Lfree target_length
- 128 9.832393043417722E+05 1 5.887953196305711E+00 1 1.000000000000000E+00
- #NFcoil
- 4
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- -2.115314961365331E+00 -6.734656308267459E-01 -1.383637868937001E-01 7.327077556182286E-03 4.088839817924299E-03
- 0.000000000000000E+00 -6.425694895303902E-02 -1.823876577199207E-02 2.350240267797015E-02 5.666387840645909E-03
- -2.095397239139590E+00 -6.715823169694792E-01 -2.089283517905783E-02 3.057002908374946E-02 -4.349043278844712E-03
- 0.000000000000000E+00 -6.260467088085671E-02 -1.612881812435606E-02 2.985521462128991E-02 -4.858279502819658E-03
- 3.504795100694819E-02 1.028222095882271E-01 -5.127102410497007E-02 4.392232934097846E-02 -1.170055177359519E-03
- 0.000000000000000E+00 8.723420859147217E-01 1.288319700628161E-01 -3.272037185914903E-02 7.444587061582879E-04
- #--------------------------------------------
- #coil_type coil_name
- 1 Mod_012
- #Nseg current Ifree Length Lfree target_length
- 128 9.893062047381682E+05 1 5.902044412599986E+00 1 1.000000000000000E+00
- #NFcoil
- 4
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- -1.153279341210230E+00 -3.839351000912945E-01 -9.370469672963888E-02 1.073976140940020E-02 9.705191390130367E-03
- 0.000000000000000E+00 -1.799347255169292E-03 5.372521021132674E-02 1.857749572754733E-02 -1.603175426998955E-03
- -2.758561057693072E+00 -9.320556574942380E-01 -6.636284254294618E-02 4.432294103114773E-02 -3.053930340673634E-03
- 0.000000000000000E+00 -7.986633593798875E-02 -2.024479545844690E-02 2.213912000632430E-02 3.382339718066735E-03
- 5.630821079229477E-02 4.024688208980893E-02 -4.096234633916836E-04 2.562130898417977E-02 3.257616268485354E-03
- 0.000000000000000E+00 8.280561324748366E-01 1.199133101065342E-01 -5.093996632870944E-02 8.798511090521916E-04
- #--------------------------------------------
- #coil_type coil_name
- 1 Mod_013
- #Nseg current Ifree Length Lfree target_length
- 128 9.936998575666993E+05 1 5.912220619716824E+00 1 1.000000000000000E+00
- #NFcoil
- 4
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- 1.309642721785852E-15 -6.123934419616835E-16 -2.417365220342541E-16 -5.726911113200828E-17 -2.263645524067550E-16
- 0.000000000000000E+00 3.960999097418352E-02 8.463524634129878E-02 5.143673327579279E-03 -1.043151915207169E-02
- -3.012320674611273E+00 -1.032185815346892E+00 -7.725640730606369E-02 5.448359725908920E-02 3.213601062954197E-03
- 0.000000000000000E+00 3.234979803000865E-17 -7.798991548073831E-16 -2.382747473076669E-16 -5.086374324456303E-17
- -1.493956648761240E-15 -4.034487358009764E-17 -1.010069378053523E-15 -2.126433020881394E-16 -1.264976776682364E-16
- 0.000000000000000E+00 8.174762102110380E-01 9.004542320601913E-02 -5.566721593860124E-02 -3.801301882687245E-03
- #--------------------------------------------
- #coil_type coil_name
- 1 Mod_014
- #Nseg current Ifree Length Lfree target_length
- 128 9.893062047381685E+05 1 5.902044412599988E+00 1 1.000000000000000E+00
- #NFcoil
- 4
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- 1.153279341210230E+00 3.839351000912936E-01 9.370469672964007E-02 -1.073976140939872E-02 -9.705191390129882E-03
- 0.000000000000000E+00 -1.799347255168639E-03 5.372521021132683E-02 1.857749572754740E-02 -1.603175426998636E-03
- -2.758561057693070E+00 -9.320556574942356E-01 -6.636284254294939E-02 4.432294103114542E-02 -3.053930340673473E-03
- 0.000000000000000E+00 7.986633593798745E-02 2.024479545844683E-02 -2.213912000632334E-02 -3.382339718066471E-03
- -5.630821079229358E-02 -4.024688208980905E-02 4.096234633916470E-04 -2.562130898417867E-02 -3.257616268485252E-03
- 0.000000000000000E+00 8.280561324748386E-01 1.199133101065380E-01 -5.093996632870672E-02 8.798511090523702E-04
- #--------------------------------------------
- #coil_type coil_name
- 1 Mod_015
- #Nseg current Ifree Length Lfree target_length
- 128 9.832393043417709E+05 1 5.887953196305702E+00 1 1.000000000000000E+00
- #NFcoil
- 4
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- 2.115314961365332E+00 6.734656308267456E-01 1.383637868936978E-01 -7.327077556182388E-03 -4.088839817923967E-03
- 0.000000000000000E+00 -6.425694895303813E-02 -1.823876577199151E-02 2.350240267796986E-02 5.666387840645846E-03
- -2.095397239139589E+00 -6.715823169694777E-01 -2.089283517905502E-02 3.057002908374827E-02 -4.349043278844982E-03
- 0.000000000000000E+00 6.260467088085564E-02 1.612881812435527E-02 -2.985521462128889E-02 4.858279502819705E-03
- -3.504795100695098E-02 -1.028222095882245E-01 5.127102410496724E-02 -4.392232934097696E-02 1.170055177359472E-03
- 0.000000000000000E+00 8.723420859147224E-01 1.288319700628125E-01 -3.272037185914852E-02 7.444587061588428E-04
- #--------------------------------------------
- #coil_type coil_name
- 1 Mod_016
- #Nseg current Ifree Length Lfree target_length
- 128 9.825939193150366E+05 1 5.885523786092033E+00 1 1.000000000000000E+00
- #NFcoil
- 4
- #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
- 2.782723530238699E+00 8.188524402610796E-01 1.015627966887923E-01 3.423108106960044E-03 1.043676727969364E-03
- 0.000000000000000E+00 -7.247174059689200E-02 -5.189148393383933E-02 2.786138051989332E-02 3.138947714342312E-03
- -1.142844202833413E+00 -3.343456505400205E-01 2.370606586536152E-02 3.077659528297522E-03 4.929958141010002E-03
- 0.000000000000000E+00 -6.889974421415149E-03 -4.627570410581994E-02 -2.386049487394103E-02 4.454871233820804E-03
- -1.080877113053806E-02 -9.397062545279594E-02 5.113628370077884E-02 -4.019968101031930E-02 2.123260904718878E-04
- 0.000000000000000E+00 9.531696397783578E-01 7.516427937127053E-02 2.299214621029528E-03 -4.621870077984291E-04
diff --git a/examples/rotating_ellipse/ellipse.input b/examples/rotating_ellipse/ellipse.input
index 6d09c4a..a3d6500 100644
--- a/examples/rotating_ellipse/ellipse.input
+++ b/examples/rotating_ellipse/ellipse.input
@@ -1,19 +1,19 @@
&focusin
IsQuiet = -1 ! -2 verbose and including unconstrained cost functions; -1: verbose; 0: normal; 1: concise
- IsSymmetric = 0 ! 0: no stellarator symmetry enforced; 1: plasma periodicity enforced; 2: coil periodicity enforced
+ IsSymmetric = 2 ! 0: no stellarator symmetry enforced; 1: plasma periodicity enforced; 2: coil periodicity enforced
case_surface = 0 ! 0: general VMEC-like format (Rbc, Rbs, Zbc, Zbs); 1: read axis for knots
knotsurf = 0.200D-00 ! minor plasma radius for knototrans, only valid for case surface = 1
ellipticity = 0.000D+00 ! ellipticity of plasma for knototrans, only valid for case surface = 1
- Nteta = 128 ! poloidal number for discretizing the surface
- Nzeta = 128 ! toroidal number for discretizing the surface
+ Nteta = 64 ! poloidal number for discretizing the surface
+ Nzeta = 64 ! toroidal number for discretizing the surface
- case_init = 1 ! -1: read coils.ext file; 0: read ext.focus file; 1: initialize with circular coils
+ case_init = 1 ! -1: read coils.ext file; 0: read ext.focus file; 1: initialize with circular coils; 2: initialize with dipoles
case_coils = 1 ! 0: using piecewise linear representation; (not ready); 1: using Fourier series representation
- Ncoils = 16 ! number of coils; only valid when case_init = 1
+ Ncoils = 4 ! number of coils; only valid when case_init = 1
init_current = 1.000D+06 ! initial coil currents (Amper); only valid when case_init = 1
init_radius = 0.500D+00 ! initial coil radius (meter); only valid when case_init = 1
- IsVaryCurrent = 1 ! 0: all the currents fixed; 1: currents can be changed; overwritten by ext.focus
+ IsVaryCurrent = 0 ! 0: all the currents fixed; 1: currents can be changed; overwritten by ext.focus
IsVaryGeometry = 1 ! 0: all the geometries fixed; 1: geometries can be changed; overwritten by ext.focus
NFcoil = 4 ! number of Fourier harmonics representing the coils; overwritten by ext.focus
Nseg = 128 ! number of coil segments for discretizing; overwritten by ext.focus
@@ -22,18 +22,18 @@
IsNormWeight = 1 ! 0: do not normalize the weights; 1: normalize the weights
case_bnormal = 0 ! 0: keep raw Bn error; 1: Bn residue normalized to local |B|
case_length = 1 ! 1: quadratic format, converging the target length; 2: exponential format, as short as possible
- weight_bnorm = 1.000D+00 ! weight for real space Bn errors
+ weight_bnorm = 1.000D+02 ! weight for real space Bn errors
weight_bharm = 0.000D+00 ! weight for Bnm harmonic errors
- weight_tflux = 0.010D+00 ! weight for toroidal flux error
+ weight_tflux = 0.000D+00 ! weight for toroidal flux error
target_tflux = 0.000D+00 ! target for the toroidal flux
- weight_ttlen = 0.100D+00 ! weight for coil length error
- target_length = 0.000D+00 ! target value (or for normalization) of the coils length, if zero, automatically set to initial actual length
+ weight_ttlen = 1.000D+01 ! weight for coil length error
+ target_length = 7.000D+00 ! target value (or for normalization) of the coils length, if zero, automatically set to initial actual length
weight_specw = 0.000D+00 ! weight for spectral condensation error
weight_cssep = 0.010D+00 ! weight for coil-surface separation constraint
weight_inorm = 1.000D+00 ! weight for normalization of current. Larger weight makes the derivatives more important.
weight_gnorm = 1.000D+00 ! weight for normalization of geometric coefficients. Larger weight makes the derivatives more important.
- case_optimize = 1 ! -2: check the 2nd derivatives (not ready); -1: check the 1st derivatives; 0: no optimizations performed; 1: optimizing with algorithms using the gradient (DF and/or CG); 2: optimizing with algorithms using the Hessian (HT and/or NT)
+ case_optimize = 1 ! -2: check the 2nd derivatives (not ready); -1: check the 1st derivatives; 0: no optimizations performed; 1: optimizing using the gradient (DF and/or CG);
exit_tol = 1.000D-04 ! Exit the optimizer if the percent change in the cost function over the last 5 steps is below this threshold
DF_maxiter = 0 ! maximum iterations allowed for using Differential Flow (DF)
@@ -41,28 +41,42 @@
DF_tausta = 0.000D+00 ! starting value of τ. Usually 0.0 is a good idea
DF_tauend = 1.000D-00 ! ending value of τ. The larger value of τend − τsta, the more optimized
- CG_maxiter = 50 ! maximum iterations allowed for using Conjugate Gradient (CG)
+ CG_maxiter = 10 ! maximum iterations allowed for using Conjugate Gradient (CG)
CG_xtol = 1.000D-08 ! the stopping criteria of finding minimum; if |dχ2/dX| < CG xtol, exit the optimization
- CG_wolfe_c1 = 1.000D-04 ! c1 value in the strong wolfe condition for line search;
- CG_wolfe_c2 = 0.9 ! c2 value in the strong wolfe condition for line search; if one CG step takes too long, try to increase c2, but remember 0 < c1 < c2 < 1
+ CG_wolfe_c1 = 0.1 ! c1 value in the strong wolfe condition for line search, (0.0, 0.5)
+ CG_wolfe_c2 = 0.9 ! c2 value in the strong wolfe condition for line search; 0 < c1 < c2 < 1
- LM_maxiter = 20 ! maximum iterations allowed for using Levenberg-Marquard (LM)
+ LM_maxiter = 5 ! maximum iterations allowed for using Levenberg-Marquard (LM)
LM_xtol = 1.000D-08 ! if the relative error between two consecutivec iterates is at most xtol, the optimization terminates
LM_ftol = 1.000D-08 ! if both the actual and predicted relative reductions in the sum of squares are at most ftol, the optimization terminates;
LM_factor = 100.0 ! the initial step bound, which is set to the product of factor and the euclidean norm of diag*x if nonzero
- HN_maxiter = 0
- HN_xtol = 1.000D-08
- HN_factor = 100.0
-
- TN_maxiter = 0
- TN_xtol = 1.000D-08
- TN_reorder = 0
- TN_cr = 0.1
-
- case_postproc = 1 ! 0: no extra post-processing; 1: evaluate the current coils; 2: write mgrid file (not ready)
+ case_postproc = 3 ! 0: no extra post-processing; 1: evaluate the current coils; 2: write SPEC file; 3: perform Poincare plots; 4: calculates |B| Fourier harmonics in Boozer coordinates
save_freq = 1 ! frequency for writing output files; should be positive
save_coils = 1 ! flag for indicating whether write example.focus and example.coils
save_harmonics = 0 ! flag for indicating whether write example.harmonics
save_filaments = 0 ! flag for indicating whether write .example.filaments.xxxxxx
+
+ update_plasma = 0 ! if == 1, write new example.plasma file with updated Bn harmonics.
+ pp_phi = 0.000D+00 ! toroidal plane for poincare plots, cylindrical angle phi = pp_phi*Pi
+ pp_raxis = 3.000D+00 ! pp_raxis, pp_zaxis are initial guesses for magnetic axis at the specified toroidal angle
+ pp_zaxis = 0.000D+00 ! If both zero, FOCUS will take the geometric center as initial guess
+ pp_rmax = 0.000D+00 ! pp_rmax, pp_zmax are the upper bounds for performing fieldline tracing
+ pp_zmax = 0.000D+00 ! FOCUS will start follow fieldlines at interpolation between (pp_raxis, pp_zaxis) and (pp_rmax, pp_zmax)
+ pp_ns = 10 ! number of following fieldlines
+ pp_maxiter = 1000 ! number of periods for each fieldline following
+ pp_xtol = 1.000D-06 ! tolarence of ODE solver during fieldline fowllowing
+/
+&mgrid
+! mgrid file dimensions
+Rmin = 0.0
+Rmax = 0.0
+Zmin = 0.0
+Zmax = 0.0
+Pmin = 0.0
+Pmax = 6.283
+! resolutions
+NR = 101
+NZ = 101
+NP = 72
/
diff --git a/examples/w7x_high_mirror/w7x_high_mirror.boundary b/examples/w7x_high_mirror/w7x_high_mirror.boundary
new file mode 100644
index 0000000..f30216c
--- /dev/null
+++ b/examples/w7x_high_mirror/w7x_high_mirror.boundary
@@ -0,0 +1,33 @@
+#bmn bNfp nbf
+22 5 0
+#plasma boundary
+# n m Rbc Rbs Zbc Zbs
+ 0 0 5.50000000e+00 0.0 0.0 0.00000000e+00
+ 0 1 4.76850003e-01 0.0 0.0 6.23149991e-01
+ -1 0 2.35400006e-01 0.0 0.0 -1.15500003e-01
+ -1 1 -2.23299995e-01 0.0 0.0 2.23299995e-01
+ -1 2 1.00649998e-01 0.0 0.0 1.31999999e-01
+ 0 2 6.15999997e-02 0.0 0.0 6.43500015e-02
+ -2 2 5.49999997e-02 0.0 0.0 -5.49999997e-02
+ -2 1 -3.13500017e-02 0.0 0.0 3.13500017e-02
+ -2 0 1.26499999e-02 0.0 0.0 -1.26499999e-02
+ 1 1 -1.20999999e-02 0.0 0.0 -1.20999999e-02
+ -1 3 1.11649996e-02 0.0 0.0 -1.11649996e-02
+ -2 4 -6.87499996e-03 0.0 0.0 -6.87499996e-03
+ -3 3 -6.76500006e-03 0.0 0.0 6.76500006e-03
+ -2 3 6.43499987e-03 0.0 0.0 6.43499987e-03
+ -3 4 -2.73899990e-03 0.0 0.0 2.73899990e-03
+ -3 0 1.97999994e-03 0.0 0.0 -1.97999994e-03
+ -3 2 -1.87000004e-03 0.0 0.0 1.76000001e-03
+ -4 2 -1.76000001e-03 0.0 0.0 1.76000001e-03
+ 2 1 -1.70499994e-03 0.0 0.0 -1.70499994e-03
+ 1 2 1.37499999e-03 0.0 0.0 1.37499999e-03
+ -4 3 1.26499997e-03 0.0 0.0 -1.26499997e-03
+ 0 3 2.03500007e-04 0.0 0.0 2.03500007e-04
+
+#Bn harmonics
+# n m bnc bns
+0 0 1.0 0.0
+0 1 0.5 0.25
+1 0 0.5 0.0
+
diff --git a/examples/w7x_high_mirror/w7x_high_mirror.focus b/examples/w7x_high_mirror/w7x_high_mirror.focus
new file mode 100644
index 0000000..6c3a3b2
--- /dev/null
+++ b/examples/w7x_high_mirror/w7x_high_mirror.focus
@@ -0,0 +1,142 @@
+ # Total number of coils
+ 10
+ #----------------- 1 ---------------------------
+ #coil_type coil_name
+ 1 Mod_001
+ #Nseg current Ifree Length Lfree target_length
+ 128 1.450000000000000E+06 0 8.878681892908563E+00 1 8.000000000000000E+00
+ #NFcoil
+ 6
+ #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
+ 5.487179148911487E+00 1.429400016395425E+00 2.217953982818665E-02 -1.201023461002381E-01 6.344103257196283E-02 2.053702634952239E-02 -4.287107014357909E-02
+ 0.000000000000000E+00 1.764280659281571E-03 6.799528037889046E-03 3.186420232013008E-02 -3.420489197864295E-02 4.957521567012077E-03 1.499050738254608E-02
+ 2.608800463669345E-01 1.749926971101852E-01 -2.716745032401698E-02 -1.579001282012432E-02 7.401562885725494E-03 -4.501482985059499E-03 -1.217361863774398E-02
+ 0.000000000000000E+00 1.851013869483588E-01 9.957075639044627E-03 -1.130451356987468E-02 -6.665190221525366E-03 -5.343291592437382E-04 -2.754159552478410E-02
+ -7.126101514752108E-02 1.397243974420135E-02 2.926821671304291E-02 -1.855281804741378E-02 1.630700758548324E-03 3.597647289966902E-02 -2.944002808313162E-02
+ 0.000000000000000E+00 1.327602349616050E+00 1.121354142089685E-01 -2.072391519585482E-02 -9.840487797932793E-02 2.900406935444091E-02 -4.001295678150159E-02
+ #----------------- 2 ---------------------------
+ #coil_type coil_name
+ 1 Mod_002
+ #Nseg current Ifree Length Lfree target_length
+ 128 1.450000000000000E+06 0 9.126952778870734E+00 1 8.000000000000000E+00
+ #NFcoil
+ 6
+ #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
+ 5.716291592369995E+00 8.936205506037964E-01 1.898951827658998E-01 -9.624477965542874E-02 1.130551461493882E-02 1.672648809098414E-02 -2.174521899312509E-02
+ 0.000000000000000E+00 1.131216954774785E-01 -4.787208802595770E-02 5.415409177638602E-02 -6.961881336313257E-02 3.743241866891335E-02 -1.185475833351934E-02
+ 8.179646867434526E-01 5.440214897932921E-01 -2.628478288525486E-01 1.918010418117438E-01 -1.333801531166808E-01 3.969884273656217E-02 1.808399246390630E-02
+ 0.000000000000000E+00 1.931634716985232E-01 -8.661090157005172E-02 6.440275957968432E-02 -2.907651939033939E-02 5.834337608480664E-03 8.435448902977975E-03
+ -2.479052883328618E-01 1.396277769611820E-01 -8.358959993472168E-02 2.549650229639158E-02 1.338689925620846E-02 -1.843721132776129E-02 -9.613013394576094E-03
+ 0.000000000000000E+00 1.351347591340651E+00 6.503256291302819E-03 -3.675006465023361E-02 -1.555953278211165E-02 1.757251136217697E-02 9.185358917476405E-04
+ #----------------- 3 ---------------------------
+ #coil_type coil_name
+ 1 Mod_003
+ #Nseg current Ifree Length Lfree target_length
+ 128 1.450000000000000E+06 0 9.247875441250233E+00 1 8.000000000000000E+00
+ #NFcoil
+ 6
+ #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
+ 5.370945492192305E+00 8.438920652568541E-01 1.707299934197729E-01 5.156173639541974E-02 2.485809450317264E-02 -1.774405627671423E-02 -1.136786679212789E-02
+ 0.000000000000000E+00 1.532174185677675E-01 -1.268598195079201E-01 1.828696030777839E-01 -5.485294582567019E-02 -4.757407025860440E-02 1.721870113479997E-02
+ 1.457837778449846E+00 6.693277690968167E-01 -3.081756669341515E-01 1.615708566629775E-01 4.712713533086026E-02 -6.391124145938072E-02 -2.100512345446192E-03
+ 0.000000000000000E+00 6.687416249097021E-02 3.159114327523829E-02 -1.375373706407340E-01 1.131376770483891E-01 -7.142098990956991E-03 -2.530511088765757E-02
+ -3.078129769548630E-01 1.553495715170987E-01 -3.578472612940695E-02 -5.411821218116108E-02 1.686631529275658E-02 2.681906774439566E-02 1.061875574804644E-02
+ 0.000000000000000E+00 1.252344589983761E+00 1.950150410100455E-01 -4.060025433636689E-02 1.889219286139072E-02 -5.416472705607234E-02 -2.476180621257274E-02
+ #----------------- 4 ---------------------------
+ #coil_type coil_name
+ 1 Mod_004
+ #Nseg current Ifree Length Lfree target_length
+ 128 1.450000000000000E+06 0 9.589929490011116E+00 1 8.000000000000000E+00
+ #NFcoil
+ 6
+ #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
+ 4.907469811740065E+00 7.952955805965581E-01 5.910097514888448E-02 2.050577950536197E-01 2.789715512382224E-02 5.969588915193909E-03 2.704489851936327E-03
+ 0.000000000000000E+00 2.145867991092079E-01 -1.028987621263155E-01 1.310794795611224E-01 -4.537249368207783E-02 1.244816843815540E-02 3.079686114651623E-02
+ 2.060252928423281E+00 7.802290138956457E-01 -2.151194243809135E-01 -1.569110533599021E-01 6.070145059387227E-02 4.246710435056101E-02 4.212568029254247E-02
+ 0.000000000000000E+00 -1.499619488757697E-01 2.942556366488437E-01 -9.705500583479713E-02 -1.672260227489441E-01 -3.565669350486429E-02 3.024334206563705E-02
+ -2.960348322122993E-01 8.384711732454050E-02 2.071545194216714E-01 -1.004761113053840E-01 9.916300024152491E-02 -1.032082371779672E-02 -2.665352660980468E-02
+ 0.000000000000000E+00 1.115268737974466E+00 2.004644993902690E-01 1.271347663212788E-01 9.558075738371842E-02 3.782078781542389E-02 4.989524950505019E-02
+ #----------------- 5 ---------------------------
+ #coil_type coil_name
+ 1 Mod_005
+ #Nseg current Ifree Length Lfree target_length
+ 128 1.450000000000000E+06 0 9.592448203414783E+00 1 8.000000000000000E+00
+ #NFcoil
+ 6
+ #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
+ 4.399597992000233E+00 8.566405226226123E-01 7.147805437848011E-02 2.390145527944005E-01 5.228282237830489E-02 1.775467735177900E-02 2.220635371480953E-02
+ 0.000000000000000E+00 2.829516048355245E-01 -5.268193612981097E-02 -6.075828324623614E-02 -6.528405354259513E-02 -6.363939123407998E-02 -6.443784205666468E-02
+ 2.711674331049954E+00 7.217699232777867E-01 -2.091475919785378E-02 -9.524129428616150E-02 -1.375185481215237E-01 -7.486159793850741E-02 -3.519706256860552E-02
+ 0.000000000000000E+00 -2.856307343928454E-01 3.135709176464370E-01 1.738789628730727E-01 -1.822946747271399E-02 -8.313381097845912E-03 -5.466211170804170E-02
+ -1.399792355222378E-01 -5.209067733814801E-03 1.593133375789115E-01 4.995084170515299E-02 1.456470205612989E-01 5.203532945481463E-02 5.061308456713046E-02
+ 0.000000000000000E+00 1.124254034457361E+00 -1.409787599545690E-01 1.047583148040741E-01 -1.043043006225683E-01 -1.296290199767139E-02 -1.958904419893276E-02
+ #----------------- 6 ---------------------------
+ #coil_type coil_name
+ 1 Mod_006
+ #Nseg current Ifree Length Lfree target_length
+ 128 1.450000000000000E+06 0 9.592415309427746E+00 1 8.000000000000000E+00
+ #NFcoil
+ 6
+ #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
+ 3.938492917637658E+00 9.511471935380084E-01 2.189720261284961E-03 -1.672046212478434E-02 -1.146320741713078E-01 -6.570887907895596E-02 -2.660922412070501E-02
+ 0.000000000000000E+00 1.842105913305720E-01 -2.819467027487222E-01 -1.465995569059480E-01 3.750357005621357E-02 2.756923763702959E-02 7.189685916554893E-02
+ 3.346315131499947E+00 5.916811530473499E-01 7.444021309227024E-02 2.567449464996025E-01 9.221361795430791E-02 4.001727256452022E-02 3.199385099640822E-02
+ 0.000000000000000E+00 -3.573660866836764E-01 1.470031469317822E-01 1.115188449469101E-01 5.646187857821160E-02 5.795902704596963E-02 4.439521676839540E-02
+ 1.399750171610648E-01 5.213100186686659E-03 -1.593128878929978E-01 -4.995983088664074E-02 -1.456534738528208E-01 -5.203508241592496E-02 -5.061153612429899E-02
+ 0.000000000000000E+00 1.124260406820432E+00 -1.409810295335269E-01 1.047609736166758E-01 -1.042938714769722E-01 -1.295516932286644E-02 -1.958538764859711E-02
+ #----------------- 7 ---------------------------
+ #coil_type coil_name
+ 1 Mod_007
+ #Nseg current Ifree Length Lfree target_length
+ 128 1.450000000000000E+06 0 9.589878182406867E+00 1 8.000000000000000E+00
+ #NFcoil
+ 6
+ #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
+ 3.475890568322427E+00 9.878005022586565E-01 -1.863195771849197E-01 -8.587917293196706E-02 6.634380789125621E-02 4.223859913385011E-02 4.089332606682831E-02
+ 0.000000000000000E+00 7.631693546727060E-02 -2.480656783513641E-01 5.178457992213949E-02 1.730710311017398E-01 3.006378282542537E-02 -3.828600696095484E-02
+ 4.030623937113064E+00 5.152608893186009E-01 1.226660702732870E-01 2.435009739913578E-01 7.774512801052208E-03 -7.454662839964846E-03 -1.045799514144361E-02
+ 0.000000000000000E+00 -2.504241308857673E-01 1.887915466656375E-01 -1.546465800038216E-01 -8.519005239233076E-03 -2.286333580811500E-02 -1.993537921065092E-02
+ 2.959916567177005E-01 -8.383939213403890E-02 -2.071267150989329E-01 1.004592325009762E-01 -9.917698691119617E-02 1.034676123924799E-02 2.665722636171160E-02
+ 0.000000000000000E+00 1.115306428169187E+00 2.004479636890725E-01 1.271144070826361E-01 9.560059157436313E-02 3.782334374131620E-02 4.987000839620320E-02
+ #----------------- 8 ---------------------------
+ #coil_type coil_name
+ 1 Mod_008
+ #Nseg current Ifree Length Lfree target_length
+ 128 1.450000000000000E+06 0 9.247934279457624E+00 1 8.000000000000000E+00
+ #NFcoil
+ 6
+ #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
+ 3.046172805905547E+00 8.973713254001562E-01 -2.403222661621839E-01 1.695846187714737E-01 5.251658616456707E-02 -6.628963266088313E-02 -5.501440070619484E-03
+ 0.000000000000000E+00 -1.109307906927187E-01 9.128491577621632E-03 7.430486701784161E-02 -9.066357112928325E-02 2.149012898089881E-02 1.876247623761067E-02
+ 4.657583700935778E+00 5.957200215330040E-01 2.575826204864069E-01 -8.614111147534031E-04 9.061326067281026E-03 2.875070160884010E-03 -1.013555000193618E-02
+ 0.000000000000000E+00 -1.250659049219811E-01 1.304515131589798E-01 -2.164203583919537E-01 8.711572347073039E-02 4.306525853103116E-02 -2.421044695388754E-02
+ 3.077425834235493E-01 -1.553082310877080E-01 3.580546171895414E-02 5.406737007960228E-02 -1.682688902127233E-02 -2.683481741536933E-02 -1.064276283397544E-02
+ 0.000000000000000E+00 1.252397113153944E+00 1.949510944297579E-01 -4.058501703166175E-02 1.890807029193821E-02 -5.420730150982682E-02 -2.472452435960300E-02
+ #----------------- 9 ---------------------------
+ #coil_type coil_name
+ 1 Mod_009
+ #Nseg current Ifree Length Lfree target_length
+ 128 1.450000000000000E+06 0 9.126921402483722E+00 1 8.000000000000000E+00
+ #NFcoil
+ 6
+ #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
+ 2.544345668332877E+00 7.935830437347137E-01 -1.913104509192696E-01 1.526788175634955E-01 -1.233714383383178E-01 4.293039455577786E-02 1.047941059861469E-02
+ 0.000000000000000E+00 -2.186588536094592E-01 9.713511484730336E-02 -7.797459914902452E-02 4.915494664370501E-02 -1.709888893739096E-02 -4.377241827138344E-03
+ 5.183766024579499E+00 6.817402544016562E-01 2.618238301830882E-01 -1.507856091684961E-01 5.194111199531284E-02 3.665235348338292E-03 -2.629079304861204E-02
+ 0.000000000000000E+00 -4.790612777134268E-02 1.879471815965041E-02 -3.162200730828499E-02 5.723220928920287E-02 -3.379545037026075E-02 1.387304176761329E-02
+ 2.478482524305033E-01 -1.395761653842763E-01 8.356228898452858E-02 -2.549400016487971E-02 -1.337101213047707E-02 1.841566871605571E-02 9.630201192468740E-03
+ 0.000000000000000E+00 1.351372733352590E+00 6.455531086437420E-03 -3.670359093361790E-02 -1.559107659996455E-02 1.758789863462591E-02 9.186392688217332E-04
+ #----------------- 10 ---------------------------
+ #coil_type coil_name
+ 1 Mod_010
+ #Nseg current Ifree Length Lfree target_length
+ 128 1.450000000000000E+06 0 8.878668350627589E+00 1 8.000000000000000E+00
+ #NFcoil
+ 6
+ #Fourier harmonics for coils ( xc; xs; yc; ys; zc; zs)
+ 1.943737605105631E+00 6.081620305348665E-01 -1.897336984214495E-02 -5.213751067153701E-02 2.663745557352018E-02 2.074852897861712E-03 -2.483230856729705E-02
+ 0.000000000000000E+00 -1.765889173435116E-01 -1.157643347770281E-02 8.991099898348183E-04 1.690932077717289E-02 -1.019564427186906E-03 2.155725881892951E-02
+ 5.138003681373048E+00 1.305358000943127E+00 2.948251982239166E-02 -1.093406990533121E-01 5.805292809903444E-02 2.091735253083694E-02 -3.701004214260908E-02
+ 0.000000000000000E+00 5.551471521335664E-02 -3.387627913591810E-03 -3.379879015687111E-02 3.046636013610797E-02 -4.881299352057672E-03 -2.276252222775712E-02
+ 7.126383589202243E-02 -1.397360949196934E-02 -2.927089136923838E-02 1.855886199367714E-02 -1.628625699788456E-03 -3.597973202612652E-02 2.943853985364262E-02
+ 0.000000000000000E+00 1.327601255565311E+00 1.121360355004071E-01 -2.072265918624493E-02 -9.840540823406364E-02 2.900098316196363E-02 -4.001218588616975E-02
diff --git a/examples/w7x_high_mirror/w7x_high_mirror.input b/examples/w7x_high_mirror/w7x_high_mirror.input
new file mode 100644
index 0000000..b48cd1a
--- /dev/null
+++ b/examples/w7x_high_mirror/w7x_high_mirror.input
@@ -0,0 +1,72 @@
+&focusin
+ IsQuiet = -1 ! -2 verbose and including unconstrained cost functions; -1: verbose; 0: normal; 1: concise
+ IsSymmetric = 2 ! 0: no stellarator symmetry enforced; 1: plasma periodicity enforced; 2: coil periodicity enforced
+
+ input_surf = 'w7x_high_mirror.boundary' ! define the boundary
+
+ case_surface = 0 ! 0: general VMEC-like format (Rbc, Rbs, Zbc, Zbs); 1: read axis for knots
+ knotsurf = 0.200D-00 ! minor plasma radius for knototrans, only valid for case surface = 1
+ ellipticity = 0.000D+00 ! ellipticity of plasma for knototrans, only valid for case surface = 1
+ Nteta = 128 ! poloidal number for discretizing the surface
+ Nzeta = 128 ! toroidal number for discretizing the surface
+
+ case_init = 1 ! -1: read coils.ext file; 0: read ext.focus file; 1: initialize with circular coils; 2: initialize with dipoles
+ case_coils = 1 ! 0: using piecewise linear representation; (not ready); 1: using Fourier series representation
+ Ncoils = 10 ! number of coils; only valid when case_init = 1
+ init_current = 1.450D+06 ! initial coil currents (Amper); only valid when case_init = 1
+ init_radius = 1.500D+00 ! initial coil radius (meter); only valid when case_init = 1
+ IsVaryCurrent = 0 ! 0: all the currents fixed; 1: currents can be changed; overwritten by ext.focus
+ IsVaryGeometry = 1 ! 0: all the geometries fixed; 1: geometries can be changed; overwritten by ext.focus
+ NFcoil = 6 ! number of Fourier harmonics representing the coils; overwritten by ext.focus
+ Nseg = 128 ! number of coil segments for discretizing; overwritten by ext.focus
+
+ IsNormalize = 1 ! 0: do not normalize coil parameters; 1: normalize; I = I/I0, x = x/R0; I0 & R0 are quadrtic mean values.
+ IsNormWeight = 1 ! 0: do not normalize the weights; 1: normalize the weights
+ case_bnormal = 1 ! 0: keep raw Bn error; 1: Bn residue normalized to local |B|
+ case_length = 2 ! 1: quadratic format, converging the target length; 2: exponential format, as short as possible
+ weight_bnorm = 1.000D+02 ! weight for real space Bn errors
+ weight_bharm = 0.000D+00 ! weight for Bnm harmonic errors
+ weight_tflux = 0.000D+00 ! weight for toroidal flux error
+ target_tflux = 0.000D+00 ! target for the toroidal flux
+ weight_ttlen = 0.100D+00 ! weight for coil length error
+ target_length = 8.000D+00 ! target value (or for normalization) of the coils length, if zero, automatically set to initial actual length
+ weight_specw = 0.000D+00 ! weight for spectral condensation error
+ weight_cssep = 0.000D+00 ! weight for coil-surface separation constraint
+ weight_inorm = 1.000D+00 ! weight for normalization of current. Larger weight makes the derivatives more important.
+ weight_gnorm = 1.000D+00 ! weight for normalization of geometric coefficients. Larger weight makes the derivatives more important.
+
+ case_optimize = 1 ! -2: check the 2nd derivatives (not ready); -1: check the 1st derivatives; 0: no optimizations performed; 1: optimizing using the gradient (DF and/or CG);
+ exit_tol = 1.000D-04 ! Exit the optimizer if the percent change in the cost function over the last 5 steps is below this threshold
+
+ DF_maxiter = 0 ! maximum iterations allowed for using Differential Flow (DF)
+ DF_xtol = 1.000D-08 ! relative error for ODE solver
+ DF_tausta = 0.000D+00 ! starting value of τ. Usually 0.0 is a good idea
+ DF_tauend = 1.000D-00 ! ending value of τ. The larger value of τend − τsta, the more optimized
+
+ CG_maxiter = 200 ! maximum iterations allowed for using Conjugate Gradient (CG)
+ CG_xtol = 1.000D-08 ! the stopping criteria of finding minimum; if |dχ2/dX| < CG xtol, exit the optimization
+ CG_wolfe_c1 = 0.1 ! c1 value in the strong wolfe condition for line search, (0.0, 0.5)
+ CG_wolfe_c2 = 0.9 ! c2 value in the strong wolfe condition for line search; 0 < c1 < c2 < 1
+
+ LM_maxiter = 0 ! maximum iterations allowed for using Levenberg-Marquard (LM)
+ LM_xtol = 1.000D-08 ! if the relative error between two consecutivec iterates is at most xtol, the optimization terminates
+ LM_ftol = 1.000D-08 ! if both the actual and predicted relative reductions in the sum of squares are at most ftol, the optimization terminates;
+ LM_factor = 100.0 ! the initial step bound, which is set to the product of factor and the euclidean norm of diag*x if nonzero
+
+ case_postproc = 3 ! 0: no extra post-processing; 1: evaluate the current coils; 2: write SPEC file; 3: perform Poincare plots; 4: calculates |B| Fourier harmonics in Boozer coordinates
+ save_freq = 1 ! frequency for writing output files; should be positive
+ save_coils = 1 ! flag for indicating whether write example.focus and example.coils
+ save_harmonics = 0 ! flag for indicating whether write example.harmonics
+ save_filaments = 0 ! flag for indicating whether write .example.filaments.xxxxxx
+
+ update_plasma = 0 ! if == 1, write new example.plasma file with updated Bn harmonics.
+ pp_phi = 0.000D+00 ! toroidal plane for poincare plots, cylindrical angle phi = pp_phi*Pi
+ pp_raxis = 0.000D+00 ! pp_raxis, pp_zaxis are initial guesses for magnetic axis at the specified toroidal angle
+ pp_zaxis = 0.000D+00 ! If both zero, FOCUS will take the geometric center as initial guess
+ pp_rmax = 0.000D+00 ! pp_rmax, pp_zmax are the upper bounds for performing fieldline tracing
+ pp_zmax = 0.000D+00 ! FOCUS will start follow fieldlines at interpolation between (pp_raxis, pp_zaxis) and (pp_rmax, pp_zmax)
+ pp_ns = 32 ! number of following fieldlines
+ pp_maxiter = 1000 ! number of periods for each fieldline following
+ pp_xtol = 1.000D-06 ! tolarence of ODE solver during fieldline fowllowing
+
+/
diff --git a/sources/Makefile b/sources/Makefile
index bf6602b..53f068e 100644
--- a/sources/Makefile
+++ b/sources/Makefile
@@ -2,32 +2,45 @@
############################################################################################################
- ALLFILES= globals initial datalloc rdsurf rdknot rdcoils packdof bfield bnormal bmnharm fdcheck \
- torflux length surfsep solvers descent congrad lmalg saving diagnos specinp focus
- HFILES= $(ALLFILES:=.h)
- FFILES= $(ALLFILES:=.F90)
- PFILES= $(ALLFILES:=.pdf)
- ROBJS=$(ALLFILES:=_r.o)
- DOBJS=$(ALLFILES:=_d.o)
- NUMOBJ= ode.o lmder1.o
+ ALLFILES= globals initial surface rdsurf rdknot rdcoils packdof bfield bmnharm bnormal fdcheck \
+ torflux length surfsep datalloc solvers descent congrad lmalg saving diagnos \
+ specinp poinplot boozer wtmgrid focus
+ HFILES= $(ALLFILES:=.f90) # raw source files
+ FFILES= $(ALLFILES:=_m.F90) # Fortran 90 files
+ PFILES= $(ALLFILES:=.pdf) # documentations
+ ROBJS=$(ALLFILES:=_r.o) # release version objectives
+ DOBJS=$(ALLFILES:=_d.o) # debug version objectives
+ NUMOBJ= ode.o lmder1.o hybrj.o cg_descent.o # numerical libraries
############################################################################################################
MACROS=macros
- CC=intel # if want to use gfortran; make CC=gfortran xfocus; otherwise using Intel
+
+#### Default Intel+OpenMPI+HDF5###############
+# available env: /p/focus/modules/focus/basis
+ CC=intel # if want to use gfortran; make CC=gfortran or other options
FC=mpif90
+ PFLAGS= # for pre-processing compiler flags, like -D dposition
+ RFLAGS=-mcmodel=large -O3 -m64 -unroll0 -fno-alias -ip -traceback $(PFLAGS) #-vec_report0 #-ipo -xhost
+ DFLAGS=-O0 -g -traceback $(PFLAGS) -check all -check bounds -check noarg_temp_created -check uninit \
+ -ftrapuv -init=snan,arrays -debug all -D DEBUG
+
+#### GFORTRAN+OpenMPI+HDF5###############
+# available env: /p/focus/modules/focus/gfortran
ifeq ($(CC),gfortran)
# RFLAGS=-O3 -w -fdefault-real-8 -ffree-line-length-none -march=native -ffast-math
- RFLAGS=-O3 -w -ffree-line-length-none -march=native -ffast-math
- DFLAGS=-g3 -Wextra -Wtarget-lifetime -fbacktrace -fbounds-check -ffpe-trap=zero -fcheck=all -DDEBUG
-else
-# RFLAGS=-r8 -mcmodel=large -O3 -m64 -unroll0 -fno-alias -ip -traceback #-vec_report0 #-ipo -xhost
- RFLAGS=-mcmodel=large -O3 -m64 -unroll0 -fno-alias -ip -traceback #-vec_report0 #-ipo -xhost
- DFLAGS=-check all -check noarg_temp_created -debug full -D DEBUG
+ RFLAGS=-O3 -w -ffree-line-length-none -march=native -ffast-math $(PFLAGS)
+ DFLAGS=-Og $(PFLAGS) -w -ffree-line-length-none -Wextra -Wtarget-lifetime -fbacktrace -fbounds-check \
+ -ffpe-trap=zero -fcheck=all -DDEBUG
endif
-############################################################################################################
+#### EDDY Intel+IntelMPI+HDF5###############
+# available env: /home/caoxiang/Modules/focus/develop
+ifeq ($(CC),eddyintel)
+ FC=mpiifort # this is optional after recent updates
+endif
+############################################################################################################
HDF5=-I$(HDF5_HOME)/include -L$(HDF5_HOME)/lib -lhdf5hl_fortran -lhdf5_hl -lhdf5_fortran \
-lhdf5 -lpthread -lz -lm
@@ -56,13 +69,19 @@ ode.o : ode.f90
lmder1.o : lmder1.f
$(FC) -c $(RFLAGS) -o $@ $<
-$(ROBJS): %_r.o: %.F90
+hybrj.o: hybrj.f
+ $(FC) -c $(FLAGS) -o $@ $<
+
+cg_descent.o : cg_descent.f
+ $(FC) -c $(RFLAGS) -o $@ $<
+
+$(ROBJS): %_r.o: %_m.F90
$(FC) -c $(RFLAGS) -o $@ $< $(HDF5)
-$(DOBJS): %_d.o: %.F90
- $(FC) -c $(RFLAGS) $(DFLAGS) -o $@ $< $(HDF5)
+$(DOBJS): %_d.o: %_m.F90
+ $(FC) -c $(DFLAGS) -o $@ $< $(HDF5)
-$(FFILES): %.F90: %.h
+$(FFILES): %_m.F90: %.f90
m4 -P $(MACROS) $< > $@
############################################################################################################
@@ -72,22 +91,21 @@ clean:
############################################################################################################
-$(PFILES): %.pdf: %.h head.tex end.tex
-# @ls -lT $*.h | cut -c 35-55 > .$*.date
- @ls --full-time $*.h | cut -c 32-50 > .$*.date
+$(PFILES): %.pdf: %.f90 head.tex end.tex
+# @ls -lT $*.f90 | cut -c 35-55 > .$*.date
+ @ls --full-time $*.f90 | cut -c 32-50 > .$*.date
@awk -v file=$* -v date=.$*.date 'BEGIN{getline cdate < date ; FS="!latex" ; print "\\input{head} \\code{"file"}"} \
{if(NF>1) print $$2} \
- END{print "\\vspace{1mm} \\hrule \\vspace{1mm} \\footnotesize $*.h last modified on "cdate";" ; print "\\input{end}"}' $*.h > $*.tex
+ END{print "\\vspace{1mm} \\hrule \\vspace{1mm} \\footnotesize $*.f90 last modified on "cdate";" ; print "\\input{end}"}' $*.f90 > $*.tex
@echo $*.pdf
@pdflatex -shell-escape -interaction=nonstopmode -file-line-error $*.tex | grep ".*:[0-9]*:.*" ||:
@pdflatex -shell-escape -interaction=nonstopmode -file-line-error $*.tex | grep ".*:[0-9]*:.*" ||:
@pdflatex -shell-escape -interaction=nonstopmode -file-line-error $*.tex | grep ".*:[0-9]*:.*" ||:
+ @rm -f $*.tex $*.aux $*.blg $*.log $*.ps .$*.date $*.toc $*.out
-
############################################################################################################
pdfs: $(PFILES)
@echo "Please read pdfs in this directory!"
- @rm -f $*.tex $*.aux $*.blg $*.log $*.ps .$*.date $*.toc $*.out
############################################################################################################
diff --git a/sources/bfield.f90 b/sources/bfield.f90
new file mode 100644
index 0000000..1800334
--- /dev/null
+++ b/sources/bfield.f90
@@ -0,0 +1,323 @@
+
+!title (bfield) ! Computes magnetic field.
+
+!latex \briefly{Computes magnetic field given coil geometry.}
+
+!latex \calledby{\link{bnormal}}
+!latex \calls{}
+
+!latex \tableofcontents
+
+!latex \subsection{magnetic field}
+!latex \bi
+!latex \item The magnetic field of filamentary coils is calculated bt Biot-Savart Law, involving a line integral.
+!latex J. Hanson and S. Hirshman had a better representation for straight segments to avoid unnecessary sigularities
+!latex and improve numerical error at points neary the coil.
+!latex \item But currently, we use the normal expression of Biot-Savart Law and derivatives of B with repsect to
+!latex x, y, z is also calculated.
+!latex \item Later, error analysis and comparison to Hanson's method should be carried out.
+!latex \ei
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+subroutine bfield0(icoil, x, y, z, tBx, tBy, tBz)
+!------------------------------------------------------------------------------------------------------
+! DATE: 06/15/2016; 03/26/2017
+! calculate the magnetic field of icoil using manually discretized coils.
+! Biot-Savart constant and currents are not included for later simplication.
+! Be careful if coils have different resolutions.
+!------------------------------------------------------------------------------------------------------
+ use globals, only: dp, coil, surf, Ncoils, Nteta, Nzeta, cosnfp, sinnfp, &
+ zero, myid, ounit, Nfp, pi2, half, two, one, bsconstant
+ use mpi
+ implicit none
+
+ INTEGER, intent(in ) :: icoil
+ REAL, intent(in ) :: x, y, z
+ REAL , intent(out) :: tBx, tBy, tBz
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+ INTEGER :: ierr, astat, kseg, ip, is, cs, Npc
+ REAL :: dlx, dly, dlz, rm3, ltx, lty, ltz, rr, r2, m_dot_r, &
+ & mx, my, mz, xx, yy, zz, Bx, By, Bz
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+ FATAL( bfield0, icoil .lt. 1 .or. icoil .gt. Ncoils, icoil not in right range )
+ ! initialization
+ Npc = 1 ; cs = 0
+ tBx = zero ; tBy = zero ; tBz = zero
+ dlx = zero ; dly = zero ; dlz = zero
+ ltx = zero ; lty = zero ; ltz = zero
+ ! check if the coil is stellarator symmetric
+ select case (coil(icoil)%symm)
+ case ( 0 )
+ cs = 0
+ Npc = 1
+ case ( 1 )
+ cs = 0
+ Npc = Nfp
+ case ( 2)
+ cs = 1
+ Npc = Nfp
+ end select
+ ! periodicity and stellarator symmetry
+ do ip = 1, Npc
+ do is = 0, cs
+ ! find the point on plasma by rotating in reverse direction. + symmetric
+ xx = ( x*cosnfp(ip) + y*sinnfp(ip) )
+ yy = (-x*sinnfp(ip) + y*cosnfp(ip) ) * (-1)**is
+ zz = z * (-1)**is
+ Bx = zero; By = zero; Bz = zero
+ select case (coil(icoil)%type)
+ ! Fourier coils
+ case(1)
+ ! Biot-Savart law
+ do kseg = 0, coil(icoil)%NS-1
+ dlx = xx - coil(icoil)%xx(kseg)
+ dly = yy - coil(icoil)%yy(kseg)
+ dlz = zz - coil(icoil)%zz(kseg)
+ rm3 = (sqrt(dlx**2 + dly**2 + dlz**2))**(-3)
+ ltx = coil(icoil)%xt(kseg)
+ lty = coil(icoil)%yt(kseg)
+ ltz = coil(icoil)%zt(kseg)
+ Bx = Bx + ( dlz*lty - dly*ltz ) * rm3 * coil(icoil)%dd(kseg)
+ By = By + ( dlx*ltz - dlz*ltx ) * rm3 * coil(icoil)%dd(kseg)
+ Bz = Bz + ( dly*ltx - dlx*lty ) * rm3 * coil(icoil)%dd(kseg)
+ enddo ! enddo kseg
+ Bx = Bx * coil(icoil)%I * bsconstant
+ By = By * coil(icoil)%I * bsconstant
+ Bz = Bz * coil(icoil)%I * bsconstant
+ ! magnetic dipoles
+ case(2)
+ ! Biot-Savart law
+ dlx = xx - coil(icoil)%ox
+ dly = yy - coil(icoil)%oy
+ dlz = zz - coil(icoil)%oz
+ r2 = dlx**2 + dly**2 + dlz**2
+ rm3 = one/(sqrt(r2)*r2)
+ mx = sin(coil(icoil)%mt) * cos(coil(icoil)%mp)
+ my = sin(coil(icoil)%mt) * sin(coil(icoil)%mp)
+ mz = cos(coil(icoil)%mt)
+ m_dot_r = mx * dlx + my * dly + mz * dlz
+ Bx = 3.0_dp * m_dot_r * rm3 / r2 * dlx - mx * rm3
+ By = 3.0_dp * m_dot_r * rm3 / r2 * dly - my * rm3
+ Bz = 3.0_dp * m_dot_r * rm3 / r2 * dlz - mz * rm3
+ Bx = Bx * coil(icoil)%I * bsconstant
+ By = By * coil(icoil)%I * bsconstant
+ Bz = Bz * coil(icoil)%I * bsconstant
+ ! toroidal field and verticle field
+ case(3)
+ ! might be only valid for cylindrical coordinates
+ ! Bt = u0*I/(2 pi R)
+ rr = sqrt( xx**2 + yy**2 )
+ coil(icoil)%Bt = two/rr * coil(icoil)%I * bsconstant
+ Bx = - coil(icoil)%Bt * yy/rr
+ By = coil(icoil)%Bt * xx/rr
+ Bz = coil(icoil)%Bz
+ case default
+ FATAL(bfield0, .true., not supported coil types)
+ end select
+ ! sum all the contributions
+ tBx = tBx + (Bx*cosnfp(ip) - By*sinnfp(ip))*(-1)**is
+ tBy = tBy + (By*cosnfp(ip) + Bx*sinnfp(ip))
+ tBz = tBz + Bz
+ enddo
+ enddo
+
+ return
+
+end subroutine bfield0
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+subroutine bfield1(icoil, x, y, z, tBx, tBy, tBz, ND)
+!------------------------------------------------------------------------------------------------------
+! DATE: 06/15/2016; 03/26/2017
+! calculate the magnetic field and the first dirivatives of icoil using manually discretized coils;
+! Biot-Savart constant and currents are not included for later simplication;
+! Discretizing factor is includeed; coil(icoil)%dd(kseg)
+!------------------------------------------------------------------------------------------------------
+ use globals, only: dp, coil, DoF, surf, NFcoil, Ncoils, Nteta, Nzeta, &
+ zero, myid, ounit, Nfp, one, bsconstant, cosnfp, sinnfp
+ use mpi
+ implicit none
+
+ INTEGER, intent(in ) :: icoil, ND
+ REAL, intent(in ) :: x, y, z
+ REAL, dimension(1:1, 1:ND), intent(inout) :: tBx, tBy, tBz
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+ INTEGER :: ierr, astat, kseg, NS, ip, is, cs, Npc
+ REAL :: dlx, dly, dlz, r2, rm3, rm5, rm7, m_dot_r, ltx, lty, ltz, rxp, &
+ sinp, sint, cosp, cost, mx, my, mz, xx, yy, zz
+ REAL, dimension(1:1, 1:ND) :: Bx, By, Bz
+ REAL, dimension(1:1, 0:coil(icoil)%NS-1) :: dBxx, dBxy, dBxz, dByx, dByy, dByz, dBzx, dBzy, dBzz
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+ FATAL( bfield1, icoil .lt. 1 .or. icoil .gt. Ncoils, icoil not in right range )
+ FATAL( bfield1, ND <= 0, wrong inout dimension of ND )
+
+ ! initialization
+ Npc = 1 ; cs = 0
+ tBx = zero ; tBy = zero ; tBz = zero
+ dlx = zero ; dly = zero ; dlz = zero
+ ltx = zero ; lty = zero ; ltz = zero
+
+ ! check if the coil is stellarator symmetric
+ select case (coil(icoil)%symm)
+ case ( 0 )
+ cs = 0
+ Npc = 1
+ case ( 1 )
+ cs = 0
+ Npc = Nfp
+ case ( 2)
+ cs = 1
+ Npc = Nfp
+ end select
+ ! periodicity and stellarator symmetry
+ do ip = 1, Npc
+ do is = 0, cs
+ ! find the point on plasma by rotating in reverse direction. + symmetric
+ xx = ( x*cosnfp(ip) + y*sinnfp(ip) )
+ yy = (-x*sinnfp(ip) + y*cosnfp(ip) ) * (-1)**is
+ zz = z * (-1)**is
+ Bx = zero; By = zero; Bz = zero
+
+ select case (coil(icoil)%type)
+ case(1)
+ ! Fourier coils
+ NS = coil(icoil)%NS
+ do kseg = 0, NS-1
+ dlx = xx - coil(icoil)%xx(kseg)
+ dly = yy - coil(icoil)%yy(kseg)
+ dlz = zz - coil(icoil)%zz(kseg)
+ r2 = dlx**2 + dly**2 + dlz**2; rm3 = one/(sqrt(r2)*r2); rm5 = rm3/r2;
+ ltx = coil(icoil)%xt(kseg)
+ lty = coil(icoil)%yt(kseg)
+ ltz = coil(icoil)%zt(kseg)
+ rxp = dlx*ltx + dly*lty + dlz*ltz !r dot x'
+ dBxx(1,kseg) = ( 3*(dlz*lty-dly*ltz)*dlx*rm5 ) * coil(icoil)%dd(kseg) !Bx/x
+ dBxy(1,kseg) = ( 3*(dlz*lty-dly*ltz)*dly*rm5 - 3*dlz*rxp*rm5 + 2*ltz*rm3 ) * coil(icoil)%dd(kseg) !Bx/y
+ dBxz(1,kseg) = ( 3*(dlz*lty-dly*ltz)*dlz*rm5 + 3*dly*rxp*rm5 - 2*lty*rm3 ) * coil(icoil)%dd(kseg) !Bx/z
+ dByx(1,kseg) = ( 3*(dlx*ltz-dlz*ltx)*dlx*rm5 + 3*dlz*rxp*rm5 - 2*ltz*rm3 ) * coil(icoil)%dd(kseg) !By/x
+ dByy(1,kseg) = ( 3*(dlx*ltz-dlz*ltx)*dly*rm5 ) * coil(icoil)%dd(kseg) !By/y
+ dByz(1,kseg) = ( 3*(dlx*ltz-dlz*ltx)*dlz*rm5 - 3*dlx*rxp*rm5 + 2*ltx*rm3 ) * coil(icoil)%dd(kseg) !By/z
+ dBzx(1,kseg) = ( 3*(dly*ltx-dlx*lty)*dlx*rm5 - 3*dly*rxp*rm5 + 2*lty*rm3 ) * coil(icoil)%dd(kseg) !Bz/x
+ dBzy(1,kseg) = ( 3*(dly*ltx-dlx*lty)*dly*rm5 + 3*dlx*rxp*rm5 - 2*ltx*rm3 ) * coil(icoil)%dd(kseg) !Bz/y
+ dBzz(1,kseg) = ( 3*(dly*ltx-dlx*lty)*dlz*rm5 ) * coil(icoil)%dd(kseg) !Bz/z
+ enddo ! enddo kseg
+ ! db/dv = dB/dx * dx/dv v->variables
+ Bx(1:1, 1:ND) = matmul(dBxx, DoF(icoil)%xof) + matmul(dBxy, DoF(icoil)%yof) + matmul(dBxz, DoF(icoil)%zof)
+ By(1:1, 1:ND) = matmul(dByx, DoF(icoil)%xof) + matmul(dByy, DoF(icoil)%yof) + matmul(dByz, DoF(icoil)%zof)
+ Bz(1:1, 1:ND) = matmul(dBzx, DoF(icoil)%xof) + matmul(dBzy, DoF(icoil)%yof) + matmul(dBzz, DoF(icoil)%zof)
+ Bx = Bx * coil(icoil)%I * bsconstant
+ By = By * coil(icoil)%I * bsconstant
+ Bz = Bz * coil(icoil)%I * bsconstant
+ case(2) ! permanent dipoles
+ dlx = xx - coil(icoil)%ox
+ dly = yy - coil(icoil)%oy
+ dlz = zz - coil(icoil)%oz
+ r2 = dlx**2 + dly**2 + dlz**2
+ rm3 = one/(sqrt(r2)*r2)
+ rm5 = rm3/r2
+ rm7 = rm5/r2
+ cost = cos(coil(icoil)%mt) ; sint = sin(coil(icoil)%mt)
+ cosp = cos(coil(icoil)%mp) ; sinp = sin(coil(icoil)%mp)
+ mx = sint*cosp ; my = sint*sinp ; mz = cost
+ m_dot_r = mx*dlx + my*dly + mz*dlz
+
+#ifdef dposition
+ ! dipole position is variable
+ Bx(1, 1) = 15.0_dp*m_dot_r*dlx*dlx*rm7 - 3.0_dp*mx*dlx*rm5 - 3.0_dp*mx*dlx*rm5 - 3.0_dp*m_dot_r*rm5
+ By(1, 1) = 15.0_dp*m_dot_r*dlx*dly*rm7 - 3.0_dp*mx*dly*rm5 - 3.0_dp*my*dlx*rm5
+ Bz(1, 1) = 15.0_dp*m_dot_r*dlx*dlz*rm7 - 3.0_dp*mx*dlz*rm5 - 3.0_dp*mz*dlx*rm5
+
+ Bx(1, 2) = 15.0_dp*m_dot_r*dly*dlx*rm7 - 3.0_dp*my*dlx*rm5 - 3.0_dp*mx*dly*rm5
+ By(1, 2) = 15.0_dp*m_dot_r*dly*dly*rm7 - 3.0_dp*my*dly*rm5 - 3.0_dp*my*dly*rm5 - 3.0_dp*m_dot_r*rm5
+ Bz(1, 2) = 15.0_dp*m_dot_r*dly*dlz*rm7 - 3.0_dp*my*dlz*rm5 - 3.0_dp*mz*dly*rm5
+
+ Bx(1, 3) = 15.0_dp*m_dot_r*dlz*dlx*rm7 - 3.0_dp*mz*dlx*rm5 - 3.0_dp*mx*dlz*rm5
+ By(1, 3) = 15.0_dp*m_dot_r*dlz*dly*rm7 - 3.0_dp*mz*dly*rm5 - 3.0_dp*my*dlz*rm5
+ Bz(1, 3) = 15.0_dp*m_dot_r*dlz*dlz*rm7 - 3.0_dp*mz*dlz*rm5 - 3.0_dp*mz*dlz*rm5 - 3.0_dp*m_dot_r*rm5
+
+ Bx(1, 4) = 3.0_dp*dlx*( cost*cosp*dlx + cost*sinp*dly - sint*dlz)*rm5 - cost*cosp*rm3
+ By(1, 4) = 3.0_dp*dly*( cost*cosp*dlx + cost*sinp*dly - sint*dlz)*rm5 - cost*sinp*rm3
+ Bz(1, 4) = 3.0_dp*dlz*( cost*cosp*dlx + cost*sinp*dly - sint*dlz)*rm5 + sint *rm3
+
+ Bx(1, 5) = 3.0_dp*dlx*(-sint*sinp*dlx + sint*cosp*dly )*rm5 + sint*sinp*rm3
+ By(1, 5) = 3.0_dp*dly*(-sint*sinp*dlx + sint*cosp*dly )*rm5 - sint*cosp*rm3
+ Bz(1, 5) = 3.0_dp*dlz*(-sint*sinp*dlx + sint*cosp*dly )*rm5
+#else
+ ! dipole origins are fixed
+ Bx(1, 1) = 3.0_dp*dlx*( cost*cosp*dlx + cost*sinp*dly - sint*dlz)*rm5 - cost*cosp*rm3
+ By(1, 1) = 3.0_dp*dly*( cost*cosp*dlx + cost*sinp*dly - sint*dlz)*rm5 - cost*sinp*rm3
+ Bz(1, 1) = 3.0_dp*dlz*( cost*cosp*dlx + cost*sinp*dly - sint*dlz)*rm5 + sint *rm3
+
+ Bx(1, 2) = 3.0_dp*dlx*(-sint*sinp*dlx + sint*cosp*dly )*rm5 + sint*sinp*rm3
+ By(1, 2) = 3.0_dp*dly*(-sint*sinp*dlx + sint*cosp*dly )*rm5 - sint*cosp*rm3
+ Bz(1, 2) = 3.0_dp*dlz*(-sint*sinp*dlx + sint*cosp*dly )*rm5
+#endif
+ Bx = Bx * coil(icoil)%I * bsconstant
+ By = By * coil(icoil)%I * bsconstant
+ Bz = Bz * coil(icoil)%I * bsconstant
+ case(3) ! only for Bz
+ Bx = zero
+ By = zero
+ Bz = one
+ end select
+ ! sum all the contributions
+ tBx = tBx + (Bx*cosnfp(ip) - By*sinnfp(ip))*(-1)**is
+ tBy = tBy + (By*cosnfp(ip) + Bx*sinnfp(ip))
+ tBz = tBz + Bz
+ enddo
+ enddo
+
+ return
+
+end subroutine bfield1
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+subroutine coils_bfield(B,x,y,z)
+ use globals, only: dp, coil, surf, Ncoils, Nteta, Nzeta, &
+ zero, myid, ounit, Nfp, bsconstant, one, two, ncpu, &
+ master, nworker, myworkid, MPI_COMM_MASTERS, MPI_COMM_MYWORLD, MPI_COMM_WORKERS
+ use mpi
+ implicit none
+
+ REAL , intent( in) :: x, y, z
+ REAL , intent(inout) :: B(3)
+ !INTEGER, INTENT(in) :: comm ! MPI communicator
+
+ !-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+ INTEGER :: ierr, astat
+ REAL :: Bx, By, Bz
+ INTEGER :: icoil
+
+ !-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+ call MPI_BARRIER(MPI_COMM_MYWORLD, ierr ) ! wait all cpus;
+
+ B = zero
+ do icoil = 1, Ncoils
+ if ( myworkid /= modulo(icoil-1, nworker) ) cycle ! MPI
+ ! Bx = zero; By = zero; Bz = zero
+ call bfield0( icoil, x, y, z, Bx, By, Bz )
+ B(1) = B(1) + Bx
+ B(2) = B(2) + By
+ B(3) = B(3) + Bz
+ enddo
+
+ call MPI_ALLREDUCE(MPI_IN_PLACE, B, 3, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_MYWORLD, ierr )
+
+ return
+
+end subroutine coils_bfield
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
diff --git a/sources/bfield.h b/sources/bfield.h
deleted file mode 100644
index 9308f1e..0000000
--- a/sources/bfield.h
+++ /dev/null
@@ -1,147 +0,0 @@
-
-!title (bfield) ! Computes magnetic field.
-
-!latex \briefly{Computes magnetic field given coil geometry.}
-
-!latex \calledby{\link{bnormal}}
-!latex \calls{}
-
-!latex \tableofcontents
-
-!latex \subsection{magnetic field}
-!latex \bi
-!latex \item The magnetic field of filamentary coils is calculated bt Biot-Savart Law, involving a line integral.
-!latex J. Hanson and S. Hirshman had a better representation for straight segments to avoid unnecessary sigularities
-!latex and improve numerical error at points neary the coil.
-!latex \item But currently, we use the normal expression of Biot-Savart Law and derivatives of B with repsect to
-!latex x, y, z is also calculated.
-!latex \item Later, error analysis and comparison to Hanson's method should be carried out.
-!latex \ei
-
-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
-subroutine bfield0(icoil, iteta, jzeta, Bx, By, Bz)
-!------------------------------------------------------------------------------------------------------
-! DATE: 06/15/2016; 03/26/2017
-! calculate the magnetic field of icoil using manually discretized coils.
-! Biot-Savart constant and currents are not included for later simplication.
-! Be careful if coils have different resolutions.
-!------------------------------------------------------------------------------------------------------
- use globals, only: dp, coil, surf, Ncoils, Nteta, Nzeta, &
- zero, myid, ounit, Npc
- implicit none
- include "mpif.h"
-
- INTEGER, intent(in ) :: icoil, iteta, jzeta
- REAL , intent(out) :: Bx, By, Bz
-
-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
- INTEGER :: ierr, astat, kseg
- REAL :: dlx, dly, dlz, rm3, ltx, lty, ltz
-
-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
- FATAL( bfield0, icoil .lt. 1 .or. icoil .gt. Ncoils*Npc, icoil not in right range )
- FATAL( bfield0, iteta .lt. 0 .or. iteta .gt. Nteta , iteta not in right range )
- FATAL( bfield0, jzeta .lt. 0 .or. jzeta .gt. Nzeta , jzeta not in right range )
-
- dlx = zero; ltx = zero; Bx = zero
- dly = zero; lty = zero; By = zero
- dlz = zero; ltz = zero; Bz = zero
-
- do kseg = 0, coil(icoil)%NS-1
-
- dlx = surf(1)%xx(iteta,jzeta) - coil(icoil)%xx(kseg)
- dly = surf(1)%yy(iteta,jzeta) - coil(icoil)%yy(kseg)
- dlz = surf(1)%zz(iteta,jzeta) - coil(icoil)%zz(kseg)
- rm3 = (sqrt(dlx**2 + dly**2 + dlz**2))**(-3)
-
- ltx = coil(icoil)%xt(kseg)
- lty = coil(icoil)%yt(kseg)
- ltz = coil(icoil)%zt(kseg)
-
- Bx = Bx + ( dlz*lty - dly*ltz ) * rm3 * coil(icoil)%dd(kseg)
- By = By + ( dlx*ltz - dlz*ltx ) * rm3 * coil(icoil)%dd(kseg)
- Bz = Bz + ( dly*ltx - dlx*lty ) * rm3 * coil(icoil)%dd(kseg)
-
- enddo ! enddo kseg
-
- return
-
-end subroutine bfield0
-
-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
-subroutine bfield1(icoil, iteta, jzeta, Bx, By, Bz, ND)
-!------------------------------------------------------------------------------------------------------
-! DATE: 06/15/2016; 03/26/2017
-! calculate the magnetic field and the first dirivatives of icoil using manually discretized coils;
-! Biot-Savart constant and currents are not included for later simplication;
-! Discretizing factor is includeed; coil(icoil)%dd(kseg)
-!------------------------------------------------------------------------------------------------------
- use globals, only: dp, coil, DoF, surf, NFcoil, Ncoils, Nteta, Nzeta, &
- zero, myid, ounit, Npc
- implicit none
- include "mpif.h"
-
- INTEGER, intent(in ) :: icoil, iteta, jzeta, ND
- REAL, dimension(1:1, 1:ND), intent(inout) :: Bx, By, Bz
-
-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
- INTEGER :: ierr, astat, kseg, NS
- REAL :: dlx, dly, dlz, r, rm3, rm5, ltx, lty, ltz, rxp
- REAL, dimension(1:1, 0:coil(icoil)%NS-1) :: dBxx, dBxy, dBxz, dByx, dByy, dByz, dBzx, dBzy, dBzz
-
-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
- FATAL( bfield1, icoil .lt. 1 .or. icoil .gt. Ncoils*Npc, icoil not in right range )
- FATAL( bfield1, iteta .lt. 0 .or. iteta .gt. Nteta , iteta not in right range )
- FATAL( bfield1, jzeta .lt. 0 .or. jzeta .gt. Nzeta , jzeta not in right range )
- FATAL( bfield1, ND <= 0, wrong inout dimension of ND )
-
- NS = coil(icoil)%NS
-
- dlx = zero; ltx = zero; Bx = zero
- dly = zero; lty = zero; By = zero
- dlz = zero; ltz = zero; Bz = zero
-
- do kseg = 0, NS-1
-
- dlx = surf(1)%xx(iteta,jzeta) - coil(icoil)%xx(kseg)
- dly = surf(1)%yy(iteta,jzeta) - coil(icoil)%yy(kseg)
- dlz = surf(1)%zz(iteta,jzeta) - coil(icoil)%zz(kseg)
-
- r = sqrt(dlx**2 + dly**2 + dlz**2); rm3 = r**(-3); rm5 = r**(-5)
-
- ltx = coil(icoil)%xt(kseg)
- lty = coil(icoil)%yt(kseg)
- ltz = coil(icoil)%zt(kseg)
-
- rxp = dlx*ltx + dly*lty + dlz*ltz !r dot x'
-
- dBxx(1,kseg) = ( 3*(dlz*lty-dly*ltz)*dlx*rm5 ) * coil(icoil)%dd(kseg) !Bx/x
- dBxy(1,kseg) = ( 3*(dlz*lty-dly*ltz)*dly*rm5 - 3*dlz*rxp*rm5 + 2*ltz*rm3 ) * coil(icoil)%dd(kseg) !Bx/y
- dBxz(1,kseg) = ( 3*(dlz*lty-dly*ltz)*dlz*rm5 + 3*dly*rxp*rm5 - 2*lty*rm3 ) * coil(icoil)%dd(kseg) !Bx/z
-
- dByx(1,kseg) = ( 3*(dlx*ltz-dlz*ltx)*dlx*rm5 + 3*dlz*rxp*rm5 - 2*ltz*rm3 ) * coil(icoil)%dd(kseg) !By/x
- dByy(1,kseg) = ( 3*(dlx*ltz-dlz*ltx)*dly*rm5 ) * coil(icoil)%dd(kseg) !By/y
- dByz(1,kseg) = ( 3*(dlx*ltz-dlz*ltx)*dlz*rm5 - 3*dlx*rxp*rm5 + 2*ltx*rm3 ) * coil(icoil)%dd(kseg) !By/z
-
- dBzx(1,kseg) = ( 3*(dly*ltx-dlx*lty)*dlx*rm5 - 3*dly*rxp*rm5 + 2*lty*rm3 ) * coil(icoil)%dd(kseg) !Bz/x
- dBzy(1,kseg) = ( 3*(dly*ltx-dlx*lty)*dly*rm5 + 3*dlx*rxp*rm5 - 2*ltx*rm3 ) * coil(icoil)%dd(kseg) !Bz/y
- dBzz(1,kseg) = ( 3*(dly*ltx-dlx*lty)*dlz*rm5 ) * coil(icoil)%dd(kseg) !Bz/z
-
- enddo ! enddo kseg
-
- Bx(1:1, 1:ND) = matmul(dBxx, DoF(icoil)%xof) + matmul(dBxy, DoF(icoil)%yof) + matmul(dBxz, DoF(icoil)%zof)
- By(1:1, 1:ND) = matmul(dByx, DoF(icoil)%xof) + matmul(dByy, DoF(icoil)%yof) + matmul(dByz, DoF(icoil)%zof)
- Bz(1:1, 1:ND) = matmul(dBzx, DoF(icoil)%xof) + matmul(dBzy, DoF(icoil)%yof) + matmul(dBzz, DoF(icoil)%zof)
-
-
- return
-
-end subroutine bfield1
-
-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
diff --git a/sources/bmnharm.h b/sources/bmnharm.f90
similarity index 80%
rename from sources/bmnharm.h
rename to sources/bmnharm.f90
index 4f84c9a..a3adb0c 100644
--- a/sources/bmnharm.h
+++ b/sources/bmnharm.f90
@@ -105,6 +105,19 @@
!!$END SUBROUTINE bmnharm
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+module bharm_mod
+ ! contains some common variables used in subroutine bnormal
+ ! allocating once and re-using them will save allocation time
+ use globals, only : dp
+ implicit none
+
+ ! 0-order
+ ! none for now; in future, others should be moved to here. 03/30/2019
+ ! 1st-order
+ REAL, allocatable :: dBc(:), dBs(:)
+
+end module bharm_mod
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
SUBROUTINE readBmn
!----------------------------------------------------------------------------------------
@@ -112,20 +125,23 @@ SUBROUTINE readBmn
! allocate trig functions;
!----------------------------------------------------------------------------------------
use globals, only: dp, zero, half, pi2, myid, ounit, runit, ext, IsQuiet, Nteta, Nzeta, Nfp, &
- NBmn, Bmnin, Bmnim, wBmn, tBmnc, tBmns, carg, sarg, Nfp_raw, case_bnormal
+ NBmn, Bmnin, Bmnim, wBmn, tBmnc, tBmns, carg, sarg, case_bnormal, &
+ input_harm, bharm_jsurf, surf, plasma
+ use bharm_mod
implicit none
include "mpif.h"
- INTEGER :: ii, jj, ij, imn, ierr, astat
+ INTEGER :: ii, jj, ij, imn, ierr, astat, isurf
REAL :: teta, zeta, arg
LOGICAL :: exist
!----------------------------------------------------------------------------------------
- inquire( file="target.harmonics", exist=exist)
+ isurf = plasma
+ inquire( file=trim(input_harm), exist=exist)
FATAL( readBmn, .not.exist, ext.harmonics does not exist )
if (myid == 0) then
- open(runit, file="target.harmonics", status='old', action='read')
+ open(runit, file=trim(input_harm), status='old', action='read')
read(runit,*) ! comment line;
read(runit,*) NBmn !read dimensions
endif
@@ -161,27 +177,43 @@ SUBROUTINE readBmn
enddo
endif
close(runit)
- write(ounit, '("******* : case_bnormal has been reset to 0.")')
+ write(ounit, '("******* : case_bnormal has been reset to 0, since Bn harmonics is turned on.")')
endif
case_bnormal = 0
- !-------------------------store trig functions-------------------------------------------
- SALLOCATE( carg, (1:Nteta*Nzeta, 1:NBmn), zero )
- SALLOCATE( sarg, (1:Nteta*Nzeta, 1:NBmn), zero )
-
- Bmnin(1:NBmn) = Bmnin(1:NBmn) * Nfp_raw
-
- ij = 0
- do jj = 0, Nzeta-1 ; zeta = ( jj + half ) * pi2 / (Nzeta*Nfp) ! the same as in rdsurf.h
- do ii = 0, Nteta-1 ; teta = ( ii + half ) * pi2 / Nteta
- ij = ij + 1
- do imn = 1, NBmn
- arg = Bmnim(imn) * teta - Bmnin(imn) * zeta
- carg(ij, imn) = cos(arg)
- sarg(ij, imn) = sin(arg)
- enddo
- enddo
- enddo
+ !-------------------------store trig functions-------------------------------------------
+ SALLOCATE( carg, (1:Nteta*Nzeta, 1:NBmn), zero )
+ SALLOCATE( sarg, (1:Nteta*Nzeta, 1:NBmn), zero )
+
+ Bmnin(1:NBmn) = Bmnin(1:NBmn) * surf(isurf)%Nfp
+
+ ij = 0
+ ! the same as in rdsurf.h
+ do jj = 0, Nzeta-1
+ zeta = ( jj + half ) * pi2 / surf(isurf)%Nzeta
+ do ii = 0, Nteta-1
+ teta = ( ii + half ) * pi2 / surf(isurf)%Nteta
+ ij = ij + 1
+ do imn = 1, NBmn
+ arg = Bmnim(imn) * teta - Bmnin(imn) * zeta
+ carg(ij, imn) = cos(arg)
+ sarg(ij, imn) = sin(arg)
+ enddo
+ ! Additional weighting
+ if (bharm_jsurf == 0) then
+ continue
+ else if (bharm_jsurf == 1) then ! Bn * dA
+ carg(ij, 1:NBmn) = carg(ij, 1:NBmn) * (surf(isurf)%ds(ii, jj))
+ sarg(ij, 1:NBmn) = sarg(ij, 1:NBmn) * (surf(isurf)%ds(ii, jj))
+ else if ( bharm_jsurf == 2) then ! Bn * sqrt(dA)
+ carg(ij, 1:NBmn) = carg(ij, 1:NBmn) * sqrt(surf(isurf)%ds(ii, jj))
+ sarg(ij, 1:NBmn) = sarg(ij, 1:NBmn) * sqrt(surf(isurf)%ds(ii, jj))
+ end if
+ enddo
+ enddo
+
+ SALLOCATE( dBc, (1:NBmn), zero ) ! dB_mn_cos
+ SALLOCATE( dBs, (1:NBmn), zero ) ! dB_mn_sin
return
END SUBROUTINE readBmn
@@ -197,7 +229,8 @@ SUBROUTINE twodft(func, hs, hc, im, in, mn)
! carg and sarg stored the trig functions.
! Right now, it's using normal Fourier transforming, later FFT will be enabled.
!-------------------------------------------------------------------------------!
- use globals, only: dp, zero, half, two, pi2, myid, ounit, Nteta, Nzeta, carg, sarg
+ use globals, only: dp, zero, half, two, pi2, myid, ounit, &
+ Nteta, Nzeta, carg, sarg, bharm_jsurf, surf, plasma
implicit none
include "mpif.h"
!-------------------------------------------------------------------------------
@@ -205,11 +238,12 @@ SUBROUTINE twodft(func, hs, hc, im, in, mn)
REAL , INTENT(out) :: hc(1:mn), hs(1:mn)
INTEGER, INTENT(in ) :: mn, im(1:mn), in(1:mn)
- INTEGER :: m, n, imn, maxN, maxM, astat, ierr
+ INTEGER :: m, n, imn, maxN, maxM, astat, ierr, isurf
!-------------------------------------------------------------------------------
FATAL(twodft, mn < 1, invalid size for 2D Fourier transformation)
+ isurf = plasma
maxN = maxval(abs(in))
maxM = maxval(abs(im))
FATAL(twodft, maxN >= Nzeta/2, toroidal grid resolution not enough)
@@ -222,6 +256,7 @@ SUBROUTINE twodft(func, hs, hc, im, in, mn)
hs(imn) = sum(func(1:Nteta*Nzeta) * sarg(1:Nteta*Nzeta, imn))
if (m==0 .and. n==0) then ! for (0,0) term, times a half factor;
+ ! if (m==0) then ! for (0,0) term, times a half factor;
hc(imn) = hc(imn)*half
hs(imn) = hs(imn)*half
endif
@@ -231,6 +266,19 @@ SUBROUTINE twodft(func, hs, hc, im, in, mn)
hc = hc * two/(Nteta*Nzeta) ! Discretizing factor;
hs = hs * two/(Nteta*Nzeta) ! Discretizing factor;
+ ! Additional weighting
+ if (bharm_jsurf == 0) then
+ ! continue
+ hc = hc * two
+ hs = hs * two
+ else if (bharm_jsurf == 1) then ! divide by A
+ hc = hc / surf(isurf)%area * two * pi2**2
+ hs = hs / surf(isurf)%area * two * pi2**2
+ else if (bharm_jsurf == 2) then ! divide by sqrt(A)
+ hc = hc / sqrt(surf(isurf)%area) * two * pi2
+ hs = hs / sqrt(surf(isurf)%area) * two * pi2
+ end if
+
return
END SUBROUTINE twodft
diff --git a/sources/bnormal.f90 b/sources/bnormal.f90
new file mode 100644
index 0000000..303adaf
--- /dev/null
+++ b/sources/bnormal.f90
@@ -0,0 +1,217 @@
+
+!title (bnormal) ! Calculate total bnormal and its derivatives.
+
+!latex \briefly{Calculate the total bnormal of all coils on plasma surface and the derivatives with respect to coil geometry and currents, including the first and second dirivatives.
+!latex Calling \emph{bnormal(0), bnormal(1), bnormal(2)} calculates the $0-order$, $1^{st}-order$ and $2^{nd}-order$ derivatives respectively.}
+
+!latex \calledby{\link{costfun}}
+!latex \calls{\link{bfield}}
+
+!latex \tableofcontents
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+module bnorm_mod
+ ! contains some common variables used in subroutine bnormal
+ ! allocating once and re-using them will save allocation time
+ use globals, only : dp
+ implicit none
+
+ ! 0-order
+ REAL, allocatable :: dBx(:,:), dBy(:,:), dBz(:,:), Bm(:,:)
+ ! 1st-order
+ REAL, allocatable :: dBn(:), dBm(:), d1B(:,:,:)
+
+end module bnorm_mod
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+subroutine bnormal( ideriv )
+!------------------------------------------------------------------------------------------------------
+! DATE: 04/02/2017;
+! Calculate the Bn surface integral and its derivatives;
+! ideriv = 0 -> only calculate the Bn surface integral;
+! ideriv = 1 -> calculate the Bn surface integral and its first derivatives;
+! ideriv = 2 -> calculate the Bn surface integral and its first & second derivatives;
+!------------------------------------------------------------------------------------------------------
+ use globals, only: dp, zero, half, one, pi2, sqrtmachprec, bsconstant, ncpu, myid, ounit, &
+ coil, DoF, surf, Ncoils, Nteta, Nzeta, discretefactor, plasma, &
+ bnorm, t1B, t2B, bn, Ndof, Cdof, weight_bharm, case_bnormal, &
+ weight_bnorm, ibnorm, mbnorm, ibharm, mbharm, LM_fvec, LM_fjac, &
+ bharm, t1H, Bmnc, Bmns, wBmn, tBmnc, tBmns, Bmnim, Bmnin, NBmn
+ use bnorm_mod
+ use bharm_mod
+ use mpi
+ implicit none
+
+ INTEGER, INTENT(in) :: ideriv
+ !--------------------------------------------------------------------------------------------
+ INTEGER :: astat, ierr
+ INTEGER :: icoil, iteta, jzeta, idof, ND, NumGrid, isurf
+ !--------------------------initialize and allocate arrays-------------------------------------
+ isurf = plasma
+ NumGrid = Nteta*Nzeta
+ ! reset to zero;
+ bnorm = zero
+ surf(isurf)%Bx = zero; surf(isurf)%By = zero; surf(isurf)%Bz = zero; surf(isurf)%Bn = zero
+ dBx = zero; dBy = zero; dBz = zero; Bm = zero
+ bn = zero
+ !-------------------------------calculate Bn--------------------------------------------------
+ if( ideriv >= 0 ) then
+ do jzeta = 0, Nzeta - 1
+ do iteta = 0, Nteta - 1
+ if( myid.ne.modulo(jzeta*Nteta+iteta,ncpu) ) cycle ! parallelization loop;
+ do icoil = 1, Ncoils
+ call bfield0(icoil, surf(isurf)%xx(iteta, jzeta), surf(isurf)%yy(iteta, jzeta), &
+ & surf(isurf)%zz(iteta, jzeta), dBx(0,0), dBy(0,0), dBz(0,0))
+ surf(isurf)%Bx(iteta, jzeta) = surf(isurf)%Bx(iteta, jzeta) + dBx( 0, 0)
+ surf(isurf)%By(iteta, jzeta) = surf(isurf)%By(iteta, jzeta) + dBy( 0, 0)
+ surf(isurf)%Bz(iteta, jzeta) = surf(isurf)%Bz(iteta, jzeta) + dBz( 0, 0)
+ enddo ! end do icoil
+ surf(isurf)%Bn(iteta, jzeta) = surf(isurf)%Bx(iteta, jzeta)*surf(isurf)%nx(iteta, jzeta) &
+ & + surf(isurf)%By(iteta, jzeta)*surf(isurf)%ny(iteta, jzeta) &
+ & + surf(isurf)%Bz(iteta, jzeta)*surf(isurf)%nz(iteta, jzeta) &
+ & - surf(isurf)%pb(iteta, jzeta)
+ select case (case_bnormal)
+ case (0) ! no normalization over |B|;
+ bnorm = bnorm + surf(isurf)%Bn(iteta, jzeta) * surf(isurf)%Bn(iteta, jzeta) * surf(isurf)%ds(iteta, jzeta)
+ case (1) ! normalized over |B|;
+ Bm(iteta, jzeta) = surf(isurf)%Bx(iteta, jzeta)*surf(isurf)%Bx(iteta, jzeta) &
+ & + surf(isurf)%By(iteta, jzeta)*surf(isurf)%By(iteta, jzeta) &
+ & + surf(isurf)%Bz(iteta, jzeta)*surf(isurf)%Bz(iteta, jzeta)
+ bnorm = bnorm + surf(isurf)%Bn(iteta, jzeta) * surf(isurf)%Bn(iteta, jzeta) &
+ & / Bm(iteta, jzeta) * surf(isurf)%ds(iteta, jzeta)
+ case default
+ FATAL( bnorm, .true., case_bnormal can only be 0/1 )
+ end select
+ enddo ! end do iteta
+ enddo ! end do jzeta
+ ! gather data
+ call MPI_BARRIER( MPI_COMM_WORLD, ierr )
+ call MPI_ALLREDUCE( MPI_IN_PLACE, surf(isurf)%Bx, NumGrid, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr )
+ call MPI_ALLREDUCE( MPI_IN_PLACE, surf(isurf)%By, NumGrid, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr )
+ call MPI_ALLREDUCE( MPI_IN_PLACE, surf(isurf)%Bz, NumGrid, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr )
+ call MPI_ALLREDUCE( MPI_IN_PLACE, surf(isurf)%Bn, NumGrid, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr )
+ call MPI_ALLREDUCE( MPI_IN_PLACE, bnorm, 1 , MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr )
+ bnorm = bnorm * half * discretefactor
+ bn = surf(isurf)%Bn + surf(isurf)%pb ! bn is B.n from coils
+ ! bn = surf(isurf)%Bx * surf(isurf)%nx + surf(isurf)%By * surf(isurf)%ny + surf(isurf)%Bz * surf(isurf)%nz
+ !! if (case_bnormal == 0) bnorm = bnorm * bsconstant * bsconstant ! take bsconst back
+ ! collect |B|
+ if (case_bnormal == 1) then
+ call MPI_ALLREDUCE( MPI_IN_PLACE, Bm, NumGrid, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr )
+ !! bm = bm * bsconstant * bsconstant
+ endif
+ ! LM required discrete cost functions
+ if (mbnorm > 0) then
+ select case (case_bnormal)
+ case (0) ! no normalization over |B|;
+ LM_fvec(ibnorm+1:ibnorm+mbnorm) = weight_bnorm &
+ & * reshape(surf(isurf)%bn(0:Nteta-1, 0:Nzeta-1) , (/Nteta*Nzeta/))
+ case (1) ! normalized over |B|;
+ LM_fvec(ibnorm+1:ibnorm+mbnorm) = weight_bnorm &
+ & * reshape(surf(isurf)%bn(0:Nteta-1, 0:Nzeta-1)/sqrt(bm(0:Nteta-1, 0:Nzeta-1)), (/Nteta*Nzeta/))
+ case default
+ FATAL( bnorm, .true., case_bnormal can only be 0/1 )
+ end select
+ endif
+ ! Bn harmonics related
+ if (weight_bharm > sqrtmachprec) then
+ call twodft( bn, Bmns, Bmnc, Bmnim, Bmnin, NBmn ) ! Bn from coils
+ bharm = half * sum( wBmn * ((Bmnc - tBmnc)**2 + (Bmns - tBmns)**2) )
+ if (mbharm > 0) then
+ LM_fvec(ibharm+1:ibharm+mbharm/2) = weight_bharm * wBmn * (Bmnc - tBmnc)
+ LM_fvec(ibharm+mbharm/2+1:ibharm+mbharm) = weight_bharm * wBmn * (Bmns - tBmns)
+ endif
+ endif
+ endif
+
+ !-------------------------------calculate Bn/x------------------------------------------------
+ if ( ideriv >= 1 ) then
+ ! reset data
+ t1B = zero ; d1B = zero
+ dBn = zero ; dBm = zero
+ do jzeta = 0, Nzeta - 1
+ do iteta = 0, Nteta - 1
+ if( myid.ne.modulo(jzeta*Nteta+iteta,ncpu) ) cycle ! parallelization loop;
+ idof = 0
+ do icoil = 1, Ncoils
+ ND = DoF(icoil)%ND
+ ! derivatives w.r.t currents
+ if ( coil(icoil)%Ic /= 0 ) then
+ call bfield0(icoil, surf(isurf)%xx(iteta, jzeta), surf(isurf)%yy(iteta, jzeta), &
+ & surf(isurf)%zz(iteta, jzeta), dBx(0,0), dBy(0,0), dBz(0,0))
+ if (coil(icoil)%type == 3) dBz(0,0) = zero ! Bz doesn't change in type=3
+ dBn(idof+1) = ( dBx(0,0)*surf(isurf)%nx(iteta,jzeta) &
+ & + dBy(0,0)*surf(isurf)%ny(iteta,jzeta) &
+ & + dBz(0,0)*surf(isurf)%nz(iteta,jzeta) ) / coil(icoil)%I
+ if (case_bnormal == 1) then ! normalized over |B|;
+ dBm(idof+1) = ( dBx(0,0)*surf(isurf)%Bx(iteta,jzeta) &
+ & + dBy(0,0)*surf(isurf)%By(iteta,jzeta) &
+ & + dBz(0,0)*surf(isurf)%Bz(iteta,jzeta) ) / coil(icoil)%I
+ endif
+ idof = idof +1
+ endif
+ ! derivatives w.r.t geometries
+ if ( coil(icoil)%Lc /= 0 ) then
+ call bfield1(icoil, surf(isurf)%xx(iteta, jzeta), surf(isurf)%yy(iteta, jzeta), &
+ & surf(isurf)%zz(iteta, jzeta), dBx(1:ND,0), dBy(1:ND,0), dBz(1:ND,0), ND)
+ dBn(idof+1:idof+ND) = ( dBx(1:ND,0)*surf(isurf)%nx(iteta,jzeta) &
+ & + dBy(1:ND,0)*surf(isurf)%ny(iteta,jzeta) &
+ & + dBz(1:ND,0)*surf(isurf)%nz(iteta,jzeta) )
+ if (case_bnormal == 1) then ! normalized over |B|;
+ dBm(idof+1:idof+ND) = ( dBx(1:ND,0)*surf(isurf)%Bx(iteta,jzeta) &
+ & + dBy(1:ND,0)*surf(isurf)%By(iteta,jzeta) &
+ & + dBz(1:ND,0)*surf(isurf)%Bz(iteta,jzeta) )
+ endif
+ idof = idof + ND
+ endif
+ enddo !end icoil;
+ FATAL( bnormal , idof .ne. Ndof, counting error in packing )
+ select case (case_bnormal)
+ case (0) ! no normalization over |B|;
+ t1B(1:Ndof) = t1B(1:Ndof) + surf(isurf)%bn(iteta,jzeta) * surf(isurf)%ds(iteta,jzeta) * dBn(1:Ndof)
+ d1B(1:Ndof, iteta, jzeta) = d1B(1:Ndof, iteta, jzeta) + dBn(1:Ndof)
+ case (1) ! normalized over |B|;
+ t1B(1:Ndof) = t1B(1:Ndof) + ( surf(isurf)%Bn(iteta,jzeta) * dBn(1:Ndof) &
+ & / bm(iteta, jzeta) &
+ & - surf(isurf)%Bn(iteta,jzeta) * surf(isurf)%Bn(iteta,jzeta) &
+ & / (bm(iteta, jzeta)*bm(iteta, jzeta)) &
+ & * dBm(1:Ndof) ) * surf(isurf)%ds(iteta,jzeta)
+ d1B(1:Ndof, iteta, jzeta) = d1B(1:Ndof, iteta, jzeta) + dBn(1:Ndof) &
+ & / sqrt(bm(iteta, jzeta)) &
+ & - surf(isurf)%Bn(iteta,jzeta) * dBm(1:Ndof) &
+ & / (bm(iteta, jzeta) * sqrt(bm(iteta, jzeta)))
+ case default
+ FATAL( bnorm, .true., case_bnormal can only be 0/1 )
+ end select
+ enddo !end iteta;
+ enddo !end jzeta;
+ ! gather data
+ call MPI_BARRIER( MPI_COMM_WORLD, ierr )
+ call MPI_ALLREDUCE( MPI_IN_PLACE, t1B, Ndof , MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr )
+ call MPI_ALLREDUCE( MPI_IN_PLACE, d1B, Ndof*NumGrid, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr )
+ t1B = t1B * discretefactor
+ ! LM discrete derivatives
+ if (mbnorm > 0) then
+ do idof = 1, Ndof
+ LM_fjac(ibnorm+1:ibnorm+mbnorm, idof) = weight_bnorm &
+ & * reshape(d1B(idof, 0:Nteta-1, 0:Nzeta-1), (/Nteta*Nzeta/))
+ enddo
+ endif
+ ! derivatives for Bn harmonics
+ if (weight_bharm > sqrtmachprec) then
+ dBc = zero ; dBs = zero
+ do idof = 1, Ndof
+ call twodft( d1B(idof, 0:Nteta-1, 0:Nzeta-1), dBs, dBc, Bmnim, Bmnin, NBmn )
+ t1H(idof) = sum( wBmn * ( (Bmnc - tBmnc)*dBc + (Bmns - tBmns)*dBs ) )
+ if (mbharm > 0) then
+ LM_fjac(ibharm+1 :ibharm+mbharm/2, idof) = weight_bharm * wBmn * dBc
+ LM_fjac(ibharm+mbharm/2+1:ibharm+mbharm , idof) = weight_bharm * wBmn * dBs
+ endif
+ enddo
+ endif
+ endif
+ !--------------------------------------------------------------------------------------------
+ call MPI_barrier( MPI_COMM_WORLD, ierr )
+ return
+end subroutine bnormal
diff --git a/sources/bnormal.h b/sources/bnormal.h
deleted file mode 100644
index d9c22a3..0000000
--- a/sources/bnormal.h
+++ /dev/null
@@ -1,249 +0,0 @@
-
-!title (bnormal) ! Calculate total bnormal and its derivatives.
-
-!latex \briefly{Calculate the total bnormal of all coils on plasma surface and the derivatives with respect to coil geometry and currents, including the first and second dirivatives.
-!latex Calling \emph{bnormal(0), bnormal(1), bnormal(2)} calculates the $0-order$, $1^{st}-order$ and $2^{nd}-order$ derivatives respectively.}
-
-!latex \calledby{\link{costfun}}
-!latex \calls{\link{bfield}}
-
-!latex \tableofcontents
-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-subroutine bnormal( ideriv )
-!------------------------------------------------------------------------------------------------------
-! DATE: 04/02/2017;
-! Calculate the Bn surface integral and its derivatives;
-! ideriv = 0 -> only calculate the Bn surface integral;
-! ideriv = 1 -> calculate the Bn surface integral and its first derivatives;
-! ideriv = 2 -> calculate the Bn surface integral and its first & second derivatives;
-!------------------------------------------------------------------------------------------------------
- use globals, only: dp, zero, half, one, pi2, sqrtmachprec, bsconstant, ncpu, myid, ounit, &
- coil, DoF, surf, Ncoils, Nteta, Nzeta, discretefactor, &
- bnorm, t1B, t2B, bn, Ndof, Npc, Cdof, weight_bharm, case_bnormal, &
- weight_bnorm, ibnorm, mbnorm, ibharm, mbharm, LM_fvec, LM_fjac, &
- bharm, t1H, Bmnc, Bmns, wBmn, tBmnc, tBmns, Bmnim, Bmnin, NBmn
-
- implicit none
- include "mpif.h"
-
- INTEGER, INTENT(in) :: ideriv
- !--------------------------------------------------------------------------------------------
- INTEGER :: astat, ierr
- INTEGER :: icoil, iteta, jzeta, idof, ND, NumGrid, ip
- REAL :: lbnorm ! local bnorm
- REAL, dimension(0:Nteta-1, 0:Nzeta-1) :: lbx, lby, lbz, lbn, lbm, Bm ! local Bx, By and Bz
- REAL, dimension(0:Cdof, 0:Cdof) :: dBx, dBy, dBz ! dB of each coil;
- REAL, dimension(1:Ndof) :: l1B, dBn, dBm
- REAL, allocatable :: ldB(:,:,:), dB(:,:,:)
- REAL, allocatable :: dBc(:), dBs(:)
-
- !--------------------------initialize and allocate arrays-------------------------------------
-
- NumGrid = Nteta*Nzeta
- lbnorm = zero; bnorm = zero ; lbm = zero
- lbx = zero; lby = zero; lbz = zero; lbn = zero !already allocted; reset to zero;
- dBx = zero; dBy = zero; dBz = zero
-
- bn = zero
- surf(1)%bn = zero; surf(1)%Bx = zero; surf(1)%By = zero; surf(1)%Bz = zero
-
- !-------------------------------calculate Bn--------------------------------------------------
- if( ideriv >= 0 ) then
-
-
- do jzeta = 0, Nzeta - 1
- do iteta = 0, Nteta - 1
- if( myid.ne.modulo(jzeta*Nteta+iteta,ncpu) ) cycle ! parallelization loop;
-
- do icoil = 1, Ncoils*Npc
- call bfield0(icoil, iteta, jzeta, dBx(0,0), dBy(0,0), dBz(0,0))
- lbx(iteta, jzeta) = lbx(iteta, jzeta) + dBx( 0, 0) * coil(icoil)%I!* bsconstant
- lby(iteta, jzeta) = lby(iteta, jzeta) + dBy( 0, 0) * coil(icoil)%I!* bsconstant
- lbz(iteta, jzeta) = lbz(iteta, jzeta) + dBz( 0, 0) * coil(icoil)%I!* bsconstant
- enddo ! end do icoil
-
- lbn(iteta, jzeta) = lbx(iteta, jzeta)*surf(1)%nx(iteta, jzeta) &
- & + lby(iteta, jzeta)*surf(1)%ny(iteta, jzeta) &
- & + lbz(iteta, jzeta)*surf(1)%nz(iteta, jzeta) &
- & - surf(1)%pb(iteta, jzeta)/bsconstant
-
- select case (case_bnormal)
- case (0) ! no normalization over |B|;
- lbnorm = lbnorm + lbn(iteta, jzeta) * lbn(iteta, jzeta) * surf(1)%ds(iteta, jzeta)
- case (1) ! normalized over |B|;
- lbm(iteta, jzeta) = lbx(iteta, jzeta)*lbx(iteta, jzeta) + lby(iteta, jzeta)*lby(iteta, jzeta) &
- & + lbz(iteta, jzeta)*lbz(iteta, jzeta)
- lbnorm = lbnorm + lbn(iteta, jzeta) * lbn(iteta, jzeta) &
- & / lbm(iteta, jzeta) * surf(1)%ds(iteta, jzeta)
- case default
- FATAL( bnorm, .true., case_bnormal can only be 0/1 )
- end select
-
- enddo ! end do iteta
- enddo ! end do jzeta
-
- call MPI_BARRIER( MPI_COMM_WORLD, ierr )
- call MPI_ALLREDUCE( lbx, surf(1)%Bx, NumGrid, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr )
- call MPI_ALLREDUCE( lby, surf(1)%By, NumGrid, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr )
- call MPI_ALLREDUCE( lbz, surf(1)%Bz, NumGrid, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr )
- call MPI_ALLREDUCE( lbn, surf(1)%Bn, NumGrid, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr )
- call MPI_ALLREDUCE( lbnorm, bnorm , 1 , MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr )
-
- surf(1)%Bx = surf(1)%Bx * bsconstant
- surf(1)%By = surf(1)%By * bsconstant
- surf(1)%Bz = surf(1)%Bz * bsconstant
- surf(1)%Bn = surf(1)%Bn * bsconstant
-
- bnorm = bnorm * half * discretefactor
- bn = surf(1)%Bn + surf(1)%pb ! bn is B.n from coils
- ! bn = surf(1)%Bx * surf(1)%nx + surf(1)%By * surf(1)%ny + surf(1)%Bz * surf(1)%nz
- if (case_bnormal == 0) bnorm = bnorm * bsconstant * bsconstant ! take bsconst back
-
- if (case_bnormal == 1) then ! collect |B|
- call MPI_ALLREDUCE( lbm, bm, NumGrid, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr )
- bm = bm * bsconstant * bsconstant
- endif
-
- ! Another type of target functions
- if (mbnorm > 0) then
- select case (case_bnormal)
- case (0) ! no normalization over |B|;
- LM_fvec(ibnorm+1:ibnorm+mbnorm) = weight_bnorm &
- & * reshape(surf(1)%bn(0:Nteta-1, 0:Nzeta-1) , (/Nteta*Nzeta/))
- case (1) ! normalized over |B|;
- LM_fvec(ibnorm+1:ibnorm+mbnorm) = weight_bnorm &
- & * reshape(surf(1)%bn(0:Nteta-1, 0:Nzeta-1)/sqrt(bm(0:Nteta-1, 0:Nzeta-1)), (/Nteta*Nzeta/))
- case default
- FATAL( bnorm, .true., case_bnormal can only be 0/1 )
- end select
-
- endif
-
- ! Bn harmonics related
- if (weight_bharm > sqrtmachprec) then
- call twodft( bn, Bmns, Bmnc, Bmnim, Bmnin, NBmn ) ! Bn from coils
- bharm = half * sum( wBmn * ((Bmnc - tBmnc)**2 + (Bmns - tBmns)**2) )
-
- if (mbharm > 0) then
- LM_fvec(ibharm+1:ibharm+mbharm/2) = weight_bharm * wBmn * (Bmnc - tBmnc)
- LM_fvec(ibharm+mbharm/2+1:ibharm+mbharm) = weight_bharm * wBmn * (Bmns - tBmns)
- endif
-
- endif
- endif
-
- !-------------------------------calculate Bn/x------------------------------------------------
- if ( ideriv >= 1 ) then
-
- t1B = zero ; l1B = zero
- SALLOCATE( ldB, (1:Ndof, 0:Nteta-1, 0:Nzeta-1), zero)
- SALLOCATE( dB, (1:Ndof, 0:Nteta-1, 0:Nzeta-1), zero)
-
- do jzeta = 0, Nzeta - 1
- do iteta = 0, Nteta - 1
-
- if( myid.ne.modulo(jzeta*Nteta+iteta,ncpu) ) cycle ! parallelization loop;
-
- do ip = 1, Npc
-
- idof = 0
- do icoil = 1, Ncoils
- ND = DoF(icoil)%ND
- if ( coil(icoil)%Ic /= 0 ) then !if current is free;
- call bfield0(icoil+(ip-1)*Ncoils, iteta, jzeta, dBx(0,0), dBy(0,0), dBz(0,0))
- dBn(idof+1) = bsconstant * ( dBx(0,0)*surf(1)%nx(iteta,jzeta) &
- & + dBy(0,0)*surf(1)%ny(iteta,jzeta) &
- & + dBz(0,0)*surf(1)%nz(iteta,jzeta) )
- if (case_bnormal == 1) then ! normalized over |B|;
- dBm(idof+1) = bsconstant * ( dBx(0,0)*surf(1)%Bx(iteta,jzeta) &
- & + dBy(0,0)*surf(1)%By(iteta,jzeta) &
- & + dBz(0,0)*surf(1)%Bz(iteta,jzeta) )
- endif
-
- idof = idof +1
- endif
-
- if ( coil(icoil)%Lc /= 0 ) then !if geometry is free;
- call bfield1(icoil+(ip-1)*Ncoils, iteta, jzeta, dBx(1:ND,0), dBy(1:ND,0), dBz(1:ND,0), ND)
- dBn(idof+1:idof+ND) = bsconstant * coil(icoil)%I &
- & * ( dBx(1:ND,0)*surf(1)%nx(iteta,jzeta) &
- & + dBy(1:ND,0)*surf(1)%ny(iteta,jzeta) &
- & + dBz(1:ND,0)*surf(1)%nz(iteta,jzeta) )
- if (case_bnormal == 1) then ! normalized over |B|;
- dBm(idof+1:idof+ND) = bsconstant * coil(icoil)%I &
- & * ( dBx(1:ND,0)*surf(1)%Bx(iteta,jzeta) &
- & + dBy(1:ND,0)*surf(1)%By(iteta,jzeta) &
- & + dBz(1:ND,0)*surf(1)%Bz(iteta,jzeta) )
- endif
-
- idof = idof + ND
-
- endif
-
- enddo !end icoil;
- FATAL( bnormal , idof .ne. Ndof, counting error in packing )
-
- select case (case_bnormal)
- case (0) ! no normalization over |B|;
- l1B(1:Ndof) = l1B(1:Ndof) + surf(1)%bn(iteta,jzeta) * surf(1)%ds(iteta,jzeta) * dBn(1:Ndof)
- ldB(1:Ndof, iteta, jzeta) = ldB(1:Ndof, iteta, jzeta) + dBn(1:Ndof)
- case (1) ! normalized over |B|;
- l1B(1:Ndof) = l1B(1:Ndof) + ( surf(1)%Bn(iteta,jzeta) * dBn(1:Ndof) &
- & / bm(iteta, jzeta) &
- & - surf(1)%Bn(iteta,jzeta) * surf(1)%Bn(iteta,jzeta) &
- & / (bm(iteta, jzeta)*bm(iteta, jzeta)) &
- & * dBm(1:Ndof) ) * surf(1)%ds(iteta,jzeta)
- ldB(1:Ndof, iteta, jzeta) = ldB(1:Ndof, iteta, jzeta) + dBn(1:Ndof) &
- & / sqrt(bm(iteta, jzeta)) &
- & - surf(1)%Bn(iteta,jzeta) * dBm(1:Ndof) &
- & / (bm(iteta, jzeta) * sqrt(bm(iteta, jzeta)))
- case default
- FATAL( bnorm, .true., case_bnormal can only be 0/1 )
- end select
-
- enddo !end ip;
-
- enddo !end iteta;
- enddo !end jzeta;
-
- call MPI_BARRIER( MPI_COMM_WORLD, ierr )
- call MPI_ALLREDUCE(l1B, t1B, Ndof, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr )
- call MPI_ALLREDUCE(ldB, dB, Ndof*NumGrid, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr )
-
- t1B = t1B * discretefactor
-
- ! Another type of target functions
- if (mbnorm > 0) then
- do idof = 1, Ndof
- LM_fjac(ibnorm+1:ibnorm+mbnorm, idof) = weight_bnorm &
- & * reshape(dB(idof, 0:Nteta-1, 0:Nzeta-1), (/Nteta*Nzeta/))
- enddo
- endif
-
- if (weight_bharm > sqrtmachprec) then
- SALLOCATE( dBc, (1:NBmn), zero ) ! temporary dB_mn_cos
- SALLOCATE( dBs, (1:NBmn), zero ) ! temporary dB_mn_sin
- do idof = 1, Ndof
- call twodft( dB(idof, 0:Nteta-1, 0:Nzeta-1), dBs, dBc, Bmnim, Bmnin, NBmn )
- t1H(idof) = sum( wBmn * ( (Bmnc - tBmnc)*dBc + (Bmns - tBmns)*dBs ) )
- if (mbharm > 0) then
- LM_fjac(ibharm+1 :ibharm+mbharm/2, idof) = weight_bharm * wBmn * dBc
- LM_fjac(ibharm+mbharm/2+1:ibharm+mbharm , idof) = weight_bharm * wBmn * dBs
- endif
-
- enddo
- DALLOCATE( dBc )
- DALLOCATE( dBs )
- endif
-
- DALLOCATE( ldB )
- DALLOCATE( dB )
-
- endif
-
- !--------------------------------------------------------------------------------------------
-
- call MPI_barrier( MPI_COMM_WORLD, ierr )
-
- return
-end subroutine bnormal
diff --git a/sources/boozer.f90 b/sources/boozer.f90
new file mode 100644
index 0000000..4b8fc8d
--- /dev/null
+++ b/sources/boozer.f90
@@ -0,0 +1,402 @@
+subroutine boozmn
+ USE globals, only : dp, myid, ncpu, zero, ounit, total_num, pp_maxiter, pp_ns, &
+ XYZB, lboozmn, bmin, bmim, booz_mnc, booz_mns, booz_mpol, booz_ntor, booz_mn
+ USE mpi
+ IMPLICIT NONE
+
+ ! allocate data for following calculations
+
+ !-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+ INTEGER :: ierr, astat, iflag
+ INTEGER :: tor_num, in, im, imn
+ !-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+ call MPI_BARRIER( MPI_COMM_WORLD, ierr ) ! wait all cpus;
+
+ FATAL( boozmn_01, booz_mpol < 0, invalid poloidal mode resolution )
+ FATAL( boozmn_02, booz_ntor < 0, invalid toroidal mode resolution )
+
+ lboozmn = .true. ! turn on boozmn
+ tor_num = 360 ! toroidal planes number
+ total_num = pp_maxiter * tor_num ! total data points per line
+
+ booz_mpol = 16 ; booz_ntor = 32
+ booz_mn = booz_mpol*(2*booz_ntor+1) + (booz_ntor+1) ! (1:M, -N:N) + (0, 0:N)
+ SALLOCATE( bmin, (1:booz_mn), 0)
+ SALLOCATE( bmim, (1:booz_mn), 0)
+ SALLOCATE( booz_mnc, (1:booz_mn, 1:pp_ns), zero)
+ SALLOCATE( booz_mns, (1:booz_mn, 1:pp_ns), zero)
+ SALLOCATE( XYZB, (1:total_num, 1:4, 1:pp_ns), zero)
+
+ ! prepare bmin & bmim
+ imn = 0
+ do im = 0, booz_mpol
+ do in = -booz_ntor, booz_ntor
+ if ( im==0 .and. in<0 ) cycle
+ imn = imn + 1
+ bmim(imn) = im
+ bmin(imn) = in !*Nfp_raw
+ enddo
+ enddo
+
+ FATAL( boozmn_03, imn .ne. booz_mn, packing error )
+
+end subroutine boozmn
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+subroutine boozsurf(XYZB, x, y, z, iota, isurf)
+ USE globals, only : dp, myid, ncpu, zero, half, two, pi, pi2, ounit, total_num, pp_maxiter, &
+ bmin, bmim, booz_mnc, booz_mns, booz_mn, machprec, &
+ masterid, myworkid
+ USE mpi
+ IMPLICIT NONE
+
+ !-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+ REAL, dimension(total_num, 4) :: XYZB ! XYZB on one surface
+ REAL , intent( in) :: x, y, z ! starting point
+ REAL , intent( in) :: iota ! calculated iota
+ INTEGER, intent( in) :: isurf ! fieldline ordering
+
+ INTEGER :: ierr, astat, iflag
+ INTEGER :: i, imn, tor_num, pol_num, iteta, jzeta
+ REAL,dimension(total_num) :: chi, zeta, teta
+ REAL :: Gpol, ang, dteta, dzeta
+ INTEGER, allocatable :: weight(:,:)
+ REAL, allocatable :: Btz(:,:)
+
+ !-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+ ! write(ounit, '("poincare: starting filed line tracing at x="F5.2, ", y="F5.2, ", z="F5.2)') x, y, z
+
+ ! filedline tracing
+ call fieldline_tracing(x, y, z, total_num, pp_maxiter, XYZB(1:total_num, 1:4))
+
+ ! calculate chi = \int B dl
+ chi = zero
+ do i = 2, total_num
+ chi(i) = chi(i-1) + (XYZB(i, 4) + XYZB(i-1, 4))*half &
+ * sqrt( (XYZB(i, 1) - XYZB(i-1, 1))**2 &
+ + (XYZB(i, 2) - XYZB(i-1, 2))**2 &
+ + (XYZB(i, 3) - XYZB(i-1, 3))**2 )
+ enddo
+
+ ! calculate poloidal current Gpol = \int \vetc{B} \cdot d \zeta
+ ! Gpol = 2.0E-7 * total_current
+ Gpol = chi(total_num) / (pi2*pp_maxiter)
+ FATAL(booz_04 , abs(Gpol) < machprec, zero external poloidal currents)
+
+!!$ ! Fourier decomposition
+!!$ do imn = 1, booz_mn
+!!$
+!!$ do i = 1, total_num
+!!$ ang = (bmin(imn) - bmim(imn)*abs(iota))/Gpol * chi(i)
+!!$ booz_mnc(imn, isurf) = booz_mnc(imn, isurf) + XYZB(i, 4) * cos(ang)
+!!$ booz_mns(imn, isurf) = booz_mns(imn, isurf) + XYZB(i, 4) * sin(ang)
+!!$ enddo
+!!$
+!!$ if ( bmim(imn) == 0 .and. bmin(imn) == 0 ) then
+!!$ booz_mnc(imn, isurf) = booz_mnc(imn, isurf) * half
+!!$ booz_mns(imn, isurf) = booz_mns(imn, isurf) * half
+!!$ endif
+!!$ enddo
+!!$
+!!$ booz_mnc(1:booz_mn, isurf) = booz_mnc(1:booz_mn, isurf) * two / total_num
+!!$ booz_mns(1:booz_mn, isurf) = booz_mns(1:booz_mn, isurf) * two / total_num
+
+
+ ! Boozer angles
+ zeta = mod(chi/Gpol , pi2)
+ teta = mod(chi/Gpol*abs(iota), pi2)
+
+ ! map back to two dimensional grid
+ ! tor_num = total_num/pp_maxiter
+ ! pol_num = pp_maxiter
+ tor_num = 256
+ pol_num = 128
+ SALLOCATE( Btz , (0:pol_num, 0:tor_num), zero )
+ SALLOCATE( weight, (0:pol_num, 0:tor_num), 0 )
+ dzeta = pi2/tor_num
+ dteta = pi2/pol_num
+ do i = 1, total_num
+ iteta = int(teta(i)/dteta)
+ jzeta = int(zeta(i)/dzeta)
+ Btz(iteta, jzeta) = Btz(iteta, jzeta) + XYZB(i, 4)
+ weight(iteta, jzeta) = weight(iteta, jzeta) + 1
+ enddo
+
+ ! Fourier decomposition
+ do jzeta = 0, tor_num-1
+ do iteta = 0, pol_num-1
+ ! weight(iteta, jzeta) = max(weight(iteta, jzeta), 1) ! avoida dividing zero
+ if ( weight(iteta,jzeta) /= 0) Btz(iteta,jzeta) = Btz(iteta,jzeta) / weight(iteta,jzeta)
+ do imn = 1, booz_mn
+ ang = bmim(imn) * iteta*dteta - bmin(imn) * jzeta*dzeta
+ booz_mnc(imn, isurf) = booz_mnc(imn, isurf) + Btz(iteta,jzeta) * cos(ang)
+ booz_mns(imn, isurf) = booz_mns(imn, isurf) + Btz(iteta,jzeta) * sin(ang)
+ enddo
+ enddo
+ enddo
+
+ booz_mnc(1:booz_mn, isurf) = booz_mnc(1:booz_mn, isurf) * two / (tor_num*pol_num)
+ booz_mns(1:booz_mn, isurf) = booz_mns(1:booz_mn, isurf) * two / (tor_num*pol_num)
+
+ imn = 1
+ FATAL( boozer_05, bmim(imn) /= 0 .or. bmin(imn) /= 0, wrong mn initialization )
+ booz_mnc(imn, isurf) = booz_mnc(imn, isurf) * half
+ booz_mns(imn, isurf) = booz_mns(imn, isurf) * half
+
+ DALLOCATE( Btz )
+ DALLOCATE( weight )
+!!$
+!!$ ! Fourier decomposition
+!!$ do imn = 1, booz_mn
+!!$
+!!$ booz_mnc(imn, isurf) = zero ; booz_mns(imn, isurf) = zero
+!!$
+!!$ do i = 1, total_num
+!!$ ang = bmim(imn) * teta(i) - bmin(imn) * zeta(i)
+!!$ booz_mnc(imn, isurf) = booz_mnc(imn, isurf) + XYZB(i, 4) * cos(ang)
+!!$ booz_mns(imn, isurf) = booz_mns(imn, isurf) + XYZB(i, 4) * sin(ang)
+!!$ enddo
+!!$
+!!$ if ( bmim(imn) == 0 .and. bmin(imn) == 0 ) then
+!!$ booz_mnc(imn, isurf) = booz_mnc(imn, isurf) * half
+!!$ booz_mns(imn, isurf) = booz_mns(imn, isurf) * half
+!!$ endif
+!!$ enddo
+!!$
+!!$ booz_mnc(1:booz_mn, isurf) = booz_mnc(1:booz_mn, isurf) * two / total_num
+!!$ booz_mns(1:booz_mn, isurf) = booz_mns(1:booz_mn, isurf) * two / total_num
+
+ ! finish decomposition
+
+ if (myworkid == 0) write(ounit, '("boozmn : order="I6" ; Gpol="ES12.5" ; iota="ES12.5 &
+ " ; Booz_mnc(1)="ES12.5" ; Booz_mns(1)="ES12.5)') isurf, Gpol, iota, &
+ booz_mnc(1, isurf), booz_mns(1, isurf)
+
+ return
+end subroutine boozsurf
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+SUBROUTINE Bmn_clt(phi_B,theta_B,B0,Bf)
+implicit none
+
+real*8,dimension(300000,1):: B0,phi_B,theta_B
+real*8,dimension(30,30)::Bf
+real*8,dimension(60,60)::Bmn
+real*8,dimension(30,60)::theta,phi,ang,Bf1
+real*8,dimension(61,61)::B1,n_B,B2
+real*8,dimension(30,1)::phi1
+real*8,dimension(1,60)::theta1
+integer*4 m,n,i,j,k,l
+real*8 pi,s1,s2,s3,s4,B_mn,B_c,B_s, dteta, dzeta
+
+pi=3.141592653589793239
+m=60
+n=60
+dzeta = 2*pi/n
+dteta = 2*pi/m
+
+do k=2,300000
+ j=floor(theta_B(k,1)/(dzeta))
+ i=floor(phi_B(k,1)/(dteta))
+
+
+ s1=sqrt((theta_B(k,1)-dzeta* j )**2+(phi_B(k,1)-dteta* i )**2)
+ s2=sqrt((theta_B(k,1)-dzeta* j )**2+(phi_B(k,1)-dteta*(i+1))**2)
+ s3=sqrt((theta_B(k,1)-dzeta*(j+1))**2+(phi_B(k,1)-dteta*(i+1))**2)
+ s4=sqrt((theta_B(k,1)-dzeta*(j+1))**2+(phi_B(k,1)-dteta* i )**2)
+ i=i+1
+ j=j+1
+
+ B1(i,j)=B1(i,j)+B0(k,1)/s1
+ n_B(i,j)=n_B(i,j)+1/s1
+ B1(i+1,j)=B1(i+1,j)+B0(k,1)/s2
+ n_B(i+1,j)=n_B(i+1,j)+1/s2
+ B1(i+1,j+1)=B1(i+1,j+1)+B0(k,1)/s3
+ n_B(i+1,j+1)=n_B(i+1,j+1)+1/s3
+ B1(i,j+1)=B1(i,j+1)+B0(k,1)/s4
+ n_B(i,j+1)=n_B(i,j+1)+1/s4
+enddo
+B1(1:m,1)=B1(1:m,1)+B1(1:m,n+1)
+n_B(1:m,1)=n_B(1:m,1)+n_B(1:m,n+1)
+B1(1,1:n)=B1(1,1:n)+B1(m+1,1:n)
+n_B(1,1:n)=n_B(1,1:n)+n_B(m+1,1:n)
+do i=1,m+1
+do j=1,n+1
+ B2(i,j)=B1(i,j)/n_B(i,j)
+enddo
+enddo
+
+Bmn=B2(1:m,1:n)
+
+
+do i=1,m/2
+phi1(i,1)=dteta*2*(i-1)
+enddo
+
+do i=1,n
+theta1(1,i)=dzeta*(i-1)
+enddo
+
+do i=1,n
+phi(:,i)=phi1(:,1)
+enddo
+
+do i=1,m/2
+theta(i,:)=theta1(1,:)
+enddo
+
+
+do i=0,m/2-1
+ do j=0,n-1
+ ang=-i*Phi+j*Theta
+ B_mn=0
+ B_c=0
+ B_s=0
+ do k=1,m/2
+ do l=1,n
+ B_c=B_c+Bmn(k,l)*cos(ang(k,l))
+ B_s=B_s+Bmn(k,l)*sin(ang(k,l))
+ B_mn=sqrt(B_c**2+B_s**2)/float(n*m/2)
+ enddo
+ enddo
+ Bf1(i+1,j+1)=B_mn
+ ! write(*,*)B_mn
+ enddo
+enddo
+
+Bf=Bf1(:,1:n/2)*2.0
+Bf(1,1)=Bf1(1,1)
+return
+end SUBROUTINE Bmn_clt
+
+subroutine fieldline_tracing(x,y,z,imax,n2,H)
+ implicit none
+ integer*4 ::n2,imax,j,i
+ real*8 :: x,y,z,dphi,pi,dt,B,Bx,By,Bz,x0,y0,z0,g,iota
+ real*8 :: s(4), k1x,k2x,k3x,k4x,k5x,k6x,k7x,k8x,k9x,k10x
+ real*8 :: k1y,k2y,k3y,k4y,k5y,k6y,k7y,k8y,k9y,k10y,xr
+ real*8 :: k1z,k2z,k3z,k4z,k5z,k6z,k7z,k8z,k9z,k10z
+ real*8,dimension(imax,4):: H
+
+ real*8,dimension(imax+1,4):: f
+ real*8,dimension(2*n2,3):: f2
+
+ pi=3.141592653589793239
+ dphi=2*pi/(float(imax)/n2)
+
+ do j=1,imax
+ H(j,1)=x ; H(j,2)=y ; H(j,3)=z
+ call get_bfield(s,x,y,z)
+ Bx=s(1) ; By=s(2) ; Bz=s(3) ; B=s(4)
+ H(j,4)=B
+ dt=(y-x*tan(j*dphi))/(tan(j*dphi)*Bx/sqrt(Bx**2+By**2)-By/sqrt(Bx**2+By**2))*sqrt(B**2/(Bx**2+By**2))
+
+ f(j,1)=Bx/B
+ f(j,2)=By/B
+ f(j,3)=Bz/B
+ x0=x ; y0=y ; z0=z
+
+ if(j<8)then
+ k1x=Bx/B ; k1y=By/B ; k1z=Bz/B
+
+ call get_bfield(s,x+dt*4/27*k1x,y+dt*4/27*k1y,z+dt*4/27*k1z)
+ Bx=s(1) ; By=s(2) ; Bz=s(3) ; B=s(4)
+ k2x=Bx/B ; k2y=By/B ; k2z=Bz/B
+
+ call get_bfield(s,x+dt/18*(k1x+3*k2x),y+dt/18*(k1y+3*k2y),z+dt/18*(k1z+3*k2z))
+ Bx=s(1) ; By=s(2) ; Bz=s(3) ; B=s(4)
+ k3x=Bx/B ; k3y=By/B ; k3z=Bz/B
+
+ call get_bfield(s,x+dt/12*(k1x+3*k3x),y+dt/12*(k1y+3*k3y),z+dt/12*(k1z+3*k3z))
+ Bx=s(1) ; By=s(2) ; Bz=s(3) ; B=s(4)
+ k4x=Bx/B ; k4y=By/B ; k4z=Bz/B
+
+ call get_bfield(s,x+dt/8*(k1x+3*k4x),y+dt/8*(k1y+3*k4y),z+dt/8*(k1z+3*k4z))
+ Bx=s(1) ; By=s(2) ; Bz=s(3) ; B=s(4)
+ k5x=Bx/B ; k5y=By/B ; k5z=Bz/B
+
+ call get_bfield(s,x+dt/54*(13*k1x-27*k3x+42*k4x+8*k5x),y+dt/54*(13*k1y-27*k3y+&
+ 42*k4y+8*k5y),z+dt/54*(13*k1z-27*k3z+42*k4z+8*k5z))
+ Bx=s(1) ; By=s(2) ; Bz=s(3) ; B=s(4)
+ k6x=Bx/B ; k6y=By/B ; k6z=Bz/B
+
+ call get_bfield(s,x+dt/4320*(389*k1x-54*k3x+966*k4x-824*k5x+243*k6x),y+dt/4320*(389*k1y-&
+ 54*k3y+966*k4y-824*k5y+243*k6y),z+dt/4320*(389*k1z-54*k3z+966*k4z-824*k5z+243*k6z))
+ Bx=s(1) ; By=s(2) ; Bz=s(3) ; B=s(4)
+ k7x=Bx/B ; k7y=By/B ; k7z=Bz/B
+
+ call get_bfield(s,x+dt/20*(-234*k1x+81*k3x-1164*k4x+656*k5x-122*k6x+800*k7x),y+dt/20*(-234*k1y+81*k3y-&
+ 1164*k4y+656*k5y-122*k6y+800*k7y),z+dt/20*(-234*k1z+81*k3z-1164*k4z+656*k5z-122*k6z+800*k7z))
+ Bx=s(1) ; By=s(2) ; Bz=s(3) ; B=s(4)
+ k8x=Bx/B ; k8y=By/B ; k8z=Bz/B
+
+ call get_bfield(s,x+dt/288*(-127*k1x+18*k3x-678*k4x+456*k5x-9*k6x+576*k7x+4*k8x),y+&
+ dt/288*(-127*k1y+18*k3y-678*k4y+456*k5y-9*k6y+576*k7y+4*k8y),z+dt/288*(-127*k1z+&
+ 18*k3z-678*k4z+456*k5z-9*k6z+576*k7z+4*k8z))
+ Bx=s(1) ; By=s(2) ; Bz=s(3) ; B=s(4)
+ k9x=Bx/B ; k9y=By/B ; k9z=Bz/B
+
+ call get_bfield(s,x+dt/820*(1481*k1x-81*k3x+7104*k4x-3376*k5x+&
+ 72*k6x-5040*k7x-60*k8x+720*k9x),y+dt/820*(1481*k1y-81*k3y+&
+ 7104*k4y-3376*k5y+72*k6y-5040*k7y-60*k8y+720*k9y),z+dt/820*(1481*k1z-&
+ 81*k3z+7104*k4z-3376*k5z+72*k6z-5040*k7z-60*k8z+720*k9z))
+ Bx=s(1) ; By=s(2) ; Bz=s(3) ; B=s(4)
+ k10x=Bx/B ; k10y=By/B ; k10z=Bz/B
+
+ x=x+dt/840*(41*k1x+27*k4x+272*k5x+27*k6x+216*k7x+216*k9x+41*k10x)
+ y=y+dt/840*(41*k1y+27*k4y+272*k5y+27*k6y+216*k7y+216*k9y+41*k10y)
+ z=z+dt/840*(41*k1z+27*k4z+272*k5z+27*k6z+216*k7z+216*k9z+41*k10z)
+
+ else
+ x=x+dt/120960*(-36799.0*f(j-7,1)+295767.0*f(j-6,1)-1041723.0*f(j-5,1)&
+ +2102243.0*f(j-4,1)-2664477.0*f(j-3,1)+2183877.0*f(j-2,1)-1152169.0*f(j-1,1)+434241.0*f(j,1))
+ y=y+dt/120960*(-36799.0*f(j-7,2)+295767.0*f(j-6,2)-1041723.0*f(j-5,2)&
+ +2102243.0*f(j-4,2)-2664477.0*f(j-3,2)+2183877.0*f(j-2,2)-1152169.0*f(j-1,2)+434241.0*f(j,2))
+ z=z+dt/120960*(-36799.0*f(j-7,3)+295767.0*f(j-6,3)-1041723.0*f(j-5,3)&
+ +2102243.0*f(j-4,3)-2664477.0*f(j-3,3)+2183877.0*f(j-2,3)-1152169.0*f(j-1,3)+434241.0*f(j,3))
+ end if
+
+ call get_bfield(s,x,y,z)
+ Bx=s(1) ; By=s(2) ; Bz=s(3) ; B=s(4)
+ f(j+1,1)=Bx/B
+ f(j+1,2)=By/B
+ f(j+1,3)=Bz/B
+
+ if (j>7) then
+ x=x0+dt/120960*(1375.0*f(j-6,1)-11351.0*f(j-5,1)+41499.0*f(j-4,1)-88547.0*f(j-3,1)&
+ +123133.0*f(j-2,1)-121797.0*f(j-1,1)+139849.0*f(j,1)+36799.0*f(j+1,1))
+ y=y0+dt/120960*(1375.0*f(j-6,2)-11351.0*f(j-5,2)+41499.0*f(j-4,2)-88547.0*f(j-3,2)&
+ +123133.0*f(j-2,2)-121797.0*f(j-1,2)+139849.0*f(j,2)+36799.0*f(j+1,2))
+ z=z0+dt/120960*(1375.0*f(j-6,3)-11351.0*f(j-5,3)+41499.0*f(j-4,3)-88547.0*f(j-3,3)&
+ +123133.0*f(j-2,3)-121797.0*f(j-1,3)+139849.0*f(j,3)+36799.0*f(j+1,3))
+ end if
+
+ end do
+ return
+
+end subroutine fieldline_tracing
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+SUBROUTINE get_bfield(B,x,y,z)
+ use globals, only: dp
+ use mpi
+ implicit none
+
+ REAL , intent( in) :: x, y, z
+ REAL , intent(out) :: B(4)
+
+ call coils_bfield(B(1:3), x, y, z)
+ B(4) = sqrt( B(1)*B(1) + B(2)*B(2) + B(3)*B(3) )
+
+ return
+END SUBROUTINE get_bfield
diff --git a/sources/cg_descent.f b/sources/cg_descent.f
new file mode 100644
index 0000000..98c2521
--- /dev/null
+++ b/sources/cg_descent.f
@@ -0,0 +1,1607 @@
+c ________________________________________________________________
+c | A conjugate gradient method with guaranteed descent |
+c | |
+c | Version 1.1 (December 10, 2004) |
+c | Version 1.2 (June 4, 2005) |
+c | Version 1.3 (October 6, 2005) |
+c | Version 1.4 (November 14, 2005) |
+c | |
+c | William W. Hager and Hongchao Zhang |
+c | hager@math.ufl.edu hzhang@math.ufl.edu |
+c | Department of Mathematics |
+c | University of Florida |
+c | Gainesville, Florida 32611 USA |
+c | 352-392-0281 x 244 |
+c | |
+c | Copyright 2004 by William W. Hager |
+c | |
+c |This program is free software; you can redistribute it and/or |
+c |modify it under the terms of the GNU General Public License as |
+c |published by the Free Software Foundation; either version 2 of |
+c |the License, or (at your option) any later version. |
+c |This program is distributed in the hope that it will be useful, |
+c |but WITHOUT ANY WARRANTY; without even the implied warranty of |
+c |MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
+c |GNU General Public License for more details. |
+c | |
+c |You should have received a copy of the GNU General Public |
+c |License along with this program; if not, write to the Free |
+c |Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, |
+c |MA 02110-1301 USA |
+c | |
+c | http://www.math.ufl.edu/~hager/papers/CG |
+c | |
+c | INPUT: |
+c | |
+c |(double) grad_tol-- StopRule = T: |g|_infty <= max (grad_tol, |
+c | StopFac*initial |g|_infty) [default] |
+c | StopRule = F: |g|_infty <= grad_tol(1+|f|) |
+c | |
+c |(double) x --starting guess (length n) |
+c | |
+c |(int) dim --problem dimension (also denoted n) |
+c | |
+c | cg_value--name of cost evaluation subroutine |
+c | (external in main program, cg_value(f, x, n) |
+c | puts value of cost function at x in f |
+c | f is double precision scalar and x is |
+c | double precision array of length n) |
+c | |
+c | cg_grad --name gradient evaluation subroutine |
+c | (external in main program, cg_grad (g, x, n) |
+c | puts gradient at x in g, g and x are |
+c | double precision arrays of length n) |
+c | |
+c |(double) gnorm --if the parameter Step in cg_descent.parm is |
+c | .true., then gnorm contains the initial step |
+c | used at iteration 0 in the line search |
+c | |
+c |(double) d --direction (work array, length n) |
+c | |
+c |(double) g --gradient (work array, length n) |
+c | |
+c |(double) xtemp --work array (work array, length n) |
+c | |
+c |(double) gtemp --work array (work array, length n) |
+c | |
+c | OUTPUT: |
+c | |
+c |(int) status -- 0 (convergence tolerance satisfied) |
+c | 1 (change in func <= feps*|f|) |
+c | 2 (total iterations exceeded maxit) |
+c | 3 (slope always negative in line search) |
+c | 4 (number secant iterations exceed nsecant) |
+c | 5 (search direction not a descent direction)|
+c | 6 (line search fails in initial interval) |
+c | 7 (line search fails during bisection) |
+c | 8 (line search fails during interval update)|
+c | |
+c |(double) gnorm --max abs component of gradient |
+c | |
+c |(double) f --function value at solution |
+c | |
+c |(double) x --solution (length n) |
+c | |
+c |(int) iter --number of iterations |
+c | |
+c |(int) nfunc --number of function evaluations |
+c | |
+c |(int) ngrad --number of gradient evaluations |
+c | |
+c |Note: The file cg_descent.parm must be placed in the directory |
+c | where the code is run |
+c |________________________________________________________________|
+c
+ subroutine cg_descent (grad_tol, x, dim, cg_value, cg_grad,
+ & status, gnorm, f, iter, nfunc, ngrad,
+ & d, g, xtemp, gtemp)
+
+ use globals, only: dp, myid, ounit, IsQuiet, tstart, tfinish
+ use mpi
+
+ double precision x (*), d (*), g (*), xtemp (*), gtemp (*),
+ & delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & grad_tol, delta2, eta_sq, Qk,
+ & f, ftemp, gnorm, xnorm, gnorm2, dnorm2, denom,
+ & t, t1, t2, t3, t4, dphi, dphi0, alpha, talpha,
+ & yk, yk2, ykgk, dkyk, beta
+
+ integer n, n5, n6, nf, ng, info, nrestart,
+ & nexpand, nsecant, maxit,
+ & iter, status, nfunc, ngrad,
+ & i, j, i1, i2, i3, i4, dim
+
+ logical PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug,
+ & cg_tol
+
+ external cg_value, cg_grad
+
+ common /cgparms/delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & n, n5, n6, nf, ng, info,
+ & nrestart, nexpand, nsecant, maxit,
+ & PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug
+
+c initialize the parameters
+
+ call cg_init (grad_tol, dim)
+
+ if ( Step ) then
+ alpha = gnorm
+ endif
+ delta2 = 2*delta - 1
+ eta_sq = eta*eta
+ iter = 0
+ Ck = 0
+ Qk = 0
+
+c initial function and gradient evaluations, initial direction
+
+ call cg_value (f, x, n)
+ nf = nf + 1
+ call cg_grad (g, x, n)
+ ng = ng + 1
+ f0 = f + f
+ gnorm = zero
+ xnorm = zero
+ gnorm2 = zero
+ do i = 1, n5
+ xnorm = dmax1 (xnorm, dabs (x (i)))
+ t = g (i)
+ d (i) = -t
+ gnorm = dmax1 (gnorm, dabs(t))
+ gnorm2 = gnorm2 + t*t
+ enddo
+ do i = n6, n, 5
+ xnorm = dmax1 (xnorm, dabs (x (i)))
+ t = g (i)
+ gnorm = dmax1 (gnorm, dabs (t))
+ d (i) = -t
+ j = i + 1
+ t1 = g (j)
+ d (j) = -t1
+ gnorm = dmax1 (gnorm, dabs (t1))
+ xnorm = dmax1 (xnorm, dabs (x (j)))
+ j = i + 2
+ t2 = g (j)
+ d (j) = -t2
+ gnorm = dmax1 (gnorm, dabs (t2))
+ xnorm = dmax1 (xnorm, dabs (x (j)))
+ j = i + 3
+ t3 = g (j)
+ d (j) = -t3
+ gnorm = dmax1 (gnorm, dabs (t3))
+ xnorm = dmax1 (xnorm, dabs (x (j)))
+ j = i + 4
+ t4 = g (j)
+ d (j) = -t4
+ gnorm = dmax1 (gnorm, dabs (t4))
+ xnorm = dmax1 (xnorm, dabs (x (j)))
+ gnorm2 = gnorm2 + t*t + t1*t1 + t2*t2 + t3*t3 + t4*t4
+ enddo
+
+ if ( StopRule ) then
+ tol = dmax1 (gnorm*StopFac, tol)
+ endif
+
+ if ( PrintLevel ) then
+ write (*, 10) iter, f, gnorm, AWolfe
+10 format ('iter: ', i5, ' f= ', e14.6,
+ & ' gnorm= ', e14.6, ' AWolfe= ', l2)
+ endif
+
+ if ( cg_tol (f, gnorm) ) goto 100
+
+ dphi0 = -gnorm2
+ if ( .not.Step ) then
+ alpha = psi0*xnorm/gnorm
+ if ( xnorm .eq. zero ) then
+ if ( f .ne. zero ) then
+ alpha = psi0*dabs (f)/gnorm2
+ else
+ alpha = 1.d0
+ endif
+ endif
+ endif
+
+c start the conjugate gradient iteration
+
+c
+c alpha starts as old step, ends as initial step for next iteration
+c f is function value for alpha = 0
+c QuadOK = .true. means that a quadratic step was taken
+c
+
+ do iter = 1, maxit
+ QuadOK = .false.
+ alpha = psi2*alpha
+ if ( QuadStep ) then
+ if ( f .ne. zero ) then
+ t = dabs ((f-f0)/f)
+ else
+ t = 1.d0
+ endif
+ if ( t .gt. QuadCutOff ) then
+ talpha = psi1*alpha
+ call cg_step (xtemp, x, d, talpha)
+ call cg_value (ftemp, xtemp, n)
+ nf = nf + 1
+ if ( ftemp .lt. f ) then
+ denom = 2.0d0*(((ftemp-f)/talpha)-dphi0)
+ if ( denom .gt. zero ) then
+ QuadOK = .true.
+ alpha = -dphi0*talpha/denom
+ endif
+ endif
+ endif
+ endif
+ f0 = f
+
+ if ( PrintLevel .and. IsQuiet<0 ) then
+ if (myid .eq. 0) write (*, 20) QuadOK, alpha, f0, dphi0
+20 format ('QuadOK:', l2, ' initial a:',
+ & e14.6,' f0:', e14.6, ' dphi', e14.6)
+ endif
+
+c parameters in Wolfe and approximiate Wolfe conditions, and in update
+
+ Qk = Qdecay*Qk + 1.
+ Ck = Ck + (dabs (f) - Ck)/Qk
+
+ if ( PertRule ) then
+ fpert = f + eps*Ck
+ else
+ fpert = f + eps
+ endif
+
+ wolfe_hi = delta*dphi0
+ wolfe_lo = sigma*dphi0
+ awolfe_hi = delta2*dphi0
+ if ( AWolfe ) then
+ call cg_line (alpha, f, dphi, dphi0, x, xtemp, d, gtemp,
+ & cg_value, cg_grad)
+ else
+ call cg_lineW (alpha, f, dphi, dphi0, x, xtemp, d, gtemp,
+ & cg_value, cg_grad)
+ endif
+
+ if ( info .gt. 0 ) goto 100
+c
+c Test for convergence to within machine epsilon
+c (set feps to zero to remove this test)
+c
+ if ( -alpha*dphi0 .le. feps*dabs (f) ) then
+ info = 1
+ goto 100
+ endif
+
+c compute beta, yk2, gnorm, gnorm2, dnorm2, update x and g,
+
+ if ( mod (iter, nrestart) .ne. 0 ) then
+ gnorm = zero
+ dnorm2 = zero
+ yk2 = zero
+ ykgk = zero
+ do i = 1, n5
+ x (i) = xtemp (i)
+ t = gtemp (i)
+ yk = t - g (i)
+ yk2 = yk2 + yk**2
+ ykgk = ykgk + yk*t
+ g (i) = t
+ gnorm = dmax1 (gnorm, dabs (t))
+ dnorm2 = dnorm2 + d (i)**2
+ enddo
+ do i = n6, n, 5
+ x (i) = xtemp (i)
+ t = gtemp (i)
+ yk = t - g (i)
+ yk2 = yk2 + yk**2
+ ykgk = ykgk + yk*t
+ i1 = i + 1
+ x (i1) = xtemp (i1)
+ t1 = gtemp (i1)
+ i2 = i + 2
+ x (i2) = xtemp (i2)
+ t2 = gtemp (i2)
+ i3 = i + 3
+ x (i3) = xtemp (i3)
+ t3 = gtemp (i3)
+ i4 = i + 4
+ x (i4) = xtemp (i4)
+ t4 = gtemp (i4)
+ yk2 = yk2 + (t1-g (i1))**2 + (t2-g (i2))**2
+ & + (t3-g (i3))**2 + (t4-g (i4))**2
+ ykgk = ykgk + (t1-g (i1))*t1 + (t2-g (i2))*t2
+ & + (t3-g (i3))*t3 + (t4-g (i4))*t4
+ g (i) = t
+ gnorm = dmax1 (gnorm, dabs (t))
+ g (i1) = t1
+ gnorm = dmax1 (gnorm, dabs (t1))
+ g (i2) = t2
+ gnorm = dmax1 (gnorm, dabs (t2))
+ g (i3) = t3
+ gnorm = dmax1 (gnorm, dabs (t3))
+ g (i4) = t4
+ gnorm = dmax1 (gnorm, dabs (t4))
+ dnorm2 = dnorm2 + d (i)**2 + d (i1)**2 + d (i2)**2
+ & + d (i3)**2 + d (i4)**2
+ enddo
+ if ( cg_tol (f, gnorm) ) goto 100
+ dkyk = dphi - dphi0
+ beta = (ykgk - 2.d0*dphi*yk2/dkyk)/dkyk
+
+c faster: initialize dnorm2 = gnorm2 at start, then
+c dnorm2 = gnorm2 + beta**2*dnorm2 - 2.d0*beta*dphi
+c gnorm2 = ||g_{k+1}||^2
+c dnorm2 = ||d_{k+1}||^2
+c dpi = g_{k+1}' d_k
+
+ beta = dmax1 (beta,
+ & -1.d0/dsqrt (dmin1 (eta_sq, gnorm2)*dnorm2))
+
+c update search direction d = -g + beta*dold
+
+ gnorm2 = zero
+ do i = 1, n5
+ t = g (i)
+ d (i) = -t + beta*d (i)
+ gnorm2 = gnorm2 + t*t
+ enddo
+ do i = n6, n, 5
+ d (i) = -g (i) + beta*d (i)
+ i1 = i + 1
+ d (i1) = -g (i1) + beta*d (i1)
+ i2 = i + 2
+ d (i2) = -g (i2) + beta*d (i2)
+ i3 = i + 3
+ d (i3) = -g (i3) + beta*d (i3)
+ i4 = i + 4
+ d (i4) = -g (i4) + beta*d (i4)
+ gnorm2 = gnorm2 + g (i)**2 + g (i1)**2 + g (i2)**2
+ & + g (i3)**2 + g (i4)**2
+ enddo
+ dphi0 = -gnorm2 + beta*dphi
+
+ else
+
+c search direction d = -g
+
+ if ( PrintLevel .and. IsQuiet <0 ) then
+ if (myid .eq. 0) write (*, *) "RESTART CG"
+ endif
+ gnorm = zero
+ gnorm2 = zero
+ do i = 1, n5
+ x (i) = xtemp (i)
+ t = gtemp (i)
+ g (i) = t
+ d (i) = -t
+ gnorm = dmax1 (gnorm, dabs(t))
+ gnorm2 = gnorm2 + t*t
+ enddo
+ do i = n6, n, 5
+ x (i) = xtemp (i)
+ t = gtemp (i)
+ g (i) = t
+ d (i) = -t
+ gnorm = dmax1 (gnorm, dabs(t))
+ j = i + 1
+ x (j) = xtemp (j)
+ t1 = gtemp (j)
+ g (j) = t1
+ d (j) = -t1
+ gnorm = dmax1 (gnorm, dabs(t1))
+ j = i + 2
+ x (j) = xtemp (j)
+ t2 = gtemp (j)
+ g (j) = t2
+ d (j) = -t2
+ gnorm = dmax1 (gnorm, dabs(t2))
+ j = i + 3
+ x (j) = xtemp (j)
+ t3 = gtemp (j)
+ g (j) = t3
+ d (j) = -t3
+ gnorm = dmax1 (gnorm, dabs(t3))
+ j = i + 4
+ x (j) = xtemp (j)
+ t4 = gtemp (j)
+ g (j) = t4
+ d (j) = -t4
+ gnorm = dmax1 (gnorm, dabs(t4))
+ gnorm2 = gnorm2 + t*t + t1*t1 + t2*t2 + t3*t3 + t4*t4
+ enddo
+ if ( cg_tol (f, gnorm) ) goto 100
+ dphi0 = -gnorm2
+ endif
+ if ( .not.AWolfe ) then
+ if ( dabs (f-f0) .lt. AWolfeFac*Ck ) then
+ AWolfe = .true.
+ endif
+ endif
+
+ if ( PrintLevel .or. PrintFinal ) then
+ tstart = MPI_Wtime()
+ call output(tstart-tfinish)
+c write (*, 10) iter, f, gnorm, AWolfe
+ endif
+
+ if ( debug ) then
+ if ( f .gt. f0 + 1.e-10*Ck ) then
+ write (*, 270)
+ write (*, 50) f, f0
+50 format (' new value:', e30.16, 'old value:', e30.16)
+ stop
+ endif
+ endif
+
+ if ( dphi0 .gt. zero ) then
+ info = 5
+ goto 100
+ endif
+ enddo
+ info = 2
+100 nfunc = nf
+ ngrad = ng
+ status = info
+ if ( info .gt. 2 ) then
+ gnorm = zero
+ do i = 1, n
+ x (i) = xtemp (i)
+ g (i) = gtemp (i)
+ gnorm = dmax1 (gnorm, dabs(g (i)))
+ enddo
+ endif
+ if ( PrintFinal .and. .false. ) then
+ write (6, *) 'Termination status:', status
+ if ( status .eq. 0 ) then
+ write (6, 200)
+ else if ( status .eq. 1 ) then
+ write (6, 210)
+ else if ( status .eq. 2 ) then
+ write (6, 220) maxit
+ write (6, 300)
+ write (6, 400) grad_tol
+ else if ( status .eq. 3 ) then
+ write (6, 230)
+ write (6, 300)
+ write (6, 430)
+ write (6, 410)
+ else if ( status .eq. 4 ) then
+ write (6, 240)
+ write (6, 300)
+ write (6, 400) grad_tol
+ else if ( status .eq. 5 ) then
+ write (6, 250)
+ else if ( status .eq. 6 ) then
+ write (6, 260)
+ write (6, 300)
+ write (6, 400) grad_tol
+ write (6, 410)
+ write (6, 420)
+ else if ( status .eq. 7 ) then
+ write (6, 260)
+ write (6, 300)
+ write (6, 400) grad_tol
+ else if ( status .eq. 8 ) then
+ write (6, 260)
+ write (6, 300)
+ write (6, 400) grad_tol
+ write (6, 410)
+ write (6, 420)
+ endif
+ write (6, 500) gnorm
+ write (6, *) 'function value:', f
+ write (6, *) 'cg iterations:', iter
+ write (6, *) 'function evaluations:', nfunc
+ write (6, *) 'gradient evaluations:', ngrad
+ endif
+ return
+200 format (' Convergence tolerance for gradient satisfied')
+210 format (' Terminating since change in function value <= feps*|f|')
+220 format (' Total number of iterations exceed max allow:', i10)
+230 format (' Slope always negative in line search')
+240 format (' Line search fails, too many secant steps')
+250 format (' Search direction not a descent direction')
+260 format (' Line search fails')
+270 format (' Debugger is on, function value does not improve')
+300 format (' Possible causes of this error message:')
+400 format (' - your tolerance (grad_tol = ', d12.4,
+ & ') may be too strict')
+410 format (' - your gradient routine has an error')
+420 format (' - parameter epsilon in cg_descent.parm is too small')
+430 format (' - your cost function has an error')
+500 format (' absolute largest component of gradient: ', d12.4)
+ end
+
+c PARAMETERS:
+c
+c delta - range (0, .5), used in the Wolfe conditions
+c sigma - range [delta, 1), used in the Wolfe conditions
+c eps - range [0, infty), used to compute line search perturbation
+c gamma - range (0,1), determines when to perform bisection step
+c rho - range (1, infty), growth factor when finding initial interval
+c eta - range (0, infty), used in lower bound for beta
+c psi0 - range (0, 1), factor used in very initial starting guess
+c psi1 - range (0, 1), factor previous step multiplied by in QuadStep
+c psi2 - range (1, infty), factor previous step is multipled by for startup
+c QuadCutOff - perform QuadStep if relative change in f > QuadCutOff
+c StopFac - used in StopRule
+c AWolfeFac - used to decide when to switch from Wolfe to AWolfe
+c restart_fac - range (0, infty) restart cg when iter = n*restart
+c maxit_fac - range (0, infty) terminate in maxit = maxit_fac*n iterations
+c feps - stop when -alpha*dphi0 (est. change in value) <= feps*|f|
+c (feps = 0 removes this test, example: feps = eps*1.e-5
+c where eps is machine epsilon)
+c tol - range (0, infty), convergence tolerance
+c nexpand - range [0, infty), number of grow/shrink allowed in bracket
+c nsecant - range [0, infty), maximum number of secant steps
+c PertRule - gives the rule used for the perturbation in f
+c F => fpert = eps
+c T => fpert = eps*Ck, Ck is an average of prior |f|
+c Ck is an average of prior |f|
+c QuadStep- .true. (use quadratic step) .false. (no quadratic step)
+c PrintLevel- .false. (no printout) .true. (print intermediate results)
+c PrintFinal- .false. (no printout) .true. (print messages, final error)
+c StopRule - .true. (max abs grad <= max (tol, StopFac*initial abs grad))
+c .false. (... <= tol*(1+|f|))
+c AWolfe - .false. (use standard Wolfe initially)
+c - .true. (use approximate + standard Wolfe)
+c Step - .false. (program computing starting step at iteration 0)
+c - .true. (user provides starting step in gnorm argument of cg_descent
+c debug - .false. (no debugging)
+c - .true. (check that function values do not increase)
+c info - same as status
+c
+c DEFAULT PARAMETER VALUES:
+c
+c delta : 0.1
+c sigma : 0.9
+c eps : 1.e-6
+c gamma : 0.66
+c rho : 5.0
+c restart: 1.0
+c eta : 0.01
+c psi0 : 0.01
+c psi1 : 0.1
+c psi2 : 2.0
+c QuadCutOff: 1.d-12
+c StopFac: 0.d0
+c AWolfeFac: 1.d-3
+c tol : grad_tol
+c nrestart: n (restart_fac = 1)
+c maxit : 500*n (maxit_fac = 500)
+c feps : 0.0
+c Qdecay : 0.7
+c nexpand: 50
+c nsecant: 50
+c PertRule: .true.
+c QuadStep: .true.
+c PrintLevel: .false.
+c PrintFinal: .true.
+c StopRule: .true.
+c AWolfe: .false.
+c Step: .false.
+c debug: .false.
+c info : 0
+c feps : 0.0
+c
+
+c (double) grad_tol-- used in stopping rule
+c (int) dim --problem dimension (also denoted n)
+
+ subroutine cg_init (grad_tol, dim)
+ use globals, only : cg_maxiter, CG_wolfe_c1, CG_wolfe_c2, cg_xtol,
+ & IsQuiet
+ double precision delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & grad_tol, restart_fac, maxit_fac
+
+ integer n, n5, n6, nf, ng, info, nrestart,
+ & nexpand, nsecant, maxit, dim
+
+ logical PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug
+
+ common /cgparms/delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & n, n5, n6, nf, ng, info,
+ & nrestart, nexpand, nsecant, maxit,
+ & PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug
+
+ n = dim
+ tol = grad_tol
+c$$$ open (10, file='cg_descent_f.parm')
+c$$$ read (10, *) delta
+c$$$ read (10, *) sigma
+c$$$ read (10, *) eps
+c$$$ read (10, *) gamma
+c$$$ read (10, *) rho
+c$$$ read (10, *) eta
+c$$$ read (10, *) psi0
+c$$$ read (10, *) psi1
+c$$$ read (10, *) psi2
+c$$$ read (10, *) QuadCutOff
+c$$$ read (10, *) StopFac
+c$$$ read (10, *) AWolfeFac
+c$$$ read (10, *) restart_fac
+c$$$ read (10, *) maxit_fac
+c$$$ read (10, *) feps
+c$$$ read (10, *) Qdecay
+c$$$ read (10, *) nexpand
+c$$$ read (10, *) nsecant
+c$$$ read (10, *) PertRule
+c$$$ read (10, *) QuadStep
+c$$$ read (10, *) PrintLevel
+c$$$ read (10, *) PrintFinal
+c$$$ read (10, *) StopRule
+c$$$ read (10, *) AWolfe
+c$$$ read (10, *) Step
+c$$$ read (10, *) debug
+ delta = cg_Wolfe_c1
+ sigma = cg_Wolfe_c2
+ eps = 1.d-6
+ gamma = .66d0
+ rho = 5.0d0
+ eta = .01d0
+ psi0 = .01d0
+ psi1 = .1d0
+ psi2 = 2.d0
+ QuadCutOff = 1.d-12
+ StopFact = 0.d-12
+ AWolfeFac = 1.d-3
+ restart_fac= 1.0d0
+ maxit_fac = 500.d0
+ feps = 0.d0
+ Qdecay = .7d0
+ nexpand = 50
+ nsecant = 50
+ PertRule = .true.
+ QuadStep = .true.
+ if (myid==0 .and. IsQuiet<-1) then
+ PrintLevel = .true.
+ else
+ PrintLevel = .false.
+ end if
+ if (myid==0) then
+ PrintFinal = .true.
+ else
+ PrintFinal = .false.
+ end if
+ StopRule = .true.
+ AWolfe = .false.
+ Step = .false.
+ if (myid==0 .and. IsQuiet<-1) then
+ debug = .true.
+ else
+ debug = .false.
+ end if
+ nrestart = n*restart_fac
+c maxit = n*maxit_fac
+ maxit = cg_maxiter
+ zero = 0.d0
+ info = 0
+ n5 = mod (n, 5)
+ n6 = n5 + 1
+ nf = 0
+ ng = 0
+c close (10)
+ return
+ end
+
+c check whether the Wolfe or the approximate Wolfe conditions
+c are satisfied
+
+c (double) alpha -- stepsize
+c (double) f -- function value associated with stepsize alpha
+c (double) dphi -- derivative value associated with stepsize alpha
+
+ logical function cg_Wolfe (alpha, f, dphi)
+
+ double precision delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & alpha, f, dphi
+
+ integer n, n5, n6, nf, ng, info, nrestart,
+ & nexpand, nsecant, maxit
+
+ logical PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug
+
+ common /cgparms/delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & n, n5, n6, nf, ng, info,
+ & nrestart, nexpand, nsecant, maxit,
+ & PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug
+
+ if ( dphi .ge. wolfe_lo ) then
+
+c test original Wolfe conditions
+
+ if ( f-f0 .le. alpha*wolfe_hi ) then
+ cg_Wolfe = .true.
+ if ( PrintLevel) then
+ write (*, 10) f, f0, alpha*wolfe_hi, dphi
+10 format (' wolfe f:', e14.6, ' f0: ',
+ & e14.6, e14.6, ' dphi:', e14.6)
+ endif
+ return
+
+c test approximate Wolfe conditions
+
+ elseif ( AWolfe ) then
+ if ( (f .le. fpert).and.(dphi .le. awolfe_hi) ) then
+ cg_Wolfe = .true.
+ if ( PrintLevel ) then
+ write (*, 20) f, fpert, dphi, awolfe_hi
+20 format ('f:', e14.6, ' fpert:', e14.6,
+ & ' dphi: ', e14.6, ' fappx:', e14.6)
+ endif
+ return
+ endif
+ endif
+ endif
+ cg_Wolfe = .false.
+ return
+ end
+
+c check for convergence of the cg iterations
+c (double) f -- function value associated with stepsize
+c (double) gnorm -- gradient (infinity) norm
+
+ logical function cg_tol (f, gnorm)
+
+ double precision delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & f, gnorm
+
+ integer n, n5, n6, nf, ng, info, nrestart,
+ & nexpand, nsecant, maxit
+
+ logical PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug
+
+ common /cgparms/delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & n, n5, n6, nf, ng, info,
+ & nrestart, nexpand, nsecant, maxit,
+ & PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug
+
+ if ( StopRule ) then
+ if ( gnorm .le. tol ) then
+ cg_tol = .true.
+ return
+ endif
+ else
+ if ( gnorm .le. tol*(1.0 + dabs (f)) ) then
+ cg_tol = .true.
+ return
+ endif
+ endif
+ cg_tol = .false.
+ return
+ end
+
+c compute dot product of x and y, vectors of length n
+c (double) x -- first vector
+c (double) y -- second vector
+
+ double precision function cg_dot (x, y)
+
+ double precision delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & x (*), y(*), t
+
+ integer n, n5, n6, nf, ng, info, nrestart,
+ & nexpand, nsecant, maxit, i
+
+ logical PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug
+
+ common /cgparms/delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & n, n5, n6, nf, ng, info,
+ & nrestart, nexpand, nsecant, maxit,
+ & PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug
+
+ t = zero
+ do i = 1, n5
+ t = t + x (i)*y (i)
+ enddo
+ do i = n6, n, 5
+ t = t + x (i)*y(i) + x (i+1)*y (i+1) + x (i+2)*y (i+2)
+ & + x (i+3)*y (i+3) + x (i+4)*y (i+4)
+ enddo
+ cg_dot = t
+ return
+ end
+
+c
+c compute xtemp = x + alpha d
+c
+c (double) xtemp -- output vector
+c (double) x -- initial vector
+c (double) d -- search direction vector
+c (double) alpha -- stepsize along search direction vector
+
+ subroutine cg_step (xtemp, x, d, alpha)
+
+ double precision delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & xtemp (*), x (*), d (*), alpha
+
+ integer n, n5, n6, nf, ng, info, nrestart,
+ & nexpand, nsecant, maxit, i, j
+
+ logical PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug
+
+ common /cgparms/delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & n, n5, n6, nf, ng, info,
+ & nrestart, nexpand, nsecant, maxit,
+ & PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug
+
+ do i = 1, n5
+ xtemp (i) = x(i) + alpha*d(i)
+ enddo
+ do i = n6, n, 5
+ xtemp (i) = x (i) + alpha*d (i)
+ j = i + 1
+ xtemp (j) = x (j) + alpha*d (j)
+ j = i + 2
+ xtemp (j) = x (j) + alpha*d (j)
+ j = i + 3
+ xtemp (j) = x (j) + alpha*d (j)
+ j = i + 4
+ xtemp (j) = x (j) + alpha*d (j)
+ enddo
+ end
+
+c (double) alpha -- stepsize along search direction vector
+c (double) phi -- function value for step alpha
+c (double) dphi -- function derivative for step alpha
+c (double) dphi0 -- function derivative at starting point (alpha = 0)
+c (double) x -- current iterate
+c (double) xtemp -- x + alpha*d
+c (double) d -- current search direction
+c (double) gtemp -- gradient at x + alpha*d
+c (external) cg_value -- routine to evaluate function value
+c (external) cg_grad -- routine to evaluate function gradient
+
+ subroutine cg_line (alpha, phi, dphi, dphi0, x, xtemp, d, gtemp,
+ & cg_value, cg_grad)
+
+ double precision delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & x (*), xtemp (*), d (*), gtemp (*),
+ & a, dphia, b, dphib, alpha, phi, dphi, c,
+ & a0, da0, b0, db0, width, fquad, dphi0,
+ & cg_dot
+
+ integer n, n5, n6, nf, ng, info, nrestart,
+ & nexpand, nsecant, maxit,
+ & ngrow, nshrink, cg_update, iter, flag
+
+ logical PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug,
+ & cg_Wolfe
+
+ external cg_value, cg_grad
+
+ common /cgparms/delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & n, n5, n6, nf, ng, info,
+ & nrestart, nexpand, nsecant, maxit,
+ & PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug
+
+ call cg_step (xtemp, x, d, alpha)
+ call cg_grad (gtemp, xtemp, n)
+ ng = ng + 1
+ dphi = cg_dot (gtemp, d)
+c
+c Find initial interval [a,b] such that dphia < 0, dphib >= 0,
+c and phia <= phi0 + feps*dabs (phi0)
+c
+ a = zero
+ dphia = dphi0
+ ngrow = 0
+ nshrink = 0
+ do while ( dphi .lt. zero )
+ call cg_value (phi, xtemp, n)
+ nf = nf + 1
+c
+c if quadstep in effect and quadratic conditions hold, check wolfe condition
+c
+ if ( QuadOK ) then
+ if ( ngrow .eq. 0 ) fquad = dmin1 (phi, f0)
+ if ( phi .le. fquad ) then
+ if ( PrintLevel ) then
+ write (*, 10) alpha, phi, fquad
+10 format ('alpha:', e14.6, ' phi:', e14.6,
+ & ' fquad:', e14.6)
+ endif
+ if ( cg_Wolfe (alpha, phi, dphi) ) return
+ endif
+ endif
+ if ( phi .le. fpert ) then
+ a = alpha
+ dphia = dphi
+ else
+c
+c contraction phase
+c
+ b = alpha
+ do while ( .true. )
+ alpha = .5d0*(a+b)
+ nshrink = nshrink + 1
+ if ( nshrink .gt. nexpand ) then
+ info = 6
+ return
+ endif
+ call cg_step (xtemp, x, d, alpha)
+ call cg_grad (gtemp, xtemp, n)
+ ng = ng + 1
+ dphi = cg_dot (gtemp, d)
+ if ( dphi .ge. zero ) goto 100
+ call cg_value (phi, xtemp, n)
+ nf = nf + 1
+ if ( PrintLevel ) then
+ write (6, 20) a, b, alpha, phi, dphi
+20 format ('contract, a:', e14.6,
+ & ' b:', e14.6, ' alpha:', e14.6,
+ & ' phi:', e14.6, ' dphi:', e14.6)
+ endif
+ if ( QuadOK .and. (phi .le. fquad) ) then
+ if ( cg_Wolfe (alpha, phi, dphi) ) return
+ endif
+ if ( phi .le. fpert ) then
+ a = alpha
+ dphia = dphi
+ else
+ b = alpha
+ endif
+ enddo
+ endif
+c
+c expansion phase
+c
+ ngrow = ngrow + 1
+ if ( ngrow .gt. nexpand ) then
+ info = 3
+ return
+ endif
+ alpha = rho*alpha
+ call cg_step (xtemp, x, d, alpha)
+ call cg_grad (gtemp, xtemp, n)
+ ng = ng + 1
+ dphi = cg_dot (gtemp, d)
+ if ( PrintLevel ) then
+ write (*, 30) a, alpha, phi, dphi
+30 format ('expand, a:', e14.6, ' alpha:', e14.6,
+ & ' phi:', e14.6, ' dphi:', e14.6)
+ endif
+ enddo
+100 continue
+ b = alpha
+ dphib = dphi
+ if ( QuadOK ) then
+ call cg_value (phi, xtemp, n)
+ nf = nf + 1
+ if ( ngrow + nshrink .eq. 0 ) fquad = dmin1 (phi, f0)
+ if ( phi .le. fquad ) then
+ if ( cg_Wolfe (alpha, phi, dphi) ) return
+ endif
+ endif
+ do iter = 1, nsecant
+ if ( PrintLevel ) then
+ write (*, 40) a, b, dphia, dphib
+40 format ('secant, a:', e14.6, ' b:', e14.6,
+ & ' da:', e14.6, ' db:', e14.6)
+ endif
+ width = gamma*(b - a)
+ if ( -dphia .le. dphib ) then
+ alpha = a - (a-b)*(dphia/(dphia-dphib))
+ else
+ alpha = b - (a-b)*(dphib/(dphia-dphib))
+ endif
+ c = alpha
+ a0 = a
+ b0 = b
+ da0 = dphia
+ db0 = dphib
+ flag = cg_update (a, dphia, b, dphib, alpha, phi,
+ & dphi, x, xtemp, d, gtemp, cg_value, cg_grad)
+ if ( flag .gt. 0 ) then
+ return
+ else if ( flag .eq. 0 ) then
+ if ( c .eq. a ) then
+ if ( dphi .gt. da0 ) then
+ alpha = c - (c-a0)*(dphi/(dphi-da0))
+ else
+ alpha = a
+ endif
+ else
+ if ( dphi .lt. db0 ) then
+ alpha = c - (c-b0)*(dphi/(dphi-db0))
+ else
+ alpha = b
+ endif
+ endif
+ if ( (alpha .gt. a) .and. (alpha .lt. b) ) then
+ if ( PrintLevel ) write (*, *) "2nd secant"
+ flag = cg_update (a, dphia, b, dphib, alpha, phi,
+ & dphi, x, xtemp, d, gtemp, cg_value, cg_grad)
+ if ( flag .gt. 0 ) return
+ endif
+ endif
+c
+c bisection iteration
+c
+ if ( (b-a) .ge. width ) then
+ alpha = .5d0*(b+a)
+ if ( PrintLevel ) write (*, *) "bisection"
+ flag = cg_update (a, dphia, b, dphib, alpha, phi,
+ & dphi, x, xtemp, d, gtemp, cg_value, cg_grad)
+ if ( flag .gt. 0 ) return
+ else
+ if ( b .le. a ) then
+ info = 7
+ return
+ endif
+ endif
+ end do
+ info = 4
+ return
+ end
+
+c This routine is identical to cg_line except that the function
+c psi (a) = phi (a) - phi (0) - a*delta*dphi (0) is miniminized instead of
+c the function phi
+
+c (double) alpha -- stepsize along search direction vector
+c (double) phi -- function value for step alpha
+c (double) dphi -- function derivative for step alpha
+c (double) dphi0 -- function derivative at starting point (alpha = 0)
+c (double) x -- current iterate
+c (double) xtemp -- x + alpha*d
+c (double) d -- current search direction
+c (double) gtemp -- gradient at x + alpha*d
+c (external) cg_value -- routine to evaluate function value
+c (external) cg_grad -- routine to evaluate function gradient
+
+ subroutine cg_lineW (alpha, phi, dphi, dphi0, x, xtemp, d, gtemp,
+ & cg_value, cg_grad)
+
+ double precision delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & x (*), xtemp (*), d (*), gtemp (*),
+ & a, dpsia, b, dpsib, alpha, phi, dphi, c,
+ & a0, da0, b0, db0, width, fquad, dphi0,
+ & cg_dot, psi, dpsi
+
+ integer n, n5, n6, nf, ng, info, nrestart,
+ & nexpand, nsecant, maxit,
+ & ngrow, nshrink, cg_updateW, iter, flag
+
+ logical PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug,
+ & cg_Wolfe
+
+ external cg_value, cg_grad
+
+ common /cgparms/delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & n, n5, n6, nf, ng, info,
+ & nrestart, nexpand, nsecant, maxit,
+ & PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug
+
+ call cg_step (xtemp, x, d, alpha)
+ call cg_grad (gtemp, xtemp, n)
+ ng = ng + 1
+ dphi = cg_dot (gtemp, d)
+ dpsi = dphi - wolfe_hi
+c
+c Find initial interval [a,b] such that dpsia < 0, dpsib >= 0,
+c and psia <= phi0 + feps*dabs (phi0)
+c
+ a = zero
+ dpsia = dphi0 - wolfe_hi
+ ngrow = 0
+ nshrink = 0
+ do while ( dpsi .lt. zero )
+ call cg_value (phi, xtemp, n)
+ psi = phi - alpha*wolfe_hi
+
+ nf = nf + 1
+c
+c if quadstep in effect and quadratic conditions hold, check wolfe condition
+c
+ if ( QuadOK ) then
+ if ( ngrow .eq. 0 ) fquad = dmin1 (phi, f0)
+ if ( phi .le. fquad ) then
+ if ( PrintLevel ) then
+ write (*, 10) alpha, phi, fquad
+10 format ('alpha:', e14.6, ' phi:', e14.6,
+ & ' fquad:', e14.6)
+ endif
+ if ( cg_Wolfe (alpha, phi, dphi) ) return
+ endif
+ endif
+ if ( psi .le. fpert ) then
+ a = alpha
+ dpsia = dpsi
+ else
+c
+c contraction phase
+c
+ b = alpha
+ do while ( .true. )
+ alpha = .5d0*(a+b)
+ nshrink = nshrink + 1
+ if ( nshrink .gt. nexpand ) then
+ info = 6
+ return
+ endif
+ call cg_step (xtemp, x, d, alpha)
+ call cg_grad (gtemp, xtemp, n)
+ ng = ng + 1
+ dphi = cg_dot (gtemp, d)
+ dpsi = dphi - wolfe_hi
+ if ( dpsi .ge. zero ) goto 100
+ call cg_value (phi, xtemp, n)
+ psi = phi - alpha*wolfe_hi
+ nf = nf + 1
+ if ( PrintLevel ) then
+ write (6, 20) a, b, alpha, phi, dphi
+20 format ('contract, a:', e14.6,
+ & ' b:', e14.6, ' alpha:', e14.6,
+ & ' phi:', e14.6, ' dphi:', e14.6)
+ endif
+ if ( QuadOK .and. (phi .le. fquad) ) then
+ if ( cg_Wolfe (alpha, phi, dphi) ) return
+ endif
+ if ( psi .le. fpert ) then
+ a = alpha
+ dpsia = dpsi
+ else
+ b = alpha
+ endif
+ enddo
+ endif
+c
+c expansion phase
+c
+ ngrow = ngrow + 1
+ if ( ngrow .gt. nexpand ) then
+ info = 3
+ return
+ endif
+ alpha = rho*alpha
+ call cg_step (xtemp, x, d, alpha)
+ call cg_grad (gtemp, xtemp, n)
+ ng = ng + 1
+ dphi = cg_dot (gtemp, d)
+ dpsi = dphi - wolfe_hi
+ if ( PrintLevel ) then
+ write (*, 30) a, alpha, phi, dphi
+30 format ('expand, a:', e14.6, ' alpha:', e14.6,
+ & ' phi:', e14.6, ' dphi:', e14.6)
+ write (6, *) "expand, alpha:", alpha, "dphi:", dphi
+ endif
+ enddo
+100 continue
+ b = alpha
+ dpsib = dpsi
+ if ( QuadOK ) then
+ call cg_value (phi, xtemp, n)
+ nf = nf + 1
+ if ( ngrow + nshrink .eq. 0 ) fquad = dmin1 (phi, f0)
+ if ( phi .le. fquad ) then
+ if ( cg_Wolfe (alpha, phi, dphi) ) return
+ endif
+ endif
+ do iter = 1, nsecant
+ if ( PrintLevel ) then
+ write (*, 40) a, b, dpsia, dpsib
+40 format ('secant, a:', e14.6, ' b:', e14.6,
+ & ' da:', e14.6, ' db:', e14.6)
+ endif
+ width = gamma*(b - a)
+ if ( -dpsia .le. dpsib ) then
+ alpha = a - (a-b)*(dpsia/(dpsia-dpsib))
+ else
+ alpha = b - (a-b)*(dpsib/(dpsia-dpsib))
+ endif
+ c = alpha
+ a0 = a
+ b0 = b
+ da0 = dpsia
+ db0 = dpsib
+ flag = cg_updateW (a, dpsia, b, dpsib, alpha,
+ & phi, dphi, dpsi, x, xtemp, d, gtemp,
+ & cg_value, cg_grad)
+ if ( flag .gt. 0 ) then
+ return
+ else if ( flag .eq. 0 ) then
+ if ( c .eq. a ) then
+ if ( dpsi .gt. da0 ) then
+ alpha = c - (c-a0)*(dpsi/(dpsi-da0))
+ else
+ alpha = a
+ endif
+ else
+ if ( dpsi .lt. db0 ) then
+ alpha = c - (c-b0)*(dpsi/(dpsi-db0))
+ else
+ alpha = b
+ endif
+ endif
+ if ( (alpha .gt. a) .and. (alpha .lt. b) ) then
+ if ( PrintLevel ) write (*, *) "2nd secant"
+ flag = cg_updateW (a, dpsia, b, dpsib, alpha,
+ & phi, dphi, dpsi, x, xtemp, d, gtemp,
+ & cg_value, cg_grad)
+ if ( flag .gt. 0 ) return
+ endif
+ endif
+c
+c bisection iteration
+c
+ if ( (b-a) .ge. width ) then
+ alpha = .5d0*(b+a)
+ if ( PrintLevel ) write (*, *) "bisection"
+ flag = cg_updateW (a, dpsia, b, dpsib, alpha,
+ & phi, dphi, dpsi, x, xtemp, d, gtemp,
+ & cg_value, cg_grad)
+ if ( flag .gt. 0 ) return
+ else
+ if ( b .le. a ) then
+ info = 7
+ return
+ endif
+ endif
+ end do
+ info = 4
+ return
+ end
+c
+c update returns 1 if Wolfe condition is satisfied or too many iterations
+c returns 0 if the interval updated successfully
+c returns -1 if search done
+c
+c (double) a -- left side of bracketting interval
+c (double) dphia -- derivative at a
+c (double) b -- right side of bracketting interval
+c (double) dphib -- derivative at b
+c (double) alpha -- trial step (between a and b)
+c (double) phi -- function value at alpha (returned)
+c (double) dphi -- function derivative at alpha (returned)
+c (double) x -- current iterate
+c (double) xtemp -- x + alpha*d
+c (double) d -- current search direction
+c (double) gtemp -- gradient at x + alpha*d
+c (external) cg_value -- routine to evaluate function value
+c (external) cg_grad -- routine to evaluate function gradient
+
+ integer function cg_update (a, dphia, b, dphib, alpha, phi,
+ & dphi, x, xtemp, d, gtemp, cg_value, cg_grad)
+
+ double precision delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & a, dphia, b, dphib, alpha, phi, dphi,
+ & x (*), xtemp (*), d (*), gtemp (*),
+ & cg_dot
+
+ integer n, n5, n6, nf, ng, info, nrestart,
+ & nexpand, nsecant, maxit,
+ & nshrink
+
+ logical PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug,
+ & cg_Wolfe
+
+ external cg_value, cg_grad
+
+ common /cgparms/delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & n, n5, n6, nf, ng, info,
+ & nrestart, nexpand, nsecant, maxit,
+ & PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug
+
+ call cg_step (xtemp, x, d, alpha)
+ call cg_value (phi, xtemp, n)
+ nf = nf + 1
+ call cg_grad (gtemp, xtemp, n)
+ ng = ng + 1
+ dphi = cg_dot (gtemp, d)
+ if ( PrintLevel ) then
+ write (*, 10) alpha, phi, dphi
+10 format ('update alpha:', e14.6, ' phi:', e14.6,
+ & ' dphi:', e14.6)
+ endif
+ cg_update = 0
+ if ( cg_Wolfe (alpha, phi, dphi) ) then
+ cg_update = 1
+ goto 110
+ endif
+ if ( dphi .ge. zero ) then
+ b = alpha
+ dphib = dphi
+ goto 110
+ else
+ if ( phi .le. fpert ) then
+ a = alpha
+ dphia = dphi
+ goto 110
+ endif
+ endif
+ nshrink = 0
+ b = alpha
+ do while ( .true. )
+ alpha = .5d0*(a+b)
+ nshrink = nshrink + 1
+ if ( nshrink .gt. nexpand ) then
+ info = 8
+ cg_update = 1
+ goto 110
+ endif
+ call cg_step (xtemp, x, d, alpha)
+ call cg_grad (gtemp, xtemp, n)
+ ng = ng + 1
+ dphi = cg_dot (gtemp, d)
+ call cg_value (phi, xtemp, n)
+ nf = nf + 1
+ if ( PrintLevel ) then
+ write (6, 20) a, alpha, phi, dphi
+20 format ('contract, a:', e14.6, ' alpha:', e14.6,
+ & ' phi:', e14.6, ' dphi:', e14.6)
+ endif
+ if ( cg_Wolfe (alpha, phi, dphi) ) then
+ cg_update = 1
+ goto 110
+ endif
+ if ( dphi .ge. zero ) then
+ b = alpha
+ dphib = dphi
+ goto 100
+ endif
+ if ( phi .le. fpert ) then
+ if ( PrintLevel ) then
+ write (6, *) "update a:", alpha, "dphia:", dphi
+ endif
+ a = alpha
+ dphia = dphi
+ else
+ b = alpha
+ endif
+ enddo
+100 continue
+ cg_update = -1
+110 continue
+ if ( PrintLevel ) then
+ write (*, 200) a, b, dphia, dphib, cg_update
+200 format ('UP a:', e14.6, ' b:', e14.6,
+ & ' da:', e14.6, ' db:', e14.6, ' up:', i2)
+ endif
+ return
+ end
+
+c This routine is identical to cg_update except that the function
+c psi (a) = phi (a) - phi (0) - a*delta*dphi (0) is miniminized instead of
+c the function phi
+c
+c update returns 1 if Wolfe condition is satisfied or too many iterations
+c returns 0 if the interval updated successfully
+c returns -1 if search done
+c
+c (double) a -- left side of bracketting interval
+c (double) dpsia -- derivative at a
+c (double) b -- right side of bracketting interval
+c (double) dpsib -- derivative at b
+c (double) alpha -- trial step (between a and b)
+c (double) phi -- function value at alpha (returned)
+c (double) dphi -- derivative of phi at alpha (returned)
+c (double) dpsi -- derivative of psi at alpha (returned)
+c (double) x -- current iterate
+c (double) xtemp -- x + alpha*d
+c (double) d -- current search direction
+c (double) gtemp -- gradient at x + alpha*d
+c (external) cg_value -- routine to evaluate function value
+c (external) cg_grad -- routine to evaluate function gradient
+
+ integer function cg_updateW (a, dpsia, b, dpsib, alpha, phi, dphi,
+ & dpsi, x, xtemp, d, gtemp, cg_value, cg_grad)
+
+ double precision delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & a, dpsia, b, dpsib, alpha, phi, dphi,
+ & x (*), xtemp (*), d (*), gtemp (*),
+ & cg_dot, psi, dpsi
+
+ integer n, n5, n6, nf, ng, info, nrestart,
+ & nexpand, nsecant, maxit, nshrink
+
+ logical PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug,
+ & cg_Wolfe
+
+ external cg_value, cg_grad
+
+ common /cgparms/delta, sigma, eps,
+ & gamma, rho, tol, eta, fpert, f0, Ck, Qdecay,
+ & wolfe_hi, wolfe_lo, awolfe_hi,
+ & QuadCutOff, StopFac, AWolfeFac,
+ & zero, feps, psi0, psi1, psi2,
+ & n, n5, n6, nf, ng, info,
+ & nrestart, nexpand, nsecant, maxit,
+ & PertRule, QuadOK, QuadStep, PrintLevel,
+ & PrintFinal, StopRule, AWolfe, Step, debug
+
+ call cg_step (xtemp, x, d, alpha)
+ call cg_value (phi, xtemp, n)
+ psi = phi - alpha*wolfe_hi
+ nf = nf + 1
+ call cg_grad (gtemp, xtemp, n)
+ ng = ng + 1
+ dphi = cg_dot (gtemp, d)
+ dpsi = dphi - wolfe_hi
+ if ( PrintLevel ) then
+ write (*, 10) alpha, psi, dpsi
+10 format ('update alpha:', e14.6, ' psi:', e14.6,
+ & ' dpsi:', e14.6)
+ endif
+ cg_updateW = 0
+ if ( cg_Wolfe (alpha, phi, dphi) ) then
+ cg_updateW = 1
+ goto 110
+ endif
+ if ( dpsi .ge. zero ) then
+ b = alpha
+ dpsib = dpsi
+ goto 110
+ else
+ if ( psi .le. fpert ) then
+ a = alpha
+ dpsia = dpsi
+ goto 110
+ endif
+ endif
+ nshrink = 0
+ b = alpha
+ do while ( .true. )
+ alpha = .5d0*(a+b)
+ nshrink = nshrink + 1
+ if ( nshrink .gt. nexpand ) then
+ info = 8
+ cg_updateW = 1
+ goto 110
+ endif
+ call cg_step (xtemp, x, d, alpha)
+ call cg_grad (gtemp, xtemp, n)
+ ng = ng + 1
+ dphi = cg_dot (gtemp, d)
+ dpsi = dphi - wolfe_hi
+ call cg_value (phi, xtemp, n)
+ psi = phi - alpha*wolfe_hi
+ nf = nf + 1
+ if ( PrintLevel ) then
+ write (6, 20) a, alpha, phi, dphi
+20 format ('contract, a:', e14.6, ' alpha:', e14.6,
+ & ' phi:', e14.6, ' dphi:', e14.6)
+ endif
+ if ( cg_Wolfe (alpha, phi, dphi) ) then
+ cg_updateW = 1
+ goto 110
+ endif
+ if ( dpsi .ge. zero ) then
+ b = alpha
+ dpsib = dpsi
+ goto 100
+ endif
+ if ( psi .le. fpert ) then
+ if ( PrintLevel ) then
+ write (6, *) "update a:", alpha, "dpsia:", dpsi
+ endif
+ a = alpha
+ dpsia = dpsi
+ else
+ b = alpha
+ endif
+ enddo
+100 continue
+ cg_updateW = -1
+110 continue
+ if ( PrintLevel ) then
+ write (*, 200) a, b, dpsia, dpsib, cg_updateW
+200 format ('UP a:', e14.6, ' b:', e14.6,
+ & ' da:', e14.6, ' db:', e14.6, ' up:', i2)
+ endif
+ return
+ end
+c Version 1.2 Changes:
+c
+c 1. Fix problem with user specified initial step (overwriting step)
+c 2. Change dphi to dpsi at lines 1228 and 1234 in cg_lineW
+c 3. Add comment about how to compute dnorm2 by an update of previous dnorm2
+c 4. In comment statements for cg_lineW and cg_updateW, insert "delta"
+c in definition of psi (a)
+c 5. In dimension statements, change "(1)" to "(*)"
+
+c Version 1.3 Changes:
+c 1. Remove extraneous write in line 985 (same thing written out twice)
+c 2. Remove the parameter theta from cg_descent.parm and from the code
+c (we use theta = .5 in the cg_update)
+
+c Version 1.4 Change:
+c 1. The variable dpsi needs to be included in the argument list for
+c subroutine updateW (update of a Wolfe line search)
diff --git a/sources/congrad.h b/sources/congrad.f90
similarity index 72%
rename from sources/congrad.h
rename to sources/congrad.f90
index 0ae0843..7e2ed4c 100644
--- a/sources/congrad.h
+++ b/sources/congrad.f90
@@ -31,7 +31,7 @@
!latex the strong Wolfe conditions.
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
+#ifdef oldcg
SUBROUTINE congrad
use globals, only: dp, sqrtmachprec, myid, ounit, Ncoils, Ndof, t1E, iout, CG_maxiter, CG_xtol, xdof, &
exit_signal, tstart, tfinish
@@ -42,6 +42,7 @@ SUBROUTINE congrad
REAL :: alpha, beta, f
REAL, dimension(1:Ndof) :: lxdof, p, gradk, gradf
+ tfinish = MPI_Wtime()
iter = 0
call packdof(lxdof(1:Ndof)) ! initial xdof;
call getdf(lxdof, f, gradk)
@@ -94,6 +95,7 @@ SUBROUTINE congrad
return
END SUBROUTINE congrad
+#endif
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
@@ -104,9 +106,9 @@ SUBROUTINE wolfe( x0, p, alpha, iflag )
implicit none
include "mpif.h"
- REAL , INTENT( in) :: x0(1:Ndof), p(1:Ndof)
- INTEGER, INTENT(out) :: iflag
- REAL , INTENT(out) :: alpha
+ REAL , INTENT( in) :: x0(1:Ndof), p(1:Ndof)
+ INTEGER, INTENT(out) :: iflag
+ REAL , INTENT(inout) :: alpha
REAL :: zoom
INTEGER :: i, maxiter
@@ -264,3 +266,89 @@ SUBROUTINE getdf(lxdof, f, g)
return
END SUBROUTINE getdf
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+#ifndef oldcg
+
+SUBROUTINE congrad
+ use globals, only: dp, sqrtmachprec, myid, ounit, Ncoils, Ndof, t1E, iout, CG_maxiter, CG_xtol, xdof, &
+ exit_signal, tstart, tfinish
+ use mpi
+ implicit none
+
+ INTEGER :: ierr, astat, iter, n, nfunc, ngrad, status
+ REAL :: f, gnorm
+ REAL, dimension(1:Ndof) :: x, g, d, xtemp, gtemp
+ EXTERNAL :: myvalue, mygrad
+
+ tfinish = MPI_Wtime()
+ iter = 0
+ n = Ndof
+ call packdof(x(1:n)) ! initial xdof;
+ call cg_descent (CG_xtol, x, n, myvalue, mygrad, status, gnorm, f, iter, nfunc, ngrad, d, g, xtemp, gtemp)
+
+ !tstart = MPI_Wtime()
+ !call output(tstart-tfinish)
+
+ if (myid == 0) then
+ select case (status)
+ case (0)
+ write(ounit, '("congrad : status="I1": convergence tolerance satisfied.")') status
+ case (1)
+ write(ounit, '("congrad : status="I1": change in func <= feps*|f|.")') status
+ case (2)
+ write(ounit, '("congrad : status="I1": total iterations exceeded maxit.")') status
+ case (3)
+ write(ounit, '("congrad : status="I1": slope always negative in line search.")') status
+ case (4)
+ write(ounit, '("congrad : status="I1": number secant iterations exceed nsecant.")') status
+ case (5)
+ write(ounit, '("congrad : status="I1": search direction not a descent direction.")') status
+ case (6)
+ write(ounit, '("congrad : status="I1": line search fails in initial interval.")') status
+ case (7)
+ write(ounit, '("congrad : status="I1": line search fails during bisection.")') status
+ case (8)
+ write(ounit, '("congrad : status="I1": line search fails during interval update.")') status
+ case default
+ write(ounit, '("congrad : status="I1": unknow options!")') status
+ end select
+ end if
+
+ if(myid .eq. 0) write(ounit, '("congrad : Computation using conjugate gradient finished.")')
+
+ return
+END SUBROUTINE congrad
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-
+SUBROUTINE myvalue(f, x, n)
+ use globals, only: dp, myid, ounit, ierr, chi
+ implicit none
+ include "mpif.h"
+
+ INTEGER, INTENT(in) :: n
+ REAL, INTENT(in) :: x(n)
+ REAL, INTENT(out) :: f
+
+ call MPI_BARRIER( MPI_COMM_WORLD, ierr ) ! wait all cpus;
+ call unpacking(x)
+ call costfun(0)
+ f = chi
+ return
+
+END SUBROUTINE myvalue
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+SUBROUTINE mygrad(g, x, n)
+ use globals, only: dp, myid, ounit, ierr, t1E
+ implicit none
+ include "mpif.h"
+
+ INTEGER, INTENT(in) :: n
+ REAL, INTENT(in) :: x(n)
+ REAL, INTENT(out) :: g(n)
+
+ call MPI_BARRIER( MPI_COMM_WORLD, ierr ) ! wait all cpus;
+ call unpacking(x)
+ call costfun(1)
+ g = t1E
+END SUBROUTINE mygrad
+#endif
diff --git a/sources/datalloc.f90 b/sources/datalloc.f90
new file mode 100644
index 0000000..88c05bd
--- /dev/null
+++ b/sources/datalloc.f90
@@ -0,0 +1,324 @@
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+subroutine AllocData(type)
+!------------------------------------------------------------------------------------------------------
+! DATE: 04/05/2017
+! Allocate data before using them, especially for those used several times;
+! part can be : -1('dof'), 0('costfun0'), 1('costfun1')
+!------------------------------------------------------------------------------------------------------
+ use globals
+ use bnorm_mod
+ implicit none
+ include "mpif.h"
+
+ INTEGER, intent(in) :: type
+
+ INTEGER :: icoil, idof, ND, NF, icur, imag, isurf, NS, mm, iseg
+ REAL :: xtmp, mtmp, tt
+
+ isurf = plasma
+
+ !-------------------------------------------------------------------------------------------
+ if (type == -1) then ! dof related data;
+ Cdof = 0; Ndof = 0; Tdof = 0
+ do icoil = 1, Ncoils
+ select case (coil(icoil)%type)
+ case(1)
+ ! get number of DoF for each coil and allocate arrays;
+ NS = coil(icoil)%NS
+ NF = FouCoil(icoil)%NF
+ ND = (6*NF + 3) ! total variables for geometry
+ DoF(icoil)%ND = coil(icoil)%Lc * ND !# of DoF for icoil;
+ SALLOCATE(DoF(icoil)%xdof, (1:DoF(icoil)%ND), zero)
+ SALLOCATE(DoF(icoil)%xof , (0:coil(icoil)%NS-1, 1:ND), zero)
+ SALLOCATE(DoF(icoil)%yof , (0:coil(icoil)%NS-1, 1:ND), zero)
+ SALLOCATE(DoF(icoil)%zof , (0:coil(icoil)%NS-1, 1:ND), zero)
+ ! allocate and calculate trignometric functions for re-use
+ SALLOCATE( FouCoil(icoil)%cmt, (0:NS, 0:NF), zero )
+ SALLOCATE( FouCoil(icoil)%smt, (0:NS, 0:NF), zero )
+ do iseg = 0, NS
+ tt = iseg * pi2 / NS
+ do mm = 0, NF
+ FouCoil(icoil)%cmt(iseg,mm) = cos( mm * tt )
+ FouCoil(icoil)%smt(iseg,mm) = sin( mm * tt )
+ enddo
+ enddo
+
+!!$ ip = (icoil-1)/Ncoils ! the integer is the period number;
+!!$ DoF(icoil)%xof(0:NS-1, 1: NF+1) = cosip(ip) * cmt(0:NS-1, 0:NF) !x/xc
+!!$ DoF(icoil)%xof(0:NS-1, NF+2:2*NF+1) = cosip(ip) * smt(0:NS-1, 1:NF) !x/xs
+!!$ DoF(icoil)%xof(0:NS-1, 2*NF+2:3*NF+2) = -sinip(ip) * cmt(0:NS-1, 0:NF) !x/yc ; valid for ip>0 ;
+!!$ DoF(icoil)%xof(0:NS-1, 3*NF+3:4*NF+2) = -sinip(ip) * smt(0:NS-1, 1:NF) !x/ys ; valid for ip>0 ;
+!!$ DoF(icoil)%yof(0:NS-1, 1: NF+1) = sinip(ip) * cmt(0:NS-1, 0:NF) !y/xc ; valid for ip>0 ;
+!!$ DoF(icoil)%yof(0:NS-1, NF+2:2*NF+1) = sinip(ip) * smt(0:NS-1, 1:NF) !y/xs ; valid for ip>0 ;
+!!$ DoF(icoil)%yof(0:NS-1, 2*NF+2:3*NF+2) = cosip(ip) * cmt(0:NS-1, 0:NF) !y/yc
+!!$ DoF(icoil)%yof(0:NS-1, 3*NF+3:4*NF+2) = cosip(ip) * smt(0:NS-1, 1:NF) !y/ys
+!!$ DoF(icoil)%zof(0:NS-1, 4*NF+3:5*NF+3) = cmt(0:NS-1, 0:NF) !z/zc
+!!$ DoF(icoil)%zof(0:NS-1, 5*NF+4:6*NF+3) = smt(0:NS-1, 1:NF) !z/zs
+
+ ! the derivatives of dx/dv
+ DoF(icoil)%xof(0:NS-1, 1: NF+1) = FouCoil(icoil)%cmt(0:NS-1, 0:NF) !x/xc
+ DoF(icoil)%xof(0:NS-1, NF+2:2*NF+1) = FouCoil(icoil)%smt(0:NS-1, 1:NF) !x/xs
+ !DoF(icoil)%xof(0:NS-1, 2*NF+2:3*NF+2) = FouCoil(icoil)%cmt(0:NS-1, 0:NF) !x/yc
+ !DoF(icoil)%xof(0:NS-1, 3*NF+3:4*NF+2) = FouCoil(icoil)%smt(0:NS-1, 1:NF) !x/ys
+ !DoF(icoil)%yof(0:NS-1, 1: NF+1) = FouCoil(icoil)%cmt(0:NS-1, 0:NF) !y/xc
+ !DoF(icoil)%yof(0:NS-1, NF+2:2*NF+1) = FouCoil(icoil)%smt(0:NS-1, 1:NF) !y/xs
+ DoF(icoil)%yof(0:NS-1, 2*NF+2:3*NF+2) = FouCoil(icoil)%cmt(0:NS-1, 0:NF) !y/yc
+ DoF(icoil)%yof(0:NS-1, 3*NF+3:4*NF+2) = FouCoil(icoil)%smt(0:NS-1, 1:NF) !y/ys
+ DoF(icoil)%zof(0:NS-1, 4*NF+3:5*NF+3) = FouCoil(icoil)%cmt(0:NS-1, 0:NF) !z/zc
+ DoF(icoil)%zof(0:NS-1, 5*NF+4:6*NF+3) = FouCoil(icoil)%smt(0:NS-1, 1:NF) !z/zs
+ ! allocate xyz data
+ SALLOCATE( coil(icoil)%xx, (0:coil(icoil)%NS), zero )
+ SALLOCATE( coil(icoil)%yy, (0:coil(icoil)%NS), zero )
+ SALLOCATE( coil(icoil)%zz, (0:coil(icoil)%NS), zero )
+ SALLOCATE( coil(icoil)%xt, (0:coil(icoil)%NS), zero )
+ SALLOCATE( coil(icoil)%yt, (0:coil(icoil)%NS), zero )
+ SALLOCATE( coil(icoil)%zt, (0:coil(icoil)%NS), zero )
+ SALLOCATE( coil(icoil)%xa, (0:coil(icoil)%NS), zero )
+ SALLOCATE( coil(icoil)%ya, (0:coil(icoil)%NS), zero )
+ SALLOCATE( coil(icoil)%za, (0:coil(icoil)%NS), zero )
+ SALLOCATE( coil(icoil)%dl, (0:coil(icoil)%NS), zero )
+ SALLOCATE( coil(icoil)%dd, (0:coil(icoil)%NS), zero )
+ coil(icoil)%dd = pi2 / NS ! discretizing factor;
+ case(2)
+#ifdef dposition
+ DoF(icoil)%ND = coil(icoil)%Lc * 5 ! number of DoF for permanent magnet
+#else
+ DoF(icoil)%ND = coil(icoil)%Lc * 2 ! number of DoF for permanent magnet
+#endif
+ SALLOCATE(DoF(icoil)%xdof, (1:DoF(icoil)%ND), zero)
+ case(3)
+ DoF(icoil)%ND = coil(icoil)%Lc * 1 ! number of DoF for background Bt, Bz
+ SALLOCATE(DoF(icoil)%xdof, (1:DoF(icoil)%ND), zero)
+ case default
+ FATAL(AllocData, .true., not supported coil types)
+ end select
+
+ enddo
+
+ do icoil = 1, Ncoils
+
+ Ndof = Ndof + coil(icoil)%Ic + DoF(icoil)%ND
+ if (allocated(FouCoil)) then
+ Tdof = Tdof + 1 + 6*(FouCoil(icoil)%NF)+3
+ else
+ Tdof = Tdof + coil(icoil)%Ic + DoF(icoil)%ND
+ end if
+ if (DoF(icoil)%ND >= Cdof) Cdof = DoF(icoil)%ND ! find the largest ND for single coil;
+
+ enddo
+
+ if(Ndof == 0) then ! no DOF;
+ Nouts = 0
+ if(myid==0) write(ounit, *) "AllocData : No free variables; no optimization will be performed."
+ endif
+
+ SALLOCATE( xdof, (1:Ndof), zero ) ! dof vector;
+ SALLOCATE( dofnorm, (1:Ndof), one ) ! dof normalized value vector;
+ SALLOCATE( evolution, (1:Nouts+1, 0:7), zero ) !evolution array;
+ SALLOCATE( coilspace, (1:Nouts+1, 1:Tdof), zero ) ! all the coil parameters;
+
+ ! determine dofnorm
+ if ( IsNormalize > 0 ) then
+ ! calculate Inorm and Gnorm
+ Inorm = zero ; Mnorm = zero
+ icur = 0 ; imag = 0 ! icur for coil current count, imag for dipole count
+ do icoil = 1, Ncoils
+ if(coil(icoil)%type == 1 .or. coil(icoil)%type == 3 ) then
+ ! Fourier representation or central currents
+ Inorm = Inorm + coil(icoil)%I**2
+ icur = icur + 1
+ else if (coil(icoil)%type == 2) then
+ ! permanent dipole
+ Mnorm = Mnorm + coil(icoil)%I**2
+ imag = imag + 1
+ endif
+ enddo
+ Gnorm = (surf(plasma)%vol/(pi*pi2))**(one/three) ! Gnorm is a hybrid of major and minor radius
+ Gnorm = Gnorm * weight_gnorm
+
+ icur = max(1, icur) ; imag = max(1, imag) ! avoid dividing zero
+ Inorm = sqrt(Inorm/icur) * weight_inorm ! quadratic mean
+ Mnorm = sqrt(Mnorm/imag) * weight_mnorm ! quadratic mean
+
+ if (abs(Gnorm) < machprec) Gnorm = one
+ if (abs(Inorm) < machprec) Inorm = one
+ if (abs(Mnorm) < machprec) Mnorm = one
+
+ if (IsQuiet<1) then
+ if (myid==0) then
+ write(ounit, '(8X": Parameter normalizations : "3(A6, ES12.5, 2X))') &
+ 'Inorm=', Inorm, 'Gnorm=', Gnorm, 'Mnorm=', Mnorm
+ endif
+ endif
+
+ ! construct dofnorm
+ idof = 0
+ do icoil = 1, Ncoils
+
+ if(coil(icoil)%type == 1) then ! Fourier representation
+ if(coil(icoil)%Ic /= 0) then
+ dofnorm(idof+1) = Inorm
+ idof = idof + 1
+ endif
+
+ ND = DoF(icoil)%ND
+ if(coil(icoil)%Lc /= 0) then
+ dofnorm(idof+1:idof+ND) = Gnorm
+ idof = idof + ND
+ endif
+ else if (coil(icoil)%type == 2) then ! permanent magnets
+ if(coil(icoil)%Ic /= 0) then
+ dofnorm(idof+1) = Mnorm
+ idof = idof + 1
+ endif
+ if(coil(icoil)%Lc /= 0) then
+ !xtmp = max(one, sqrt( coil(icoil)%ox**2 + coil(icoil)%oy**2 + coil(icoil)%oz**2 ) ) ! origin position
+ !mtmp = max(one, sqrt( coil(icoil)%mp**2 + coil(icoil)%mt**2 ) ) ! moment orentation
+ xtmp = Gnorm ! position normalized to Gnorm
+ mtmp = pi ! orentation normalized to pi
+#ifdef dposition
+ dofnorm(idof+1:idof+3) = xtmp
+ dofnorm(idof+4:idof+5) = mtmp
+ idof = idof + 5
+#else
+ dofnorm(idof+1:idof+2) = mtmp
+ idof = idof + 2
+#endif
+ endif
+ else if (coil(icoil)%type == 3) then ! backgroud toroidal/vertical field
+ if(coil(icoil)%Ic /= 0) then
+ dofnorm(idof+1) = Inorm
+ idof = idof + 1
+ endif
+
+ if(coil(icoil)%Lc /= 0) then
+ if(abs(coil(icoil)%Bz) > sqrtmachprec) then
+ dofnorm(idof+1) = coil(icoil)%Bz
+ else
+ dofnorm(idof+1) = one
+ endif
+ idof = idof + 1
+ endif
+ else
+ STOP " wrong coil type in rdcoils"
+ call MPI_ABORT(MPI_COMM_WORLD, 1, ierr)
+ endif
+
+ enddo !end do icoil;
+ FATAL( AllocData , idof .ne. Ndof, counting error in unpacking )
+
+ endif
+
+ endif
+
+ !---------------------------------------------------------------------------------------------
+ if (type == 0 .or. type == 1) then ! 0-order cost functions related arrays;
+
+ ! Bnorm and Bharm needed;
+ if (weight_bnorm > sqrtmachprec .or. weight_bharm > sqrtmachprec .or. IsQuiet <= -2) then
+ SALLOCATE( bn, (0:Nteta-1,0:Nzeta-1), zero ) ! Bn from coils;
+ SALLOCATE( surf(isurf)%bn, (0:Nteta-1,0:Nzeta-1), zero ) ! total Bn;
+ SALLOCATE( surf(isurf)%Bx, (0:Nteta-1,0:Nzeta-1), zero ) ! Bx on the surface;
+ SALLOCATE( surf(isurf)%By, (0:Nteta-1,0:Nzeta-1), zero ) ! By on the surface;
+ SALLOCATE( surf(isurf)%Bz, (0:Nteta-1,0:Nzeta-1), zero ) ! Bz on the surface;
+ SALLOCATE( Bm, (0:Nteta-1,0:Nzeta-1), zero ) ! |B| on the surface;
+ SALLOCATE( dBx, (0:Cdof,0:Cdof), zero ) ! d^2Bx/(dx1,dx2) on each coil; Cdof is the max coil dof
+ SALLOCATE( dBy, (0:Cdof,0:Cdof), zero ) ! d^2By/(dx1,dx2) on each coil;
+ SALLOCATE( dBz, (0:Cdof,0:Cdof), zero ) ! d^2Bz/(dx1,dx2) on each coil;
+ endif
+
+ ! Bharm needed;
+ if (weight_bharm > sqrtmachprec) then
+ call readbmn
+ SALLOCATE( Bmnc , (1:NBmn), zero ) ! current Bmn cos values;
+ SALLOCATE( Bmns , (1:NBmn), zero ) ! current Bmn sin values;
+ SALLOCATE( iBmnc , (1:NBmn), zero )
+ SALLOCATE( iBmns , (1:NBmn), zero )
+ endif
+
+ endif
+
+ !---------------------------------------------------------------------------------------------
+ if (type == 1) then ! 1st-order cost functions related arrays;
+
+ FATAL( AllocData, Ndof < 1, INVALID Ndof value )
+ SALLOCATE( t1E, (1:Ndof), zero )
+ SALLOCATE( deriv, (1:Ndof, 0:6), zero )
+
+ ! Bnorm related;
+ if (weight_bnorm > sqrtmachprec .or. weight_bharm > sqrtmachprec) then
+ SALLOCATE( t1B, (1:Ndof), zero ) !total d bnorm / d x;
+ SALLOCATE( dBn, (1:Ndof), zero ) !total d Bn / d x;
+ SALLOCATE( dBm, (1:Ndof), zero ) !total d Bm / d x;
+ SALLOCATE( d1B, (1:Ndof,0:Nteta-1,0:Nzeta-1), zero ) ! discretized dBn
+ endif
+
+ ! Bharm related;
+ if (weight_bharm > sqrtmachprec) then
+ SALLOCATE( t1H, (1:Ndof), zero )
+! SALLOCATE( dB , (1:Ndof, 0:Nteta-1, 0:Nzeta-1), zero ) !distribution of dB/dx;
+ endif
+
+ ! tflux needed;
+ if (weight_tflux > sqrtmachprec) then
+ SALLOCATE( t1F, (1:Ndof), zero )
+ endif
+
+ ! ttlen needed;
+ if (weight_ttlen > sqrtmachprec) then
+ SALLOCATE( t1L, (1:Ndof), zero )
+ endif
+
+ ! cssep needed;
+ if (weight_cssep > sqrtmachprec) then
+ SALLOCATE( t1S, (1:Ndof), zero )
+ endif
+
+ ! L-M algorithn enabled
+ if (LM_maxiter > 0) then
+ LM_mfvec = 0 ! number of total cost functions
+
+ if (weight_bnorm > sqrtmachprec) then
+ ibnorm = LM_mfvec
+ mbnorm = Nteta*Nzeta
+ LM_mfvec = LM_mfvec + mbnorm
+ endif
+
+ if (weight_bharm > sqrtmachprec) then
+ ibharm = LM_mfvec
+ mbharm = 2*NBmn
+ LM_mfvec = LM_mfvec + mbharm
+ endif
+
+ if (weight_tflux > sqrtmachprec) then
+ itflux = LM_mfvec
+ mtflux = Nzeta
+ LM_mfvec = LM_mfvec + mtflux
+ endif
+
+ if (weight_ttlen > sqrtmachprec) then
+ ittlen = LM_mfvec
+ mttlen = Ncoils - Nfixgeo
+ LM_mfvec = LM_mfvec + mttlen
+ endif
+
+ if (weight_cssep > sqrtmachprec) then
+ icssep = LM_mfvec
+ mcssep = Ncoils - Nfixgeo
+ LM_mfvec = LM_mfvec + mcssep
+ endif
+
+ FATAL( AllocData, LM_mfvec <= 0, INVALID number of cost functions )
+ SALLOCATE( LM_fvec, (1:LM_mfvec), zero )
+ SALLOCATE( LM_fjac , (1:LM_mfvec, 1:Ndof), zero )
+
+ if (myid == 0) write(ounit, '("datalloc: total number of cost functions for L-M is "I0)') LM_mfvec
+
+ endif
+
+ endif
+ !---------------------------------------------------------------------------------------------
+
+ return
+end subroutine AllocData
diff --git a/sources/datalloc.h b/sources/datalloc.h
deleted file mode 100644
index 59c13c7..0000000
--- a/sources/datalloc.h
+++ /dev/null
@@ -1,179 +0,0 @@
-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
-subroutine AllocData(itype)
-!------------------------------------------------------------------------------------------------------
-! DATE: 04/05/2017
-! Allocate data before using them, especially for those used several times;
-! part can be : -1('dof'), 0('costfun0'), 1('costfun1')
-!------------------------------------------------------------------------------------------------------
- use globals
- implicit none
- include "mpif.h"
-
- INTEGER, intent(in) :: itype
-
- INTEGER :: icoil, idof, ND, NF
-
- !-------------------------------------------------------------------------------------------
- if (itype == -1) then ! dof related data;
-
- Cdof = 0; Ndof = 0; Tdof = 0
-
- do icoil = 1, Ncoils*Npc
-
- select case (coil(icoil)%itype)
- case(1)
- ! get number of DoF for each coil and allocate arrays;
- NF = FouCoil(icoil)%NF
- ND = (6*NF + 3) ! total variables for geometry
- DoF(icoil)%ND = coil(icoil)%Lc * ND !# of DoF for icoil;
- SALLOCATE(DoF(icoil)%xdof, (1:DoF(icoil)%ND), zero)
- SALLOCATE(DoF(icoil)%xof , (0:coil(icoil)%NS-1, 1:ND), zero)
- SALLOCATE(DoF(icoil)%yof , (0:coil(icoil)%NS-1, 1:ND), zero)
- SALLOCATE(DoF(icoil)%zof , (0:coil(icoil)%NS-1, 1:ND), zero)
- case default
- FATAL(AllocData, .true., not supported coil types)
- end select
-
- enddo
-
- do icoil = 1, Ncoils
-
- Ndof = Ndof + coil(icoil)%Ic + DoF(icoil)%ND
- Tdof = Tdof + 1 + 6*(FouCoil(icoil)%NF)+3
- if (DoF(icoil)%ND >= Cdof) Cdof = DoF(icoil)%ND ! find the largest ND for single coil;
-
- enddo
-
- if(Ndof == 0) then ! no DOF;
- Nouts = 0
- if(myid==0) write(ounit, *) "AllocData : No free variables; no optimization will be performed."
- endif
-
- SALLOCATE( xdof, (1:Ndof), zero ) ! dof vector;
- SALLOCATE( dofnorm, (1:Ndof), zero ) ! dof normalized value vector;
- SALLOCATE( evolution, (1:Nouts+1, 0:7), zero ) !evolution array;
- SALLOCATE( coilspace, (1:Nouts+1, 1:Tdof), zero ) ! all the coil parameters;
-
- idof = 0
- do icoil = 1, Ncoils
-
- if(coil(icoil)%Ic /= 0) then
- dofnorm(idof+1) = Inorm
- idof = idof + 1
- endif
-
- ND = DoF(icoil)%ND
- if(coil(icoil)%Lc /= 0) then
- dofnorm(idof+1:idof+ND) = Gnorm
- idof = idof + ND
- endif
-
- enddo !end do icoil;
- FATAL( AllocData , idof .ne. Ndof, counting error in unpacking )
-
- endif
-
- !---------------------------------------------------------------------------------------------
- if (itype == 0 .or. itype == 1) then ! 0-order cost functions related arrays;
-
- ! Bnorm and Bharm needed;
- if (weight_bnorm > sqrtmachprec .or. weight_bharm > sqrtmachprec .or. IsQuiet <= -2) then
- SALLOCATE( bn, (0:Nteta-1,0:Nzeta-1), zero ) !Bn from coils;
- SALLOCATE( surf(1)%bn, (0:Nteta-1,0:Nzeta-1), zero ) !total Bn;
- SALLOCATE( surf(1)%Bx, (0:Nteta-1,0:Nzeta-1), zero ) !Bx on the surface;
- SALLOCATE( surf(1)%By, (0:Nteta-1,0:Nzeta-1), zero ) !By on the surface;
- SALLOCATE( surf(1)%Bz, (0:Nteta-1,0:Nzeta-1), zero ) !Bz on the surface;
- endif
-
- ! Bharm needed;
- if (weight_bharm > sqrtmachprec) then
- call readbmn
- SALLOCATE( Bmnc , (1:NBmn), zero ) ! current Bmn cos values;
- SALLOCATE( Bmns , (1:NBmn), zero ) ! current Bmn sin values;
- SALLOCATE( iBmnc , (1:NBmn), zero )
- SALLOCATE( iBmns , (1:NBmn), zero )
- endif
-
- endif
-
- !---------------------------------------------------------------------------------------------
- if (itype == 1) then ! 1st-order cost functions related arrays;
-
- FATAL( AllocData, Ndof < 1, INVALID Ndof value )
- SALLOCATE( t1E, (1:Ndof), zero )
- SALLOCATE( deriv, (1:Ndof, 0:6), zero )
-
- ! Bnorm related;
- if (weight_bnorm > sqrtmachprec .or. weight_bharm > sqrtmachprec) then
- SALLOCATE( t1B, (1:Ndof), zero ) !total dB/dx;
- endif
-
- ! Bharm related;
- if (weight_bharm > sqrtmachprec) then
- SALLOCATE( t1H, (1:Ndof), zero )
-! SALLOCATE( dB , (1:Ndof, 0:Nteta-1, 0:Nzeta-1), zero ) !distribution of dB/dx;
- endif
-
- ! tflux needed;
- if (weight_tflux > sqrtmachprec) then
- SALLOCATE( t1F, (1:Ndof), zero )
- endif
-
- ! ttlen needed;
- if (weight_ttlen > sqrtmachprec) then
- SALLOCATE( t1L, (1:Ndof), zero )
- endif
-
- ! cssep needed;
- if (weight_cssep > sqrtmachprec) then
- SALLOCATE( t1S, (1:Ndof), zero )
- endif
-
- ! L-M algorithn enabled
- if (LM_maxiter > 0) then
- LM_mfvec = 0 ! number of total cost functions
-
- if (weight_bnorm > sqrtmachprec) then
- ibnorm = LM_mfvec
- mbnorm = Nteta*Nzeta
- LM_mfvec = LM_mfvec + mbnorm
- endif
-
- if (weight_bharm > sqrtmachprec) then
- ibharm = LM_mfvec
- mbharm = 2*NBmn
- LM_mfvec = LM_mfvec + mbharm
- endif
-
- if (weight_tflux > sqrtmachprec) then
- itflux = LM_mfvec
- mtflux = Nzeta
- LM_mfvec = LM_mfvec + mtflux
- endif
-
- if (weight_ttlen > sqrtmachprec) then
- ittlen = LM_mfvec
- mttlen = Ncoils - Nfixgeo
- LM_mfvec = LM_mfvec + mttlen
- endif
-
- if (weight_cssep > sqrtmachprec) then
- icssep = LM_mfvec
- mcssep = Ncoils - Nfixgeo
- LM_mfvec = LM_mfvec + mcssep
- endif
-
- FATAL( AllocData, LM_mfvec <= 0, INVALID number of cost functions )
- SALLOCATE( LM_fvec, (1:LM_mfvec), zero )
- SALLOCATE( LM_fjac , (1:LM_mfvec, 1:Ndof), zero )
-
- if (myid == 0) write(ounit, '("datalloc: total number of cost functions for L-M is "I0)') LM_mfvec
-
- endif
-
- endif
- !---------------------------------------------------------------------------------------------
-
- return
-end subroutine AllocData
diff --git a/sources/descent.h b/sources/descent.f90
similarity index 100%
rename from sources/descent.h
rename to sources/descent.f90
diff --git a/sources/diagnos.h b/sources/diagnos.f90
similarity index 68%
rename from sources/diagnos.h
rename to sources/diagnos.f90
index 73f8380..59a5d0c 100644
--- a/sources/diagnos.h
+++ b/sources/diagnos.f90
@@ -7,17 +7,21 @@ SUBROUTINE diagnos
!------------------------------------------------------------------------------------------------------
use globals, only: dp, zero, one, myid, ounit, sqrtmachprec, IsQuiet, case_optimize, coil, surf, Ncoils, &
Nteta, Nzeta, bnorm, bharm, tflux, ttlen, specw, ccsep, coilspace, FouCoil, iout, Tdof, case_length, &
- cssep, Bmnc, Bmns, tBmnc, tBmns, weight_bharm, coil_importance, Npc, weight_bnorm, overlap
-
+ cssep, Bmnc, Bmns, tBmnc, tBmns, weight_bharm, coil_importance, Nfp, weight_bnorm, overlap, plasma, &
+ cosnfp, sinnfp, symmetry, discretefactor
+ use mpi
implicit none
- include "mpif.h"
- INTEGER :: icoil, itmp, astat, ierr, NF, idof, i, j
- LOGICAL :: lwbnorm = .True. , l_raw = .False.!if use raw coils data
+ INTEGER :: icoil, itmp, astat, ierr, NF, idof, i, j, isurf, cs, ip, is, Npc
+ LOGICAL :: lwbnorm, l_raw
REAL :: MaxCurv, AvgLength, MinCCdist, MinCPdist, tmp_dist, ReDot, ImDot
REAL, parameter :: infmax = 1.0E6
REAL, allocatable :: Atmp(:,:), Btmp(:,:)
+ isurf = plasma
+ itmp = 0
+ lwbnorm = .True.
+ l_raw = .False. ! if use raw coils data
if (myid == 0 .and. IsQuiet < 0) write(ounit, *) "-----------COIL DIAGNOSTICS----------------------------------"
!--------------------------------cost functions-------------------------------------------------------
@@ -34,7 +38,7 @@ SUBROUTINE diagnos
do icoil = 1, Ncoils
coilspace(iout, idof+1 ) = coil(icoil)%I ; idof = idof + 1
- select case (coil(icoil)%itype)
+ select case (coil(icoil)%type)
case (1)
NF = FouCoil(icoil)%NF
coilspace(iout, idof+1:idof+NF+1) = FouCoil(icoil)%xc(0:NF) ; idof = idof + NF +1
@@ -43,16 +47,17 @@ SUBROUTINE diagnos
coilspace(iout, idof+1:idof+NF ) = FouCoil(icoil)%ys(1:NF) ; idof = idof + NF
coilspace(iout, idof+1:idof+NF+1) = FouCoil(icoil)%zc(0:NF) ; idof = idof + NF +1
coilspace(iout, idof+1:idof+NF ) = FouCoil(icoil)%zs(1:NF) ; idof = idof + NF
- case default
- FATAL(descent, .true., not supported coil types)
+!!$ case default
+!!$ FATAL(descent, .true., not supported coil types)
end select
enddo
- FATAL( output , idof .ne. Tdof, counting error in restart )
+!!$ FATAL( output , idof .ne. Tdof, counting error in restart )
endif
!-------------------------------coil maximum curvature----------------------------------------------------
MaxCurv = zero
do icoil = 1, Ncoils
+ if(coil(icoil)%type .ne. 1) exit ! only for Fourier
call curvature(icoil)
if (coil(icoil)%maxcurv .ge. MaxCurv) then
MaxCurv = coil(icoil)%maxcurv
@@ -71,6 +76,7 @@ SUBROUTINE diagnos
if ( (case_length == 1) .and. (sum(coil(1:Ncoils)%Lo) < sqrtmachprec) ) coil(1:Ncoils)%Lo = one
call length(0)
do icoil = 1, Ncoils
+ if(coil(icoil)%type .ne. 1) exit ! only for Fourier
AvgLength = AvgLength + coil(icoil)%L
enddo
AvgLength = AvgLength / Ncoils
@@ -80,29 +86,48 @@ SUBROUTINE diagnos
! coils are supposed to be placed in order
minCCdist = infmax
do icoil = 1, Ncoils
-
- if(Ncoils .eq. 1) exit !if only one coil
- itmp = icoil + 1
- if(icoil .eq. Ncoils) itmp = 1
-
+ if(coil(icoil)%type .ne. 1) exit ! only for Fourier
+ if(Ncoils .eq. 1) exit ! if only one coil
+ ! Data for the first coil
SALLOCATE(Atmp, (1:3,0:coil(icoil)%NS-1), zero)
- SALLOCATE(Btmp, (1:3,0:coil(itmp )%NS-1), zero)
-
Atmp(1, 0:coil(icoil)%NS-1) = coil(icoil)%xx(0:coil(icoil)%NS-1)
Atmp(2, 0:coil(icoil)%NS-1) = coil(icoil)%yy(0:coil(icoil)%NS-1)
Atmp(3, 0:coil(icoil)%NS-1) = coil(icoil)%zz(0:coil(icoil)%NS-1)
-
- Btmp(1, 0:coil(itmp )%NS-1) = coil(itmp)%xx(0:coil(itmp )%NS-1)
- Btmp(2, 0:coil(itmp )%NS-1) = coil(itmp)%yy(0:coil(itmp )%NS-1)
- Btmp(3, 0:coil(itmp )%NS-1) = coil(itmp)%zz(0:coil(itmp )%NS-1)
-
- call mindist(Atmp, coil(icoil)%NS, Btmp, coil(itmp)%NS, tmp_dist)
-
- if (minCCdist .ge. tmp_dist) minCCdist=tmp_dist
-
+ do itmp = 1, Ncoils
+ ! skip self and non-Fourier coils
+ if (itmp == icoil .or. coil(icoil)%type /= 1) cycle
+ SALLOCATE(Btmp, (1:3,0:coil(itmp )%NS-1), zero)
+ ! check if the coil is stellarator symmetric
+ select case (coil(icoil)%symm)
+ case ( 0 )
+ cs = 0
+ Npc = 1
+ case ( 1 )
+ cs = 0
+ Npc = Nfp
+ case ( 2)
+ cs = 1
+ Npc = Nfp
+ end select
+ ! periodicity and stellarator symmetry
+ do ip = 1, Npc
+ do is = 0, cs
+ Btmp(1, 0:coil(itmp)%NS-1) = (coil(itmp)%xx(0:coil(itmp)%NS-1)*cosnfp(ip) &
+ & - coil(itmp)%yy(0:coil(itmp)%NS-1)*sinnfp(ip) )
+ Btmp(2, 0:coil(itmp)%NS-1) = (-1)**is * (coil(itmp)%xx(0:coil(itmp)%NS-1)*sinnfp(ip) &
+ & + coil(itmp)%yy(0:coil(itmp)%NS-1)*cosnfp(ip) )
+ Btmp(3, 0:coil(itmp)%NS-1) = (-1)**is * (coil(itmp)%zz(0:coil(itmp)%NS-1))
+ call mindist(Atmp, coil(icoil)%NS, Btmp, coil(itmp)%NS, tmp_dist)
+#ifdef DEBUG
+ if(myid .eq. 0) write(ounit, '(8X": distance between "I3.3"-th and "I3.3"-th coil (ip="I2.2 &
+ ", is="I1") is : " ES23.15)') icoil, itmp, ip, is, tmp_dist
+#endif
+ if (minCCdist .ge. tmp_dist) minCCdist=tmp_dist
+ enddo
+ enddo
+ DALLOCATE(Btmp)
+ enddo
DALLOCATE(Atmp)
- DALLOCATE(Btmp)
-
enddo
if(myid .eq. 0) write(ounit, '(8X": The minimum coil-coil distance is "4X" :" ES23.15)') minCCdist
@@ -111,6 +136,8 @@ SUBROUTINE diagnos
minCPdist = infmax
do icoil = 1, Ncoils
+ if(coil(icoil)%type .ne. 1) exit ! only for Fourier
+
SALLOCATE(Atmp, (1:3,0:coil(icoil)%NS-1), zero)
SALLOCATE(Btmp, (1:3,1:(Nteta*Nzeta)), zero)
@@ -118,9 +145,9 @@ SUBROUTINE diagnos
Atmp(2, 0:coil(icoil)%NS-1) = coil(icoil)%yy(0:coil(icoil)%NS-1)
Atmp(3, 0:coil(icoil)%NS-1) = coil(icoil)%zz(0:coil(icoil)%NS-1)
- Btmp(1, 1:(Nteta*Nzeta)) = reshape(surf(1)%xx(0:Nteta-1, 0:Nzeta-1), (/Nteta*Nzeta/))
- Btmp(2, 1:(Nteta*Nzeta)) = reshape(surf(1)%yy(0:Nteta-1, 0:Nzeta-1), (/Nteta*Nzeta/))
- Btmp(3, 1:(Nteta*Nzeta)) = reshape(surf(1)%zz(0:Nteta-1, 0:Nzeta-1), (/Nteta*Nzeta/))
+ Btmp(1, 1:(Nteta*Nzeta)) = reshape(surf(isurf)%xx(0:Nteta-1, 0:Nzeta-1), (/Nteta*Nzeta/))
+ Btmp(2, 1:(Nteta*Nzeta)) = reshape(surf(isurf)%yy(0:Nteta-1, 0:Nzeta-1), (/Nteta*Nzeta/))
+ Btmp(3, 1:(Nteta*Nzeta)) = reshape(surf(isurf)%zz(0:Nteta-1, 0:Nzeta-1), (/Nteta*Nzeta/))
call mindist(Atmp, coil(icoil)%NS, Btmp, Nteta*Nzeta, tmp_dist)
@@ -154,26 +181,34 @@ SUBROUTINE diagnos
endif
!--------------------------------calculate the average Bn error-------------------------------
- if (allocated(surf(1)%bn)) then
+ if (allocated(surf(isurf)%bn)) then
! \sum{ |Bn| / |B| }/ (Nt*Nz)
- if(myid .eq. 0) write(ounit, '(8X": Average relative absolute Bn error is :" ES23.15)') &
- sum(abs(surf(1)%bn/sqrt(surf(1)%Bx**2 + surf(1)%By**2 + surf(1)%Bz**2))) / (Nzeta*Nzeta)
+ if(myid .eq. 0) then
+ write(ounit, '(8X": Ave. relative absolute Bn error |Bn|/B : " ES12.5"; max(|Bn|)="ES12.5)') &
+ sum(abs(surf(plasma)%bn/sqrt(surf(plasma)%Bx**2+surf(plasma)%By**2+surf(plasma)%Bz**2))) &
+ / (Nteta*Nzeta), maxval(abs(surf(plasma)%bn))
+ write(ounit, '(8X": Surface area normalized Bn error int(|Bn|/B*ds)/A : "ES23.15)') &
+ sum(abs(surf(plasma)%bn)/sqrt(surf(plasma)%Bx**2+surf(plasma)%By**2+surf(plasma)%Bz**2) &
+ *surf(plasma)%ds)*discretefactor/(surf(plasma)%area/(Nfp*2**symmetry))
+ endif
endif
+ return
+
!--------------------------------calculate coil importance------------------------------------
if (.not. allocated(coil_importance)) then
- SALLOCATE( coil_importance, (1:Ncoils*Npc), zero )
+ SALLOCATE( coil_importance, (1:Ncoils), zero )
endif
if (weight_bnorm > sqrtmachprec .or. weight_bharm > sqrtmachprec) then ! make sure data_allocated
- do icoil = 1, Ncoils*Npc
+ do icoil = 1, Ncoils
call importance(icoil)
enddo
if(myid .eq. 0) write(ounit, '(8X": The most and least important coils are : " &
- F8.3"% at coil" I4 " ; " F8.3"% at coil "I4)') &
- 100*maxval(coil_importance), maxloc(coil_importance), &
- 100*minval(coil_importance), minloc(coil_importance)
+ ES12.5" at coil" I4 " ; " ES12.5" at coil "I4)') &
+ maxval(coil_importance), maxloc(coil_importance), &
+ minval(coil_importance), minloc(coil_importance)
endif
!---------------------------------------------------------------------------------------------
@@ -244,47 +279,39 @@ end subroutine mindist
subroutine importance(icoil)
use globals, only: dp, zero, pi2, ncpu, astat, ierr, myid, ounit, coil, NFcoil, Nseg, Ncoils, &
- surf, Nteta, Nzeta, bsconstant, coil_importance
+ surf, Nteta, Nzeta, bsconstant, coil_importance, plasma
implicit none
include "mpif.h"
INTEGER, INTENT(in) :: icoil
- INTEGER :: iteta, jzeta, NumGrid
+ INTEGER :: iteta, jzeta, NumGrid, isurf
REAL :: dBx, dBy, dBz
- REAL, dimension(0:Nteta-1, 0:Nzeta-1) :: lbx, lby, lbz ! local Bx, By and Bz
REAL, dimension(0:Nteta-1, 0:Nzeta-1) :: tbx, tby, tbz ! summed Bx, By and Bz
!--------------------------initialize and allocate arrays-------------------------------------
+ isurf = plasma
NumGrid = Nteta*Nzeta
- lbx = zero; lby = zero; lbz = zero !already allocted; reset to zero;
tbx = zero; tby = zero; tbz = zero !already allocted; reset to zero;
do jzeta = 0, Nzeta - 1
do iteta = 0, Nteta - 1
if( myid.ne.modulo(jzeta*Nteta+iteta,ncpu) ) cycle ! parallelization loop;
- call bfield0(icoil, iteta, jzeta, lbx(iteta, jzeta), lby(iteta, jzeta), lbz(iteta, jzeta))
+ call bfield0(icoil, surf(isurf)%xx(iteta, jzeta), surf(isurf)%yy(iteta, jzeta), &
+ & surf(isurf)%zz(iteta, jzeta), tbx(iteta, jzeta), tby(iteta, jzeta), tbz(iteta, jzeta))
enddo ! end do iteta
enddo ! end do jzeta
call MPI_BARRIER( MPI_COMM_WORLD, ierr )
- call MPI_REDUCE( lbx, tbx, NumGrid, MPI_DOUBLE_PRECISION, MPI_SUM, 0, MPI_COMM_WORLD, ierr )
- call MPI_REDUCE( lby, tby, NumGrid, MPI_DOUBLE_PRECISION, MPI_SUM, 0, MPI_COMM_WORLD, ierr )
- call MPI_REDUCE( lbz, tbz, NumGrid, MPI_DOUBLE_PRECISION, MPI_SUM, 0, MPI_COMM_WORLD, ierr )
-
- RlBCAST( tbx, NumGrid, 0 ) ! total Bx from icoil;
- RlBCAST( tby, NumGrid, 0 ) ! total By from icoil;
- RlBCAST( tbz, NumGrid, 0 ) ! total Bz from icoil;
-
- tbx = tbx * coil(icoil)%I * bsconstant
- tby = tby * coil(icoil)%I * bsconstant
- tbz = tbz * coil(icoil)%I * bsconstant
+ call MPI_ALLREDUCE( MPI_IN_PLACE, tbx, NumGrid, MPI_DOUBLE_PRECISION, MPI_SUM, 0, MPI_COMM_WORLD, ierr )
+ call MPI_ALLREDUCE( MPI_IN_PLACE, tby, NumGrid, MPI_DOUBLE_PRECISION, MPI_SUM, 0, MPI_COMM_WORLD, ierr )
+ call MPI_ALLREDUCE( MPI_IN_PLACE, tbz, NumGrid, MPI_DOUBLE_PRECISION, MPI_SUM, 0, MPI_COMM_WORLD, ierr )
- coil_importance(icoil) = sum( (tbx*surf(1)%Bx + tby*surf(1)%By + tbz*surf(1)%Bz) / &
- (surf(1)%Bx**2 + surf(1)%By**2 + surf(1)%Bz**2) ) / NumGrid
+ coil_importance(icoil) = sum( (tbx*surf(isurf)%Bx + tby*surf(isurf)%By + tbz*surf(isurf)%Bz) / &
+ (surf(isurf)%Bx**2 + surf(isurf)%By**2 + surf(isurf)%Bz**2) ) / NumGrid
return
diff --git a/sources/fdcheck.h b/sources/fdcheck.f90
similarity index 100%
rename from sources/fdcheck.h
rename to sources/fdcheck.f90
diff --git a/sources/focus.h b/sources/focus.f90
similarity index 55%
rename from sources/focus.h
rename to sources/focus.f90
index eaf628f..ee7c640 100644
--- a/sources/focus.h
+++ b/sources/focus.f90
@@ -16,64 +16,11 @@
!latex coils using space curves (either Fundamental theorem of space curves or Fourier series or other
!latex representations.). And for the first time, the derivatives (both the first and the second ones)
!latex are analytically calculated. \par
-
-!latex Parts of the code were first written by
-!latex \href{http://w3.pppl.gov/~shudson/}{\blu{Dr. Stuart R. Hudson}} in April 2016.
-!latex Then Caoxiang Zhu (CZHU) took over the whole project and it's currently under developping.
+!latex For more information, please visti \href{https://princetonuniversity.github.io/FOCUS/}
!latex If you have any questions, please send a email to czhu@pppl.gov (or zcxiang@mail.ustc.edu.cn).
-!latex \subsection{Update Diary}
-!latex 2015/10/30: Dr. Stuart Hudson wrote the code {\bf OPTIM} using
-!latex \nag{http://www.nag.co.uk/numeric/FL/manual19/pdf/E04/e04jyf_fl19.pdf}{E04JYF} to find the
-!latex optimal Fourier series for coils on a given winding surface. \par
-!latex 2016/04/xx: New code {\bf KNOTOPT} that represents coils using 3D Fourier series was written.\par
-!latex 2016/04/21: CZHU began to join the project and mainly took over the project. \par
-!latex 2016/xx/xx: A lot of new stuffs were added in but not well documented. \par
-!latex 2016/11/01: The code was renmaed to FOCUS and a poster was presented by CZHU at the APS-DPP
-!latex meeting in San Jose, CA. \par
-!latex 2017/02/15: A re-writing for debugging and better structure began by CZHU. \par
-!latex 2017/04/04: The code repository was tranported to Princeton University @ GitHub \par
-!latex 2017/05/15: Nonlinear Conjugate Gradient method was implemented. \par
-!latex 2017/05/20: Truncated Newton Method with Preconditioning CG method was implemented.\par
-!latex 2017/06/04: The first paper introducing FOCUS was submitted to Nuclear Fusion. \par
-!latex 2017/06/07: Hybrid Newton method was implemented. \par
-!latex 2017/06/23: NAG and OCULUS dependance have been removed in the new code.\par
-!latex 2017/07/18: Enable field periodicity and add coil diagnostic part. \par
-!latex 2018/06/19: Update diary in this doc will not be 'updated' any more. Please view the website. \par
-
-!!$!latex \subsection{Structure of the code}
-!!$!latex \begin{tikzpicture}[node distance=2cm, auto]
-!!$!latex \node [block] (start) {Main program in \link{focus}};
-!!$!latex \node [io, below of=start] (input) {read input in \link{initial} \& allocate data in \link{datalloc}};
-!!$!latex \node [io, below of=input] (surface) {read \& discretize surface data in \link{rdsurf}};
-!!$!latex \node [io, below of=surface] (coils) {initialize coils data in \link{rdcoils}};
-!!$!latex \node [cloud, left of=coils, xshift=-4cm, yshift=1.0cm] (diagnos)
-!!$!latex {coils evaluation in \link{diagnos}};
-!!$!latex \node [block, below of=coils] (pack) {Packing degrees of freedom in \link{packdof}};
-!!$!latex \node [decision, below of=pack,] (optimizer) {Optimizing in \link{solvers}};
-!!$!latex \node [block, right of=optimizer, xshift=2.5cm] (unpack)
-!!$!latex {unpack DOF to coils in \link{packdof}};
-!!$!latex \node [block, right of=unpack, xshift=2cm] (costfun)
-!!$!latex {calculate the cost functions in \link{solvers}};
-!!$!latex \node [block, below of=optimizer, yshift=-1.5cm] (postproc) {post proceedings};
-!!$!latex \node [io, below of=postproc] (output) {saving all the data in \link{saving}};
-!!$!latex \node [block, below of=output] (clean) {clean and finish in \link{cleanup}};
-!!$
-!!$!latex \path [line] (start) -- (input);
-!!$!latex \path [line] (input) -- (surface);
-!!$!latex \path [line] (surface) -- (coils);
-!!$!latex \path [line, dashed] (surface) -| (diagnos);
-!!$!latex \path [line, dashed] (coils) -| (diagnos);
-!!$!latex \path [line] (coils) -- (pack);
-!!$!latex \path [line] (pack) -- (optimizer);
-!!$!latex \path [line] (optimizer) -- node {iterations} (unpack);
-!!$!latex \path [line] (unpack) -- (costfun);
-!!$!latex \path [line] (costfun) |- (pack);
-!!$!latex \path [line] (optimizer) -- node {is over} (postproc);
-!!$!latex \path [line] (postproc) -- (output);
-!!$!latex \path [line, dashed] (postproc) -| (diagnos);
-!!$!latex \path [line] (output) -- (clean);
-!!$!latex \end{tikzpicture}
+!latex \subsection{How to execute}
+!latex A brief help message will be printed if you just type `xfocus --help`
!latex \subsection{Misc}
!latex \bi
@@ -87,20 +34,16 @@
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
PROGRAM focus
-
use globals, only: dp, ncpu, myid, ounit, ierr, astat, eunit, case_surface, case_coils, case_optimize, &
- case_postproc, xdof, tstart, tfinish, time_initialize, time_optimize, time_postproc, &
+ case_postproc, xdof, time_initialize, time_optimize, time_postproc, &
version
-
use mpi !to enable gfortran mpi_wtime bugs; 07/20/2017
-
implicit none
-
- !include "mpif.h"
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
INTEGER :: secs, mins, hrs
+ REAL :: tstart, tfinish ! local variables
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
@@ -121,12 +64,11 @@ PROGRAM focus
select case( case_surface )
- case( 0 ) ; call fousurf ! general format (VMEC-like) plasma boundary;
+ case( 0 ) ; call surface ! general format (VMEC-like) plasma boundary;
case( 1 ) ; call rdknot ! knototran-like plasma boundary;
!case( 2 ) ; call readwout ! read vmec output for plasma boundary and Boozer coordinates; for future;
end select
-
select case( case_coils )
@@ -173,15 +115,20 @@ PROGRAM focus
select case( case_postproc )
- case( 0 ) ; call saving
- case( 1 ) ; call diagnos ; call saving
- case( 2 ) ; call diagnos ; call specinp ; call saving
+ case( 0 )
+ case( 1 ) ; call diagnos ;
+ case( 2 ) ; call diagnos ; call specinp !; call saving
!case( 2 ) ; call saving ; call diagnos ; call wtmgrid ! write mgrid file;
- !case( 3 ) ; call saving ; call diagnos ; call poinplot ! Poincare plots; for future;
+ case( 3 ) ; call diagnos ; call poinplot ! Poincare plots; for future;
+ ! case( 3 ) ; call poinplot ! Poincare plots; for future;
+ case( 4 ) ; call diagnos ; call boozmn ; call poinplot ! Last closed surface
+ case( 5 ) ; call diagnos ; call wtmgrid ! write mgrid file
!case( 4 ) ; call saving ; call diagnos ; call resonant ! resonant harmonics analysis; for future;
end select
+ call saving ! save all the outputs
+
call MPI_BARRIER( MPI_COMM_WORLD, ierr )
tfinish = MPI_Wtime()
diff --git a/sources/globals.h b/sources/globals.f90
similarity index 62%
rename from sources/globals.h
rename to sources/globals.f90
index f625886..75fd942 100644
--- a/sources/globals.h
+++ b/sources/globals.f90
@@ -15,7 +15,7 @@ module globals
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
- CHARACTER(LEN=10), parameter :: version='v0.5.03' ! version number
+ CHARACTER(LEN=10), parameter :: version='v0.11.00' ! version number
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
@@ -68,90 +68,106 @@ module globals
CHARACTER(LEN=100) :: ext ! extention
CHARACTER(LEN=100) :: inputfile ! input namelist
- CHARACTER(LEN=100) :: surffile ! surface file
- CHARACTER(LEN=100) :: knotfile ! knototran file
- CHARACTER(LEN=100) :: coilfile ! FOCUS coil file
- CHARACTER(LEN=100) :: harmfile ! harmonics file
CHARACTER(LEN=100) :: hdf5file ! hdf5 file
- CHARACTER(LEN=100) :: inpcoils ! input coils.ext file
- CHARACTER(LEN=100) :: outcoils ! output ext.coils file
+ CHARACTER(LEN=100) :: out_coils ! output ext.coils file
+ CHARACTER(LEN=100) :: out_focus ! output ext.focus file
+ CHARACTER(LEN=100) :: out_harm ! output harmonics file
+ CHARACTER(LEN=100) :: out_plasma ! updated plasma boundary
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
!latex \subsection{Input namelist: \type{focusin}}
- INTEGER :: IsQuiet = -1
- INTEGER :: IsSymmetric = 0
+ INTEGER :: IsQuiet = -1
+ INTEGER :: IsSymmetric = 0
- INTEGER :: case_surface = 0
- REAL :: knotsurf = 0.200D-00
- REAL :: ellipticity = 0.000D+00
- INTEGER :: Nteta = 64
- INTEGER :: Nzeta = 64
-
- INTEGER :: case_init = 0
- INTEGER :: case_coils = 1
- INTEGER :: Ncoils = 0
- REAL :: init_current = 1.000D+06
- REAL :: init_radius = 1.000D+00
- INTEGER :: IsVaryCurrent = 1
- INTEGER :: IsVaryGeometry = 1
- INTEGER :: NFcoil = 4
- INTEGER :: Nseg = 128
+ INTEGER :: case_surface = 0
+ REAL :: knotsurf = 0.200D-00
+ REAL :: ellipticity = 0.000D+00
+ INTEGER :: Nteta = 64
+ INTEGER :: Nzeta = 64
+
+ INTEGER :: case_init = 0
+ INTEGER :: case_coils = 1
+ INTEGER :: Ncoils = 0
+ REAL :: init_current = 1.000D+06
+ REAL :: init_radius = 1.000D+00
+ INTEGER :: IsVaryCurrent = 1
+ INTEGER :: IsVaryGeometry = 1
+ INTEGER :: NFcoil = 4
+ INTEGER :: Nseg = 128
- INTEGER :: IsNormalize = 1
- INTEGER :: IsNormWeight = 1
- INTEGER :: case_bnormal = 0
- INTEGER :: case_length = 1
- REAL :: weight_bnorm = 1.000D+00
- REAL :: weight_bharm = 0.000D+00
- REAL :: weight_tflux = 0.000D+00
- REAL :: target_tflux = 0.000D+00
- REAL :: weight_ttlen = 0.000D+00
- REAL :: target_length = 0.000D+00
- REAL :: weight_cssep = 0.000D+00
- REAL :: cssep_factor = 1.000D+00
- REAL :: weight_specw = 0.000D+00
- REAL :: weight_ccsep = 0.000D+00
- REAL :: weight_inorm = 1.000D+00
- REAL :: weight_gnorm = 1.000D+00
-
- INTEGER :: case_optimize = 1
- REAL :: exit_tol = 1.000D-04
- INTEGER :: DF_maxiter = 0
- REAL :: DF_xtol = 1.000D-08
- REAL :: DF_tausta = 0.000D+00
- REAL :: DF_tauend = 1.000D+00
+ INTEGER :: IsNormalize = 1
+ INTEGER :: IsNormWeight = 1
+ INTEGER :: case_bnormal = 0
+ INTEGER :: case_length = 1
+ REAL :: weight_bnorm = 1.000D+00
+ INTEGER :: bharm_jsurf = 0
+ REAL :: weight_bharm = 0.000D+00
+ REAL :: weight_tflux = 0.000D+00
+ REAL :: target_tflux = 0.000D+00
+ REAL :: weight_ttlen = 0.000D+00
+ REAL :: target_length = 0.000D+00
+ REAL :: weight_cssep = 0.000D+00
+ REAL :: cssep_factor = 4.000D+00
+ REAL :: weight_specw = 0.000D+00
+ REAL :: weight_ccsep = 0.000D+00
+ REAL :: weight_inorm = 1.000D+00
+ REAL :: weight_gnorm = 1.000D+00
+ REAL :: weight_mnorm = 1.000D+00
+
+ INTEGER :: case_optimize = 0
+ REAL :: exit_tol = 1.000D-04
+ INTEGER :: DF_maxiter = 0
+ REAL :: DF_xtol = 1.000D-08
+ REAL :: DF_tausta = 0.000D+00
+ REAL :: DF_tauend = 1.000D+00
- INTEGER :: CG_maxiter = 0
- REAL :: CG_xtol = 1.000D-08
- REAL :: CG_wolfe_c1 = 1.000D-04
- REAL :: CG_wolfe_c2 = 0.1
-
- INTEGER :: LM_maxiter = 0
- REAL :: LM_xtol = 1.000D-08
- REAL :: LM_ftol = 1.000D-08
- REAL :: LM_factor = 1.000D+02
-
- INTEGER :: HN_maxiter = 0
- REAL :: HN_xtol = 1.000D-08
- REAL :: HN_factor = 100.0
-
- INTEGER :: TN_maxiter = 0
- REAL :: TN_xtol = 1.000D-08
- INTEGER :: TN_reorder = 0
- REAL :: TN_cr = 0.1
-
- INTEGER :: case_postproc = 1
- INTEGER :: save_freq = 1
- INTEGER :: save_coils = 0
- INTEGER :: save_harmonics = 0
- INTEGER :: save_filaments = 0
+ INTEGER :: CG_maxiter = 0
+ REAL :: CG_xtol = 1.000D-08
+ REAL :: CG_wolfe_c1 = 0.1
+ REAL :: CG_wolfe_c2 = 0.9
+
+ INTEGER :: LM_maxiter = 0
+ REAL :: LM_xtol = 1.000D-08
+ REAL :: LM_ftol = 1.000D-08
+ REAL :: LM_factor = 1.000D+02
+
+ INTEGER :: HN_maxiter = 0
+ REAL :: HN_xtol = 1.000D-08
+ REAL :: HN_factor = 100.0
+
+ INTEGER :: TN_maxiter = 0
+ REAL :: TN_xtol = 1.000D-08
+ INTEGER :: TN_reorder = 0
+ REAL :: TN_cr = 0.1
+
+ INTEGER :: case_postproc = 1
+ INTEGER :: save_freq = 1
+ INTEGER :: save_coils = 0
+ INTEGER :: save_harmonics = 0
+ INTEGER :: save_filaments = 0
+ INTEGER :: update_plasma = 0
+
+ REAL :: pp_phi = 0.000D+00
+ REAL :: pp_raxis = 0.000D+00
+ REAL :: pp_zaxis = 0.000D+00
+ REAL :: pp_rmax = 0.000D+00
+ REAL :: pp_zmax = 0.000D+00
+ INTEGER :: pp_ns = 10
+ INTEGER :: pp_maxiter = 1000
+ REAL :: pp_xtol = 1.000D-06
+
+ CHARACTER(LEN=100) :: input_surf = 'plasma.boundary' ! surface file
+ CHARACTER(LEN=100) :: input_coils = 'none' ! input file for coils
+ CHARACTER(LEN=100) :: input_harm = 'target.harmonics' ! input target harmonics file
+ CHARACTER(LEN=100) :: limiter_surf = 'none' ! limiter surface
-
-
-
namelist / focusin / IsQuiet , &
- IsSymmetric , &
+ IsSymmetric , &
+ input_surf , &
+ limiter_surf , &
+ input_harm , &
+ input_coils , &
case_surface , &
knotsurf , &
ellipticity , &
@@ -171,6 +187,7 @@ module globals
case_bnormal , &
case_length , &
weight_bnorm , &
+ bharm_jsurf , &
weight_bharm , &
weight_tflux , &
target_tflux , &
@@ -182,6 +199,7 @@ module globals
weight_ccsep , &
weight_inorm , &
weight_gnorm , &
+ weight_mnorm , &
case_optimize , &
exit_tol , &
DF_maxiter , &
@@ -207,12 +225,24 @@ module globals
save_freq , &
save_coils , &
save_harmonics , &
- save_filaments
-
+ save_filaments , &
+ update_plasma , &
+ pp_phi , &
+ pp_raxis , &
+ pp_zaxis , &
+ pp_rmax , &
+ pp_zmax , &
+ pp_ns , &
+ pp_maxiter , &
+ pp_xtol
+
+
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
!latex \subsection{MPI stuffs}
- INTEGER :: myid, ncpu
+ INTEGER, PARAMETER :: master=0
+ INTEGER :: myid, ncpu, myworkid, color, masterid, nmaster, nworker
+ INTEGER :: MPI_COMM_MASTERS, MPI_COMM_MYWORLD, MPI_COMM_WORKERS
REAL :: machprec, vsmall, small, sqrtmachprec
CHARACTER :: nodelabel*3
@@ -220,16 +250,19 @@ module globals
!latex \subsection{surface and coils data}
type toroidalsurface
- INTEGER :: Nteta, Nzeta
+ INTEGER :: Nteta, Nzeta, Nfou=0, Nfp=0, NBnf=0
+ REAL , allocatable :: Rbc(:), Zbs(:), Rbs(:), Zbc(:), Bnc(:), Bns(:)
REAL , allocatable :: xx(:,:), yy(:,:), zz(:,:), nx(:,:), ny(:,:), nz(:,:), &
xt(:,:), yt(:,:), zt(:,:), xp(:,:), yp(:,:), zp(:,:), &
ds(:,:), bn(:,:), pb(:,:), &
Bx(:,:), By(:,:), Bz(:,:)
+ INTEGER, allocatable :: bim(:), bin(:), Bnim(:), Bnin(:)
+ REAL :: vol, area
end type toroidalsurface
type arbitrarycoil
- INTEGER :: NS, Ic, Lc, itype
- REAL :: I, L, Lo, maxcurv
+ INTEGER :: NS, Ic=0, Lc=0, type=0, symm=0
+ REAL :: I=zero, L=zero, Lo, maxcurv, ox, oy, oz, mt, mp, Bt, Bz
REAL , allocatable :: xx(:), yy(:), zz(:), xt(:), yt(:), zt(:), xa(:), ya(:), za(:), &
dl(:), dd(:)
character(LEN=10) :: name
@@ -237,7 +270,7 @@ module globals
type FourierCoil
INTEGER :: NF
- REAL , allocatable :: xc(:), xs(:), yc(:), ys(:), zc(:), zs(:)
+ REAL , allocatable :: xc(:), xs(:), yc(:), ys(:), zc(:), zs(:), cmt(:,:), smt(:,:)
end type FourierCoil
type DegreeOfFreedom
@@ -250,15 +283,15 @@ module globals
type(FourierCoil) , allocatable :: FouCoil(:)
type(DegreeOfFreedom), allocatable :: DoF(:)
- INTEGER :: Nfou=0, Nfp=0, NBnf=0, Npc = 1, Nfp_raw = 1
- INTEGER, allocatable :: bim(:), bin(:), Bnim(:), Bnin(:)
- REAL , allocatable :: Rbc(:), Zbs(:), Rbs(:), Zbc(:), Bnc(:), Bns(:), cosip(:), sinip(:)
+ INTEGER :: Nfp = 1, symmetry = 0
+ INTEGER :: plasma = 1, limiter = 1
+ REAL , allocatable :: cosnfp(:), sinnfp(:)
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
!latex \subsection{Packing and unpacking}
INTEGER :: Cdof, Ndof, nfixcur, nfixgeo, Tdof
- REAL :: Inorm = one, Gnorm = one !current and geometry normalizations;
+ REAL :: Inorm = one, Gnorm = one, Mnorm = one !current, geometry, and moment normalizations;
REAL , allocatable :: xdof(:), dofnorm(:)
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
@@ -282,6 +315,7 @@ module globals
REAL , allocatable :: t1H(:), t2H(:,:), Bmnc(:),Bmns(:), wBmn(:), tBmnc(:), tBmns(:), &
carg(:,:), sarg(:,:), iBmnc(:), iBmns(:)
! Tflux error;
+ INTEGER :: tflux_sign = -1 ! default theta : counter-clockwise
REAL :: tflux, psi_avg
REAL , allocatable :: t1F(:), t2F(:,:)
! Length constraint
@@ -320,12 +354,21 @@ module globals
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
!latex \subsection{Miscellaneous}
- REAL :: tmpw_bnorm, tmpw_tflux ,tmpt_tflux, tmpw_ttlen, tmpw_specw, tmpw_ccsep, tmpw_bharm
+ REAL :: tmpw_bnorm, tmpw_tflux ,tmpt_tflux, tmpw_ttlen, tmpw_specw, tmpw_cssep, tmpw_bharm
REAL :: overlap = 0.0
!tmp weight for saving to restart file
REAL, allocatable :: mincc(:,:), coil_importance(:)
INTEGER :: ierr, astat
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+ ! fieldline tracing
+ REAL, ALLOCATABLE :: XYZB(:,:,:), ppr(:,:), ppz(:,:), iota(:)
+ INTEGER :: tor_num, total_num, booz_mpol, booz_ntor, booz_mn
+ LOGICAL :: lboozmn = .false.
+ INTEGER, ALLOCATABLE :: bmim(:), bmin(:)
+ REAL, ALLOCATABLE :: booz_mnc(:,:), booz_mns(:,:)
+
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
end module globals
diff --git a/sources/hybrj.f b/sources/hybrj.f
index 094a3fb..b8ca7f9 100644
--- a/sources/hybrj.f
+++ b/sources/hybrj.f
@@ -175,334 +175,200 @@ subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2)
c last card of subroutine dogleg.
c
end
- double precision function dpmpar(i)
- integer i
+ subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,
+ * wa1,wa2)
+ integer n,ldfjac,iflag,ml,mu
+ double precision epsfcn
+ double precision x(n),fvec(n),fjac(ldfjac,n),wa1(n),wa2(n)
c **********
c
-c Function dpmpar
+c subroutine fdjac1
c
-c This function provides double precision machine parameters
-c when the appropriate set of data statements is activated (by
-c removing the c from column 1) and all other data statements are
-c rendered inactive. Most of the parameter values were obtained
-c from the corresponding Bell Laboratories Port Library function.
+c this subroutine computes a forward-difference approximation
+c to the n by n jacobian matrix associated with a specified
+c problem of n functions in n variables. if the jacobian has
+c a banded form, then function evaluations are saved by only
+c approximating the nonzero terms.
c
-c The function statement is
+c the subroutine statement is
c
-c double precision function dpmpar(i)
+c subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,
+c wa1,wa2)
c
c where
c
-c i is an integer input variable set to 1, 2, or 3 which
-c selects the desired machine parameter. If the machine has
-c t base b digits and its smallest and largest exponents are
-c emin and emax, respectively, then these parameters are
-c
-c dpmpar(1) = b**(1 - t), the machine precision,
-c
-c dpmpar(2) = b**(emin - 1), the smallest magnitude,
-c
-c dpmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude.
-c
-c Argonne National Laboratory. MINPACK Project. November 1996.
-c Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More'
-c
-c **********
- integer mcheps(4)
- integer minmag(4)
- integer maxmag(4)
- double precision dmach(3)
- equivalence (dmach(1),mcheps(1))
- equivalence (dmach(2),minmag(1))
- equivalence (dmach(3),maxmag(1))
-c
-c Machine constants for the IBM 360/370 series,
-c the Amdahl 470/V6, the ICL 2900, the Itel AS/6,
-c the Xerox Sigma 5/7/9 and the Sel systems 85/86.
-c
-c data mcheps(1),mcheps(2) / z34100000, z00000000 /
-c data minmag(1),minmag(2) / z00100000, z00000000 /
-c data maxmag(1),maxmag(2) / z7fffffff, zffffffff /
-c
-c Machine constants for the Honeywell 600/6000 series.
-c
-c data mcheps(1),mcheps(2) / o606400000000, o000000000000 /
-c data minmag(1),minmag(2) / o402400000000, o000000000000 /
-c data maxmag(1),maxmag(2) / o376777777777, o777777777777 /
-c
-c Machine constants for the CDC 6000/7000 series.
-c
-c data mcheps(1) / 15614000000000000000b /
-c data mcheps(2) / 15010000000000000000b /
-c
-c data minmag(1) / 00604000000000000000b /
-c data minmag(2) / 00000000000000000000b /
-c
-c data maxmag(1) / 37767777777777777777b /
-c data maxmag(2) / 37167777777777777777b /
-c
-c Machine constants for the PDP-10 (KA processor).
-c
-c data mcheps(1),mcheps(2) / "114400000000, "000000000000 /
-c data minmag(1),minmag(2) / "033400000000, "000000000000 /
-c data maxmag(1),maxmag(2) / "377777777777, "344777777777 /
-c
-c Machine constants for the PDP-10 (KI processor).
-c
-c data mcheps(1),mcheps(2) / "104400000000, "000000000000 /
-c data minmag(1),minmag(2) / "000400000000, "000000000000 /
-c data maxmag(1),maxmag(2) / "377777777777, "377777777777 /
-c
-c Machine constants for the PDP-11.
-c
-c data mcheps(1),mcheps(2) / 9472, 0 /
-c data mcheps(3),mcheps(4) / 0, 0 /
-c
-c data minmag(1),minmag(2) / 128, 0 /
-c data minmag(3),minmag(4) / 0, 0 /
-c
-c data maxmag(1),maxmag(2) / 32767, -1 /
-c data maxmag(3),maxmag(4) / -1, -1 /
-c
-c Machine constants for the Burroughs 6700/7700 systems.
-c
-c data mcheps(1) / o1451000000000000 /
-c data mcheps(2) / o0000000000000000 /
-c
-c data minmag(1) / o1771000000000000 /
-c data minmag(2) / o7770000000000000 /
-c
-c data maxmag(1) / o0777777777777777 /
-c data maxmag(2) / o7777777777777777 /
-c
-c Machine constants for the Burroughs 5700 system.
-c
-c data mcheps(1) / o1451000000000000 /
-c data mcheps(2) / o0000000000000000 /
-c
-c data minmag(1) / o1771000000000000 /
-c data minmag(2) / o0000000000000000 /
-c
-c data maxmag(1) / o0777777777777777 /
-c data maxmag(2) / o0007777777777777 /
-c
-c Machine constants for the Burroughs 1700 system.
-c
-c data mcheps(1) / zcc6800000 /
-c data mcheps(2) / z000000000 /
-c
-c data minmag(1) / zc00800000 /
-c data minmag(2) / z000000000 /
-c
-c data maxmag(1) / zdffffffff /
-c data maxmag(2) / zfffffffff /
-c
-c Machine constants for the Univac 1100 series.
-c
-c data mcheps(1),mcheps(2) / o170640000000, o000000000000 /
-c data minmag(1),minmag(2) / o000040000000, o000000000000 /
-c data maxmag(1),maxmag(2) / o377777777777, o777777777777 /
-c
-c Machine constants for the Data General Eclipse S/200.
-c
-c Note - it may be appropriate to include the following card -
-c static dmach(3)
-c
-c data minmag/20k,3*0/,maxmag/77777k,3*177777k/
-c data mcheps/32020k,3*0/
-c
-c Machine constants for the Harris 220.
-c
-c data mcheps(1),mcheps(2) / '20000000, '00000334 /
-c data minmag(1),minmag(2) / '20000000, '00000201 /
-c data maxmag(1),maxmag(2) / '37777777, '37777577 /
-c
-c Machine constants for the Cray-1.
-c
-c data mcheps(1) / 0376424000000000000000b /
-c data mcheps(2) / 0000000000000000000000b /
-c
-c data minmag(1) / 0200034000000000000000b /
-c data minmag(2) / 0000000000000000000000b /
-c
-c data maxmag(1) / 0577777777777777777777b /
-c data maxmag(2) / 0000007777777777777776b /
-c
-c Machine constants for the Prime 400.
-c
-c data mcheps(1),mcheps(2) / :10000000000, :00000000123 /
-c data minmag(1),minmag(2) / :10000000000, :00000100000 /
-c data maxmag(1),maxmag(2) / :17777777777, :37777677776 /
-c
-c Machine constants for the VAX-11.
-c
-c data mcheps(1),mcheps(2) / 9472, 0 /
-c data minmag(1),minmag(2) / 128, 0 /
-c data maxmag(1),maxmag(2) / -32769, -1 /
-c
-c Machine constants for IEEE machines.
+c fcn is the name of the user-supplied subroutine which
+c calculates the functions. fcn must be declared
+c in an external statement in the user calling
+c program, and should be written as follows.
c
- data dmach(1) /2.22044604926d-16/
- data dmach(2) /2.22507385852d-308/
- data dmach(3) /1.79769313485d+308/
+c subroutine fcn(n,x,fvec,iflag)
+c integer n,iflag
+c double precision x(n),fvec(n)
+c ----------
+c calculate the functions at x and
+c return this vector in fvec.
+c ----------
+c return
+c end
c
- dpmpar = dmach(i)
- return
+c the value of iflag should not be changed by fcn unless
+c the user wants to terminate execution of fdjac1.
+c in this case set iflag to a negative integer.
c
-c Last card of function dpmpar.
+c n is a positive integer input variable set to the number
+c of functions and variables.
c
- end
- double precision function enorm(n,x)
- integer n
- double precision x(n)
-c **********
+c x is an input array of length n.
c
-c function enorm
+c fvec is an input array of length n which must contain the
+c functions evaluated at x.
c
-c given an n-vector x, this function calculates the
-c euclidean norm of x.
+c fjac is an output n by n array which contains the
+c approximation to the jacobian matrix evaluated at x.
c
-c the euclidean norm is computed by accumulating the sum of
-c squares in three different sums. the sums of squares for the
-c small and large components are scaled so that no overflows
-c occur. non-destructive underflows are permitted. underflows
-c and overflows do not occur in the computation of the unscaled
-c sum of squares for the intermediate components.
-c the definitions of small, intermediate and large components
-c depend on two constants, rdwarf and rgiant. the main
-c restrictions on these constants are that rdwarf**2 not
-c underflow and rgiant**2 not overflow. the constants
-c given here are suitable for every known computer.
+c ldfjac is a positive integer input variable not less than n
+c which specifies the leading dimension of the array fjac.
c
-c the function statement is
+c iflag is an integer variable which can be used to terminate
+c the execution of fdjac1. see description of fcn.
c
-c double precision function enorm(n,x)
+c ml is a nonnegative integer input variable which specifies
+c the number of subdiagonals within the band of the
+c jacobian matrix. if the jacobian is not banded, set
+c ml to at least n - 1.
c
-c where
+c epsfcn is an input variable used in determining a suitable
+c step length for the forward-difference approximation. this
+c approximation assumes that the relative errors in the
+c functions are of the order of epsfcn. if epsfcn is less
+c than the machine precision, it is assumed that the relative
+c errors in the functions are of the order of the machine
+c precision.
c
-c n is a positive integer input variable.
+c mu is a nonnegative integer input variable which specifies
+c the number of superdiagonals within the band of the
+c jacobian matrix. if the jacobian is not banded, set
+c mu to at least n - 1.
c
-c x is an input array of length n.
+c wa1 and wa2 are work arrays of length n. if ml + mu + 1 is at
+c least n, then the jacobian is considered dense, and wa2 is
+c not referenced.
c
c subprograms called
c
-c fortran-supplied ... dabs,dsqrt
+c minpack-supplied ... dpmpar
+c
+c fortran-supplied ... dabs,dmax1,dsqrt
c
c argonne national laboratory. minpack project. march 1980.
c burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c **********
- integer i
- double precision agiant,floatn,one,rdwarf,rgiant,s1,s2,s3,xabs,
- * x1max,x3max,zero
- data one,zero,rdwarf,rgiant /1.0d0,0.0d0,3.834d-20,1.304d19/
- s1 = zero
- s2 = zero
- s3 = zero
- x1max = zero
- x3max = zero
- floatn = n
- agiant = rgiant/floatn
- do 90 i = 1, n
- xabs = dabs(x(i))
- if (xabs .gt. rdwarf .and. xabs .lt. agiant) go to 70
- if (xabs .le. rdwarf) go to 30
-c
-c sum for large components.
-c
- if (xabs .le. x1max) go to 10
- s1 = one + s1*(x1max/xabs)**2
- x1max = xabs
- go to 20
- 10 continue
- s1 = s1 + (xabs/x1max)**2
- 20 continue
- go to 60
- 30 continue
+ integer i,j,k,msum
+ double precision eps,epsmch,h,temp,zero
+ double precision dpmpar
+ data zero /0.0d0/
c
-c sum for small components.
+c epsmch is the machine precision.
c
- if (xabs .le. x3max) go to 40
- s3 = one + s3*(x3max/xabs)**2
- x3max = xabs
- go to 50
- 40 continue
- if (xabs .ne. zero) s3 = s3 + (xabs/x3max)**2
- 50 continue
- 60 continue
- go to 80
- 70 continue
+ epsmch = dpmpar(1)
c
-c sum for intermediate components.
+ eps = dsqrt(dmax1(epsfcn,epsmch))
+ msum = ml + mu + 1
+ if (msum .lt. n) go to 40
+c
+c computation of dense approximate jacobian.
+c
+ do 20 j = 1, n
+ temp = x(j)
+ h = eps*dabs(temp)
+ if (h .eq. zero) h = eps
+ x(j) = temp + h
+ call fcn(n,x,wa1,iflag)
+ if (iflag .lt. 0) go to 30
+ x(j) = temp
+ do 10 i = 1, n
+ fjac(i,j) = (wa1(i) - fvec(i))/h
+ 10 continue
+ 20 continue
+ 30 continue
+ go to 110
+ 40 continue
c
- s2 = s2 + xabs**2
- 80 continue
- 90 continue
+c computation of banded approximate jacobian.
c
-c calculation of norm.
-c
- if (s1 .eq. zero) go to 100
- enorm = x1max*dsqrt(s1+(s2/x1max)/x1max)
- go to 130
- 100 continue
- if (s2 .eq. zero) go to 110
- if (s2 .ge. x3max)
- * enorm = dsqrt(s2*(one+(x3max/s2)*(x3max*s3)))
- if (s2 .lt. x3max)
- * enorm = dsqrt(x3max*((s2/x3max)+(x3max*s3)))
- go to 120
- 110 continue
- enorm = x3max*dsqrt(s3)
- 120 continue
- 130 continue
+ do 90 k = 1, msum
+ do 60 j = k, n, msum
+ wa2(j) = x(j)
+ h = eps*dabs(wa2(j))
+ if (h .eq. zero) h = eps
+ x(j) = wa2(j) + h
+ 60 continue
+ call fcn(n,x,wa1,iflag)
+ if (iflag .lt. 0) go to 100
+ do 80 j = k, n, msum
+ x(j) = wa2(j)
+ h = eps*dabs(wa2(j))
+ if (h .eq. zero) h = eps
+ do 70 i = 1, n
+ fjac(i,j) = zero
+ if (i .ge. j - mu .and. i .le. j + ml)
+ * fjac(i,j) = (wa1(i) - fvec(i))/h
+ 70 continue
+ 80 continue
+ 90 continue
+ 100 continue
+ 110 continue
return
c
-c last card of function enorm.
+c last card of subroutine fdjac1.
c
end
- subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode,
- * factor,nprint,info,nfev,njev,r,lr,qtf,wa1,wa2,
- * wa3,wa4)
- integer n,ldfjac,maxfev,mode,nprint,info,nfev,njev,lr
- double precision xtol,factor
- double precision x(n),fvec(n),fjac(ldfjac,n),diag(n),r(lr),
+
+ subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,diag,
+ * mode,factor,nprint,info,nfev,fjac,ldfjac,r,lr,
+ * qtf,wa1,wa2,wa3,wa4)
+ integer n,maxfev,ml,mu,mode,nprint,info,nfev,ldfjac,lr
+ double precision xtol,epsfcn,factor
+ double precision x(n),fvec(n),diag(n),fjac(ldfjac,n),r(lr),
* qtf(n),wa1(n),wa2(n),wa3(n),wa4(n)
+ external fcn
c **********
c
-c subroutine hybrj
+c subroutine hybrd
c
-c the purpose of hybrj is to find a zero of a system of
+c the purpose of hybrd is to find a zero of a system of
c n nonlinear functions in n variables by a modification
c of the powell hybrid method. the user must provide a
-c subroutine which calculates the functions and the jacobian.
+c subroutine which calculates the functions. the jacobian is
+c then calculated by a forward-difference approximation.
c
c the subroutine statement is
c
-c subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,
-c mode,factor,nprint,info,nfev,njev,r,lr,qtf,
-c wa1,wa2,wa3,wa4)
+c subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,
+c diag,mode,factor,nprint,info,nfev,fjac,
+c ldfjac,r,lr,qtf,wa1,wa2,wa3,wa4)
c
c where
c
c fcn is the name of the user-supplied subroutine which
-c calculates the functions and the jacobian. fcn must
-c be declared in an external statement in the user
-c calling program, and should be written as follows.
+c calculates the functions. fcn must be declared
+c in an external statement in the user calling
+c program, and should be written as follows.
c
-c subroutine fcn(n,x,fvec,fjac,ldfjac,iflag)
-c integer n,ldfjac,iflag
-c double precision x(n),fvec(n),fjac(ldfjac,n)
+c subroutine fcn(n,x,fvec,iflag)
+c integer n,iflag
+c double precision x(n),fvec(n)
c ----------
-c if iflag = 1 calculate the functions at x and
-c return this vector in fvec. do not alter fjac.
-c if iflag = 2 calculate the jacobian at x and
-c return this matrix in fjac. do not alter fvec.
+c calculate the functions at x and
+c return this vector in fvec.
c ---------
c return
c end
c
c the value of iflag should not be changed by fcn unless
-c the user wants to terminate execution of hybrj.
+c the user wants to terminate execution of hybrd.
c in this case set iflag to a negative integer.
c
c n is a positive integer input variable set to the number
@@ -515,20 +381,31 @@ subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode,
c fvec is an output array of length n which contains
c the functions evaluated at the output x.
c
-c fjac is an output n by n array which contains the
-c orthogonal matrix q produced by the qr factorization
-c of the final approximate jacobian.
-c
-c ldfjac is a positive integer input variable not less than n
-c which specifies the leading dimension of the array fjac.
-c
c xtol is a nonnegative input variable. termination
c occurs when the relative error between two consecutive
c iterates is at most xtol.
c
c maxfev is a positive integer input variable. termination
-c occurs when the number of calls to fcn with iflag = 1
-c has reached maxfev.
+c occurs when the number of calls to fcn is at least maxfev
+c by the end of an iteration.
+c
+c ml is a nonnegative integer input variable which specifies
+c the number of subdiagonals within the band of the
+c jacobian matrix. if the jacobian is not banded, set
+c ml to at least n - 1.
+c
+c mu is a nonnegative integer input variable which specifies
+c the number of superdiagonals within the band of the
+c jacobian matrix. if the jacobian is not banded, set
+c mu to at least n - 1.
+c
+c epsfcn is an input variable used in determining a suitable
+c step length for the forward-difference approximation. this
+c approximation assumes that the relative errors in the
+c functions are of the order of epsfcn. if epsfcn is less
+c than the machine precision, it is assumed that the relative
+c errors in the functions are of the order of the machine
+c precision.
c
c diag is an array of length n. if mode = 1 (see
c below), diag is internally set. if mode = 2, diag
@@ -551,9 +428,8 @@ subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode,
c fcn is called with iflag = 0 at the beginning of the first
c iteration and every nprint iterations thereafter and
c immediately prior to return, with x and fvec available
-c for printing. fvec and fjac should not be altered.
-c if nprint is not positive, no special calls of fcn
-c with iflag = 0 are made.
+c for printing. if nprint is not positive, no special calls
+c of fcn with iflag = 0 are made.
c
c info is an integer output variable. if the user has
c terminated execution, info is set to the (negative)
@@ -565,8 +441,8 @@ subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode,
c info = 1 relative error between two consecutive iterates
c is at most xtol.
c
-c info = 2 number of calls to fcn with iflag = 1 has
-c reached maxfev.
+c info = 2 number of calls to fcn has reached or exceeded
+c maxfev.
c
c info = 3 xtol is too small. no further improvement in
c the approximate solution x is possible.
@@ -580,10 +456,14 @@ subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode,
c ten iterations.
c
c nfev is an integer output variable set to the number of
-c calls to fcn with iflag = 1.
+c calls to fcn.
+c
+c fjac is an output n by n array which contains the
+c orthogonal matrix q produced by the qr factorization
+c of the final approximate jacobian.
c
-c njev is an integer output variable set to the number of
-c calls to fcn with iflag = 2.
+c ldfjac is a positive integer input variable not less than n
+c which specifies the leading dimension of the array fjac.
c
c r is an output array of length lr which contains the
c upper triangular matrix produced by the qr factorization
@@ -601,16 +481,16 @@ subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode,
c
c user-supplied ...... fcn
c
-c minpack-supplied ... dogleg,dpmpar,enorm,
+c minpack-supplied ... dogleg,dpmpar,enorm,fdjac1,
c qform,qrfac,r1mpyq,r1updt
c
-c fortran-supplied ... dabs,dmax1,dmin1,mod
+c fortran-supplied ... dabs,dmax1,dmin1,min0,mod
c
c argonne national laboratory. minpack project. march 1980.
c burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c **********
- integer i,iflag,iter,j,jm1,l,ncfail,ncsuc,nslow1,nslow2
+ integer i,iflag,iter,j,jm1,l,msum,ncfail,ncsuc,nslow1,nslow2
integer iwa(1)
logical jeval,sing
double precision actred,delta,epsmch,fnorm,fnorm1,one,pnorm,
@@ -627,13 +507,12 @@ subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode,
info = 0
iflag = 0
nfev = 0
- njev = 0
c
c check the input parameters for errors.
c
- if (n .le. 0 .or. ldfjac .lt. n .or. xtol .lt. zero
- * .or. maxfev .le. 0 .or. factor .le. zero
- * .or. lr .lt. (n*(n + 1))/2) go to 300
+ if (n .le. 0 .or. xtol .lt. zero .or. maxfev .le. 0
+ * .or. ml .lt. 0 .or. mu .lt. 0 .or. factor .le. zero
+ * .or. ldfjac .lt. n .or. lr .lt. (n*(n + 1))/2) go to 300
if (mode .ne. 2) go to 20
do 10 j = 1, n
if (diag(j) .le. zero) go to 300
@@ -644,11 +523,16 @@ subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode,
c and calculate its norm.
c
iflag = 1
- call fcn(n,x,fvec,fjac,ldfjac,iflag)
+ call fcn(n,x,fvec,iflag)
nfev = 1
if (iflag .lt. 0) go to 300
fnorm = enorm(n,fvec)
c
+c determine the number of calls to fcn needed to compute
+c the jacobian matrix.
+c
+ msum = min0(ml+mu+1,n)
+c
c initialize iteration counter and monitors.
c
iter = 1
@@ -665,8 +549,9 @@ subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode,
c calculate the jacobian matrix.
c
iflag = 2
- call fcn(n,x,fvec,fjac,ldfjac,iflag)
- njev = njev + 1
+ call fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,wa1,
+ * wa2)
+ nfev = nfev + msum
if (iflag .lt. 0) go to 300
c
c compute the qr factorization of the jacobian.
@@ -749,8 +634,7 @@ subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode,
c
if (nprint .le. 0) go to 190
iflag = 0
- if (mod(iter-1,nprint) .eq. 0)
- * call fcn(n,x,fvec,fjac,ldfjac,iflag)
+ if (mod(iter-1,nprint) .eq. 0) call fcn(n,x,fvec,iflag)
if (iflag .lt. 0) go to 300
190 continue
c
@@ -774,7 +658,7 @@ subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode,
c evaluate the function at x + p and calculate its norm.
c
iflag = 1
- call fcn(n,wa2,wa4,fjac,ldfjac,iflag)
+ call fcn(n,wa2,wa4,iflag)
nfev = nfev + 1
if (iflag .lt. 0) go to 300
fnorm1 = enorm(n,wa4)
@@ -856,7 +740,8 @@ subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode,
if (nslow1 .eq. 10) info = 5
if (info .ne. 0) go to 300
c
-c criterion for recalculating jacobian.
+c criterion for recalculating jacobian approximation
+c by forward differences.
c
if (ncfail .eq. 2) go to 290
c
@@ -894,10 +779,10 @@ subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode,
c
if (iflag .lt. 0) info = iflag
iflag = 0
- if (nprint .gt. 0) call fcn(n,x,fvec,fjac,ldfjac,iflag)
+ if (nprint .gt. 0) call fcn(n,x,fvec,iflag)
return
c
-c last card of subroutine hybrj.
+c last card of subroutine hybrd.
c
end
subroutine qform(m,n,q,ldq,wa)
@@ -993,170 +878,6 @@ subroutine qform(m,n,q,ldq,wa)
return
c
c last card of subroutine qform.
-c
- end
- subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)
- integer m,n,lda,lipvt
- integer ipvt(lipvt)
- logical pivot
- double precision a(lda,n),rdiag(n),acnorm(n),wa(n)
-c **********
-c
-c subroutine qrfac
-c
-c this subroutine uses householder transformations with column
-c pivoting (optional) to compute a qr factorization of the
-c m by n matrix a. that is, qrfac determines an orthogonal
-c matrix q, a permutation matrix p, and an upper trapezoidal
-c matrix r with diagonal elements of nonincreasing magnitude,
-c such that a*p = q*r. the householder transformation for
-c column k, k = 1,2,...,min(m,n), is of the form
-c
-c t
-c i - (1/u(k))*u*u
-c
-c where u has zeros in the first k-1 positions. the form of
-c this transformation and the method of pivoting first
-c appeared in the corresponding linpack subroutine.
-c
-c the subroutine statement is
-c
-c subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)
-c
-c where
-c
-c m is a positive integer input variable set to the number
-c of rows of a.
-c
-c n is a positive integer input variable set to the number
-c of columns of a.
-c
-c a is an m by n array. on input a contains the matrix for
-c which the qr factorization is to be computed. on output
-c the strict upper trapezoidal part of a contains the strict
-c upper trapezoidal part of r, and the lower trapezoidal
-c part of a contains a factored form of q (the non-trivial
-c elements of the u vectors described above).
-c
-c lda is a positive integer input variable not less than m
-c which specifies the leading dimension of the array a.
-c
-c pivot is a logical input variable. if pivot is set true,
-c then column pivoting is enforced. if pivot is set false,
-c then no column pivoting is done.
-c
-c ipvt is an integer output array of length lipvt. ipvt
-c defines the permutation matrix p such that a*p = q*r.
-c column j of p is column ipvt(j) of the identity matrix.
-c if pivot is false, ipvt is not referenced.
-c
-c lipvt is a positive integer input variable. if pivot is false,
-c then lipvt may be as small as 1. if pivot is true, then
-c lipvt must be at least n.
-c
-c rdiag is an output array of length n which contains the
-c diagonal elements of r.
-c
-c acnorm is an output array of length n which contains the
-c norms of the corresponding columns of the input matrix a.
-c if this information is not needed, then acnorm can coincide
-c with rdiag.
-c
-c wa is a work array of length n. if pivot is false, then wa
-c can coincide with rdiag.
-c
-c subprograms called
-c
-c minpack-supplied ... dpmpar,enorm
-c
-c fortran-supplied ... dmax1,dsqrt,min0
-c
-c argonne national laboratory. minpack project. march 1980.
-c burton s. garbow, kenneth e. hillstrom, jorge j. more
-c
-c **********
- integer i,j,jp1,k,kmax,minmn
- double precision ajnorm,epsmch,one,p05,sum,temp,zero
- double precision dpmpar,enorm
- data one,p05,zero /1.0d0,5.0d-2,0.0d0/
-c
-c epsmch is the machine precision.
-c
- epsmch = dpmpar(1)
-c
-c compute the initial column norms and initialize several arrays.
-c
- do 10 j = 1, n
- acnorm(j) = enorm(m,a(1,j))
- rdiag(j) = acnorm(j)
- wa(j) = rdiag(j)
- if (pivot) ipvt(j) = j
- 10 continue
-c
-c reduce a to r with householder transformations.
-c
- minmn = min0(m,n)
- do 110 j = 1, minmn
- if (.not.pivot) go to 40
-c
-c bring the column of largest norm into the pivot position.
-c
- kmax = j
- do 20 k = j, n
- if (rdiag(k) .gt. rdiag(kmax)) kmax = k
- 20 continue
- if (kmax .eq. j) go to 40
- do 30 i = 1, m
- temp = a(i,j)
- a(i,j) = a(i,kmax)
- a(i,kmax) = temp
- 30 continue
- rdiag(kmax) = rdiag(j)
- wa(kmax) = wa(j)
- k = ipvt(j)
- ipvt(j) = ipvt(kmax)
- ipvt(kmax) = k
- 40 continue
-c
-c compute the householder transformation to reduce the
-c j-th column of a to a multiple of the j-th unit vector.
-c
- ajnorm = enorm(m-j+1,a(j,j))
- if (ajnorm .eq. zero) go to 100
- if (a(j,j) .lt. zero) ajnorm = -ajnorm
- do 50 i = j, m
- a(i,j) = a(i,j)/ajnorm
- 50 continue
- a(j,j) = a(j,j) + one
-c
-c apply the transformation to the remaining columns
-c and update the norms.
-c
- jp1 = j + 1
- if (n .lt. jp1) go to 100
- do 90 k = jp1, n
- sum = zero
- do 60 i = j, m
- sum = sum + a(i,j)*a(i,k)
- 60 continue
- temp = sum/a(j,j)
- do 70 i = j, m
- a(i,k) = a(i,k) - temp*a(i,j)
- 70 continue
- if (.not.pivot .or. rdiag(k) .eq. zero) go to 80
- temp = a(j,k)/rdiag(k)
- rdiag(k) = rdiag(k)*dsqrt(dmax1(zero,one-temp**2))
- if (p05*(rdiag(k)/wa(k))**2 .gt. epsmch) go to 80
- rdiag(k) = enorm(m-j,a(jp1,k))
- wa(k) = rdiag(k)
- 80 continue
- 90 continue
- 100 continue
- rdiag(j) = -ajnorm
- 110 continue
- return
-c
-c last card of subroutine qrfac.
c
end
subroutine r1mpyq(m,n,a,lda,v,w)
diff --git a/sources/initial.h b/sources/initial.f90
similarity index 71%
rename from sources/initial.h
rename to sources/initial.f90
index 22b3b7a..101c6d6 100644
--- a/sources/initial.h
+++ b/sources/initial.f90
@@ -8,7 +8,8 @@
!latex \section{Input namelist}
!latex The \emph{focusin} namelist is the only input namelist needed for FOCUS running. It should be
-!latex written from the file \emph{example.input}. Here are the details for the variables. \\
+!latex written to the file \emph{example.input}, where `example' is the argument passed by command line.
+!latex Here are the details for the variables. \\
!latex \bi
!latex \item \inputvar{IsQuiet = -1} \\
!latex \textit{Information displayed to the user} \\
@@ -22,13 +23,29 @@
!latex \item \inputvar{IsSymmetric = 0} \\
!latex \textit{Enforce stellarator symmetry or not} \\
!latex \bi \vspace{-5mm}
-!latex \item[0:] no stellarator symmetry enforced;
-!latex \item[1:] plasma periodicty enforced;
-!latex \item[2:] coil and plasma periodicity enforced.
+!latex \item[0:] no symmetry or periodicity enforced;
+!latex \item[1:] periodicty of the plasma boundary enforced;
+!latex \item[2:] periodicity and stellartor symmetry of the plasma boundary enforced.
!latex \ei
!latex
!latex \par \begin{tikzpicture} \draw[dashed] (0,1) -- (10,1); \end{tikzpicture}
!latex
+!latex \item \inputvar{input\_surf = `plasma.boundary'} \\
+!latex \textit{Input file containing plasma boundary information.}
+!latex
+!latex \item \inputvar{input\_coils = `none'} \\
+!latex \textit{Input file containing initial guess for coils (in either format).}
+!latex If it is 'none' by default, it will be updated to 'coils.example' (case\_init=-1)
+!latex or 'example.focus' (case\_init=0).
+!latex
+!latex \item \inputvar{input\_harm = `target.harmonics'} \\
+!latex \textit{Input file containing the target harmonics for Bmn optimization.}
+!latex
+!latex \item \inputvar{limiter\_surf = `none'} \\
+!latex \textit{Input file containing the limiter surface for coil-surface separation.}
+!latex
+!latex \par \begin{tikzpicture} \draw[dashed] (0,1) -- (10,1); \end{tikzpicture}
+!latex
!latex \item \inputvar{case\_surface = 0} \\
!latex \textit{Specify the input plasma boundary format} \\
!latex \bi \vspace{-5mm}
@@ -54,9 +71,12 @@
!latex \item \inputvar{case\_init = 0} \\
!latex \textit{Specify the initializing method for coils, seen in \link{rdcoils}} \\
!latex \bi \vspace{-5mm}
-!latex \item[-1:] read the standard \emph{coils.example} file;
-!latex \item[0:] read FOCUS format data in \emph{example.focus};
+!latex \item[-1:] read the standard MAKEGRID format coils from \inputvar{input\_coils};
+!latex \item[0:] read FOCUS format data from \inputvar{input\_coils};
!latex \item[1:] toroidally spaced \inputvar{Ncoils} circular coils with radius of \inputvar{init\_radius};
+!latex \item[2:] toroidally spaced \inputvar{Ncoils}-1 magnetic dipoles pointing poloidallly on the toroidal surface
+!latex with radius of \inputvar{init\_radius} and a central infinitely long current.
+!latex Dipole magnetizations anc the central current are all set to \inputvar{init\_current}.
!latex \ei
!latex
!latex \item \inputvar{case\_coils = 1} \\
@@ -151,8 +171,11 @@
!latex \item \inputvar{weight\_specw = 0.0} \\
!latex \textit{weight for spectral condensation error, if zero, turned off; seen in \link{specwid}}; (not ready)
!latex
-!latex \item \inputvar{weight\_ccsep = 0.0} \\
-!latex \textit{weight for coil-coil separation constraint, if zero, turned off; seen in \link{coilsep}}; (not ready)
+!latex \item \inputvar{weight\_cssep = 0.0} \\
+!latex \textit{weight for coil-surface separation constraint, if zero, turned off; seen in \link{surfsep}};
+!latex
+!latex \item \inputvar{cssep\_factor = 4.0} \\
+!latex \textit{exponential index for coil-surface separation; the higher, the steeper; seen in \link{surfsep}};
!latex
!latex \item \inputvar{weight\_Inorm = 1.0} \\
!latex \textit{additional factor for normalizing currents; the larger, the more optimized for currents;
@@ -170,7 +193,7 @@
!latex \item[-2:] check the 2nd derivatives; seen in\link{fdcheck}; (not ready)
!latex \item[-1:] check the 1st derivatives; seen in\link{fdcheck};
!latex \item[ 0:] no optimizations performed;
-!latex \item[ 1:] optimizing with algorithms using the gradient (DF and/or CG); seen in \link{solvers};
+!latex \item[ 1:] optimizing with algorithms using the gradient (DF, CG and/or LM); seen in \link{solvers};
!latex \item[ 2:] optimizing with algorithms using the Hessian (HT and/or NT); seen in \link{solvers}; (not ready)
!latex \ei
!latex
@@ -212,7 +235,7 @@
!latex \textit{the stopping criteria of finding minimum; if both the actual and predicted relative reductions in the sum of squares are at most ftol, the optimization terminates; seen in \link{lmalg}};
!latex
!latex \item \inputvar{LM\_factor = 1.000D+02} \\
-!latex \textit{factor is a positive input variable used in determining the initial step bound. this bound is set to the product of factor and the euclidean norm of diag*x if nonzero, or else to factor itself. in most cases factor should lie in the interval (.1,100.).100. is a generally recommended value. seen in \link{lmalg}};
+!latex \textit{factor is a positive input variable used in determining the initial step bound. this bound is set to the product of factor and the euclidean norm of diag*x if nonzero, or else to factor itself. in most cases factor should lie in the interval (0.1,100.0). 100 is a generally recommended value. seen in \link{lmalg}};
!latex
!latex \par \begin{tikzpicture} \draw[dashed] (0,1) -- (10,1); \end{tikzpicture}
!latex
@@ -221,9 +244,40 @@
!latex \bi \vspace{-5mm}
!latex \item[ 0:] no extra post-processing;
!latex \item[ 1:] evaluate the present coils for each cost functions, coil curvature, coil-coil separation, and coil-plasma separation, Bn harmonics overlap, coil importance;
-!latex \item[ 2:] diagnos; write SPEC input file; (not ready)
+!latex \item[ 2:] diagnos; write SPEC input file;
+!latex \item[ 3:] diagnos; Field-line tracing, axis locating and iota calculating;
+!latex \item[ 4:] diagnos; Field-line tracing; Calculates Bmn coefficients in Boozer coordinates;
+!latex \item[ 5:] diagnos; write mgrid file (input variables in the namelist \&mgrid);
!latex \ei
!latex
+!latex \item \inputvar{update\_plasma = 0} \\
+!latex \textit{if euqals 1, write example.plasma file with updated Bn coefficients};
+!latex
+!latex \item \inputvar{pp\_phi = 0.0} \\
+!latex \textit{Toroidal angle $\phi = pp\_phi * \pi$ for filed-line tracing, axis locating, etc.}
+!latex
+!latex \item \inputvar{pp\_raxis = 0.0} \\
+!latex \inputvar{pp\_zaxis = 0.0} \\
+!latex \textit{Initial guess for axis positions (raxis, zaxis).
+!latex If both zero, will be overide to ($\frac{r_1+r_2}{2}, \frac{z_1+z_2}{2}$),
+!latex where $r_1 = R(0, \phi)$ , $r_2=R(\pi, \phi)$ (likewise for $z_1, z_2$.)}
+!latex
+!latex \item \inputvar{pp\_rmax = 0.0} \\
+!latex \inputvar{pp\_zmax = 0.0} \\
+!latex \textit{Upper bounds for field-line tracing.
+!latex If both zero, will be overide to ($r_1, z_1$).}
+!latex
+!latex \item \inputvar{pp\_ns = 10} \\
+!latex \textit{Number of surfaces for filed-line tracing, axis locating, etc.
+!latex Starting points on $\phi$ will be interpolated between
+!latex ($r_{axis}, z_{axis}$) and ($r_{max}, z_{max}$).}
+!latex
+!latex \item \inputvar{pp\_maxiter = 1000} \\
+!latex \textit{Cycles for tracing the field-line, representing the dots for each field-line in Poincare plots.}
+!latex
+!latex \item \inputvar{pp\_tol = 1.0E-6} \\
+!latex \textit{Tolerance of ODE solver used for tracing field-lines.}
+!latex
!latex \item \inputvar{save\_freq = 1} \\
!latex \textit{frequency for writing output files; should be positive; seen in \link{solvers}};
!latex
@@ -242,11 +296,11 @@
subroutine initial
use globals
+ use mpi
implicit none
- include "mpif.h"
LOGICAL :: exist
- INTEGER :: icpu
+ INTEGER :: icpu, index_dot
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
@@ -258,20 +312,31 @@ subroutine initial
!-------------read input namelist----------------------------------------------------------------------
if( myid == 0 ) then ! only the master node reads the input; 25 Mar 15;
call getarg(1,ext) ! get argument from command line
- write(ounit, '("initial : machine_prec = ", ES12.5, " ; sqrtmachprec = ", ES12.5 &
- & )') machprec, sqrtmachprec
+
+ select case(trim(ext))
+ case ( '-h', '--help' )
+ write(ounit,*)'-------HELP INFORMATION--------------------------'
+ write(ounit,*)' Usage: xfocus input_file'
+ write(ounit,*)' '
+ write(ounit,*)' --init / -i : Write an example input file'
+ write(ounit,*)' --help / -h : Output help message'
+ write(ounit,*)'-------------------------------------------------'
+ call MPI_ABORT( MPI_COMM_WORLD, 1, ierr )
+ case ( '-i', '--init' )
+ call write_focus_namelist ! in initial.h
+ case default
+ index_dot = INDEX(ext,'.input')
+ IF (index_dot .gt. 0) ext = ext(1:index_dot-1)
+ write(ounit, '("initial : machine_prec = ", ES12.5, " ; sqrtmachprec = ", ES12.5 &
+ & )') machprec, sqrtmachprec
+#ifdef DEBUG
+ write(ounit, '("DEBUG info: extension from command line is "A)') trim(ext)
+#endif
+ end select
endif
- ClBCAST( ext , 100, 0 )
- !-------------IO files name ---------------------------------------------------------------------------
+ ClBCAST( ext, 100, 0 )
inputfile = trim(ext)//".input"
- surffile = "plasma.boundary"
- knotfile = trim(ext)//".knot"
- coilfile = trim(ext)//".focus"
- harmfile = trim(ext)//".harmonics"
- hdf5file = "focus_"//trim(ext)//".h5"
- inpcoils = "coils."//trim(ext)
- outcoils = trim(ext)//".coils"
!-------------read the namelist-----------------------------------------------------------------------
if( myid == 0 ) then
@@ -288,12 +353,62 @@ subroutine initial
endif ! end of if( myid == 0 )
enddo
+ !-------------output files name ---------------------------------------------------------------------------
+
+ hdf5file = "focus_"//trim(ext)//".h5"
+ out_focus = trim(ext)//".focus"
+ out_coils = trim(ext)//".coils"
+ out_harm = trim(ext)//".harmonics"
+ out_plasma = trim(ext)//".plasma"
+
!-------------show the namelist for checking----------------------------------------------------------
if (myid == 0) then ! Not quiet to output more informations;
write(ounit, *) "-----------INPUT NAMELIST------------------------------------"
- write(ounit, '("initial : Read namelist focusin from ", A)') trim(inputfile)
+ write(ounit, '("initial : Read namelist focusin from : ", A)') trim(inputfile)
+ write(ounit, '(" : Read plasma boundary from : ", A)') trim(input_surf)
+ if ( weight_cssep > machprec ) then
+ if (trim(limiter_surf) == 'none') then ! by default, use the plasma surface
+ limiter_surf = input_surf
+ endif
+ write(ounit, '(" : Read limiter surface from : ", A)') trim(limiter_surf)
+ endif
+ if (weight_bharm > machprec) then
+ write(ounit, '(" : Read Bmn harmonics from : ", A)') trim(input_harm)
+ endif
+
+ select case( case_init )
+ case(-1 )
+ if (trim(input_coils) == 'none') input_coils = "coils."//trim(ext)
+ inquire( file=trim(input_coils), exist=exist )
+ FATAL( initial, .not.exist, coils file coils.ext not provided )
+ FATAL( initial, NFcoil <= 0 , no enough harmonics )
+ FATAL( initial, Nseg <= 0 , no enough segments )
+ FATAL( initial, target_length < zero, illegal )
+ write(ounit, '(" : Read initial coils from : ", A, A)') trim(input_coils), '(MAKEGRID format)'
+ case( 0 )
+ if (trim(input_coils) == 'none') input_coils = trim(ext)//".focus"
+ inquire( file=trim(input_coils), exist=exist )
+ FATAL( initial, .not.exist, FOCUS coil file ext.focus not provided )
+ write(ounit, '(" : Read initial coils from : ", A, A)') trim(input_coils), '(Parameters only)'
+ case( 1 )
+ FATAL( initial, Ncoils < 1, should provide the No. of coils)
+ FATAL( initial, init_current == zero, invalid coil current)
+ FATAL( initial, init_radius < zero, invalid coil radius)
+ FATAL( initial, NFcoil <= 0 , no enough harmonics )
+ FATAL( initial, Nseg <= 0 , no enough segments )
+ FATAL( initial, target_length < zero, illegal )
+ if (IsQuiet < 1) write(ounit, 1000) 'case_init', case_init, 'Initialize circular coils.'
+ case( 2 )
+ FATAL( initial, Ncoils < 1, should provide the No. of coils)
+ FATAL( initial, init_current == zero, invalid coil current)
+ FATAL( initial, init_radius < zero, invalid coil radius)
+ FATAL( initial, target_length < zero, illegal )
+ if (IsQuiet < 1) write(ounit, 1000) 'case_init', case_init, 'Initialize magnetic dipoles.'
+ case default
+ FATAL( initial, .true., selected case_init is not supported )
+ end select
select case (IsQuiet)
case (:-2)
@@ -316,22 +431,21 @@ subroutine initial
& 'No stellarator symmetry or periodicity enforced.'
case (1)
if (IsQuiet < 0) write(ounit, 1000) 'IsSymmetric', IsSymmetric, &
- & 'Plasma boundary periodicity is enforced.'
- FATAL( initial, .true., This would cause unbalanced coils please use IsSymmetric=0 instead)
+ & 'Periodicity is enforced.'
case (2)
if (IsQuiet < 0) write(ounit, 1000) 'IsSymmetric', IsSymmetric, &
- & 'Plasma boundary and coil periodicity are both enforced.'
+ & 'Periodicity and stellarator symmetry are both enforced.'
case default
FATAL( initial, .true., IsSymmetric /= 0 or 2 unspported option)
end select
select case (case_surface)
case (0)
- inquire( file=trim(surffile), exist=exist )
+ inquire( file=trim(input_surf), exist=exist )
FATAL( initial, .not.exist, plasma boundary file not provided )
write(ounit, 1000) 'case_surface', case_surface, 'Read VMEC-like Fourier harmonics for plasma boundary.'
case (1)
- inquire( file=trim(knotfile), exist=exist )
+ inquire( file=trim(input_surf), exist=exist )
FATAL( initial, .not.exist, axis file not provided )
FATAL( initial, knotsurf < zero, illegal minor radius)
write(ounit, 1000) 'case_surface', case_surface, 'Read axis information for expanding plasma boundary.'
@@ -344,30 +458,6 @@ subroutine initial
FATAL( initial, Nteta <= 0, illegal surface resolution )
FATAL( initial, Nzeta <= 0, illegal surface resolution )
- select case( case_init )
- case(-1 )
- inquire( file=trim(inpcoils), exist=exist )
- FATAL( initial, .not.exist, coils file coils.ext not provided )
- FATAL( initial, NFcoil <= 0 , no enough harmonics )
- FATAL( initial, Nseg <= 0 , no enough segments )
- FATAL( initial, target_length < zero, illegal )
- if (IsQuiet < 1) write(ounit, 1000) 'case_init', case_init, 'Read coils in MAKEGRID format.'
- case( 0 )
- inquire( file=trim(coilfile), exist=exist )
- FATAL( initial, .not.exist, FOCUS coil file ext.focus not provided )
- if (IsQuiet < 1) write(ounit, 1000) 'case_init', case_init, 'Read coils in FOCUS format.'
- case( 1 )
- FATAL( initial, Ncoils < 1, should provide the No. of coils)
- FATAL( initial, init_current == zero, invalid coil current)
- FATAL( initial, init_radius < zero, invalid coil radius)
- FATAL( initial, NFcoil <= 0 , no enough harmonics )
- FATAL( initial, Nseg <= 0 , no enough segments )
- FATAL( initial, target_length < zero, illegal )
- if (IsQuiet < 1) write(ounit, 1000) 'case_init', case_init, 'Initialize circular coils.'
- case default
- FATAL( initial, .true., selected case_init is not supported )
- end select
-
FATAL( initial, case_coils /= 1, only fourier representation is valid )
if (IsQuiet < 0) write(ounit, 1000) 'case_coils', case_coils, 'Using Fourier series as the basic representation.'
@@ -465,6 +555,17 @@ subroutine initial
FATAL( initial, .true., selected case_bnormal is not supported )
end select
+ select case ( bharm_jsurf )
+ case ( 0 )
+ if (IsQuiet < 1) write(ounit, 1000) 'bharm_jsurf', case_bnormal, 'No normalization on Bn harmonics.'
+ case ( 1 )
+ if (IsQuiet < 1) write(ounit, 1000) 'bharm_jsurf', case_bnormal, 'Bn harmonics are multiplied with surface area.'
+ case ( 2 )
+ if (IsQuiet < 1) write(ounit, 1000) 'bharm_jsurf', case_bnormal, 'Bn harmonics are multiplied with sqrt(surface area).'
+ case default
+ FATAL( initial, .true., selected case_bnormal is not supported )
+ end select
+
select case ( case_length )
case ( 1 )
if (IsQuiet < 1) write(ounit, 1000) 'case_length', case_length, 'Quadratic format of length penalty.'
@@ -490,21 +591,36 @@ subroutine initial
case ( 2 )
if (IsQuiet < 1) write(ounit, 1000) 'case_postproc', case_postproc, &
& 'Coil evaluations and writing SPEC input will be performed.'
+ case ( 3 )
+ if (IsQuiet < 1) write(ounit, 1000) 'case_postproc', case_postproc, &
+ & 'Coil evaluations and field-line tracing will be performed.'
+ case ( 4 )
+ if (IsQuiet < 1) write(ounit, 1000) 'case_postproc', case_postproc, &
+ & 'Vacuum Boozer coordinates decompostion will be performed.'
+ case ( 5 )
+ if (IsQuiet < 1) write(ounit, 1000) 'case_postproc', case_postproc, &
+ & 'A binary mgrid file will be saved.'
case default
FATAL( initial, .true., selected case_postproc is not supported )
end select
FATAL( initial, save_freq <= 0, should not be negative )
- if (IsQuiet < 0) write(ounit, '(8X,": Files saving setteings: freq = "I4" ; coils = "I1" ; harmonics = "&
- & I1" ; filaments = " I1)') save_freq, save_coils, save_harmonics, save_filaments
- if (IsQuiet < 0) then
- write(ounit,'(8X,5A)') ": '", trim(coilfile), "' and '", trim(hdf5file), "' will be stored."
- if (save_coils /= 0) write(ounit,'(8X, 3A)') ": new coils file '", trim(outcoils), "' will be updated."
- if (save_harmonics /= 0) write(ounit,'(8X,3A)')": Bmn harmonics file '", trim(harmfile), &
- & "' will be updated."
+ write(ounit, '("outputs : HDF5 outputs are saved in : ", A)') trim(hdf5file)
+ if (save_coils /= 0) then
+ write(ounit, '("outputs : Optimizated coils are saved in : ", A, " ; ", A)') &
+ trim(out_focus), trim(out_coils)
+ endif
+ if (weight_bharm > machprec) then
+ write(ounit, '("outputs : Realized Bn harmonics are saved in : ", A)') trim(out_harm)
+ endif
+ if (update_plasma/=0) then
+ write(ounit, '("outputs : Updated plasma boundary is saved in : ", A)') trim(out_plasma)
endif
endif
+
+ ClBCAST( limiter_surf, 100, 0 )
+ ClBCAST( input_coils , 100, 0 )
FATAL( initial, ncpu >= 1000 , too macy cpus, modify nodelabel)
write(nodelabel,'(i3.3)') myid ! nodelabel is global; 30 Oct 15;
@@ -522,13 +638,36 @@ subroutine initial
tmpt_tflux = target_tflux
tmpw_ttlen = weight_ttlen
!tmpw_specw = weight_specw
- tmpw_ccsep = weight_ccsep
+ tmpw_cssep = weight_cssep
call MPI_BARRIER( MPI_COMM_WORLD, ierr )
-
return
- !-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
end subroutine initial
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+SUBROUTINE write_focus_namelist
+ use globals
+ implicit none
+ include "mpif.h"
+
+ LOGICAL :: exist
+ CHARACTER(LEN=100) :: example = 'example.input'
+
+ if( myid == 0 ) then
+ inquire(file=trim(example), EXIST=exist) ! inquire if inputfile existed;
+ FATAL( initial, exist, example input file example.input already existed )
+ write(ounit, *) 'Writing an template input file in ', trim(example)
+ open(wunit, file=trim(example), status='unknown', action='write')
+ write(wunit, focusin)
+ close(wunit)
+ endif
+
+ call MPI_BARRIER( MPI_COMM_WORLD, ierr )
+ call MPI_FINALIZE( ierr )
+ stop
+
+ return
+END SUBROUTINE write_focus_namelist
diff --git a/sources/length.h b/sources/length.f90
similarity index 78%
rename from sources/length.h
rename to sources/length.f90
index fff3b45..c603195 100644
--- a/sources/length.h
+++ b/sources/length.f90
@@ -73,82 +73,70 @@ subroutine length(ideriv)
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
ttlen = zero
+ ivec = 1
if( ideriv >= 0 ) then
-
do icoil = 1, Ncoils !only care about unique coils;
-
- !if( myid.ne.modulo(icoil-1,ncpu) ) cycle ! parallelization loop;
- call LenDeriv0(icoil, coil(icoil)%L)
- !RlBCAST( coil(icoil)%L, 1, modulo(icoil-1,ncpu) ) !broadcast each coil's length
-
- enddo
-
- ivec = 1
-
- if (case_length == 1) then ! quadratic;
- do icoil = 1, Ncoils
- if ( coil(icoil)%Lc /= 0 ) then
- ttlen = ttlen + half * (coil(icoil)%L - coil(icoil)%Lo)**2 / coil(icoil)%Lo**2
- if (mttlen > 0) then ! L-M format of targets
- LM_fvec(ittlen+ivec) = weight_ttlen * (coil(icoil)%L - coil(icoil)%Lo)
- ivec = ivec + 1
- endif
- endif
- enddo
- elseif (case_length == 2) then ! exponential;
- do icoil = 1, Ncoils
+ if(coil(icoil)%type == 1) then ! only for Fourier
+ !if( myid.ne.modulo(icoil-1,ncpu) ) cycle ! parallelization loop;
+ call LenDeriv0(icoil, coil(icoil)%L)
+ !RlBCAST( coil(icoil)%L, 1, modulo(icoil-1,ncpu) ) !broadcast each coil's length
if ( coil(icoil)%Lc /= 0 ) then
- ttlen = ttlen + exp(coil(icoil)%L) / exp(coil(icoil)%Lo)
- if (mttlen > 0) then ! L-M format of targets
- LM_fvec(ittlen+ivec) = weight_ttlen * exp(coil(icoil)%L) / exp(coil(icoil)%Lo)
- ivec = ivec + 1
- endif
- endif
- enddo
- else
- FATAL( length, .true. , invalid case_length option )
- end if
-
+ if (case_length == 1) then ! quadratic;
+ ttlen = ttlen + half * (coil(icoil)%L - coil(icoil)%Lo)**2 / coil(icoil)%Lo**2
+ if (mttlen > 0) then ! L-M format of targets
+ LM_fvec(ittlen+ivec) = weight_ttlen * (coil(icoil)%L - coil(icoil)%Lo)
+ ivec = ivec + 1
+ endif
+ elseif (case_length == 2) then ! exponential;
+ ttlen = ttlen + exp(coil(icoil)%L) / exp(coil(icoil)%Lo)
+ if (mttlen > 0) then ! L-M format of targets
+ LM_fvec(ittlen+ivec) = weight_ttlen * exp(coil(icoil)%L) / exp(coil(icoil)%Lo)
+ ivec = ivec + 1
+ endif
+ else
+ FATAL( length, .true. , invalid case_length option )
+ end if
+ endif
+ endif
+ enddo
if (mttlen > 0) then ! L-M format of targets
FATAL( length, ivec == mttlen, Errors in counting ivec for L-M )
endif
-
ttlen = ttlen / (Ncoils - Nfixgeo + machprec)
-
endif
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
if ( ideriv >= 1 ) then
-
t1L = zero ; d1L = zero ; norm = zero
-
idof = 0 ; ivec = 1
do icoil = 1, Ncoils
-
ND = DoF(icoil)%ND
-
- if (case_length == 1) then
- norm(icoil) = (coil(icoil)%L - coil(icoil)%Lo) / coil(icoil)%Lo**2 ! quadratic;
- elseif (case_length == 2) then
- norm(icoil) = exp(coil(icoil)%L) / exp(coil(icoil)%Lo) ! exponential;
- else
- FATAL( length, .true. , invalid case_length option )
- end if
-
if ( coil(icoil)%Ic /= 0 ) then !if current is free;
idof = idof +1
endif
-
if ( coil(icoil)%Lc /= 0 ) then !if geometry is free;
- call lenDeriv1( icoil, d1L(idof+1:idof+ND), ND )
- t1L(idof+1:idof+ND) = d1L(idof+1:idof+ND) * norm(icoil)
- if (mttlen > 0) then ! L-M format of targets
- LM_fjac(ivec, idof+1:idof+ND) = weight_ttlen * d1L(idof+1:idof+ND)
- if (case_length == 2) LM_fjac(ivec, idof+1:idof+ND) = LM_fjac(ivec, idof+1:idof+ND) * exp(coil(icoil)%L) / exp(coil(icoil)%Lo)
- ivec = ivec + 1
- endif
+ if(coil(icoil)%type .eq. 1) then ! only for Fourier
+ ! calculate normalization
+ if (case_length == 1) then
+ norm(icoil) = (coil(icoil)%L - coil(icoil)%Lo) / coil(icoil)%Lo**2 ! quadratic;
+ elseif (case_length == 2) then
+ norm(icoil) = exp(coil(icoil)%L) / exp(coil(icoil)%Lo) ! exponential;
+ else
+ FATAL( length, .true. , invalid case_length option )
+ end if
+ ! call lederiv1 to calculate the 1st derivatives
+ call lenDeriv1( icoil, d1L(idof+1:idof+ND), ND )
+ t1L(idof+1:idof+ND) = d1L(idof+1:idof+ND) * norm(icoil)
+ if (mttlen > 0) then ! L-M format of targets
+ LM_fjac(ivec, idof+1:idof+ND) = weight_ttlen * d1L(idof+1:idof+ND)
+ if (case_length == 2) &
+ & LM_fjac(ivec, idof+1:idof+ND) = LM_fjac(ivec, idof+1:idof+ND) &
+ & * exp(coil(icoil)%L) / exp(coil(icoil)%Lo)
+ ivec = ivec + 1
+ endif
+ endif
idof = idof + ND
endif
diff --git a/sources/lmalg.h b/sources/lmalg.f90
similarity index 99%
rename from sources/lmalg.h
rename to sources/lmalg.f90
index f7ad6c4..56ffe91 100644
--- a/sources/lmalg.h
+++ b/sources/lmalg.f90
@@ -294,8 +294,8 @@ end subroutine lmalg
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
subroutine focus_fcn(m,n,x,fvec,fjac,ldfjac,iflag)
- use globals, only: dp, zero, myid, ounit, tstart, tfinish, LM_iter, LM_maxiter, &
- & exit_signal, LM_fvec, LM_fjac
+ use globals, only: dp, zero, myid, ounit, LM_iter, LM_maxiter, &
+ & exit_signal, LM_fvec, LM_fjac, tstart, tfinish
use mpi
implicit none
diff --git a/sources/packdof.f90 b/sources/packdof.f90
new file mode 100644
index 0000000..fbdd634
--- /dev/null
+++ b/sources/packdof.f90
@@ -0,0 +1,308 @@
+!title (packdof) ! paking degree of freedom (dof) into one vector
+
+!latex \briefly{Packing all the free coil parameters into a one rank vector.}
+!latex
+!latex \subsection{Overview}
+!latex \bi
+!latex \item The \inputvar{case\_coils} determines the packing and unpacking patern.
+!latex \item \inputvar{case\_coils} = 1: Coils are represented with Fourier series.
+!latex \item For each coil, the number of DOF is $6N_F+4$ ($\sin 0$ terms are omitted.)
+!latex \be
+!latex \vect{X_i} = \left [ \overbrace{I, \underbrace{X_{c,0}, \cdots, X_{c,N}}_{\text{N+1}},
+!latex \underbrace{X_{s,1}, \cdots, X_{s,N}}_{\mathrm{N}}, Y_{c,0}, \cdots, Z_{s,N}}^{\mathrm{6N+4}} \right ]
+!latex \ee
+!latex \item Coil currents/geometry can also be fixed, and they are determined by coil\%Ic and coil\%Lc.
+!latex \item The total number of DOF $Ndof$ should be
+!latex \be
+!latex Ndof = Ncoils \ * \ (6 * NFcoil + 4) \, - \, Nfixcur \, - \, Nfixgeo \ * \ (6 * NFcoil + 3)
+!latex \ee
+!latex \ei
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+SUBROUTINE packdof(lxdof)
+ !---------------------------------------------------------------------------------------------
+ ! Pack all DOF into one vector;
+ ! DATE: 2017/03/19
+ !---------------------------------------------------------------------------------------------
+ use globals, only : dp, zero, myid, ounit, &
+ & case_coils, Ncoils, coil, DoF, Ndof, DoFnorm
+ implicit none
+ include "mpif.h"
+
+ REAL :: lxdof(1:Ndof)
+ INTEGER :: idof, icoil, ND, astat, ierr
+ !---------------------------------------------------------------------------------------------
+
+ ! reset xdof;
+ lxdof = zero
+
+ call packcoil !pack coil parameters into DoF;
+ ! packing;
+ idof = 0
+ do icoil = 1, Ncoils
+
+ select case (coil(icoil)%type)
+ !---------------------------------------------------------------------------------------------
+ case(1)
+
+ if(coil(icoil)%Ic /= 0) then
+ lxdof(idof+1) = coil(icoil)%I
+ idof = idof + 1
+ endif
+
+ ND = DoF(icoil)%ND
+ if(coil(icoil)%Lc /= 0) then
+ lxdof(idof+1:idof+ND) = DoF(icoil)%xdof(1:ND)
+ idof = idof + ND
+ endif
+ !---------------------------------------------------------------------------------------------
+ case(2)
+ if(coil(icoil)%Ic /= 0) then
+ lxdof(idof+1) = coil(icoil)%I
+ idof = idof + 1
+ endif
+ ND = DoF(icoil)%ND
+ if(coil(icoil)%Lc /= 0) then
+ lxdof(idof+1:idof+ND) = DoF(icoil)%xdof(1:ND)
+ idof = idof + ND
+ endif
+ !---------------------------------------------------------------------------------------------
+ case(3)
+ if(coil(icoil)%Ic /= 0) then
+ lxdof(idof+1) = coil(icoil)%I
+ idof = idof + 1
+ endif
+
+ if(coil(icoil)%Lc /= 0) then
+ lxdof(idof+1) = DoF(icoil)%xdof(1)
+ idof = idof + 1
+ endif
+ !---------------------------------------------------------------------------------------------
+ case default
+ FATAL(packdof01, .true., not supported coil types)
+ end select
+
+ enddo !end do icoil;
+
+ !---------------------------------------------------------------------------------------------
+ FATAL( packdof02 , idof .ne. Ndof, counting error in packing )
+
+ !write(ounit, *) "pack ", lxdof(1)
+ lxdof = lxdof / DoFnorm
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+
+ return
+END SUBROUTINE packdof
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+SUBROUTINE unpacking(lxdof)
+ !---------------------------------------------------------------------------------------------
+ ! UnPack all DOF from one vector;
+ ! DATE: 2017/04/03
+ !---------------------------------------------------------------------------------------------
+ use globals, only: dp, zero, myid, ounit, &
+ & case_coils, Ncoils, coil, DoF, Ndof, DoFnorm
+ implicit none
+ include "mpif.h"
+
+ REAL :: lxdof(1:Ndof)
+ INTEGER :: idof, icoil, ND, astat, ierr, ifirst
+ !---------------------------------------------------------------------------------------------
+ !FATAL( packdof, .not. allocated(xdof), Please allocate xdof first. )
+
+ idof = 0 ; ifirst = 0
+ do icoil = 1, Ncoils
+
+ select case (coil(icoil)%type)
+ !---------------------------------------------------------------------------------------------
+ case(1)
+
+ if(coil(icoil)%Ic /= 0) then
+ coil(icoil)%I = lxdof(idof+1) * dofnorm(idof+1)
+ idof = idof + 1
+ endif
+
+ ND = DoF(icoil)%ND
+ if(coil(icoil)%Lc /= 0) then
+ DoF(icoil)%xdof(1:ND) = lxdof(idof+1:idof+ND) * dofnorm(idof+1:idof+ND)
+ idof = idof + ND
+ endif
+
+ !---------------------------------------------------------------------------------------------
+ case(2)
+ if(coil(icoil)%Ic /= 0) then
+ coil(icoil)%I = lxdof(idof+1) * dofnorm(idof+1)
+ idof = idof + 1
+ endif
+ ND = DoF(icoil)%ND
+ if(coil(icoil)%Lc /= 0) then
+ DoF(icoil)%xdof(1:ND) = lxdof(idof+1:idof+ND) * dofnorm(idof+1:idof+ND)
+ idof = idof + ND
+ endif
+ !---------------------------------------------------------------------------------------------
+ case(3)
+ if(coil(icoil)%Ic /= 0) then
+ coil(icoil)%I = lxdof(idof+1) * dofnorm(idof+1)
+ idof = idof + 1
+ endif
+
+ if(coil(icoil)%Lc /= 0) then
+ DoF(icoil)%xdof(1) = lxdof(idof+1) * dofnorm(idof+1)
+ idof = idof + 1
+ endif
+ !---------------------------------------------------------------------------------------------
+ case default
+ FATAL(unpacking01, .true., not supported coil types)
+ end select
+
+ enddo !end do icoil;
+
+ !---------------------------------------------------------------------------------------------
+ FATAL( unpacking02 , idof .ne. Ndof, counting error in unpacking )
+
+ call unpackcoil !unpack DoF to coil parameters;
+ call discoil(ifirst)
+
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+
+ return
+END SUBROUTINE unpacking
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+SUBROUTINE packcoil
+ !---------------------------------------------------------------------------------------------
+ ! pack coil representation variables into DoF (only geometries without currents);
+ ! DATE: 2017/03/25
+ !---------------------------------------------------------------------------------------------
+ use globals, only: dp, zero, myid, ounit, case_coils, Ncoils, coil, FouCoil, DoF
+ implicit none
+ include "mpif.h"
+
+ INTEGER :: icoil, idof, NF, ierr, astat
+
+ FATAL( packcoil01, .not. allocated(coil) , illegal )
+ ! FATAL( packcoil, .not. allocated(FouCoil), illegal )
+ FATAL( packcoil02, .not. allocated(DoF) , illegal )
+
+ do icoil = 1, Ncoils
+
+ select case (coil(icoil)%type)
+ !---------------------------------------------------------------------------------------------
+ case(1)
+ ! get number of DoF for each coil and allocate arrays;
+ NF = FouCoil(icoil)%NF
+ DoF(icoil)%xdof = zero
+
+ !pack Fourier series;
+ idof = 0
+ if(coil(icoil)%Lc /= 0) then
+ DoF(icoil)%xdof(idof+1 : idof+NF+1) = FouCoil(icoil)%xc(0:NF); idof = idof + NF + 1
+ DoF(icoil)%xdof(idof+1 : idof+NF ) = FouCoil(icoil)%xs(1:NF); idof = idof + NF
+ DoF(icoil)%xdof(idof+1 : idof+NF+1) = FouCoil(icoil)%yc(0:NF); idof = idof + NF + 1
+ DoF(icoil)%xdof(idof+1 : idof+NF ) = FouCoil(icoil)%ys(1:NF); idof = idof + NF
+ DoF(icoil)%xdof(idof+1 : idof+NF+1) = FouCoil(icoil)%zc(0:NF); idof = idof + NF + 1
+ DoF(icoil)%xdof(idof+1 : idof+NF ) = FouCoil(icoil)%zs(1:NF); idof = idof + NF
+ endif
+ FATAL( packcoil03 , idof .ne. DoF(icoil)%ND, counting error in packing )
+
+ !---------------------------------------------------------------------------------------------
+ case(2)
+ idof = 0
+ if(coil(icoil)%Lc /= 0) then
+#ifdef dposition
+ ! dipole position is variable
+ DoF(icoil)%xdof(idof+1:idof+5) = (/ coil(icoil)%ox, coil(icoil)%oy, coil(icoil)%oz, &
+ coil(icoil)%mt, coil(icoil)%mp /)
+ idof = idof + 5
+#else
+ DoF(icoil)%xdof(idof+1:idof+2) = (/ coil(icoil)%mt, coil(icoil)%mp /)
+ idof = idof + 2
+#endif
+ endif
+ FATAL( packcoil04 , idof .ne. DoF(icoil)%ND, counting error in packing )
+ !---------------------------------------------------------------------------------------------
+ case(3)
+ idof = 0
+ if(coil(icoil)%Lc /= 0) then
+ DoF(icoil)%xdof(idof+1) = coil(icoil)%Bz; idof = idof + 1
+ endif
+ FATAL( packcoil05 , idof .ne. DoF(icoil)%ND, counting error in packing )
+ !---------------------------------------------------------------------------------------------
+ case default
+ FATAL(packcoil06, .true., not supported coil types)
+ end select
+
+ enddo ! end do icoil;
+
+END SUBROUTINE packcoil
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+SUBROUTINE unpackcoil
+ !---------------------------------------------------------------------------------------------
+ ! pack coil representation variables into DoF (only geometries without currents);
+ ! DATE: 2017/03/25
+ !---------------------------------------------------------------------------------------------
+ use globals, only: dp, zero, myid, ounit, case_coils, Ncoils, coil, FouCoil, DoF
+ implicit none
+ include "mpif.h"
+
+ INTEGER :: icoil, idof, NF, ierr, astat
+
+ FATAL( unpackcoil01, .not. allocated(coil) , illegal )
+ ! FATAL( unpackcoil, .not. allocated(FouCoil), illegal )
+ FATAL( unpackcoil02, .not. allocated(DoF) , illegal )
+
+ do icoil = 1, Ncoils
+
+ select case (coil(icoil)%type)
+ !---------------------------------------------------------------------------------------------
+ case(1)
+ ! get number of DoF for each coil and allocate arrays;
+ NF = FouCoil(icoil)%NF
+ idof = 0
+ if (coil(icoil)%Lc /= 0) then
+ !unpack Fourier series;
+ FouCoil(icoil)%xc(0:NF) = DoF(icoil)%xdof(idof+1 : idof+NF+1) ; idof = idof + NF + 1
+ FouCoil(icoil)%xs(1:NF) = DoF(icoil)%xdof(idof+1 : idof+NF ) ; idof = idof + NF
+ FouCoil(icoil)%yc(0:NF) = DoF(icoil)%xdof(idof+1 : idof+NF+1) ; idof = idof + NF + 1
+ FouCoil(icoil)%ys(1:NF) = DoF(icoil)%xdof(idof+1 : idof+NF ) ; idof = idof + NF
+ FouCoil(icoil)%zc(0:NF) = DoF(icoil)%xdof(idof+1 : idof+NF+1) ; idof = idof + NF + 1
+ FouCoil(icoil)%zs(1:NF) = DoF(icoil)%xdof(idof+1 : idof+NF ) ; idof = idof + NF
+ endif
+ FATAL( unpackcoil03 , idof .ne. DoF(icoil)%ND, counting error in packing )
+
+ !---------------------------------------------------------------------------------------------
+ case(2)
+ idof = 0
+ if(coil(icoil)%Lc /= 0) then
+#ifdef dposition
+ ! dipole position is variable
+ coil(icoil)%ox = DoF(icoil)%xdof(idof+1) ; idof = idof + 1
+ coil(icoil)%oy = DoF(icoil)%xdof(idof+1) ; idof = idof + 1
+ coil(icoil)%oz = DoF(icoil)%xdof(idof+1) ; idof = idof + 1
+#endif
+ coil(icoil)%mt = DoF(icoil)%xdof(idof+1) ; idof = idof + 1
+ coil(icoil)%mp = DoF(icoil)%xdof(idof+1) ; idof = idof + 1
+ endif
+ FATAL( unpackcoil04 , idof .ne. DoF(icoil)%ND, counting error in packing )
+
+ !---------------------------------------------------------------------------------------------
+ case(3)
+ idof = 0
+
+ if(coil(icoil)%Lc /= 0) then
+ coil(icoil)%Bz = DoF(icoil)%xdof(idof+1) ; idof = idof + 1
+ endif
+ FATAL( unpackcoil05 , idof .ne. DoF(icoil)%ND, counting error in packing )
+
+ !---------------------------------------------------------------------------------------------
+ case default
+ FATAL( unpackcoil06 , .true., not supported coil types)
+ end select
+
+ enddo ! end do icoil;
+
+END SUBROUTINE unpackcoil
diff --git a/sources/packdof.h b/sources/packdof.h
deleted file mode 100644
index b6a1b16..0000000
--- a/sources/packdof.h
+++ /dev/null
@@ -1,200 +0,0 @@
-!title (packdof) ! paking degree of freedom (dof) into one vector
-
-!latex \briefly{Packing all the free coil parameters into a one rank vector.}
-!latex
-!latex \subsection{Overview}
-!latex \bi
-!latex \item The \inputvar{case\_coils} determines the packing and unpacking patern.
-!latex \item \inputvar{case\_coils} = 1: Coils are represented with Fourier series.
-!latex \item For each coil, the number of DOF is $6N_F+3$ ($\sin 0$ terms are omitted.)
-!latex \be
-!latex \vect{X_i} = \left[ \overbrace{I, \underbrace{X_{c,0}, \cdots, X_{c,N}}_\text{N+1},
-!latex \underbrace{X_{s,1}, \cdots, X_{s,N}}_\text{N}, Y_{c,0}, \cdots, Z_{s,N}}^\text{6N+4} \right ]
-!latex \ee
-!latex \item Coil currents/geometry can also be fixed, and they are determined by coil\%Ic and coil\%Lc.
-!latex \item The total number of DOF $Ndof$ should be
-!latex \be
-!latex Ndof = Ncoils \ * \ (6 * NFcoil + 4) \, - \, Nfixcur \, - \, Nfixgeo \ * \ (6 * NFcoil + 3)
-!latex \ee
-!latex \ei
-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
-SUBROUTINE packdof(lxdof)
- !---------------------------------------------------------------------------------------------
- ! Pack all DOF into one vector;
- ! DATE: 2017/03/19
- !---------------------------------------------------------------------------------------------
- use globals, only : dp, zero, myid, ounit, &
- & case_coils, Ncoils, coil, DoF, Ndof, Inorm, Gnorm
- implicit none
- include "mpif.h"
-
- REAL :: lxdof(1:Ndof)
- INTEGER :: idof, icoil, ND, astat, ierr
- !---------------------------------------------------------------------------------------------
-
- ! reset xdof;
- lxdof = zero
-
- call packcoil !pack coil parameters into DoF;
- ! packing;
- idof = 0
- do icoil = 1, Ncoils
-
- if(coil(icoil)%Ic /= 0) then
- lxdof(idof+1) = coil(icoil)%I / Inorm
- idof = idof + 1
- endif
-
- ND = DoF(icoil)%ND
- if(coil(icoil)%Lc /= 0) then
- lxdof(idof+1:idof+ND) = DoF(icoil)%xdof(1:ND) / Gnorm
- idof = idof + ND
- endif
-
- enddo !end do icoil;
-
- !---------------------------------------------------------------------------------------------
- FATAL( packdof , idof .ne. Ndof, counting error in packing )
-
- !write(ounit, *) "pack ", lxdof(1)
- call mpi_barrier(MPI_COMM_WORLD, ierr)
-
- return
-END SUBROUTINE packdof
-
-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
-SUBROUTINE unpacking(lxdof)
- !---------------------------------------------------------------------------------------------
- ! UnPack all DOF from one vector;
- ! DATE: 2017/04/03
- !---------------------------------------------------------------------------------------------
- use globals, only: dp, zero, myid, ounit, &
- & case_coils, Ncoils, coil, DoF, Ndof, Inorm, Gnorm
- implicit none
- include "mpif.h"
-
- REAL :: lxdof(1:Ndof)
- INTEGER :: idof, icoil, ND, astat, ierr, ifirst
- !---------------------------------------------------------------------------------------------
- !FATAL( packdof, .not. allocated(xdof), Please allocate xdof first. )
-
- idof = 0 ; ifirst = 0
- do icoil = 1, Ncoils
-
- if(coil(icoil)%Ic /= 0) then
- coil(icoil)%I = lxdof(idof+1) * Inorm
- idof = idof + 1
- endif
-
- ND = DoF(icoil)%ND
- if(coil(icoil)%Lc /= 0) then
- DoF(icoil)%xdof(1:ND) = lxdof(idof+1:idof+ND) * Gnorm
- idof = idof + ND
- endif
-
- enddo !end do icoil;
-
- !---------------------------------------------------------------------------------------------
- FATAL( unpacking , idof .ne. Ndof, counting error in unpacking )
-
- call unpackcoil !unpack DoF to coil parameters;
- call discoil(ifirst)
-
- call mpi_barrier(MPI_COMM_WORLD, ierr)
-
- return
-END SUBROUTINE unpacking
-
-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
-SUBROUTINE packcoil
- !---------------------------------------------------------------------------------------------
- ! pack coil representation variables into DoF (only geometries without currents);
- ! DATE: 2017/03/25
- !---------------------------------------------------------------------------------------------
- use globals, only: dp, zero, myid, ounit, case_coils, Ncoils, coil, FouCoil, DoF
- implicit none
- include "mpif.h"
-
- INTEGER :: icoil, idof, NF, ierr, astat
-
- FATAL( packcoil, .not. allocated(coil) , illegal )
- FATAL( packcoil, .not. allocated(FouCoil), illegal )
- FATAL( packcoil, .not. allocated(DoF) , illegal )
-
- do icoil = 1, Ncoils
-
- select case (coil(icoil)%itype)
- !---------------------------------------------------------------------------------------------
- case(1)
- ! get number of DoF for each coil and allocate arrays;
- NF = FouCoil(icoil)%NF
- DoF(icoil)%xdof = zero
-
- !pack Fourier series;
- idof = 0
- if(coil(icoil)%Lc /= 0) then
- DoF(icoil)%xdof(idof+1 : idof+NF+1) = FouCoil(icoil)%xc(0:NF); idof = idof + NF + 1
- DoF(icoil)%xdof(idof+1 : idof+NF ) = FouCoil(icoil)%xs(1:NF); idof = idof + NF
- DoF(icoil)%xdof(idof+1 : idof+NF+1) = FouCoil(icoil)%yc(0:NF); idof = idof + NF + 1
- DoF(icoil)%xdof(idof+1 : idof+NF ) = FouCoil(icoil)%ys(1:NF); idof = idof + NF
- DoF(icoil)%xdof(idof+1 : idof+NF+1) = FouCoil(icoil)%zc(0:NF); idof = idof + NF + 1
- DoF(icoil)%xdof(idof+1 : idof+NF ) = FouCoil(icoil)%zs(1:NF); idof = idof + NF
- endif
- FATAL( packcoil , idof .ne. DoF(icoil)%ND, counting error in packing )
-
- !---------------------------------------------------------------------------------------------
- case default
- FATAL(packcoil, .true., not supported coil types)
- end select
-
- enddo ! end do icoil;
-
-END SUBROUTINE packcoil
-
-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
-SUBROUTINE unpackcoil
- !---------------------------------------------------------------------------------------------
- ! pack coil representation variables into DoF (only geometries without currents);
- ! DATE: 2017/03/25
- !---------------------------------------------------------------------------------------------
- use globals, only: dp, zero, myid, ounit, case_coils, Ncoils, coil, FouCoil, DoF
- implicit none
- include "mpif.h"
-
- INTEGER :: icoil, idof, NF, ierr, astat
-
- FATAL( unpackcoil, .not. allocated(coil) , illegal )
- FATAL( unpackcoil, .not. allocated(FouCoil), illegal )
- FATAL( unpackcoil, .not. allocated(DoF) , illegal )
-
- do icoil = 1, Ncoils
-
- select case (coil(icoil)%itype)
- !---------------------------------------------------------------------------------------------
- case(1)
- ! get number of DoF for each coil and allocate arrays;
- NF = FouCoil(icoil)%NF
- idof = 0
- if (coil(icoil)%Lc /= 0) then
- !unpack Fourier series;
- FouCoil(icoil)%xc(0:NF) = DoF(icoil)%xdof(idof+1 : idof+NF+1) ; idof = idof + NF + 1
- FouCoil(icoil)%xs(1:NF) = DoF(icoil)%xdof(idof+1 : idof+NF ) ; idof = idof + NF
- FouCoil(icoil)%yc(0:NF) = DoF(icoil)%xdof(idof+1 : idof+NF+1) ; idof = idof + NF + 1
- FouCoil(icoil)%ys(1:NF) = DoF(icoil)%xdof(idof+1 : idof+NF ) ; idof = idof + NF
- FouCoil(icoil)%zc(0:NF) = DoF(icoil)%xdof(idof+1 : idof+NF+1) ; idof = idof + NF + 1
- FouCoil(icoil)%zs(1:NF) = DoF(icoil)%xdof(idof+1 : idof+NF ) ; idof = idof + NF
- endif
- FATAL( packcoil , idof .ne. DoF(icoil)%ND, counting error in packing )
-
- !---------------------------------------------------------------------------------------------
- case default
- FATAL(packcoil, .true., not supported coil types)
- end select
-
- enddo ! end do icoil;
-
-END SUBROUTINE unpackcoil
diff --git a/sources/poinplot.f90 b/sources/poinplot.f90
new file mode 100644
index 0000000..92cbdd7
--- /dev/null
+++ b/sources/poinplot.f90
@@ -0,0 +1,380 @@
+SUBROUTINE poinplot
+ !------------------------------------------------------------------------------------------------------
+ ! DATE: 12/12/2018
+ ! Poincare plots of the vacuum flux surfaces and calculate the rotational transform
+ !------------------------------------------------------------------------------------------------------
+ USE globals, only : dp, myid, ncpu, zero, half, pi, pi2, ounit, pi, sqrtmachprec, pp_maxiter, &
+ pp_phi, pp_raxis, pp_zaxis, pp_xtol, pp_rmax, pp_zmax, ppr, ppz, pp_ns, iota, &
+ XYZB, lboozmn, booz_mnc, booz_mns, booz_mn, total_num, &
+ master, nmaster, nworker, masterid, color, myworkid, MPI_COMM_MASTERS, &
+ MPI_COMM_MYWORLD, MPI_COMM_WORKERS, plasma, surf
+ USE mpi
+ IMPLICIT NONE
+
+ !-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+ INTEGER :: ierr, astat, iflag
+ INTEGER :: ip, is, niter, icommand
+ REAL :: theta, zeta, r, RZ(2), r1, z1, rzrzt(5), x, y, z
+ REAL :: B(3), start, finish
+
+ !-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+ FATAL( poinplot, pp_ns < 1 , not enough starting points )
+ FATAL( poinplot, pp_maxiter<1 , not enough max. iterations )
+
+ pp_phi = pp_phi * pi ! pp_phi=0.5 -> pi/2
+ x = zero ; y = zero ; z = zero ; B = zero
+
+ ! if raxis, zaxis not provided
+ if ( (abs(pp_raxis) + abs(pp_zaxis)) < sqrtmachprec) then
+ zeta = pp_phi
+ theta = zero ; call surfcoord( plasma, theta, zeta, r , z )
+ theta = pi ; call surfcoord( plasma, theta, zeta, r1, z1)
+
+ pp_raxis = (r+r1)*half
+ pp_zaxis = (z+z1)*half
+ endif
+
+ ! split cores for calculating axis
+ color = 0
+ !CALL MPI_COMM_FREE(MPI_COMM_MYWORLD, ierr)
+ CALL MPI_COMM_SPLIT(MPI_COMM_WORLD, color, myid, MPI_COMM_MYWORLD, ierr)
+ CALL MPI_COMM_RANK(MPI_COMM_MYWORLD, myworkid, ierr)
+ CALL MPI_COMM_SIZE(MPI_COMM_MYWORLD, nworker, ierr)
+
+ RZ(1) = pp_raxis ; RZ(2) = pp_zaxis
+ start = MPI_Wtime()
+ call find_axis(RZ, pp_maxiter, pp_xtol)
+ finish = MPI_Wtime()
+ !print *, 'finding axis takes ', finish-start
+ pp_raxis = RZ(1) ; pp_zaxis = RZ(2)
+
+ call MPI_BARRIER( MPI_COMM_MYWORLD, ierr )
+ CALL MPI_COMM_FREE(MPI_COMM_MYWORLD, ierr)
+
+ ! split cores
+ color = modulo(myid, pp_ns)
+ CALL MPI_COMM_SPLIT(MPI_COMM_WORLD, color, myid, MPI_COMM_MYWORLD, ierr)
+ CALL MPI_COMM_RANK(MPI_COMM_MYWORLD, myworkid, ierr)
+ CALL MPI_COMM_SIZE(MPI_COMM_MYWORLD, nworker, ierr)
+
+ if (myworkid /= 0) then
+ color = MPI_UNDEFINED
+ masterid = -1
+ else
+ color = 0
+ endif
+ !CALL MPI_COMM_FREE(MPI_COMM_MASTERS, ierr)
+ CALL MPI_COMM_SPLIT(MPI_COMM_WORLD, color, myid, MPI_COMM_MASTERS, ierr)
+ if (myworkid==0) then
+ CALL MPI_COMM_RANK(MPI_COMM_MASTERS, masterid, ierr)
+ CALL MPI_COMM_SIZE(MPI_COMM_MASTERS, nmaster, ierr)
+ endif
+ IlBCAST( nmaster, 1, master )
+
+ ! poincare plot and calculate iota
+ SALLOCATE( ppr , (1:pp_ns, 0:pp_maxiter), zero )
+ SALLOCATE( ppz , (1:pp_ns, 0:pp_maxiter), zero )
+ SALLOCATE( iota, (1:pp_ns) , zero )
+
+ ! if pp_rmax and pp_zmax not provied
+ if ( (abs(pp_rmax) + abs(pp_zmax)) < sqrtmachprec) then
+ zeta = pp_phi
+ theta = zero ; call surfcoord( plasma, theta, zeta, r , z )
+ pp_rmax = r*1.0 ; pp_zmax = z*1.0
+ endif
+
+ if(myid==0) write(ounit, '("poinplot: following fieldlines between ("ES12.5 &
+ ","ES12.5" ) and ("ES12.5","ES12.5" )")') pp_raxis, pp_zaxis, pp_rmax, pp_zmax
+
+ do is = 1, pp_ns ! pp_ns is the number of eavaluation surfaces
+ niter = 0 ! number of successful iterations
+ if ( modulo(myid, pp_ns) /= modulo((is-1), nmaster)) cycle ! MPI
+ rzrzt(1:5) = (/ pp_raxis + is*(pp_rmax-pp_raxis)/pp_ns, &
+ pp_zaxis + is*(pp_zmax-pp_zaxis)/pp_ns, &
+ pp_raxis, pp_zaxis, zero /)
+ ppr(is, 0) = rzrzt(1) ; ppz(is, 0) = rzrzt(2)
+
+ do ip = 1, pp_maxiter
+ iflag = 1
+ call ppiota(rzrzt, iflag)
+ if (iflag >= 0) niter = niter + 1 ! counting
+ ppr(is, ip) = rzrzt(1)
+ ppz(is, ip) = rzrzt(2)
+ ! FATAL( poinplot, abs((rzrzt(3)-pp_raxis)/pp_raxis)>pp_xtol, magnetic axis is not coming back )
+ enddo
+
+ if (niter==0) then
+ iota(is) = zero
+ else
+ iota(is) = rzrzt(5) / (niter*pi2/surf(Plasma)%Nfp)
+ endif
+
+ if (myworkid == 0) write(ounit, '(8X": order="I6" ; masterid="I6" ; (R,Z)=("ES12.5","ES12.5 &
+ " ) ; iota="ES12.5" ; niter="I6" .")') is, masterid, ppr(is,0), ppz(is,0), iota(is), niter
+
+ if(lboozmn .and. abs(iota(is))>sqrtmachprec) then
+ x = ppr(is, 0) * cos(pp_phi) ; y = ppr(is, 0) * sin(pp_phi) ; z = ppz(is, 0)
+ call boozsurf( XYZB(1:total_num, 1:4, is), x, y, z, iota(is), is)
+ endif
+ enddo
+
+ if (masterid >= 0) then
+ call MPI_ALLREDUCE( MPI_IN_PLACE, ppr, pp_ns*(pp_maxiter+1), MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_MASTERS, ierr )
+ call MPI_ALLREDUCE( MPI_IN_PLACE, ppz, pp_ns*(pp_maxiter+1), MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_MASTERS, ierr )
+ call MPI_ALLREDUCE( MPI_IN_PLACE, iota, pp_ns , MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_MASTERS, ierr )
+
+ if(lboozmn) then
+ call MPI_ALLREDUCE (MPI_IN_PLACE, XYZB, 4*pp_ns*total_num, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_MASTERS, ierr )
+ call MPI_ALLREDUCE (MPI_IN_PLACE, booz_mnc, pp_ns*booz_mn, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_MASTERS, ierr )
+ call MPI_ALLREDUCE (MPI_IN_PLACE, booz_mns, pp_ns*booz_mn, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_MASTERS, ierr )
+ endif
+
+ CALL MPI_COMM_FREE(MPI_COMM_MASTERS, ierr)
+ endif
+
+ CALL MPI_COMM_FREE(MPI_COMM_MYWORLD, ierr)
+
+return
+
+END SUBROUTINE poinplot
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+SUBROUTINE find_axis(RZ, MAXFEV, XTOL)
+ USE globals, only : dp, myid, ounit, zero, pp_phi
+ USE mpi
+ IMPLICIT NONE
+
+ REAL, INTENT(INOUT) :: RZ(2)
+ REAL, INTENT(IN ) :: XTOL
+ INTEGER, INTENT(IN) :: MAXFEV
+
+ INTEGER, parameter :: n=2
+ INTEGER :: ml,mu,mode,nprint,info,nfev,ldfjac,lr
+ REAL :: epsfcn,factor
+ REAL :: fvec(n),diag(n),qtf(n),wa1(n),wa2(n),wa3(n),wa4(n)
+ REAL, allocatable :: fjac(:,:),r(:)
+ external :: axis_fcn
+
+ LR = N*(N+1)/2
+ LDFJAC = N
+ ml = n-1
+ mu = n-1
+ epsfcn = 1.0E-4
+ mode = 1
+ factor = 100.0
+ nprint = -1
+
+ allocate(fjac(ldfjac,n))
+ allocate(r(lr))
+
+ call hybrd(axis_fcn,n,RZ,fvec,xtol,maxfev,ml,mu,epsfcn,diag, &
+ mode,factor,nprint,info,nfev,fjac,ldfjac,r,lr,qtf,wa1,wa2,wa3,wa4)
+
+ if (myid == 0) then
+ write(ounit,'("findaxis: Finding axis at phi = "ES12.5" with (R,Z) = ( "ES12.5,","ES12.5" ).")') &
+ pp_phi, RZ(1), RZ(2)
+ select case (info)
+ case (0)
+ write(ounit,'("findaxis: info=0, improper input parameters.")')
+ case (1)
+ write(ounit,'("findaxis: info=1, relative error between two consecutive iterates is at most xtol.")')
+ case (2)
+ write(ounit,'("findaxis: info=2, number of calls to fcn has reached or exceeded maxfev.")')
+ case (3)
+ write(ounit,'("findaxis: info=3, xtol is too small.")')
+ case (4)
+ write(ounit,'("findaxis: info=4, iteration is not making good progress, jacobian.")')
+ case (5)
+ write(ounit,'("findaxis: info=5, iteration is not making good progress, function.")')
+ case default
+ write(ounit,'("findaxis: info="I2", something wrong with the axis finding subroutine.")') info
+ end select
+ endif
+
+ return
+
+END SUBROUTINE find_axis
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+SUBROUTINE axis_fcn(n,x,fvec,iflag)
+ USE globals, only : dp, myid, IsQuiet, ounit, zero, pi2, sqrtmachprec, pp_phi, surf, pp_xtol, plasma
+ USE mpi
+ IMPLICIT NONE
+
+ INTEGER :: n, iflag
+ REAL :: x(n), fvec(n)
+
+ INTEGER :: iwork(5), ierr, ifail
+ REAL :: rz_end(n), phi_init, phi_stop, relerr, abserr, work(100+21*N)
+ EXTERNAL :: BRpZ
+
+ ifail = 1
+ relerr = pp_xtol
+ abserr = sqrtmachprec
+ phi_init = pp_phi
+ phi_stop = pp_phi + pi2/surf(plasma)%Nfp
+ rz_end = x
+
+ call ode( BRpZ, n, rz_end, phi_init, phi_stop, relerr, abserr, ifail, work, iwork )
+ if ( ifail /= 2 ) then
+ if ( myid==0 .and. IsQuiet < 0 ) then
+ write ( ounit, '(A,I3)' ) 'axis_fcn: ODE solver ERROR; returned IFAIL = ', ifail
+ select case ( ifail )
+ case ( 3 )
+ write(ounit, '("axis_fcn: DF_xtol or abserr too small.")')
+ case ( 4 )
+ write(ounit, '("axis_fcn: tau not reached after 500 steps.")')
+ case ( 5 )
+ write(ounit, '("axis_fcn: tau not reached because equation to be stiff.")')
+ case ( 6 )
+ write(ounit, '("axis_fcn: INVALID input parameters.")')
+ end select
+ end if
+ iflag = -1
+ ! call MPI_ABORT( MPI_COMM_WORLD, 1, ierr )
+ end if
+
+ fvec = rz_end - x
+
+ return
+END SUBROUTINE axis_fcn
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+SUBROUTINE ppiota(rzrzt,iflag)
+ USE globals, only : dp, myid, IsQuiet, ounit, zero, pi2, sqrtmachprec, pp_phi, surf, pp_xtol, plasma
+ USE mpi
+ IMPLICIT NONE
+
+ INTEGER, parameter :: n = 5
+ INTEGER :: iflag
+ REAL :: rzrzt(n)
+
+ INTEGER :: iwork(5), ierr, ifail
+ REAL :: phi_init, phi_stop, relerr, abserr, work(100+21*N)
+ EXTERNAL :: BRpZ_iota
+
+ ifail = 1
+ relerr = pp_xtol
+ abserr = sqrtmachprec
+ phi_init = pp_phi
+ phi_stop = pp_phi + pi2/surf(plasma)%Nfp
+
+ call ode( BRpZ_iota, n, rzrzt, phi_init, phi_stop, relerr, abserr, ifail, work, iwork )
+ if ( ifail /= 2 ) then
+ if ( IsQuiet < -1 ) then
+ write ( ounit, '(A,I3)' ) 'ppiota : ODE solver ERROR; returned IFAIL = ', ifail
+ select case ( ifail )
+ case ( 3 )
+ write(ounit, '("ppiota : DF_xtol or abserr too small.")')
+ case ( 4 )
+ write(ounit, '("ppiota : tau not reached after 500 steps.")')
+ case ( 5 )
+ write(ounit, '("ppiota : tau not reached because equation to be stiff.")')
+ case ( 6 )
+ write(ounit, '("ppiota : INVALID input parameters.")')
+ end select
+ end if
+ iflag = -1
+ ! call MPI_ABORT( MPI_COMM_WORLD, 1, ierr )
+ end if
+
+ return
+END SUBROUTINE ppiota
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+SUBROUTINE BRpZ( t, x, dx )
+ !----------------------
+ ! dR/dphi = BR / Bphi
+ ! dZ/dphi = BZ / Bphi
+ !----------------------
+ use globals, only : dp, zero, ounit, myid, ierr, myworkid, nworker, MPI_COMM_MYWORLD
+ USE MPI
+ implicit none
+
+ !---------------------------------------------------------------------------------------------
+ INTEGER, parameter :: n=2
+ REAL, INTENT( IN) :: t, x(n)
+ REAL, INTENT(OUT) :: dx(n)
+
+ REAL :: RR, ZZ, XX, YY, BR, BP, BZ, B(3)
+ external :: coils_bfield
+ !---------------------------------------------------------------------------------------------
+
+ RR = x(1); ZZ = x(2) ! cylindrical coordinate
+ XX = RR*cos(t); YY = RR*sin(t) ! cartesian coordinate
+ B = zero
+
+ call coils_bfield(B, XX, YY, ZZ)
+
+ BR = B(1)*cos(t) + B(2)*sin(t)
+ BP = ( - B(1)*sin(t) + B(2)*cos(t) ) / RR
+ BZ = B(3)
+
+ dx(1) = BR/BP
+ dx(2) = BZ/BP
+
+ return
+END SUBROUTINE BRpZ
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+SUBROUTINE BRpZ_iota( t, x, dx )
+ !----------------------
+ ! dR/dphi = BR / Bphi
+ ! dZ/dphi = BZ / Bphi
+ !----------------------
+ use globals, only : dp, zero, ounit, myid, ierr, machprec
+ USE MPI
+ implicit none
+
+ !---------------------------------------------------------------------------------------------
+ INTEGER, parameter :: n=5
+ REAL, INTENT( IN) :: t, x(n)
+ REAL, INTENT(OUT) :: dx(n)
+
+ REAL :: RR, ZZ, XX, YY, BR, BP, BZ, B(3), length
+ external :: coils_bfield
+ !---------------------------------------------------------------------------------------------
+
+ ! field line
+ RR = x(1); ZZ = x(2) ! cylindrical coordinate
+ XX = RR*cos(t); YY = RR*sin(t) ! cartesian coordinate
+ B = zero
+
+ call coils_bfield(B, XX, YY, ZZ)
+
+ BR = B(1)*cos(t) + B(2)*sin(t)
+ BP = ( - B(1)*sin(t) + B(2)*cos(t) ) / RR
+ BZ = B(3)
+
+ dx(1) = BR/BP
+ dx(2) = BZ/BP
+
+ ! magnetic axis
+ RR = x(3); ZZ = x(4) ! cylindrical coordinate
+ XX = RR*cos(t); YY = RR*sin(t) ! cartesian coordinate
+ B = zero
+
+ call coils_bfield(B, XX, YY, ZZ)
+
+ BR = B(1)*cos(t) + B(2)*sin(t)
+ BP = ( - B(1)*sin(t) + B(2)*cos(t) ) / RR
+ BZ = B(3)
+
+ dx(3) = BR/BP
+ dx(4) = BZ/BP
+
+ ! integrate theta
+ length = (x(1) - x(3))**2 + (x(2)-x(4))**2 ! delta R^2 + delta Z^2
+ FATAL( poinplot, length < machprec, the field line is too close to the axis )
+ dx(5) = ( (x(1) - x(3))*(dx(2)-dx(4)) - (x(2)-x(4))*(dx(1)-dx(3)) ) / length
+
+ return
+END SUBROUTINE BRpZ_iota
+
diff --git a/sources/rdcoils.h b/sources/rdcoils.f90
similarity index 60%
rename from sources/rdcoils.h
rename to sources/rdcoils.f90
index 05c9298..ba7691b 100644
--- a/sources/rdcoils.h
+++ b/sources/rdcoils.f90
@@ -22,14 +22,14 @@
!latex \item[1.] \inputvar{case\_init = 1} : Toroidally placing \inputvar{Ncoils} circular coils with a
!latex radius of \inputvar{init\_radius} and current of \inputvar{init\_current}. The $i$th coil
!latex is placed at $\z = \frac{i-1}{Ncoils} \frac{2\pi}{Nfp}$.
-!latex \item[2.] \inputvar{case\_init = 0} : Read coils data from {\bf ext.focus} file. The format is as following. \red{This is the most flexible way, and
-!latex each coil can be different.}
+!latex \item[2.] \inputvar{case\_init = 0} : Read coils data from {\bf ext.focus} file. The format is as following.
+!latex \red{This is the most flexible way, and each coil can be different.}
!latex \begin{raw}
!latex # Total number of coils
!latex 16
!latex #------------1--------------------------------
-!latex #coil_type coil_name
-!latex 1 Mod_001
+!latex #coil_type symm coil_name
+!latex 1 0 Mod_001
!latex #Nseg current Ifree Length Lfree target_length
!latex 128 9.844910899889484E+05 1 5.889288927667147E+00 1 1.000000000000000E+00
!latex #NFcoil
@@ -41,7 +41,16 @@
!latex 0.000000000000000E+00 -5.425716121023922E-02 -8.986316303345250E-02 -2.946386365076052E-03 -4.487052148209031E-03
!latex -4.293247278325474E-17 -1.303273952226587E-15 7.710821807870230E-16 -3.156539892466338E-16 9.395672288215928E-17
!latex 0.000000000000000E+00 9.997301975562740E-01 2.929938238054118E-02 2.436889176706748E-02 1.013941937492003E-03
-!latex #-----------2---------------------------------
+!latex #-----------2--permanent magnet---------------
+!latex #coil_type symm coil_name
+!latex 2 0 dipole_01
+!latex # Lc ox oy oz Ic I mt mp
+!latex 1 0.0 0.0 0.0 1 1.0E6 0.0 0.0
+!latex #-----------3--backgound Bt Bz----------------
+!latex #coil_type symm coil_name
+!latex 3 0 bg_BtBz_01
+!latex # Ic I Lc Bz (Ic control I; Lc control Bz)
+!latex 1 1.0E6 0 0.0
!latex .
!latex .
!latex .
@@ -83,39 +92,36 @@
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
subroutine rdcoils
-
use globals
-
+ use mpi
implicit none
- include "mpif.h"
-
LOGICAL :: exist
- INTEGER :: icoil, maxnseg, ifirst, NF, itmp, ip, icoef, total_coef
- REAL :: Rmaj, zeta, totalcurrent, z0, r1, r2, z1, z2
+ INTEGER :: icoil, maxnseg, ifirst, NF, itmp, ip, icoef, total_coef, num_pm, num_bg, &
+ num_per_array, num_tor, ipol, itor
+ REAL :: Rmaj, zeta, totalcurrent, z0, r1, r2, z1, z2, rtmp, teta
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
Nfixcur = 0 ! fixed coil current number
Nfixgeo = 0 ! fixed coil geometry number
+ num_pm = 0 ! number of permanent magnets
+ num_bg = 0 ! number of background field
if(myid == 0) write(ounit, *) "-----------INITIALIZE COILS----------------------------------"
-
select case( case_init )
-
- !-------------read coils file--------------------------------------------------------------------------
+ !-------------read coils file--------------------------------------------------------------------------
case(-1 )
if (myid == 0) then
- write(ounit,'("rdcoils : Reading coils data (MAKEGRID format) from "A)') trim(inpcoils)
- call readcoils(inpcoils, maxnseg)
+ write(ounit,'("rdcoils : Reading coils data (MAKEGRID format) from "A)') trim(input_coils)
+ call readcoils(input_coils, maxnseg)
write(ounit,'(" : Read ",i6," coils.")') Ncoils
if (IsQuiet < 0) write(ounit, '(8X,": NFcoil = "I3" ; IsVaryCurrent = "I1 &
" ; IsVaryGeometry = "I1)') NFcoil, IsVaryCurrent, IsVaryGeometry
endif
-
IlBCAST( Ncoils , 1, 0 )
IlBCAST( maxnseg , 1, 0 )
-
- if( .not. allocated(coilsX) ) then !allocate arrays on other nodes;
+ ! allocate arrays on other nodes;
+ if( .not. allocated(coilsX) ) then
SALLOCATE( coilsX, (1:maxnseg,1:Ncoils), zero )
SALLOCATE( coilsY, (1:maxnseg,1:Ncoils), zero )
SALLOCATE( coilsZ, (1:maxnseg,1:Ncoils), zero )
@@ -123,7 +129,6 @@ subroutine rdcoils
SALLOCATE( coilseg,( 1:Ncoils), 0 )
SALLOCATE( coilname,( 1:Ncoils), '' )
endif
-
! broadcast coils data;
RlBCAST( coilsX, maxnseg*Ncoils, 0 )
RlBCAST( coilsY, maxnseg*Ncoils, 0 )
@@ -131,16 +136,15 @@ subroutine rdcoils
RlBCAST( coilsI, Ncoils, 0 )
IlBCAST( coilseg, Ncoils, 0 )
ClBCAST( coilname, Ncoils, 0 )
-
+ ! Ncoils are the number of unique coils
allocate( coil(1:Ncoils) )
allocate( FouCoil(1:Ncoils) )
allocate( DoF(1:Ncoils) )
-
- Ncoils = Ncoils / Npc ! Ncoils changed to unique number of coils;
+ !Ncoils = Ncoils / Npc ! Ncoils changed to unique number of coils;
icoil = 0
do icoil = 1, Ncoils
-
- !general coil parameters;
+ ! general coil parameters;
+ coil(icoil)%symm = 0 ! no symmetry or periodicity
coil(icoil)%NS = Nseg
coil(icoil)%I = coilsI(icoil)
coil(icoil)%Ic = IsVaryCurrent
@@ -148,14 +152,13 @@ subroutine rdcoils
coil(icoil)%Lc = IsVaryGeometry
coil(icoil)%Lo = target_length
coil(icoil)%name = trim(coilname(icoil))
-
- FATAL( rdcoils, coil(icoil)%Ic < 0 .or. coil(icoil)%Ic > 1, illegal )
- FATAL( rdcoils, coil(icoil)%Lc < 0 .or. coil(icoil)%Lc > 1, illegal )
- FATAL( rdcoils, coil(icoil)%Lo < zero , illegal )
+ ! check coil current and length
+ FATAL( rdcoils01, coil(icoil)%Ic < 0 .or. coil(icoil)%Ic > 1, illegal )
+ FATAL( rdcoils02, coil(icoil)%Lc < 0 .or. coil(icoil)%Lc > 1, illegal )
+ FATAL( rdcoils03, coil(icoil)%Lo < zero , illegal )
if(coil(icoil)%Ic == 0) Nfixcur = Nfixcur + 1
if(coil(icoil)%Lc == 0) Nfixgeo = Nfixgeo + 1
-
- !Fourier representation related;
+ ! Fourier representation related;
FouCoil(icoil)%NF = NFcoil
NF = NFcoil ! alias
SALLOCATE( FouCoil(icoil)%xc, (0:NF), zero )
@@ -164,129 +167,156 @@ subroutine rdcoils
SALLOCATE( FouCoil(icoil)%ys, (0:NF), zero )
SALLOCATE( FouCoil(icoil)%zc, (0:NF), zero )
SALLOCATE( FouCoil(icoil)%zs, (0:NF), zero )
-
!if(myid .ne. modulo(icoil-1, ncpu)) cycle
-
- call Fourier( coilsX(1:coilseg(icoil),icoil), Foucoil(icoil)%xc, Foucoil(icoil)%xs, coilseg(icoil), NF)
- call Fourier( coilsY(1:coilseg(icoil),icoil), Foucoil(icoil)%yc, Foucoil(icoil)%ys, coilseg(icoil), NF)
- call Fourier( coilsZ(1:coilseg(icoil),icoil), Foucoil(icoil)%zc, Foucoil(icoil)%zs, coilseg(icoil), NF)
-
+ ! Fourier transformation (FFT might be appied)
+ call Fourier( coilsX(1:coilseg(icoil),icoil), Foucoil(icoil)%xc, Foucoil(icoil)%xs, coilseg(icoil), NF)
+ call Fourier( coilsY(1:coilseg(icoil),icoil), Foucoil(icoil)%yc, Foucoil(icoil)%ys, coilseg(icoil), NF)
+ call Fourier( coilsZ(1:coilseg(icoil),icoil), Foucoil(icoil)%zc, Foucoil(icoil)%zs, coilseg(icoil), NF)
enddo
-
+ ! clean space
DALLOCATE( coilsX )
DALLOCATE( coilsY )
DALLOCATE( coilsZ )
DALLOCATE( coilsI )
DALLOCATE( coilseg)
DALLOCATE(coilname)
+ ! use Fourier representation by default
+ coil(1:Ncoils)%type = 1
- coil(1:Ncoils)%itype = case_coils
-
- !-------------individual coil file---------------------------------------------------------------------
+ !-------------individual coil file---------------------------------------------------------------------
case( 0 )
-
- if( myid==0 ) then !get file number;
- open( runit, file=trim(coilfile), status="old", action='read')
+ ! get coil number first
+ if( myid==0 ) then
+ open( runit, file=trim(input_coils), status="old", action='read')
read( runit,*)
read( runit,*) Ncoils
- write(ounit,'("rdcoils : identified "i3" unique coils in "A" ;")') Ncoils, coilfile
- endif
-
+ write(ounit,'("rdcoils : identified "i6" unique coils in "A" ;")') Ncoils, trim(input_coils)
+ endif
+ ! broadcase and allocate data
IlBCAST( Ncoils , 1, 0 )
- allocate( FouCoil(1:Ncoils*Npc) )
- allocate( coil(1:Ncoils*Npc) )
- allocate( DoF(1:Ncoils*Npc) )
-
+ allocate( FouCoil(1:Ncoils) )
+ allocate( coil(1:Ncoils) )
+ allocate( DoF(1:Ncoils) )
+ ! master CPU read the coils
if( myid==0 ) then
do icoil = 1, Ncoils
read( runit,*)
read( runit,*)
- read( runit,*) coil(icoil)%itype, coil(icoil)%name
- if(coil(icoil)%itype /= 1) then
+ read( runit,*) coil(icoil)%type, coil(icoil)%symm, coil(icoil)%name
+ FATAL( rdcoils04, coil(icoil)%type < 1 .or. coil(icoil)%type > 3, illegal )
+ FATAL( rdcoils05, coil(icoil)%symm < 0 .or. coil(icoil)%symm > 2, illegal )
+ if(coil(icoil)%type == 1) then ! Fourier representation
+ read( runit,*)
+ read( runit,*) coil(icoil)%NS, coil(icoil)%I, coil(icoil)%Ic, &
+ & coil(icoil)%L, coil(icoil)%Lc, coil(icoil)%Lo
+ FATAL( rdcoils06, coil(icoil)%NS < 0 , illegal )
+ FATAL( rdcoils07, coil(icoil)%Ic < 0 .or. coil(icoil)%Ic > 1, illegal )
+ FATAL( rdcoils08, coil(icoil)%Lc < 0 .or. coil(icoil)%Lc > 1, illegal )
+ FATAL( rdcoils09, coil(icoil)%L < zero , illegal )
+ FATAL( rdcoils10, coil(icoil)%Lo < zero , illegal )
+ read( runit,*)
+ read( runit,*) FouCoil(icoil)%NF
+ FATAL( rdcoils12, Foucoil(icoil)%NF < 0 , illegal )
+ SALLOCATE( FouCoil(icoil)%xc, (0:FouCoil(icoil)%NF), zero )
+ SALLOCATE( FouCoil(icoil)%xs, (0:FouCoil(icoil)%NF), zero )
+ SALLOCATE( FouCoil(icoil)%yc, (0:FouCoil(icoil)%NF), zero )
+ SALLOCATE( FouCoil(icoil)%ys, (0:FouCoil(icoil)%NF), zero )
+ SALLOCATE( FouCoil(icoil)%zc, (0:FouCoil(icoil)%NF), zero )
+ SALLOCATE( FouCoil(icoil)%zs, (0:FouCoil(icoil)%NF), zero )
+ read( runit,*)
+ read( runit,*) FouCoil(icoil)%xc(0:FouCoil(icoil)%NF)
+ read( runit,*) FouCoil(icoil)%xs(0:FouCoil(icoil)%NF)
+ read( runit,*) FouCoil(icoil)%yc(0:FouCoil(icoil)%NF)
+ read( runit,*) FouCoil(icoil)%ys(0:FouCoil(icoil)%NF)
+ read( runit,*) FouCoil(icoil)%zc(0:FouCoil(icoil)%NF)
+ read( runit,*) FouCoil(icoil)%zs(0:FouCoil(icoil)%NF)
+ else if (coil(icoil)%type == 2) then ! permanent magnets
+ read( runit,*)
+ read( runit,*) coil(icoil)%Lc, coil(icoil)%ox, coil(icoil)%oy, coil(icoil)%oz, &
+ coil(icoil)%Ic, coil(icoil)%I , coil(icoil)%mt, coil(icoil)%mp
+ else if (coil(icoil)%type == 3) then ! backgroud toroidal/vertical field
+ read( runit,*)
+ read( runit,*) coil(icoil)%Ic, coil(icoil)%I, coil(icoil)%Lc, coil(icoil)%Bz
+ coil(icoil)%symm = 0 ! automatic reset to 0; might not be necessary; 2020/01/17
+ else
STOP " wrong coil type in rdcoils"
call MPI_ABORT(MPI_COMM_WORLD, 1, ierr)
- endif
- read( runit,*)
- read( runit,*) coil(icoil)%NS, coil(icoil)%I, coil(icoil)%Ic, &
- & coil(icoil)%L, coil(icoil)%Lc, coil(icoil)%Lo
- FATAL( rdcoils, coil(icoil)%NS < 0 , illegal )
- FATAL( rdcoils, coil(icoil)%Ic < 0 .or. coil(icoil)%Ic > 1, illegal )
- FATAL( rdcoils, coil(icoil)%Lc < 0 .or. coil(icoil)%Lc > 2, illegal )
- FATAL( rdcoils, coil(icoil)%L < zero , illegal )
- FATAL( rdcoils, coil(icoil)%Lc < zero , illegal )
- FATAL( rdcoils, coil(icoil)%Lo < zero , illegal )
- read( runit,*)
- read( runit,*) FouCoil(icoil)%NF
- FATAL( rdcoils, Foucoil(icoil)%NF < 0 , illegal )
- SALLOCATE( FouCoil(icoil)%xc, (0:FouCoil(icoil)%NF), zero )
- SALLOCATE( FouCoil(icoil)%xs, (0:FouCoil(icoil)%NF), zero )
- SALLOCATE( FouCoil(icoil)%yc, (0:FouCoil(icoil)%NF), zero )
- SALLOCATE( FouCoil(icoil)%ys, (0:FouCoil(icoil)%NF), zero )
- SALLOCATE( FouCoil(icoil)%zc, (0:FouCoil(icoil)%NF), zero )
- SALLOCATE( FouCoil(icoil)%zs, (0:FouCoil(icoil)%NF), zero )
- read( runit,*)
- read( runit,*) FouCoil(icoil)%xc(0:FouCoil(icoil)%NF)
- read( runit,*) FouCoil(icoil)%xs(0:FouCoil(icoil)%NF)
- read( runit,*) FouCoil(icoil)%yc(0:FouCoil(icoil)%NF)
- read( runit,*) FouCoil(icoil)%ys(0:FouCoil(icoil)%NF)
- read( runit,*) FouCoil(icoil)%zc(0:FouCoil(icoil)%NF)
- read( runit,*) FouCoil(icoil)%zs(0:FouCoil(icoil)%NF)
-
+ endif
enddo !end do icoil;
-
close( runit )
endif ! end of if( myid==0 );
-
+ ! broad cast the data and allocate space on slavers
do icoil = 1, Ncoils
-
- IlBCAST( coil(icoil)%itype , 1 , 0 )
- ClBCAST( coil(icoil)%name , 10 , 0 )
- IlBCAST( coil(icoil)%NS , 1 , 0 )
- RlBCAST( coil(icoil)%I , 1 , 0 )
- IlBCAST( coil(icoil)%Ic , 1 , 0 )
- RlBCAST( coil(icoil)%L , 1 , 0 )
- IlBCAST( coil(icoil)%Lc , 1 , 0 )
- RlBCAST( coil(icoil)%Lo , 1 , 0 )
- IlBCAST( FouCoil(icoil)%NF , 1 , 0 )
-
- if (.not. allocated(FouCoil(icoil)%xc) ) then
- SALLOCATE( FouCoil(icoil)%xc, (0:FouCoil(icoil)%NF), zero )
- SALLOCATE( FouCoil(icoil)%xs, (0:FouCoil(icoil)%NF), zero )
- SALLOCATE( FouCoil(icoil)%yc, (0:FouCoil(icoil)%NF), zero )
- SALLOCATE( FouCoil(icoil)%ys, (0:FouCoil(icoil)%NF), zero )
- SALLOCATE( FouCoil(icoil)%zc, (0:FouCoil(icoil)%NF), zero )
- SALLOCATE( FouCoil(icoil)%zs, (0:FouCoil(icoil)%NF), zero )
+ IlBCAST( coil(icoil)%type , 1 , 0 )
+ IlBCAST( coil(icoil)%symm , 1 , 0 )
+ ClBCAST( coil(icoil)%name , 10 , 0 )
+ if(coil(icoil)%type == 1) then ! Fourier representation
+ IlBCAST( coil(icoil)%NS , 1 , 0 )
+ RlBCAST( coil(icoil)%I , 1 , 0 )
+ IlBCAST( coil(icoil)%Ic , 1 , 0 )
+ RlBCAST( coil(icoil)%L , 1 , 0 )
+ IlBCAST( coil(icoil)%Lc , 1 , 0 )
+ RlBCAST( coil(icoil)%Lo , 1 , 0 )
+ IlBCAST( FouCoil(icoil)%NF , 1 , 0 )
+ if (.not. allocated(FouCoil(icoil)%xc) ) then
+ SALLOCATE( FouCoil(icoil)%xc, (0:FouCoil(icoil)%NF), zero )
+ SALLOCATE( FouCoil(icoil)%xs, (0:FouCoil(icoil)%NF), zero )
+ SALLOCATE( FouCoil(icoil)%yc, (0:FouCoil(icoil)%NF), zero )
+ SALLOCATE( FouCoil(icoil)%ys, (0:FouCoil(icoil)%NF), zero )
+ SALLOCATE( FouCoil(icoil)%zc, (0:FouCoil(icoil)%NF), zero )
+ SALLOCATE( FouCoil(icoil)%zs, (0:FouCoil(icoil)%NF), zero )
+ endif
+ RlBCAST( FouCoil(icoil)%xc(0:FouCoil(icoil)%NF) , 1+FouCoil(icoil)%NF , 0 )
+ RlBCAST( FouCoil(icoil)%xs(0:FouCoil(icoil)%NF) , 1+FouCoil(icoil)%NF , 0 )
+ RlBCAST( FouCoil(icoil)%yc(0:FouCoil(icoil)%NF) , 1+FouCoil(icoil)%NF , 0 )
+ RlBCAST( FouCoil(icoil)%ys(0:FouCoil(icoil)%NF) , 1+FouCoil(icoil)%NF , 0 )
+ RlBCAST( FouCoil(icoil)%zc(0:FouCoil(icoil)%NF) , 1+FouCoil(icoil)%NF , 0 )
+ RlBCAST( FouCoil(icoil)%zs(0:FouCoil(icoil)%NF) , 1+FouCoil(icoil)%NF , 0 )
+ if(coil(icoil)%Ic == 0) Nfixcur = Nfixcur + 1
+ if(coil(icoil)%Lc == 0) Nfixgeo = Nfixgeo + 1
+ else if (coil(icoil)%type == 2) then ! permanent magnets
+ IlBCAST( coil(icoil)%Ic, 1 , 0 )
+ RlBCAST( coil(icoil)%I , 1 , 0 )
+ IlBCAST( coil(icoil)%Lc, 1 , 0 )
+ RlBCAST( coil(icoil)%ox, 1 , 0 )
+ RlBCAST( coil(icoil)%oy, 1 , 0 )
+ RlBCAST( coil(icoil)%oz, 1 , 0 )
+ RlBCAST( coil(icoil)%mt, 1 , 0 )
+ RlBCAST( coil(icoil)%mp, 1 , 0 )
+ if(coil(icoil)%Ic == 0) Nfixcur = Nfixcur + 1
+ ! if(coil(icoil)%Lc == 0) Nfixgeo = Nfixgeo + 1
+ Nfixgeo = Nfixgeo + 1 ! always treat as a fixed geometry
+ else if (coil(icoil)%type == 3) then ! backgroud toroidal/vertical field
+ IlBCAST( coil(icoil)%Ic, 1 , 0 )
+ RlBCAST( coil(icoil)%I , 1 , 0 )
+ IlBCAST( coil(icoil)%Lc, 1 , 0 )
+ RlBCAST( coil(icoil)%Bz, 1 , 0 )
+ if(coil(icoil)%Ic == 0) Nfixcur = Nfixcur + 1
+ ! if(coil(icoil)%Lc == 0) Nfixgeo = Nfixgeo + 1
+ Nfixgeo = Nfixgeo + 1 ! always treat as a fixed geometry
+ else
+ STOP " wrong coil type in rdcoils"
+ call MPI_ABORT(MPI_COMM_WORLD, 1, ierr)
endif
- RlBCAST( FouCoil(icoil)%xc(0:FouCoil(icoil)%NF) , 1+FouCoil(icoil)%NF , 0 )
- RlBCAST( FouCoil(icoil)%xs(0:FouCoil(icoil)%NF) , 1+FouCoil(icoil)%NF , 0 )
- RlBCAST( FouCoil(icoil)%yc(0:FouCoil(icoil)%NF) , 1+FouCoil(icoil)%NF , 0 )
- RlBCAST( FouCoil(icoil)%ys(0:FouCoil(icoil)%NF) , 1+FouCoil(icoil)%NF , 0 )
- RlBCAST( FouCoil(icoil)%zc(0:FouCoil(icoil)%NF) , 1+FouCoil(icoil)%NF , 0 )
- RlBCAST( FouCoil(icoil)%zs(0:FouCoil(icoil)%NF) , 1+FouCoil(icoil)%NF , 0 )
-
- if(coil(icoil)%Ic == 0) Nfixcur = Nfixcur + 1
- if(coil(icoil)%Lc == 0) Nfixgeo = Nfixgeo + 1
-
enddo
-
- !-------------toroidally placed circular coils---------------------------------------------------------
+ !-------------toroidally placed circular coils---------------------------------------------------------
case( 1 ) ! toroidally placed coils; 2017/03/13
-
- allocate( FouCoil(1:Ncoils*Npc) )
- allocate( coil(1:Ncoils*Npc) )
- allocate( DoF(1:Ncoils*Npc) )
-
+ ! allocate data
+ allocate( FouCoil(1:Ncoils) )
+ allocate( coil(1:Ncoils) )
+ allocate( DoF(1:Ncoils) )
+ ! screen outputs
if (myid == 0) then
- write(ounit,'("rdcoils : initializing "i3" unique circular coils;")') Ncoils
- if (IsQuiet < 1) write(ounit, '(8X,": Initialize "I4" circular coils with r="ES12.5"m ; I="&
+ write(ounit, '(8X,": Initialize "I4" unique circular coils with r="ES12.5"m ; I="&
ES12.5" A")') Ncoils, init_radius, init_current
if (IsQuiet < 0) write(ounit, '(8X,": NFcoil = "I3" ; IsVaryCurrent = "I1 &
" ; IsVaryGeometry = "I1)') NFcoil, IsVaryCurrent, IsVaryGeometry
endif
-
+ ! initializations
do icoil = 1, Ncoils
-
- !general coil parameters;
+ ! general coil parameters;
+ coil(icoil)%type = 1
+ coil(icoil)%symm = IsSymmetric ! follow the general setting
coil(icoil)%NS = Nseg
coil(icoil)%I = init_current
coil(icoil)%Ic = IsVaryCurrent
@@ -299,8 +329,7 @@ subroutine rdcoils
FATAL( rdcoils, coil(icoil)%Lo < zero , illegal )
if(coil(icoil)%Ic == 0) Nfixcur = Nfixcur + 1
if(coil(icoil)%Lc == 0) Nfixgeo = Nfixgeo + 1
-
- !Fourier representation related;
+ ! Fourier representation related;
FouCoil(icoil)%NF = NFcoil
SALLOCATE( FouCoil(icoil)%xc, (0:NFcoil), zero )
SALLOCATE( FouCoil(icoil)%xs, (0:NFcoil), zero )
@@ -308,82 +337,108 @@ subroutine rdcoils
SALLOCATE( FouCoil(icoil)%ys, (0:NFcoil), zero )
SALLOCATE( FouCoil(icoil)%zc, (0:NFcoil), zero )
SALLOCATE( FouCoil(icoil)%zs, (0:NFcoil), zero )
-
- !initilize with circular coils;
- zeta = (icoil-1+half) * pi2 / (Ncoils*Npc) ! put a half for a shift;
-
- call surfcoord( zero, zeta, r1, z1)
- call surfcoord( pi, zeta, r2, z2)
-
+ ! get the geometry center
+ zeta = (icoil-1+half) * pi2 / (Ncoils*Nfp*2**symmetry) ! put a half for a shift;
+ call surfcoord( plasma, zero, zeta, r1, z1)
+ call surfcoord( plasma, pi, zeta, r2, z2)
Rmaj = half * (r1 + r2)
- z0 = half * (z1 + z2)
-
+ z0 = half * (z1 + z2)
+ ! initilize with circular coils;
FouCoil(icoil)%xc(0:1) = (/ Rmaj * cos(zeta), init_radius * cos(zeta) /)
FouCoil(icoil)%xs(0:1) = (/ zero , zero /)
FouCoil(icoil)%yc(0:1) = (/ Rmaj * sin(zeta), init_radius * sin(zeta) /)
FouCoil(icoil)%ys(0:1) = (/ zero , zero /)
FouCoil(icoil)%zc(0:1) = (/ z0 , zero /)
Foucoil(icoil)%zs(0:1) = (/ zero , init_radius /)
-
enddo ! end of do icoil;
-
- coil(1:Ncoils)%itype = case_coils
-
+ !------------- permanent dipoles and background magnetic field ----------------------------------------
+ case( 2 ) ! averagely positioned permanent dipoles ; will be removed; 2020/01/17
+ allocate( coil(1:Ncoils) )
+ allocate( DoF(1:Ncoils) )
+ num_per_array = 16 ! number of dipoles at each toroidal cross-section
+ num_tor = (Ncoils-1)/num_per_array ! number of toroidal arrangements
+ if (myid == 0) then
+ write(ounit,'("rdcoils : initializing "i3" uniformly positioned magnetic dipoles with toroidal magnetif filed")') Ncoils-1
+ if (IsQuiet < 1) write(ounit, '(8X,": Initialize "I4" X "I4" dipoles on r="ES12.5"m with m="&
+ ES12.5" A")') num_tor, num_per_array, init_radius, init_current
+ if (IsQuiet < 0) write(ounit, '(8X,": IsVaryCurrent = "I1 " ; IsVaryGeometry = "I1)') &
+ IsVaryCurrent, IsVaryGeometry
+ FATAL( rdcoils, modulo(Ncoils-1, num_per_array) /= 0, Please provide a valid number )
+ endif
+ ! background magnetic field Bt Bz
+ icoil = 1
+ coil(icoil)%I = init_current
+ coil(icoil)%Ic = IsVaryCurrent
+ coil(icoil)%L = pi2*init_radius
+ coil(icoil)%Lc = 0 ! IsVaryGeometry ! ignore Bz first; 20190102
+ coil(icoil)%Lo = target_length
+ coil(icoil)%Bz = zero
+ coil(icoil)%name = 'bg_BtBz_01'
+ coil(icoil)%type = 3
+
+ do itor = 1, num_tor
+ zeta = (itor-1) * pi2 / num_tor ! put a half for a shift;
+ call surfcoord( plasma, zero, zeta, r1, z1)
+ call surfcoord( plasma, pi, zeta, r2, z2)
+ Rmaj = half * (r1 + r2)
+ z0 = half * (z1 + z2)
+ do ipol = 1, num_per_array
+ icoil = icoil + 1
+ !general coil parameters;
+ coil(icoil)%type = 2
+ coil(icoil)%Ic = IsVaryCurrent
+ coil(icoil)%I = init_current
+ coil(icoil)%L = pi2*init_radius
+ coil(icoil)%Lc = IsVaryGeometry
+ coil(icoil)%Lo = target_length
+ write(coil(icoil)%name,'("pm_"I6)') icoil
+ FATAL( rdcoils, coil(icoil)%Ic < 0 .or. coil(icoil)%Ic > 1, illegal )
+ FATAL( rdcoils, coil(icoil)%Lc < 0 .or. coil(icoil)%Lc > 1, illegal )
+ FATAL( rdcoils, coil(icoil)%Lo < zero , illegal )
+ if(coil(icoil)%Ic == 0) Nfixcur = Nfixcur + 1
+ if(coil(icoil)%Lc == 0) Nfixgeo = Nfixgeo + 1
+
+ teta = (ipol-1) * pi2 / num_per_array
+ rtmp = Rmaj + init_radius * cos(teta)
+ coil(icoil)%ox = rtmp * cos(zeta)
+ coil(icoil)%oy = rtmp * sin(zeta)
+ coil(icoil)%oz = z0 + init_radius * sin(teta)
+
+!!$ ! toroidal direction
+!!$ coil(icoil)%mx = - init_current * sin(zeta)
+!!$ coil(icoil)%my = init_current * cos(zeta)
+!!$ coil(icoil)%mz = zero
+!!$
+!!$ ! poloidal direction
+!!$ coil(icoil)%mx = - init_current * sin(teta) * cos(zeta)
+!!$ coil(icoil)%my = - init_current * sin(teta) * sin(zeta)
+!!$ coil(icoil)%mz = init_current * cos(teta)
+
+ ! poloidal and toroidal angle; in poloidal direction
+ coil(icoil)%mt = -teta
+ coil(icoil)%mp = zeta
+!!$
+!!$ ! inward direction
+!!$ coil(icoil)%mt = teta + half * pi
+!!$ coil(icoil)%mp = zeta + pi
+!!$
+!!$ ! toroidal direction
+!!$ coil(icoil)%mt = half * pi
+!!$ coil(icoil)%mp = zeta + half * pi
+
+ enddo ! enddo ipol
+ enddo ! enddo itor
+ FATAL( rdcoils, icoil .ne. Ncoils, counting coils wrong when initializing )
end select
-
FATAL( rdcoils, Nfixcur > Ncoils, error with fixed currents )
FATAL( rdcoils, Nfixgeo > Ncoils, error with fixed geometry )
- !-----------------------allocate coil data--------------------------------------------------
- do ip = 1, Npc
- do icoil = 1, Ncoils
- SALLOCATE( coil(icoil+(ip-1)*Ncoils)%xx, (0:coil(icoil)%NS), zero )
- SALLOCATE( coil(icoil+(ip-1)*Ncoils)%yy, (0:coil(icoil)%NS), zero )
- SALLOCATE( coil(icoil+(ip-1)*Ncoils)%zz, (0:coil(icoil)%NS), zero )
- SALLOCATE( coil(icoil+(ip-1)*Ncoils)%xt, (0:coil(icoil)%NS), zero )
- SALLOCATE( coil(icoil+(ip-1)*Ncoils)%yt, (0:coil(icoil)%NS), zero )
- SALLOCATE( coil(icoil+(ip-1)*Ncoils)%zt, (0:coil(icoil)%NS), zero )
- SALLOCATE( coil(icoil+(ip-1)*Ncoils)%xa, (0:coil(icoil)%NS), zero )
- SALLOCATE( coil(icoil+(ip-1)*Ncoils)%ya, (0:coil(icoil)%NS), zero )
- SALLOCATE( coil(icoil+(ip-1)*Ncoils)%za, (0:coil(icoil)%NS), zero )
- SALLOCATE( coil(icoil+(ip-1)*Ncoils)%dl, (0:coil(icoil)%NS), zero )
- SALLOCATE( coil(icoil+(ip-1)*Ncoils)%dd, (0:coil(icoil)%NS), zero )
- enddo
- enddo
-
- SALLOCATE( cosip, (0:Npc), one ) ! cos(ip*pi/Np) ; default one ;
- SALLOCATE( sinip, (0:Npc), zero ) ! sin(ip*pi/Np) ; default zero;
-
- if (Npc >= 2) then
- do ip = 1, Npc-1
- cosip(ip) = cos(ip*pi2/Npc) ; sinip(ip) = sin(ip*pi2/Npc)
- do icoil = 1, Ncoils
- select case (coil(icoil)%itype)
- case( 1 )
- NF = FouCoil(icoil)%NF
- SALLOCATE( FouCoil(icoil+ip*Ncoils)%xc, (0:NF), zero )
- SALLOCATE( FouCoil(icoil+ip*Ncoils)%xs, (0:NF), zero )
- SALLOCATE( FouCoil(icoil+ip*Ncoils)%yc, (0:NF), zero )
- SALLOCATE( FouCoil(icoil+ip*Ncoils)%ys, (0:NF), zero )
- SALLOCATE( FouCoil(icoil+ip*Ncoils)%zc, (0:NF), zero )
- SALLOCATE( FouCoil(icoil+ip*Ncoils)%zs, (0:NF), zero )
- case default
- FATAL(discoil, .true., not supported coil types)
- end select
- enddo
- enddo
-
- call mapcoil ! map perodic coils;
-
- endif
-
!-----------------------normalize currents and geometries-------------------------------------
- !sum the total currents;
+ ! sum the total currents;
totalcurrent = zero
- do icoil = 1, Ncoils*Npc
+ do icoil = 1, Ncoils
totalcurrent = totalcurrent + coil(icoil)%I
enddo
-
if(myid == 0 .and. IsQuiet <= 0) then
write(ounit,'(" : "i3" fixed currents ; "i3" fixed geometries.")') &
& Nfixcur, Nfixgeo
@@ -391,44 +446,11 @@ subroutine rdcoils
! & totalcurrent, totalcurrent * pi2 * two
endif
- if (IsNormalize > 0) then
- Gnorm = 0
- Inorm = 0
- total_coef = 0 ! total number of coefficients
- do icoil = 1, Ncoils
- NF = FouCoil(icoil)%NF
- total_coef = total_coef + (6*NF + 3)
- do icoef = 0, NF
- Gnorm = Gnorm + FouCoil(icoil)%xs(icoef)**2 + FouCoil(icoil)%xc(icoef)**2
- Gnorm = Gnorm + FouCoil(icoil)%ys(icoef)**2 + FouCoil(icoil)%yc(icoef)**2
- Gnorm = Gnorm + FouCoil(icoil)%zs(icoef)**2 + FouCoil(icoil)%zc(icoef)**2
- enddo
- Inorm = Inorm + coil(icoil)%I**2
- enddo
- Gnorm = sqrt(Gnorm/total_coef) * weight_gnorm ! quadratic mean
- Inorm = sqrt(Inorm/Ncoils) * weight_inorm ! quadratic mean
- !Inorm = Inorm * 6 ! compensate for the fact that there are so many more spatial variables
-
- FATAL( rdcoils, abs(Gnorm) < machprec, cannot be zero )
- FATAL( rdcoils, abs(Inorm) < machprec, cannot be zero )
-
- if (myid == 0) then
- write(ounit, '(" : Currents are normalized by " ES23.15)') Inorm
- write(ounit, '(" : Geometries are normalized by " ES23.15)') Gnorm
- endif
-
- else
- Inorm = one
- Gnorm = one
- endif
-
!-----------------------allocate DoF arrays --------------------------------------------------
-
itmp = -1
call AllocData(itmp)
!-----------------------discretize coil data--------------------------------------------------
-
if (myid == 0) then
if (IsQuiet < 0) write(ounit, '(8X,": coils will be discretized in "I6" segments")') Nseg
endif
@@ -441,53 +463,6 @@ subroutine rdcoils
end subroutine rdcoils
-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
-subroutine mapcoil
-!---------------------------------------------------------------------------------------------
-! mapping periodic coils;
-!---------------------------------------------------------------------------------------------
- use globals, only: dp, zero, pi2, myid, ounit, ierr, coil, FouCoil, Ncoils, DoF, Npc, cosip, sinip
- implicit none
- include "mpif.h"
-
- INTEGER :: ip, icoil, NF
-
- do ip = 1, Npc-1
-
- do icoil = 1, Ncoils
-
- coil(icoil+ip*Ncoils)%itype = coil(icoil)%itype
- coil(icoil+ip*Ncoils)%NS = coil(icoil)%NS
- coil(icoil+ip*Ncoils)%Ic = coil(icoil)%Ic
- coil(icoil+ip*Ncoils)%Lc = coil(icoil)%Lc
- coil(icoil+ip*Ncoils)%I = coil(icoil)%I
- coil(icoil+ip*Ncoils)%L = coil(icoil)%L
- coil(icoil+ip*Ncoils)%Lo = coil(icoil)%Lo
- coil(icoil+ip*Ncoils)%maxcurv = coil(icoil)%maxcurv
- coil(icoil+ip*Ncoils)%name = coil(icoil)%name
-
- select case (coil(icoil)%itype)
- case( 1 )
- Foucoil(icoil+ip*Ncoils)%NF = Foucoil(icoil)%NF
- Foucoil(icoil+ip*Ncoils)%xc = Foucoil(icoil)%xc * cosip(ip) - Foucoil(icoil)%yc * sinip(ip)
- Foucoil(icoil+ip*Ncoils)%xs = Foucoil(icoil)%xs * cosip(ip) - Foucoil(icoil)%ys * sinip(ip)
- Foucoil(icoil+ip*Ncoils)%yc = Foucoil(icoil)%yc * cosip(ip) + Foucoil(icoil)%xc * sinip(ip)
- Foucoil(icoil+ip*Ncoils)%ys = Foucoil(icoil)%ys * cosip(ip) + Foucoil(icoil)%xs * sinip(ip)
- Foucoil(icoil+ip*Ncoils)%zc = Foucoil(icoil)%zc
- Foucoil(icoil+ip*Ncoils)%zs = Foucoil(icoil)%zs
- case default
- FATAL(discoil, .true., not supported coil types)
- end select
-
- enddo
- enddo
-
- return
-
-END subroutine mapcoil
-
-
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
subroutine discoil(ifirst)
@@ -496,96 +471,62 @@ subroutine discoil(ifirst)
! if ifirst = 1, it will update all the coils; otherwise, only update free coils;
! date: 20170314
!---------------------------------------------------------------------------------------------
- use globals, only: dp, zero, pi2, myid, ounit, coil, FouCoil, Ncoils, DoF, Npc, cosip, sinip
+ use globals, only: dp, zero, pi2, myid, ounit, coil, FouCoil, Ncoils, DoF
+ use mpi
implicit none
- include "mpif.h"
INTEGER, intent(in) :: ifirst
INTEGER :: icoil, iseg, mm, NS, NF, ierr, astat, ip
REAL :: tt
- REAL,allocatable :: cmt(:,:), smt(:,:)
!-------------------------------------------------------------------------------------------
- !xx, xt, xa are 0, 1st and 2nd derivatives;
- if (Npc >= 2) call mapcoil ! map periodic coils;
-
- do icoil = 1, Ncoils*Npc
-
- if( (coil(icoil)%Lc + ifirst) /= 0) then !first time or if Lc/=0, then need discretize;
-
- !reset to zero for all the coils;
- coil(icoil)%xx = zero
- coil(icoil)%yy = zero
- coil(icoil)%zz = zero
- coil(icoil)%xt = zero
- coil(icoil)%yt = zero
- coil(icoil)%zt = zero
- coil(icoil)%xa = zero
- coil(icoil)%ya = zero
- coil(icoil)%za = zero
-
+ do icoil = 1, Ncoils
+ ! first time or if Lc/=0, then need discretize;
+ if( (coil(icoil)%Lc + ifirst) /= 0) then
!if( myid.ne.modulo(icoil-1,ncpu) ) cycle ! parallelization loop;
-
- select case (coil(icoil)%itype)
+ select case (coil(icoil)%type)
case( 1 )
-
- NS = coil(icoil)%NS; NF = FouCoil(icoil)%NF ! allias variable for simplicity;
- SALLOCATE( cmt, (0:NS, 0:NF), zero )
- SALLOCATE( smt, (0:NS, 0:NF), zero )
-
- do iseg = 0, NS ; tt = iseg * pi2 / NS
- do mm = 0, NF
- cmt(iseg,mm) = cos( mm * tt )
- smt(iseg,mm) = sin( mm * tt )
- enddo
- enddo
-
+ ! reset to zero for all the coils;
+ coil(icoil)%xx = zero
+ coil(icoil)%yy = zero
+ coil(icoil)%zz = zero
+ coil(icoil)%xt = zero
+ coil(icoil)%yt = zero
+ coil(icoil)%zt = zero
+ coil(icoil)%xa = zero
+ coil(icoil)%ya = zero
+ coil(icoil)%za = zero
+ NS = coil(icoil)%NS
+ NF = FouCoil(icoil)%NF ! allias variable for simplicity;
!-------------------------calculate coil data-------------------------------------------------
mm = 0
- coil(icoil)%xx(0:NS) = cmt(0:NS,mm) * Foucoil(icoil)%xc(mm)
- coil(icoil)%yy(0:NS) = cmt(0:NS,mm) * Foucoil(icoil)%yc(mm)
- coil(icoil)%zz(0:NS) = cmt(0:NS,mm) * Foucoil(icoil)%zc(mm)
+ coil(icoil)%xx(0:NS) = FouCoil(icoil)%cmt(0:NS,mm) * Foucoil(icoil)%xc(mm)
+ coil(icoil)%yy(0:NS) = FouCoil(icoil)%cmt(0:NS,mm) * Foucoil(icoil)%yc(mm)
+ coil(icoil)%zz(0:NS) = FouCoil(icoil)%cmt(0:NS,mm) * Foucoil(icoil)%zc(mm)
do mm = 1, NF
- coil(icoil)%xx(0:NS) = coil(icoil)%xx(0:NS) + ( cmt(0:NS,mm) * Foucoil(icoil)%xc(mm) &
- + smt(0:NS,mm) * Foucoil(icoil)%xs(mm) )
- coil(icoil)%yy(0:NS) = coil(icoil)%yy(0:NS) + ( cmt(0:NS,mm) * Foucoil(icoil)%yc(mm) &
- + smt(0:NS,mm) * Foucoil(icoil)%ys(mm) )
- coil(icoil)%zz(0:NS) = coil(icoil)%zz(0:NS) + ( cmt(0:NS,mm) * Foucoil(icoil)%zc(mm) &
- + smt(0:NS,mm) * Foucoil(icoil)%zs(mm) )
-
- coil(icoil)%xt(0:NS) = coil(icoil)%xt(0:NS) + ( - smt(0:NS,mm) * Foucoil(icoil)%xc(mm) &
- + cmt(0:NS,mm) * Foucoil(icoil)%xs(mm) ) * mm
- coil(icoil)%yt(0:NS) = coil(icoil)%yt(0:NS) + ( - smt(0:NS,mm) * Foucoil(icoil)%yc(mm) &
- + cmt(0:NS,mm) * Foucoil(icoil)%ys(mm) ) * mm
- coil(icoil)%zt(0:NS) = coil(icoil)%zt(0:NS) + ( - smt(0:NS,mm) * Foucoil(icoil)%zc(mm) &
- + cmt(0:NS,mm) * Foucoil(icoil)%zs(mm) ) * mm
-
- coil(icoil)%xa(0:NS) = coil(icoil)%xa(0:NS) + ( - cmt(0:NS,mm) * Foucoil(icoil)%xc(mm) &
- - smt(0:NS,mm) * Foucoil(icoil)%xs(mm) ) * mm*mm
- coil(icoil)%ya(0:NS) = coil(icoil)%ya(0:NS) + ( - cmt(0:NS,mm) * Foucoil(icoil)%yc(mm) &
- - smt(0:NS,mm) * Foucoil(icoil)%ys(mm) ) * mm*mm
- coil(icoil)%za(0:NS) = coil(icoil)%za(0:NS) + ( - cmt(0:NS,mm) * Foucoil(icoil)%zc(mm) &
- - smt(0:NS,mm) * Foucoil(icoil)%zs(mm) ) * mm*mm
+ coil(icoil)%xx(0:NS) = coil(icoil)%xx(0:NS) + ( FouCoil(icoil)%cmt(0:NS,mm) * Foucoil(icoil)%xc(mm) &
+ + FouCoil(icoil)%smt(0:NS,mm) * Foucoil(icoil)%xs(mm) )
+ coil(icoil)%yy(0:NS) = coil(icoil)%yy(0:NS) + ( FouCoil(icoil)%cmt(0:NS,mm) * Foucoil(icoil)%yc(mm) &
+ + FouCoil(icoil)%smt(0:NS,mm) * Foucoil(icoil)%ys(mm) )
+ coil(icoil)%zz(0:NS) = coil(icoil)%zz(0:NS) + ( FouCoil(icoil)%cmt(0:NS,mm) * Foucoil(icoil)%zc(mm) &
+ + FouCoil(icoil)%smt(0:NS,mm) * Foucoil(icoil)%zs(mm) )
+ coil(icoil)%xt(0:NS) = coil(icoil)%xt(0:NS) + ( - FouCoil(icoil)%smt(0:NS,mm) * Foucoil(icoil)%xc(mm) &
+ + FouCoil(icoil)%cmt(0:NS,mm) * Foucoil(icoil)%xs(mm) ) * mm
+ coil(icoil)%yt(0:NS) = coil(icoil)%yt(0:NS) + ( - FouCoil(icoil)%smt(0:NS,mm) * Foucoil(icoil)%yc(mm) &
+ + FouCoil(icoil)%cmt(0:NS,mm) * Foucoil(icoil)%ys(mm) ) * mm
+ coil(icoil)%zt(0:NS) = coil(icoil)%zt(0:NS) + ( - FouCoil(icoil)%smt(0:NS,mm) * Foucoil(icoil)%zc(mm) &
+ + FouCoil(icoil)%cmt(0:NS,mm) * Foucoil(icoil)%zs(mm) ) * mm
+ coil(icoil)%xa(0:NS) = coil(icoil)%xa(0:NS) + ( - FouCoil(icoil)%cmt(0:NS,mm) * Foucoil(icoil)%xc(mm) &
+ - FouCoil(icoil)%smt(0:NS,mm) * Foucoil(icoil)%xs(mm) ) * mm*mm
+ coil(icoil)%ya(0:NS) = coil(icoil)%ya(0:NS) + ( - FouCoil(icoil)%cmt(0:NS,mm) * Foucoil(icoil)%yc(mm) &
+ - FouCoil(icoil)%smt(0:NS,mm) * Foucoil(icoil)%ys(mm) ) * mm*mm
+ coil(icoil)%za(0:NS) = coil(icoil)%za(0:NS) + ( - FouCoil(icoil)%cmt(0:NS,mm) * Foucoil(icoil)%zc(mm) &
+ - FouCoil(icoil)%smt(0:NS,mm) * Foucoil(icoil)%zs(mm) ) * mm*mm
enddo ! end of do mm;
- if(ifirst /= 0) then
- ip = (icoil-1)/Ncoils ! the integer is the period number;
- DoF(icoil)%xof(0:NS-1, 1: NF+1) = cosip(ip) * cmt(0:NS-1, 0:NF) !x/xc
- DoF(icoil)%xof(0:NS-1, NF+2:2*NF+1) = cosip(ip) * smt(0:NS-1, 1:NF) !x/xs
- DoF(icoil)%xof(0:NS-1, 2*NF+2:3*NF+2) = -sinip(ip) * cmt(0:NS-1, 0:NF) !x/yc ; valid for ip>0 ;
- DoF(icoil)%xof(0:NS-1, 3*NF+3:4*NF+2) = -sinip(ip) * smt(0:NS-1, 1:NF) !x/ys ; valid for ip>0 ;
- DoF(icoil)%yof(0:NS-1, 1: NF+1) = sinip(ip) * cmt(0:NS-1, 0:NF) !y/xc ; valid for ip>0 ;
- DoF(icoil)%yof(0:NS-1, NF+2:2*NF+1) = sinip(ip) * smt(0:NS-1, 1:NF) !y/xs ; valid for ip>0 ;
- DoF(icoil)%yof(0:NS-1, 2*NF+2:3*NF+2) = cosip(ip) * cmt(0:NS-1, 0:NF) !y/yc
- DoF(icoil)%yof(0:NS-1, 3*NF+3:4*NF+2) = cosip(ip) * smt(0:NS-1, 1:NF) !y/ys
- DoF(icoil)%zof(0:NS-1, 4*NF+3:5*NF+3) = cmt(0:NS-1, 0:NF) !z/zc
- DoF(icoil)%zof(0:NS-1, 5*NF+4:6*NF+3) = smt(0:NS-1, 1:NF) !z/zs
- endif
-
- coil(icoil)%dd = pi2 / NS ! discretizing factor;
+ case(2)
- DALLOCATE(cmt)
- DALLOCATE(smt)
+ case(3)
case default
FATAL(discoil, .true., not supported coil types)
diff --git a/sources/rdknot.h b/sources/rdknot.f90
similarity index 99%
rename from sources/rdknot.h
rename to sources/rdknot.f90
index b472b3f..3306e46 100644
--- a/sources/rdknot.h
+++ b/sources/rdknot.f90
@@ -24,7 +24,7 @@
subroutine rdknot
use globals, only : dp, zero, one, half, ten, pi2, sqrtmachprec, myid, ncpu, ounit, runit, &
- ext, &
+ ext, input_surf, &
NFcoil, knotsurf, knotphase, &
xkc, xks, ykc, yks, zkc, zks!, kspring, tauend, itau
diff --git a/sources/rdsurf.f90 b/sources/rdsurf.f90
new file mode 100644
index 0000000..4b55641
--- /dev/null
+++ b/sources/rdsurf.f90
@@ -0,0 +1,347 @@
+
+!title (boundary) ! The plasma boundary is read from file
+
+!latex \briefly{A Fourier representation for the plasma boundary is read from file }
+
+!latex \calledby{\link{xfocus}}
+!latex \calls{\link{}}
+
+!latex \section{General representation (stellarator)}
+!latex \subsection{overview}
+!latex The general representation for plasma boundary is in \subroutine{generic}. The basic fomulation
+!latex is
+!latex \be
+!latex \ds R &= \sum R_{mn}^c \, \cos(m\t - n\z) + R_{mn}^s \, \sin(m\t - n\z) \nonumber \\
+!latex \ds Z &= \sum Z_{mn}^c \, \cos(m\t - n\z) + Z_{mn}^s \, \sin(m\t - n\z) \nonumber
+!latex \ee
+!latex Usually, if we imply stellarator symmetry, then $R_{mn}^s$ and $Z_{mn}^c$ would be zero.
+!latex
+!latex The positive driection for poloidal angle $\t$ is \red{counterclockwise} and for toroidal angle is also
+!latex \red{counterclockwise} from the top view. The positive surface normal should be pointed outwards.
+!latex \subsection{Variables}
+!latex The Fourier harmonics of the plasma boundary are reqired in \verb+plasma.boundary+,
+!latex and the format of this file is as follows:
+!latex \begin{raw}
+!latex Nfou ! integer: number of Fourier harmonics for the plasma boundary;
+!latex Nfp ! integer: number of field periodicity;
+!latex NBnf ! integer: number of Fourier harmonics for Bn;
+!latex ---------------------------------------------------------
+!latex bim(1:bmn) ! integer: poloidal mode identification;
+!latex bin(1:bmn) ! integer: toroidal mode identification;
+!latex Bnim(1:bmn)! integer: poloidal mode identification, for Bn;
+!latex Bnin(1:bmn)! integer: toroidal mode identification, for Bn;
+!latex ---------------------------------------------------------
+!latex Rbc(1:bmn) ! real : cylindrical R cosine harmonics;
+!latex Rbs(1:bmn) ! real : cylindrical R sine harmonics;
+!latex Zbc(1:bmn) ! real : cylindrical Z cosine harmonics;
+!latex Zbs(1:bmn) ! real : cylindrical Z sine harmonics;
+!latex Bns(1:nbf) ! real : B normal sin harmonics;
+!latex Bnc(1:nbf) ! real : B normal cos harmonics; \end{raw}
+!latex Note that immediately after reading (and broadcasting)
+!latex \verb+bin+, the field periodicity factor is included, i.e. \verb+bin = bin * Nfp+.
+!latex \subsection{Sample file}
+!latex Example of the plasma.boundary file:
+!latex { \begin{raw}
+!latex #Nfou Nfp NBnf
+!latex 4 2 1
+!latex #plasma boundary
+!latex # n m Rbc Rbs Zbc Zbs
+!latex 0 0 3.00 0.0 0.0 0.00
+!latex 0 1 0.30 0.0 0.0 -0.30
+!latex 1 0 0.00 0.0 0.0 -0.06
+!latex 1 1 -0.06 0.0 0.0 -0.06
+!latex #Bn harmonics
+!latex # n m bnc bns
+!latex 0 0 0.0 0.0
+!latex \end{raw}
+!latex }
+!latex \section{Knotran}
+!latex The input surface file for knotrans is descriped in \code{knotxx}.
+!latex \section{Tokamak}
+!latex This part is reserved for later development of the interface for tokamaks.
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+subroutine fousurf(filename, index)
+ use globals, only : dp, zero, half, pi2, myid, ounit, runit, IsQuiet, IsSymmetric, &
+ Nteta, Nzeta, surf, discretefactor, Nfp, plasma, symmetry, &
+ tflux_sign, cosnfp, sinnfp
+ use mpi
+ implicit none
+
+ CHARACTER(LEN=100), INTENT(IN) :: filename
+ INTEGER, INTENT(IN) :: index
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+ INTEGER :: iosta, astat, ierr, ii, jj, imn, Nfou, Nbnf, ip
+ REAL :: RR(0:2), ZZ(0:2), szeta, czeta, xx(1:3), xt(1:3), xz(1:3), ds(1:3), &
+ teta, zeta, arg, dd, dz
+
+ ! read the header
+ if( myid == 0 ) then
+ open(runit, file=trim(filename), status='old', action='read')
+ read(runit,*) !empty line
+ read(runit,*) surf(index)%Nfou, surf(index)%Nfp, surf(index)%NBnf !read dimensions
+ endif
+
+ !Broadcast the values
+ IlBCAST( surf(index)%Nfou , 1, 0 )
+ IlBCAST( surf(index)%Nfp , 1, 0 )
+ IlBCAST( surf(index)%NBnf , 1, 0 )
+ FATAL( rdsurf, surf(index)%Nfou <= 0, invalid )
+ FATAL( rdsurf, surf(index)%Nfp <= 0, invalid )
+ FATAL( rdsurf, surf(index)%NBnf < 0, invalid )
+ Nfou = surf(index)%Nfou
+ NBnf = surf(index)%NBnf
+
+ !allocate arrays
+ SALLOCATE( surf(index)%bim, (1:Nfou), 0 )
+ SALLOCATE( surf(index)%bin, (1:Nfou), 0 )
+ SALLOCATE( surf(index)%Rbc, (1:Nfou), zero )
+ SALLOCATE( surf(index)%Rbs, (1:Nfou), zero )
+ SALLOCATE( surf(index)%Zbc, (1:Nfou), zero )
+ SALLOCATE( surf(index)%Zbs, (1:Nfou), zero )
+
+ if( myid == 0 ) then
+ read(runit,*) !empty line
+ read(runit,*) !empty line
+ do imn = 1, surf(index)%Nfou
+ read(runit,*) surf(index)%bin(imn), surf(index)%bim(imn), surf(index)%Rbc(imn), &
+ & surf(index)%Rbs(imn), surf(index)%Zbc(imn), surf(index)%Zbs(imn)
+ enddo
+ endif
+
+ IlBCAST( surf(index)%bim(1:Nfou), surf(index)%Nfou, 0 )
+ IlBCAST( surf(index)%bin(1:Nfou), surf(index)%Nfou, 0 )
+
+ surf(index)%bin(1:Nfou) = surf(index)%bin(1:Nfou) * surf(index)%Nfp !The full plasma;
+
+ RlBCAST( surf(index)%Rbc(1:Nfou), surf(index)%Nfou, 0 )
+ RlBCAST( surf(index)%Rbs(1:Nfou), surf(index)%Nfou, 0 )
+ RlBCAST( surf(index)%Zbc(1:Nfou), surf(index)%Nfou, 0 )
+ RlBCAST( surf(index)%Zbs(1:Nfou), surf(index)%Nfou, 0 )
+
+ !read Bnormal ditributions
+ if( surf(index)%NBnf > 0) then
+ SALLOCATE( surf(index)%Bnim, (1:NBnf), 0 )
+ SALLOCATE( surf(index)%Bnin, (1:NBnf), 0 )
+ SALLOCATE( surf(index)%Bnc , (1:NBnf), zero )
+ SALLOCATE( surf(index)%Bns , (1:NBnf), zero )
+
+ if( myid == 0 ) then
+ read(runit,*) !empty line
+ read(runit,*) !empty line
+ do imn = 1, surf(index)%NBnf
+ read(runit,*) surf(index)%Bnin(imn), surf(index)%Bnim(imn), surf(index)%Bnc(imn), surf(index)%Bns(imn)
+ enddo
+ endif
+
+ IlBCAST( surf(index)%Bnim(1:NBnf), surf(index)%NBnf, 0 )
+ IlBCAST( surf(index)%Bnin(1:NBnf), surf(index)%NBnf, 0 )
+
+ !if (IsSymmetric == 0)
+ surf(index)%Bnin(1:NBnf) = surf(index)%Bnin(1:NBnf) * surf(index)%Nfp ! periodicity;
+ ! This should be consistent with bnftran; Before fully constructed the stellarator symmetry,
+ ! it's turned off;
+
+ RlBCAST( surf(index)%Bnc(1:NBnf) , surf(index)%NBnf, 0 )
+ RlBCAST( surf(index)%Bns(1:NBnf) , surf(index)%NBnf, 0 )
+ endif
+
+ if( myid == 0 ) close(runit,iostat=iosta)
+
+ IlBCAST( iosta, 1, 0 )
+
+ FATAL( surface, iosta.ne.0, error closing the surface )
+
+ !-------------output for check-------------------------------------------------------------------------
+ if( myid == 0 .and. IsQuiet <= 0) then
+ write(ounit, *) "-----------Reading surface-----------------------------------"
+ write(ounit, '("surface : The surface ", A," will be discretized in "I6" X "I6" elements.")') trim(filename), Nteta, Nzeta
+ write(ounit, '(8X": Nfou = " I06 " ; Nfp = " I06 " ; NBnf = " I06 " ;" )') surf(index)%Nfou, surf(index)%Nfp, surf(index)%NBnf
+ endif
+
+ if( myid == 0 .and. IsQuiet <= -2) then ! very detailed output;
+ write(ounit,'(" : " 10x " : bim ="10i13 )') surf(index)%bim(1:Nfou)
+ write(ounit,'(" : " 10x " : bin ="10i13 )') surf(index)%bin(1:Nfou)
+ write(ounit,'(" : " 10x " : Rbc ="10es13.5)') surf(index)%Rbc(1:Nfou)
+ write(ounit,'(" : " 10x " : Rbs ="10es13.5)') surf(index)%Rbs(1:Nfou)
+ write(ounit,'(" : " 10x " : Zbc ="10es13.5)') surf(index)%Zbc(1:Nfou)
+ write(ounit,'(" : " 10x " : Zbs ="10es13.5)') surf(index)%Zbs(1:Nfou)
+ if(Nbnf > 0) then
+ write(ounit,'(" : " 10x " : Bnim ="10i13 )') surf(index)%Bnim(1:NBnf)
+ write(ounit,'(" : " 10x " : Bnin ="10i13 )') surf(index)%Bnin(1:NBnf)
+ write(ounit,'(" : " 10x " : Bnc ="10es13.5)') surf(index)%Bnc (1:NBnf)
+ write(ounit,'(" : " 10x " : Bns ="10es13.5)') surf(index)%Bns (1:NBnf)
+ endif
+ endif
+
+ surf(index)%Nteta = Nteta
+ surf(index)%Nzeta = Nzeta
+
+ if (index == plasma) then
+ select case (IsSymmetric)
+ case ( 0 )
+ Nfp = 1 ! reset Nfp to 1;
+ symmetry = 0
+ case ( 1 ) ! plasma and coil periodicity enabled;
+ Nfp = surf(plasma)%Nfp ! use the raw Nfp
+ symmetry = 0
+ case ( 2 ) ! stellarator symmetry enforced;
+ Nfp = surf(plasma)%Nfp ! use the raw Nfp
+ symmetry = 1
+ end select
+
+ SALLOCATE( cosnfp, (1:Nfp), zero )
+ SALLOCATE( sinnfp, (1:Nfp), zero )
+ do ip = 1, Nfp
+ cosnfp(ip) = cos((ip-1)*pi2/Nfp)
+ sinnfp(ip) = sin((ip-1)*pi2/Nfp)
+ enddo
+ ! discretefactor = discretefactor/Nfp
+ surf(index)%Nzeta = Nzeta * Nfp * 2**symmetry ! the total number from [0, 2pi]
+ discretefactor = (pi2/surf(plasma)%Nteta) * (pi2/surf(plasma)%Nzeta)
+ endif
+
+ SALLOCATE( surf(index)%xx, (0:Nteta-1,0:Nzeta-1), zero ) !x coordinates;
+ SALLOCATE( surf(index)%yy, (0:Nteta-1,0:Nzeta-1), zero ) !y coordinates
+ SALLOCATE( surf(index)%zz, (0:Nteta-1,0:Nzeta-1), zero ) !z coordinates
+ SALLOCATE( surf(index)%nx, (0:Nteta-1,0:Nzeta-1), zero ) !unit nx;
+ SALLOCATE( surf(index)%ny, (0:Nteta-1,0:Nzeta-1), zero ) !unit ny;
+ SALLOCATE( surf(index)%nz, (0:Nteta-1,0:Nzeta-1), zero ) !unit nz;
+ SALLOCATE( surf(index)%ds, (0:Nteta-1,0:Nzeta-1), zero ) !jacobian;
+ SALLOCATE( surf(index)%xt, (0:Nteta-1,0:Nzeta-1), zero ) !dx/dtheta;
+ SALLOCATE( surf(index)%yt, (0:Nteta-1,0:Nzeta-1), zero ) !dy/dtheta;
+ SALLOCATE( surf(index)%zt, (0:Nteta-1,0:Nzeta-1), zero ) !dz/dtheta;
+ SALLOCATE( surf(index)%pb, (0:Nteta-1,0:Nzeta-1), zero ) !target Bn;
+ SALLOCATE( surf(index)%xp, (0:Nteta-1,0:Nzeta-1), zero ) !dx/dzeta;
+ SALLOCATE( surf(index)%yp, (0:Nteta-1,0:Nzeta-1), zero ) !dy/dzeta;
+ SALLOCATE( surf(index)%zp, (0:Nteta-1,0:Nzeta-1), zero ) !dz/dzeta;
+
+ surf(index)%vol = zero ! volume enclosed by plasma boundary
+ surf(index)%area = zero ! surface area
+
+ ! The center point value was used to discretize grid;
+ do ii = 0, Nteta-1
+ teta = ( ii + half ) * pi2 / surf(index)%Nteta
+ do jj = 0, Nzeta-1
+ zeta = ( jj + half ) * pi2 / surf(index)%Nzeta
+ RR(0:2) = zero ; ZZ(0:2) = zero
+ do imn = 1, surf(index)%Nfou
+ arg = surf(index)%bim(imn) * teta - surf(index)%bin(imn) * zeta
+ RR(0) = RR(0) + surf(index)%Rbc(imn) * cos(arg) + surf(index)%Rbs(imn) * sin(arg)
+ ZZ(0) = ZZ(0) + surf(index)%Zbc(imn) * cos(arg) + surf(index)%Zbs(imn) * sin(arg)
+ RR(1) = RR(1) + ( - surf(index)%Rbc(imn) * sin(arg) + surf(index)%Rbs(imn) * cos(arg) ) * surf(index)%bim(imn)
+ ZZ(1) = ZZ(1) + ( - surf(index)%Zbc(imn) * sin(arg) + surf(index)%Zbs(imn) * cos(arg) ) * surf(index)%bim(imn)
+ RR(2) = RR(2) - ( - surf(index)%Rbc(imn) * sin(arg) + surf(index)%Rbs(imn) * cos(arg) ) * surf(index)%bin(imn)
+ ZZ(2) = ZZ(2) - ( - surf(index)%Zbc(imn) * sin(arg) + surf(index)%Zbs(imn) * cos(arg) ) * surf(index)%bin(imn)
+ enddo ! end of do imn; 30 Oct 15;
+ szeta = sin(zeta)
+ czeta = cos(zeta)
+ xx(1:3) = (/ RR(0) * czeta, RR(0) * szeta, ZZ(0) /)
+ xt(1:3) = (/ RR(1) * czeta, RR(1) * szeta, ZZ(1) /)
+ xz(1:3) = (/ RR(2) * czeta, RR(2) * szeta, ZZ(2) /) &
+ + (/ - RR(0) * szeta, RR(0) * czeta, zero /)
+ ! minus sign for theta counterclockwise direction;
+ ds(1:3) = -(/ xt(2) * xz(3) - xt(3) * xz(2), &
+ xt(3) * xz(1) - xt(1) * xz(3), &
+ xt(1) * xz(2) - xt(2) * xz(1) /)
+ dd = sqrt( sum( ds(1:3)*ds(1:3) ) )
+ ! x, y, z coordinates for the surface;
+ surf(index)%xx(ii,jj) = xx(1)
+ surf(index)%yy(ii,jj) = xx(2)
+ surf(index)%zz(ii,jj) = xx(3)
+ ! dx/dt, dy/dt, dz/dt (dt for d theta)
+ surf(index)%xt(ii,jj) = xt(1)
+ surf(index)%yt(ii,jj) = xt(2)
+ surf(index)%zt(ii,jj) = xt(3)
+ ! dx/dp, dy/dp, dz/dp (dp for d zeta(phi))
+ surf(index)%xp(ii,jj) = xz(1)
+ surf(index)%yp(ii,jj) = xz(2)
+ surf(index)%zp(ii,jj) = xz(3)
+ ! surface normal vectors and ds for the jacobian;
+ surf(index)%nx(ii,jj) = ds(1) / dd
+ surf(index)%ny(ii,jj) = ds(2) / dd
+ surf(index)%nz(ii,jj) = ds(3) / dd
+ surf(index)%ds(ii,jj) = dd
+ ! using Gauss theorom; V = \int_S x \cdot n dt dz
+ surf(index)%vol = surf(index)%vol + surf(index)%xx(ii,jj) * ds(1) &
+ & + surf(index)%yy(ii,jj) * ds(2) + surf(index)%zz(ii,jj) * ds(3)
+ ! surface area
+ surf(index)%area = surf(index)%area + surf(index)%ds(ii,jj)
+ enddo ! end of do jj; 14 Apr 16;
+ enddo ! end of do ii; 14 Apr 16;
+
+ ! print volume and area
+ surf(index)%vol = abs(surf(index)%vol)/3 * (pi2/surf(index)%Nteta) * (pi2/surf(index)%Nzeta)
+ surf(index)%area = abs(surf(index)%area) * (pi2/surf(index)%Nteta) * (pi2/surf(index)%Nzeta)
+ if (index == plasma) then
+ surf(index)%vol = surf(index)%vol * Nfp * 2**symmetry
+ surf(index)%area = surf(index)%area * Nfp * 2**symmetry
+ endif
+
+ if( myid == 0 .and. IsQuiet <= 0) then
+ write(ounit, '(8X": Enclosed total surface volume ="ES12.5" m^3 ; area ="ES12.5" m^2." )') &
+ surf(index)%vol, surf(index)%area
+ endif
+
+ ! check theta direction for the plasma surface and determine the toroidal flux sign
+ if (index == plasma) then
+ dz = surf(plasma)%zz(1,0) - surf(plasma)%zz(0,0)
+ if (dz > 0) then
+ ! counter-clockwise
+ if( myid == 0) write(ounit, '(8X": The theta angle used is counter-clockwise.")')
+ tflux_sign = -1
+ else
+ ! clockwise
+ if( myid == 0) write(ounit, '(8X": The theta angle used is clockwise.")')
+ tflux_sign = 1
+ endif
+ endif
+
+ !calculate target Bn with input harmonics; 05 Jan 17;
+ if(surf(index)%NBnf > 0) then
+ do jj = 0, Nzeta-1
+ zeta = ( jj + half ) * pi2 / surf(index)%Nzeta
+ do ii = 0, Nteta-1
+ teta = ( ii + half ) * pi2 / surf(index)%Nteta
+ do imn = 1, surf(index)%NBnf
+ arg = surf(index)%Bnim(imn) * teta - surf(index)%Bnin(imn) * zeta
+ surf(index)%pb(ii,jj) = surf(index)%pb(ii,jj) + surf(index)%Bnc(imn)*cos(arg) + surf(index)%Bns(imn)*sin(arg)
+ enddo
+ enddo
+ enddo
+ endif
+
+ return
+
+end subroutine fousurf
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+subroutine surfcoord( index, theta, zeta, r, z)
+ use globals, only: dp, zero, surf
+ use mpi
+ implicit none
+
+ INTEGER, INTENT(in) :: index
+ REAL, INTENT(in ) :: theta, zeta
+ REAL, INTENT(out) :: r, z
+
+ INTEGER :: imn
+ REAL :: arg
+ !-------------calculate r, z coodinates for theta, zeta------------------------------------------------
+ if( .not. allocated(surf(index)%bim) ) STOP "please allocate surface data first!"
+
+ r = zero; z = zero
+ do imn = 1, surf(index)%Nfou
+ arg = surf(index)%bim(imn) * theta - surf(index)%bin(imn) * zeta
+ R = R + surf(index)%Rbc(imn) * cos(arg) + surf(index)%Rbs(imn) * sin(arg)
+ Z = Z + surf(index)%Zbc(imn) * cos(arg) + surf(index)%Zbs(imn) * sin(arg)
+ enddo
+
+ return
+end subroutine surfcoord
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
diff --git a/sources/rdsurf.h b/sources/rdsurf.h
deleted file mode 100644
index 286a94a..0000000
--- a/sources/rdsurf.h
+++ /dev/null
@@ -1,315 +0,0 @@
-
-!title (boundary) ! The plasma boundary is read from file
-
-!latex \briefly{A Fourier representation for the plasma boundary is read from file }
-
-!latex \calledby{\link{xfocus}}
-!latex \calls{\link{}}
-
-!latex \section{General representation (stellarator)}
-!latex \subsection{overview}
-!latex The general representation for plasma boundary is in \subroutine{generic}. The basic fomulation
-!latex is
-!latex \be
-!latex \ds R &= \sum R_{mn}^c \, \cos(m\t - n\z) + R_{mn}^s \, \sin(m\t - n\z) \nonumber \\
-!latex \ds Z &= \sum Z_{mn}^c \, \cos(m\t - n\z) + Z_{mn}^s \, \sin(m\t - n\z) \nonumber
-!latex \ee
-!latex Usually, if we imply stellarator symmetry, then $R_{mn}^s$ and $Z_{mn}^c$ would be zero.
-!latex
-!latex The positive driection for poloidal angle $\t$ is \red{counterclockwise} and for toroidal angle is also
-!latex \red{counterclockwise} from the top view. The positive surface normal should be pointed outwards.
-!latex \subsection{Variables}
-!latex The Fourier harmonics of the plasma boundary are reqired in \verb+plasma.boundary+,
-!latex and the format of this file is as follows:
-!latex \begin{raw}
-!latex Nfou ! integer: number of Fourier harmonics for the plasma boundary;
-!latex Nfp ! integer: number of field periodicity;
-!latex NBnf ! integer: number of Fourier harmonics for Bn;
-!latex ---------------------------------------------------------
-!latex bim(1:bmn) ! integer: poloidal mode identification;
-!latex bin(1:bmn) ! integer: toroidal mode identification;
-!latex Bnim(1:bmn)! integer: poloidal mode identification, for Bn;
-!latex Bnin(1:bmn)! integer: toroidal mode identification, for Bn;
-!latex ---------------------------------------------------------
-!latex Rbc(1:bmn) ! real : cylindrical R cosine harmonics;
-!latex Rbs(1:bmn) ! real : cylindrical R sine harmonics;
-!latex Zbc(1:bmn) ! real : cylindrical Z cosine harmonics;
-!latex Zbs(1:bmn) ! real : cylindrical Z sine harmonics;
-!latex Bns(1:nbf) ! real : B normal sin harmonics;
-!latex Bnc(1:nbf) ! real : B normal cos harmonics; \end{raw}
-!latex Note that immediately after reading (and broadcasting)
-!latex \verb+bin+, the field periodicity factor is included, i.e. \verb+bin = bin * Nfp+.
-!latex \subsection{Sample file}
-!latex Example of the plasma.boundary file:
-!latex { \begin{raw}
-!latex #Nfou Nfp NBnf
-!latex 4 2 1
-!latex #plasma boundary
-!latex # n m Rbc Rbs Zbc Zbs
-!latex 0 0 3.00 0.0 0.0 0.00
-!latex 0 1 0.30 0.0 0.0 -0.30
-!latex 1 0 0.00 0.0 0.0 -0.06
-!latex 1 1 -0.06 0.0 0.0 -0.06
-!latex #Bn harmonics
-!latex # n m bnc bns
-!latex 0 0 0.0 0.0
-!latex \end{raw}
-!latex }
-!latex \section{Knotran}
-!latex The input surface file for knotrans is descriped in \code{knotxx}.
-!latex \section{Tokamak}
-!latex This part is reserved for later development of the interface for tokamaks.
-
-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
-subroutine fousurf
-
- use globals, only : dp, zero, half, pi2, myid, ounit, runit, surffile, IsQuiet, IsSymmetric, &
- Nfou, Nfp, NBnf, bim, bin, Bnim, Bnin, Rbc, Rbs, Zbc, Zbs, Bnc, Bns, &
- Nteta, Nzeta, surf, Npc, discretefactor, Nfp_raw
-
- implicit none
-
- include "mpif.h"
-
-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
- LOGICAL :: exist
- INTEGER :: iosta, astat, ierr, ii, jj, imn
- REAL :: RR(0:2), ZZ(0:2), szeta, czeta, xx(1:3), xt(1:3), xz(1:3), ds(1:3), &
- teta, zeta, arg, dd
-
- !-------------read plasma.boundary---------------------------------------------------------------------
- inquire( file=trim(surffile), exist=exist)
- FATAL( surface, .not.exist, plasma.boundary does not exist )
- if( myid == 0 ) then
- open(runit, file=trim(surffile), status='old', action='read')
- read(runit,*) !empty line
- read(runit,*) Nfou, Nfp, NBnf !read dimensions
- endif
-
- !Broadcast the values
- IlBCAST( Nfou , 1, 0 )
- IlBCAST( Nfp , 1, 0 )
- IlBCAST( NBnf , 1, 0 )
- FATAL( surface, Nfou <= 0, invalid )
- FATAL( surface, Nfp <= 0, invalid )
- FATAL( surface, NBnf < 0, invalid )
-
- !allocate arrays
- SALLOCATE( bim, (1:Nfou), 0 )
- SALLOCATE( bin, (1:Nfou), 0 )
- SALLOCATE( Rbc, (1:Nfou), zero )
- SALLOCATE( Rbs, (1:Nfou), zero )
- SALLOCATE( Zbc, (1:Nfou), zero )
- SALLOCATE( Zbs, (1:Nfou), zero )
-
- if( myid == 0 ) then
- read(runit,*) !empty line
- read(runit,*) !empty line
- do imn = 1, Nfou
- read(runit,*) bin(imn), bim(imn), Rbc(imn), Rbs(imn), Zbc(imn), Zbs(imn)
- enddo
- endif
-
- IlBCAST( bim(1:Nfou), Nfou, 0 )
- IlBCAST( bin(1:Nfou), Nfou, 0 )
-
- bin(1:Nfou) = bin(1:Nfou) * Nfp !The full plasma;
-
- RlBCAST( Rbc(1:Nfou), Nfou, 0 )
- RlBCAST( Rbs(1:Nfou), Nfou, 0 )
- RlBCAST( Zbc(1:Nfou), Nfou, 0 )
- RlBCAST( Zbs(1:Nfou), Nfou, 0 )
-
- !read Bnormal ditributions
- if( NBnf > 0) then
- SALLOCATE( Bnim, (1:NBnf), 0 )
- SALLOCATE( Bnin, (1:NBnf), 0 )
- SALLOCATE( Bnc , (1:NBnf), zero )
- SALLOCATE( Bns , (1:NBnf), zero )
-
- if( myid == 0 ) then
- read(runit,*) !empty line
- read(runit,*) !empty line
- do imn = 1, NBnf
- read(runit,*) Bnin(imn), Bnim(imn), Bnc(imn), Bns(imn)
- enddo
- endif
-
- IlBCAST( Bnim(1:NBnf), NBnf, 0 )
- IlBCAST( Bnin(1:NBnf), NBnf, 0 )
-
- !if (IsSymmetric == 0)
- Bnin(1:NBnf) = Bnin(1:NBnf) * Nfp ! Disarde periodicity;
- ! This should be consistent with bnftran; Before fully constructed the stellarator symmetry,
- ! it's turned off;
-
- RlBCAST( Bnc(1:NBnf) , NBnf, 0 )
- RlBCAST( Bns(1:NBnf) , NBnf, 0 )
- endif
-
- if( myid == 0 ) close(runit,iostat=iosta)
-
- IlBCAST( iosta, 1, 0 )
-
- FATAL( surface, iosta.ne.0, error closing plasma.boundary )
-
- !-------------output for check-------------------------------------------------------------------------
- if( myid == 0 .and. IsQuiet <= 0) then
- write(ounit, *) "-----------Reading surface-----------------------------------"
- write(ounit, '("surface : Plasma boundary will be discretized in "I6" X "I6" elements.")') Nteta, Nzeta
- write(ounit, '(8X": Nfou = " I06 " ; Nfp = " I06 " ; NBnf = " I06 " ;" )') Nfou, Nfp, NBnf
- endif
-
- if( myid == 0 .and. IsQuiet <= -2) then !very detailed output;
- write(ounit,'(" : " 10x " : bim ="10i13 )') bim(1:Nfou)
- write(ounit,'(" : " 10x " : bin ="10i13 )') bin(1:Nfou)
- write(ounit,'(" : " 10x " : Rbc ="10es13.5)') Rbc(1:Nfou)
- write(ounit,'(" : " 10x " : Rbs ="10es13.5)') Rbs(1:Nfou)
- write(ounit,'(" : " 10x " : Zbc ="10es13.5)') Zbc(1:Nfou)
- write(ounit,'(" : " 10x " : Zbs ="10es13.5)') Zbs(1:Nfou)
- if(Nbnf > 0) then
- write(ounit,'(" : " 10x " : Bnim ="10i13 )') Bnim(1:NBnf)
- write(ounit,'(" : " 10x " : Bnin ="10i13 )') Bnin(1:NBnf)
- write(ounit,'(" : " 10x " : Bnc ="10es13.5)') Bnc (1:NBnf)
- write(ounit,'(" : " 10x " : Bns ="10es13.5)') Bns (1:NBnf)
- endif
- endif
-
- !-------------discretize surface data------------------------------------------------------------------
-
- Nfp_raw = Nfp ! save the raw value of Nfp
- select case (IsSymmetric)
- case ( 0 )
- Nfp = 1 !reset Nfp to 1;
- Npc = 1 !number of coils periodicity
- case ( 1 ) !plasma periodicity enabled;
- Npc = 1
- case ( 2 ) !plasma and coil periodicity enabled;
- Npc = Nfp
- end select
- discretefactor = discretefactor/Nfp
-
- allocate( surf(1:1) ) ! can allow for myltiple plasma boundaries
- ! if multiple currents are allowed; 14 Apr 16;
-
- surf(1)%Nteta = Nteta ! not used yet; used for multiple surfaces; 20170307;
- surf(1)%Nzeta = Nzeta ! not used yet; used for multiple surfaces; 20170307;
-
- SALLOCATE( surf(1)%xx, (0:Nteta-1,0:Nzeta-1), zero ) !x coordinates;
- SALLOCATE( surf(1)%yy, (0:Nteta-1,0:Nzeta-1), zero ) !y coordinates
- SALLOCATE( surf(1)%zz, (0:Nteta-1,0:Nzeta-1), zero ) !z coordinates
- SALLOCATE( surf(1)%nx, (0:Nteta-1,0:Nzeta-1), zero ) !unit nx;
- SALLOCATE( surf(1)%ny, (0:Nteta-1,0:Nzeta-1), zero ) !unit ny;
- SALLOCATE( surf(1)%nz, (0:Nteta-1,0:Nzeta-1), zero ) !unit nz;
- SALLOCATE( surf(1)%ds, (0:Nteta-1,0:Nzeta-1), zero ) !jacobian;
- SALLOCATE( surf(1)%xt, (0:Nteta-1,0:Nzeta-1), zero ) !dx/dtheta;
- SALLOCATE( surf(1)%yt, (0:Nteta-1,0:Nzeta-1), zero ) !dy/dtheta;
- SALLOCATE( surf(1)%zt, (0:Nteta-1,0:Nzeta-1), zero ) !dz/dtheta;
- SALLOCATE( surf(1)%pb, (0:Nteta-1,0:Nzeta-1), zero ) !target Bn;
- SALLOCATE( surf(1)%xp, (0:Nteta-1,0:Nzeta-1), zero ) !dx/dzeta;
- SALLOCATE( surf(1)%yp, (0:Nteta-1,0:Nzeta-1), zero ) !dy/dzeta;
- SALLOCATE( surf(1)%zp, (0:Nteta-1,0:Nzeta-1), zero ) !dz/dzeta;
-
-! The center point value was used to discretize grid;
- do ii = 0, Nteta-1; teta = ( ii + half ) * pi2 / Nteta
- do jj = 0, Nzeta-1; zeta = ( jj + half ) * pi2 / ( Nzeta*Nfp )
-
- RR(0:2) = zero ; ZZ(0:2) = zero
-
- do imn = 1, Nfou ; arg = bim(imn) * teta - bin(imn) * zeta
-
- RR(0) = RR(0) + Rbc(imn) * cos(arg) + Rbs(imn) * sin(arg)
- ZZ(0) = ZZ(0) + Zbc(imn) * cos(arg) + Zbs(imn) * sin(arg)
-
- RR(1) = RR(1) + ( - Rbc(imn) * sin(arg) + Rbs(imn) * cos(arg) ) * bim(imn)
- ZZ(1) = ZZ(1) + ( - Zbc(imn) * sin(arg) + Zbs(imn) * cos(arg) ) * bim(imn)
-
- RR(2) = RR(2) - ( - Rbc(imn) * sin(arg) + Rbs(imn) * cos(arg) ) * bin(imn)
- ZZ(2) = ZZ(2) - ( - Zbc(imn) * sin(arg) + Zbs(imn) * cos(arg) ) * bin(imn)
-
- enddo ! end of do imn; 30 Oct 15;
-
- szeta = sin(zeta)
- czeta = cos(zeta)
-
- xx(1:3) = (/ RR(0) * czeta, RR(0) * szeta, ZZ(0) /)
- xt(1:3) = (/ RR(1) * czeta, RR(1) * szeta, ZZ(1) /)
- xz(1:3) = (/ RR(2) * czeta, RR(2) * szeta, ZZ(2) /) + (/ - RR(0) * szeta, RR(0) * czeta, zero /)
-
- ds(1:3) = -(/ xt(2) * xz(3) - xt(3) * xz(2), & ! minus sign for theta counterclockwise direction;
- xt(3) * xz(1) - xt(1) * xz(3), &
- xt(1) * xz(2) - xt(2) * xz(1) /)
-
- dd = sqrt( sum( ds(1:3)*ds(1:3) ) )
-
- ! x, y, z coordinates for the surface;
- surf(1)%xx(ii,jj) = xx(1)
- surf(1)%yy(ii,jj) = xx(2)
- surf(1)%zz(ii,jj) = xx(3)
-
- ! dx/dt, dy/dt, dz/dt (dt for d theta)
- surf(1)%xt(ii,jj) = xt(1)
- surf(1)%yt(ii,jj) = xt(2)
- surf(1)%zt(ii,jj) = xt(3)
-
- ! dx/dp, dy/dp, dz/dp (dp for d zeta(phi))
- surf(1)%xp(ii,jj) = xz(1)
- surf(1)%yp(ii,jj) = xz(2)
- surf(1)%zp(ii,jj) = xz(3)
-
- ! surface normal vectors and ds for the jacobian;
- surf(1)%nx(ii,jj) = ds(1) / dd
- surf(1)%ny(ii,jj) = ds(2) / dd
- surf(1)%nz(ii,jj) = ds(3) / dd
- surf(1)%ds(ii,jj) = dd
-
- enddo ! end of do jj; 14 Apr 16;
- enddo ! end of do ii; 14 Apr 16;
-
- !calculate target Bn with input harmonics; 05 Jan 17;
- if(NBnf > 0) then
-
- do jj = 0, Nzeta-1 ; zeta = ( jj + half ) * pi2 / (Nzeta*Nfp)
- do ii = 0, Nteta-1 ; teta = ( ii + half ) * pi2 / Nteta
- do imn = 1, NBnf
- arg = Bnim(imn) * teta - Bnin(imn) * zeta
- surf(1)%pb(ii,jj) = surf(1)%pb(ii,jj) + Bnc(imn)*cos(arg) + Bns(imn)*sin(arg)
- enddo
- enddo
- enddo
-
- endif
-
-
- return
-
-end subroutine fousurf
-
-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
-subroutine surfcoord( theta, zeta, r, z)
- use globals, only: dp, zero, Nfou, bim, bin, Rbc, Rbs, Zbc, Zbs
- implicit none
- include "mpif.h"
-
- REAL, INTENT(in ) :: theta, zeta
- REAL, INTENT(out) :: r, z
-
- INTEGER :: imn
- REAL :: arg
- !-------------calculate r, z coodinates for theta, zeta------------------------------------------------
- if( .not. allocated(bim) ) STOP "please allocate surface data first!"
-
- r = zero; z = zero
- do imn = 1, Nfou
- arg = bim(imn) * theta - bin(imn) * zeta
- R = R + Rbc(imn) * cos(arg) + Rbs(imn) * sin(arg)
- Z = Z + Zbc(imn) * cos(arg) + Zbs(imn) * sin(arg)
- enddo
-
- return
-end subroutine surfcoord
-
-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
diff --git a/sources/saving.h b/sources/saving.f90
similarity index 53%
rename from sources/saving.h
rename to sources/saving.f90
index 8a43dfd..797a43a 100644
--- a/sources/saving.h
+++ b/sources/saving.f90
@@ -18,17 +18,15 @@
subroutine saving
use globals
-
+ use mpi
use hdf5
implicit none
- include "mpif.h"
-
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
- INTEGER :: ii, jj, icoil, NF
+ INTEGER :: ii, jj, icoil, NF, ip, is, cs, Npc
! the following are used by the macros HWRITEXX below; do not alter/remove;
INTEGER :: hdfier, rank
@@ -69,6 +67,9 @@ subroutine saving
!INPUT namelist;
HWRITEIV( 1 , IsQuiet , IsQuiet )
HWRITEIV( 1 , IsSymmetric , IsSymmetric )
+ HWRITECH( 100 , input_surf , input_surf )
+ HWRITECH( 100 , input_coils , input_coils )
+ HWRITECH( 100 , input_harm , input_harm )
HWRITEIV( 1 , case_surface , case_surface )
HWRITERV( 1 , knotsurf , knotsurf )
HWRITEIV( 1 , Nteta , Nteta )
@@ -95,9 +96,10 @@ subroutine saving
HWRITERV( 1 , weight_ttlen , weight_ttlen )
HWRITERV( 1 , target_length , target_length )
HWRITERV( 1 , weight_specw , weight_specw )
- HWRITERV( 1 , weight_ccsep , weight_ccsep )
+ HWRITERV( 1 , weight_cssep , weight_cssep )
HWRITERV( 1 , weight_gnorm , weight_gnorm )
HWRITERV( 1 , weight_inorm , weight_inorm )
+ HWRITERV( 1 , weight_mnorm , weight_mnorm )
HWRITERV( 1 , DF_tausta , DF_tausta )
HWRITERV( 1 , DF_tauend , DF_tauend )
HWRITERV( 1 , DF_xtol , DF_xtol )
@@ -118,26 +120,38 @@ subroutine saving
HWRITEIV( 1 , save_coils , save_coils )
HWRITEIV( 1 , save_harmonics, save_harmonics )
HWRITEIV( 1 , save_filaments, save_filaments )
-
- HWRITEIV( 1 , Nfp , Nfp_raw )
- HWRITERA( Nteta,Nzeta , xsurf , surf(1)%xx(0:Nteta-1,0:Nzeta-1) )
- HWRITERA( Nteta,Nzeta , ysurf , surf(1)%yy(0:Nteta-1,0:Nzeta-1) )
- HWRITERA( Nteta,Nzeta , zsurf , surf(1)%zz(0:Nteta-1,0:Nzeta-1) )
- HWRITERA( Nteta,Nzeta , nx , surf(1)%nx(0:Nteta-1,0:Nzeta-1) )
- HWRITERA( Nteta,Nzeta , ny , surf(1)%ny(0:Nteta-1,0:Nzeta-1) )
- HWRITERA( Nteta,Nzeta , nz , surf(1)%nz(0:Nteta-1,0:Nzeta-1) )
+ HWRITEIV( 1 , update_plasma , update_plasma )
+ HWRITERV( 1 , pp_phi , pp_phi )
+ HWRITERV( 1 , pp_raxis , pp_raxis )
+ HWRITERV( 1 , pp_zaxis , pp_zaxis )
+ HWRITERV( 1 , pp_rmax , pp_rmax )
+ HWRITERV( 1 , pp_zmax , pp_zmax )
+ HWRITEIV( 1 , pp_ns , pp_ns )
+ HWRITEIV( 1 , pp_maxiter , pp_maxiter )
+ HWRITERV( 1 , pp_xtol , pp_xtol )
+
+ HWRITEIV( 1 , Nfp , surf(plasma)%Nfp )
+ HWRITERV( 1 , surf_vol , surf(plasma)%vol )
+ HWRITERA( Nteta,Nzeta , xsurf , surf(plasma)%xx(0:Nteta-1,0:Nzeta-1) )
+ HWRITERA( Nteta,Nzeta , ysurf , surf(plasma)%yy(0:Nteta-1,0:Nzeta-1) )
+ HWRITERA( Nteta,Nzeta , zsurf , surf(plasma)%zz(0:Nteta-1,0:Nzeta-1) )
+ HWRITERA( Nteta,Nzeta , nx , surf(plasma)%nx(0:Nteta-1,0:Nzeta-1) )
+ HWRITERA( Nteta,Nzeta , ny , surf(plasma)%ny(0:Nteta-1,0:Nzeta-1) )
+ HWRITERA( Nteta,Nzeta , nz , surf(plasma)%nz(0:Nteta-1,0:Nzeta-1) )
+ HWRITERA( Nteta,Nzeta , nn , surf(plasma)%ds(0:Nteta-1,0:Nzeta-1) )
if (allocated(bn)) then
- HWRITERA( Nteta,Nzeta , plas_Bn , surf(1)%pb(0:Nteta-1,0:Nzeta-1) )
- HWRITERA( Nteta,Nzeta , Bn , surf(1)%bn(0:Nteta-1,0:Nzeta-1) )
- HWRITERA( Nteta,Nzeta , Bx , surf(1)%Bx(0:Nteta-1,0:Nzeta-1) )
- HWRITERA( Nteta,Nzeta , By , surf(1)%By(0:Nteta-1,0:Nzeta-1) )
- HWRITERA( Nteta,Nzeta , Bz , surf(1)%Bz(0:Nteta-1,0:Nzeta-1) )
+ HWRITERA( Nteta,Nzeta , plas_Bn , surf(plasma)%pb(0:Nteta-1,0:Nzeta-1) )
+ HWRITERA( Nteta,Nzeta , Bn , surf(plasma)%bn(0:Nteta-1,0:Nzeta-1) )
+ HWRITERA( Nteta,Nzeta , Bx , surf(plasma)%Bx(0:Nteta-1,0:Nzeta-1) )
+ HWRITERA( Nteta,Nzeta , By , surf(plasma)%By(0:Nteta-1,0:Nzeta-1) )
+ HWRITERA( Nteta,Nzeta , Bz , surf(plasma)%Bz(0:Nteta-1,0:Nzeta-1) )
endif
HWRITEIV( 1 , iout , iout )
HWRITERV( 1 , Inorm , Inorm )
HWRITERV( 1 , Gnorm , Gnorm )
+ HWRITERV( 1 , Mnorm , Mnorm )
HWRITERV( 1 , overlap , overlap )
HWRITERA( iout, 8 , evolution , evolution(1:iout, 0:7) )
HWRITERA( iout, Tdof , coilspace , coilspace(1:iout, 1:Tdof) )
@@ -158,7 +172,7 @@ subroutine saving
endif
if (allocated(coil_importance)) then
- HWRITERV( Ncoils*Npc , coil_importance , coil_importance )
+ HWRITERV( Ncoils , coil_importance , coil_importance )
endif
if (allocated(LM_fvec)) then
@@ -176,12 +190,24 @@ subroutine saving
HWRITERA( LM_mfvec, Ndof , LM_fjac , LM_fjac )
endif
+ if (allocated(ppr)) then
+ HWRITERA( pp_ns, pp_maxiter+1, ppr , ppr(1:pp_ns, 0:pp_maxiter) )
+ HWRITERA( pp_ns, pp_maxiter+1, ppz , ppz(1:pp_ns, 0:pp_maxiter) )
+ HWRITERV( pp_ns , iota , iota(1:pp_ns) )
+ endif
+
+ if (allocated(XYZB)) then
+ HWRITERC( total_num,4, pp_ns , XYZB , XYZB(1:total_num, 1:4, 1:pp_ns) )
+ HWRITERA( booz_mn, pp_ns, booz_mnc , booz_mnc(1:booz_mn, 1:pp_ns) )
+ HWRITERA( booz_mn, pp_ns, booz_mns , booz_mns(1:booz_mn, 1:pp_ns) )
+ HWRITEIV( booz_mn, bmim , bmim(1:booz_mn) )
+ HWRITEIV( booz_mn, bmin , bmin(1:booz_mn) )
+ endif
HWRITERV( 1 , time_initialize, time_initialize )
HWRITERV( 1 , time_optimize , time_optimize )
HWRITERV( 1 , time_postproc , time_postproc )
-
call h5fclose_f( file_id, hdfier ) ! terminate access;
FATAL( restart, hdfier.ne.0, error calling h5fclose_f )
@@ -191,20 +217,21 @@ subroutine saving
!--------------------------write focus coil file-----------------------------------------
if( save_coils == 1 ) then
- open( wunit, file=trim(coilfile), status="unknown", form="formatted")
+ open( wunit, file=trim(out_focus), status="unknown", form="formatted")
write(wunit, *) "# Total number of coils"
write(wunit, '(8X,I6)') Ncoils
do icoil = 1, Ncoils
write(wunit, *) "#-----------------", icoil, "---------------------------"
- write(wunit, *) "#coil_type coil_name"
- write(wunit,'(3X,I3,4X, A10)') coil(icoil)%itype, coil(icoil)%name
- write(wunit, '(3(A6, A15, 8X))') " #Nseg", "current", "Ifree", "Length", "Lfree", "target_length"
- write(wunit,'(2X, I4, ES23.15, 3X, I3, ES23.15, 3X, I3, ES23.15)') &
- coil(icoil)%NS, coil(icoil)%I, coil(icoil)%Ic, coil(icoil)%L, coil(icoil)%Lc, coil(icoil)%Lo
- select case (coil(icoil)%itype)
+ write(wunit, *) "#coil_type coil_symm coil_name"
+ write(wunit,'(3X,I3,4X,I3,4X,A10)') coil(icoil)%type, coil(icoil)%symm, coil(icoil)%name
+
+ select case (coil(icoil)%type)
case (1)
+ write(wunit, '(3(A6, A15, 8X))') " #Nseg", "current", "Ifree", "Length", "Lfree", "target_length"
+ write(wunit,'(2X, I4, ES23.15, 3X, I3, ES23.15, 3X, I3, ES23.15)') &
+ coil(icoil)%NS, coil(icoil)%I, coil(icoil)%Ic, coil(icoil)%L, coil(icoil)%Lc, coil(icoil)%Lo
NF = FouCoil(icoil)%NF ! shorthand;
write(wunit, *) "#NFcoil"
write(wunit, '(I3)') NF
@@ -215,6 +242,14 @@ subroutine saving
write(wunit, 1000) FouCoil(icoil)%ys(0:NF)
write(wunit, 1000) FouCoil(icoil)%zc(0:NF)
write(wunit, 1000) FouCoil(icoil)%zs(0:NF)
+ case (2)
+ write(wunit, *) "# Lc ox oy oz Ic I mt mp"
+ write(wunit,'(2(I3, 3ES23.15))') coil(icoil)%Lc, coil(icoil)%ox, coil(icoil)%oy, coil(icoil)%oz, &
+ coil(icoil)%Ic, coil(icoil)%I , coil(icoil)%mt, coil(icoil)%mp
+ case (3)
+ write(wunit, *) "# Ic I Lc Bz (Ic control I; Lc control Bz)"
+ write(wunit,'(I3, ES23.15, I3, ES23.15)') coil(icoil)%Ic, coil(icoil)%I, &
+ coil(icoil)%Lc, coil(icoil)%Bz
case default
FATAL(restart, .true., not supported coil types)
end select
@@ -227,17 +262,39 @@ subroutine saving
if( save_coils == 1 ) then
- open(funit,file=trim(outcoils), status="unknown", form="formatted" )
- write(funit,'("periods "I3)') Nfp_raw
+ open(funit,file=trim(out_coils), status="unknown", form="formatted" )
+ write(funit,'("periods "I3)') surf(plasma)%Nfp
write(funit,'("begin filament")')
write(funit,'("mirror NIL")')
- do icoil = 1, Ncoils*Npc
- do ii = 0, coil(icoil)%NS-1
- write(funit,1010) coil(icoil)%xx(ii), coil(icoil)%yy(ii), coil(icoil)%zz(ii), coil(icoil)%I
+ do icoil = 1, Ncoils
+ ! will only write x,y,z in cartesian coordinates
+ if (coil(icoil)%type /= 1) cycle
+ ! check if the coil is stellarator symmetric
+ select case (coil(icoil)%symm)
+ case ( 0 )
+ cs = 0
+ Npc = 1
+ case ( 1 )
+ cs = 0
+ Npc = Nfp
+ case ( 2)
+ cs = 1
+ Npc = Nfp
+ end select
+ ! periodicity and stellarator symmetry
+ do ip = 1, Npc
+ do is = 0, cs
+ do ii = 0, coil(icoil)%NS-1
+ write(funit,1010) coil(icoil)%xx(ii)*cosnfp(ip)-coil(icoil)%yy(ii)*sinnfp(ip), &
+ & (-1)**is*(coil(icoil)%xx(ii)*sinnfp(ip)+coil(icoil)%yy(ii)*cosnfp(ip)), &
+ & (-1)**is*coil(icoil)%zz(ii), coil(icoil)%I
+ enddo
+ ii = 0
+ write(funit,1010) coil(icoil)%xx(ii)*cosnfp(ip)-coil(icoil)%yy(ii)*sinnfp(ip), &
+ & (-1)**is*(coil(icoil)%xx(ii)*sinnfp(ip)+coil(icoil)%yy(ii)*cosnfp(ip)),&
+ & (-1)**is*coil(icoil)%zz(ii), zero, icoil, coil(icoil)%name
+ enddo
enddo
- ii = coil(icoil)%NS
- write(funit,1010) coil(icoil)%xx(ii), coil(icoil)%yy(ii), coil(icoil)%zz(ii), &
- zero, icoil, coil(icoil)%name
enddo
write(funit,'("end")')
close(funit)
@@ -254,7 +311,7 @@ subroutine saving
open( funit, file="."//trim(ext)//".filaments."//srestart, status="unknown", form="unformatted" )
write(funit) Ncoils, Nseg
- do icoil = 1, Ncoils*Npc
+ do icoil = 1, Ncoils
write(funit) coil(icoil)%xx(0:coil(icoil)%NS)
write(funit) coil(icoil)%yy(0:coil(icoil)%NS)
write(funit) coil(icoil)%zz(0:coil(icoil)%NS)
@@ -268,12 +325,13 @@ subroutine saving
if (save_harmonics == 1 .and. allocated(Bmnc)) then
- open(wunit, file=trim(harmfile), status='unknown', action='write')
+ open(wunit, file=trim(out_harm), status='unknown', action='write')
write(wunit,'("#NBmn")') ! comment line;
write(wunit,'(I6)') NBmn ! write dimensions
write(wunit,'("# n m Bmnc Bmns wBmn")') ! comment line;
do imn = 1, NBmn
- write(wunit,'(2(I3, 4X), 3(ES23.15,4X))') Bmnin(imn)/Nfp_raw, Bmnim(imn), Bmnc(imn), Bmns(imn), wBmn(imn)
+ write(wunit,'(2(I3, 4X), 3(ES23.15,4X))') Bmnin(imn)/surf(plasma)%Nfp, &
+ Bmnim(imn), Bmnc(imn), Bmns(imn), wBmn(imn)
enddo
close(wunit)
@@ -281,7 +339,126 @@ subroutine saving
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+ if (update_plasma == 1 ) call write_plasma
+
return
end subroutine saving
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+SUBROUTINE write_plasma
+!-------------------------------------------------------------------------------!
+! write down the unpdated plasma boundary information; !
+! CZHU; first version: 2017/01/11; last revised: 2017/01/11 !
+!-------------------------------------------------------------------------------!
+ use globals, only : dp, zero, half, two, pi2, myid, ncpu, ounit, wunit, ext, &
+ plasma, &
+ Nteta, Nzeta, surf, bnorm, sqrtmachprec, out_plasma
+
+ implicit none
+ include "mpif.h"
+
+ !-------------------------------------------------------------------------------
+ INTEGER :: mf, nf ! predefined Fourier modes size
+ INTEGER :: imn=0, ii, jj, im, in, astat, ierr, maxN, maxM, isurf
+ REAL :: teta, zeta, arg, tol, tmpc, tmps
+ !-------------------------------------------------------------------------------
+
+ ! use plasma as default
+ isurf = plasma
+ mf = 24 ; nf = 24
+ FATAL(bnftran, mf .le. 0 .and. nf .le. 0, INVALID size for Fourier harmonics)
+
+ tmpc = zero ; tmps = zero
+
+ if (bnorm .gt. sqrtmachprec ) then
+ tol = 1.0E-8 * bnorm
+ else
+ tol = 1.0E-8
+ endif
+
+ if(myid .ne. 0) return
+
+ if(surf(isurf)%Nbnf .gt. 0) then ! if there is input Bn target
+ DALLOCATE(surf(isurf)%bnim)
+ DALLOCATE(surf(isurf)%bnin)
+ DALLOCATE(surf(isurf)%bnc )
+ DALLOCATE(surf(isurf)%bns )
+ endif
+
+ surf(isurf)%Nbnf = (mf+1)*(2*nf+1) ! (0:mf)*(-nf:nf)
+
+ SALLOCATE( surf(isurf)%bnim, (1:surf(isurf)%Nbnf), 0 )
+ SALLOCATE( surf(isurf)%bnin, (1:surf(isurf)%Nbnf), 0 )
+ SALLOCATE( surf(isurf)%bnc , (1:surf(isurf)%Nbnf), zero )
+ SALLOCATE( surf(isurf)%bns , (1:surf(isurf)%Nbnf), zero )
+
+ imn = 0
+ do in = -nf, nf
+ do im = 0, mf
+
+ tmpc = zero ; tmps = zero
+ do ii = 0, Nteta-1
+ teta = ( ii + half ) * pi2 / Nteta
+ do jj = 0, Nzeta-1
+ zeta = ( jj + half ) * pi2 / Nzeta
+
+ arg = im*teta - in*surf(isurf)%Nfp*zeta
+ tmpc = tmpc + surf(isurf)%bn(ii,jj)*cos(arg)
+ tmps = tmps + surf(isurf)%bn(ii,jj)*sin(arg)
+
+ enddo ! end jj
+ enddo ! end ii
+
+ if ( (abs(tmpc) + abs(tmps)) .lt. tol ) cycle
+
+ imn = imn + 1
+ surf(isurf)%bnin(imn) = in * surf(isurf)%Nfp
+ surf(isurf)%bnim(imn) = im
+
+ if (im .eq. 0 ) then
+ tmpc = tmpc*half
+ tmps = tmps*half
+ endif
+ surf(isurf)%bnc(imn) = tmpc
+ surf(isurf)%bns(imn) = tmps
+
+ enddo ! end im
+ enddo ! end in
+
+ surf(isurf)%Nbnf = imn
+
+ surf(isurf)%bnc = surf(isurf)%bnc * two / (Nteta*Nzeta)
+ surf(isurf)%bns = surf(isurf)%bns * two / (Nteta*Nzeta)
+ !----------------------------------------------
+
+
+ open(wunit, file=trim(out_plasma), status='unknown', action='write')
+
+ write(wunit,* ) "#Nfou Nfp Nbnf"
+ write(wunit,'(3I6)' ) surf(isurf)%Nfou, surf(isurf)%Nfp, surf(isurf)%Nbnf
+
+ write(wunit,* ) "#------- plasma boundary------"
+ write(wunit,* ) "# n m Rbc Rbs Zbc Zbs"
+ do imn = 1, surf(isurf)%Nfou
+ write(wunit,'(2I6, 4ES15.6)') surf(isurf)%bin(imn)/surf(isurf)%Nfp, surf(isurf)%bim(imn), &
+ surf(isurf)%Rbc(imn), surf(isurf)%Rbs(imn), surf(isurf)%Zbc(imn), surf(isurf)%Zbs(imn)
+ enddo
+
+ write(wunit,* ) "#-------Bn harmonics----------"
+ write(wunit,* ) "# n m bnc bns"
+ if (surf(isurf)%Nbnf .gt. 0) then
+ do imn = 1, surf(isurf)%Nbnf
+ write(wunit,'(2I6, 2ES15.6)') surf(isurf)%bnin(imn)/surf(isurf)%Nfp, surf(isurf)%bnim(imn), &
+ surf(isurf)%bnc(imn), surf(isurf)%bns(imn)
+ enddo
+ else
+ write(wunit,'(2I6, 2ES15.6)') 0, 0, 0.0, 0.0
+ endif
+
+ close(wunit)
+END SUBROUTINE write_plasma
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-
diff --git a/sources/solvers.h b/sources/solvers.f90
similarity index 97%
rename from sources/solvers.h
rename to sources/solvers.f90
index 0923c83..17ee014 100644
--- a/sources/solvers.h
+++ b/sources/solvers.f90
@@ -35,7 +35,7 @@
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
subroutine solvers
- use globals, only: dp, ierr, iout, myid, ounit, IsQuiet, IsNormWeight, Ndof, Nouts, xdof, &
+ use globals, only: dp, ierr, iout, myid, ounit, zero, IsQuiet, IsNormWeight, Ndof, Nouts, xdof, &
case_optimize, DF_maxiter, LM_maxiter, CG_maxiter, HN_maxiter, TN_maxiter, coil, DoF, &
weight_bnorm, weight_bharm, weight_tflux, weight_ttlen, weight_cssep, &
target_tflux, target_length, cssep_factor
@@ -75,7 +75,7 @@ subroutine solvers
call costfun(1)
call saveBmn ! in bmnharm.h;
iout = 0 ! reset output counter;
- call output(0.0)
+ call output(zero)
!--------------------------------DF--------------------------------------------------------------------
if (DF_maxiter > 0) then
@@ -419,10 +419,10 @@ subroutine normweight
if ( weight_bharm >= machprec ) then
modBn = sqrt(sum(Bmnc**2 + Bmns**2))
modtBn = sqrt(sum(tBmnc**2 + tBmns**2))
- do icoil = 1, Ncoils
- coil(icoil)%I = coil(icoil)%I * modtBn / modBn
- enddo
- if(myid .eq. 0) write(ounit,'(8X,": rescale coil currents with a factor of "ES12.5)') &
+!!$ do icoil = 1, Ncoils
+!!$ coil(icoil)%I = coil(icoil)%I * modtBn / modBn
+!!$ enddo
+ if(myid .eq. 0) write(ounit,'(8X,": Please rescale coil currents with a factor of "ES12.5)') &
modtBn / modBn
call bnormal(0)
if (abs(bharm) > machprec) weight_bharm = weight_bharm / bharm
@@ -545,7 +545,7 @@ subroutine output (mark)
do icoil = 1, Ncoils
coilspace(iout, idof+1 ) = coil(icoil)%I ; idof = idof + 1
- select case (coil(icoil)%itype)
+ select case (coil(icoil)%type)
case (1)
NF = FouCoil(icoil)%NF
coilspace(iout, idof+1:idof+NF+1) = FouCoil(icoil)%xc(0:NF) ; idof = idof + NF +1
@@ -554,11 +554,11 @@ subroutine output (mark)
coilspace(iout, idof+1:idof+NF ) = FouCoil(icoil)%ys(1:NF) ; idof = idof + NF
coilspace(iout, idof+1:idof+NF+1) = FouCoil(icoil)%zc(0:NF) ; idof = idof + NF +1
coilspace(iout, idof+1:idof+NF ) = FouCoil(icoil)%zs(1:NF) ; idof = idof + NF
- case default
- FATAL(descent, .true., not supported coil types)
+!!$ case default
+!!$ FATAL(output, .true., not supported coil types)
end select
enddo
- FATAL( output , idof .ne. Tdof, counting error in restart )
+!!$ FATAL( output , idof .ne. Tdof, counting error in restart )
endif
if(mod(iout,save_freq) .eq. 0) call saving
diff --git a/sources/specinp.h b/sources/specinp.f90
similarity index 68%
rename from sources/specinp.h
rename to sources/specinp.f90
index b24894e..6f13fff 100644
--- a/sources/specinp.h
+++ b/sources/specinp.f90
@@ -6,17 +6,21 @@ SUBROUTINE specinp
! 2. Calculate the poloidal and toroidal closed currents (Itor and Gpol)
! 3. Write down a xxx.Vns file with all the information for SPEC
!-------------------------------------------------------------------------------!
- use globals, only: dp, zero, half, two, pi2, mu0, myid, wunit, ounit, surf, bn, ext, &
- Nfou, Nfp_raw, bim, bin, Rbc, Rbs, Zbc, Zbs, Nteta, Nzeta
+ use globals, only: dp, zero, half, two, pi2, mu0, myid, wunit, ounit, surf, bn, ext, &
+ Nteta, Nzeta, plasma
implicit none
include "mpif.h"
!-------------------------------------------------------------------------------
- INTEGER :: mf, nf ! Fourier modes size
- INTEGER :: imn=0, ii, jj, im, in, astat, ierr, Nbf, iteta, jzeta
+ INTEGER :: mf, nf, Nfp_raw ! Fourier modes size
+ INTEGER :: imn=0, ii, jj, im, in, astat, ierr, Nbf, iteta, jzeta, isurf
REAL :: teta, zeta, arg, tol, tmpc, tmps, curtor, curpol
INTEGER, allocatable:: bnim(:), bnin(:)
REAL , allocatable:: bnc(:), bns(:)
+ ! use the plasma for now; could be the limiter surface; 2019/12/15
+ isurf = plasma
+ Nfp_raw = surf(isurf)%Nfp
+ ! default Fourier resolution; could be customized
mf = 24 ; nf = 12
! compute Bn
call bnormal(0) ! calculate Bn
@@ -37,9 +41,9 @@ SUBROUTINE specinp
teta = ( ii + half ) * pi2 / Nteta
do jj = 0, Nzeta-1
zeta = ( jj + half ) * pi2 / Nzeta
- arg = im*teta - in*Nfp_raw*zeta
- tmpc = tmpc + (-bn(ii, jj)*surf(1)%ds(ii,jj))*cos(arg) ! minus sign is required because
- tmps = tmps + (-bn(ii, jj)*surf(1)%ds(ii,jj))*sin(arg) ! the normal vector in SPEC is e_t x e_z
+ arg = im*teta - in*surf(isurf)%Nfp*zeta
+ tmpc = tmpc + (-bn(ii, jj)*surf(isurf)%ds(ii,jj))*cos(arg) ! minus sign is required because
+ tmps = tmps + (-bn(ii, jj)*surf(isurf)%ds(ii,jj))*sin(arg) ! the normal vector in SPEC is e_t x e_z
enddo ! end jj
enddo ! end ii
@@ -71,17 +75,17 @@ SUBROUTINE specinp
jzeta = 0
do iteta = 0, Nteta-1
- curtor = curtor + surf(1)%Bx(iteta,jzeta)*surf(1)%xt(iteta,jzeta) &
- & + surf(1)%By(iteta,jzeta)*surf(1)%yt(iteta,jzeta) &
- & + surf(1)%Bz(iteta,jzeta)*surf(1)%zt(iteta,jzeta)
+ curtor = curtor + surf(isurf)%Bx(iteta,jzeta)*surf(isurf)%xt(iteta,jzeta) &
+ & + surf(isurf)%By(iteta,jzeta)*surf(isurf)%yt(iteta,jzeta) &
+ & + surf(isurf)%Bz(iteta,jzeta)*surf(isurf)%zt(iteta,jzeta)
enddo
curtor = curtor * pi2/Nteta ! / mu0 ! SPEC currents are normalized with mu0
iteta = 0
do jzeta = 0, Nzeta-1
- curpol = curpol + surf(1)%Bx(iteta,jzeta)*surf(1)%xp(iteta,jzeta) &
- & + surf(1)%By(iteta,jzeta)*surf(1)%yp(iteta,jzeta) &
- & + surf(1)%Bz(iteta,jzeta)*surf(1)%zp(iteta,jzeta)
+ curpol = curpol + surf(isurf)%Bx(iteta,jzeta)*surf(isurf)%xp(iteta,jzeta) &
+ & + surf(isurf)%By(iteta,jzeta)*surf(isurf)%yp(iteta,jzeta) &
+ & + surf(isurf)%Bz(iteta,jzeta)*surf(isurf)%zp(iteta,jzeta)
enddo
curpol = curpol * pi2/Nzeta
@@ -102,9 +106,11 @@ SUBROUTINE specinp
write(wunit,'(" curtor = ",es23.15 )') curtor
write(wunit,'(" curpol = ",es23.15 )') curpol
write(wunit,'(" Nfp = ",i9 )') Nfp_raw
- do imn = 1, Nfou
- write(wunit,1010) bin(imn)/Nfp_raw, bim(imn), Rbc(imn), bin(imn)/Nfp_raw, bim(imn), Zbs(imn), &
- bin(imn/Nfp_raw), bim(imn), Rbs(imn), bin(imn)/Nfp_raw, bim(imn), Zbc(imn) ! wall is read as plasma boundary
+ do imn = 1, surf(isurf)%Nfou
+ write(wunit,1010) surf(isurf)%bin(imn)/Nfp_raw, surf(isurf)%bim(imn), surf(isurf)%Rbc(imn), &
+ surf(isurf)%bin(imn)/Nfp_raw, surf(isurf)%bim(imn), surf(isurf)%Zbs(imn), &
+ surf(isurf)%bin(imn/Nfp_raw), surf(isurf)%bim(imn), surf(isurf)%Rbs(imn), &
+ surf(isurf)%bin(imn)/Nfp_raw, surf(isurf)%bim(imn), surf(isurf)%Zbc(imn) ! wall is read as plasma boundary
enddo
do imn = 1, Nbf
write(wunit,1020) bnin(imn), bnim(imn), bns(imn), bnin(imn), bnim(imn), zero, &
diff --git a/sources/surface.f90 b/sources/surface.f90
new file mode 100644
index 0000000..ca163e1
--- /dev/null
+++ b/sources/surface.f90
@@ -0,0 +1,37 @@
+! This is the overall function to handle surfaces
+SUBROUTINE surface
+ use globals, only : dp, myid, ounit, machprec, surf, plasma, limiter, input_surf, limiter_surf, &
+ psurf, weight_cssep
+ use mpi
+ implicit none
+
+ LOGICAL :: exist
+ INTEGER :: iosta, astat, ierr
+
+ ! determine the total number of surfaces
+ ! if ( weight_cssep > machprec .and. trim(limiter_surf) /= trim(input_surf) ) then
+ if ( weight_cssep > machprec ) then
+ plasma = 1
+ limiter = 2
+ else ! use the plasma surface as limiter
+ plasma = 1
+ limiter = 1
+ endif
+ allocate(surf(plasma:limiter))
+ psurf = limiter
+
+ ! read the plasma surface
+ inquire( file=trim(input_surf), exist=exist)
+ FATAL( surface, .not.exist, input_surf does not exist )
+ call fousurf( input_surf, plasma )
+
+ ! read the limiter surface
+ if (limiter /= plasma) then
+ inquire( file=trim(limiter_surf), exist=exist)
+ FATAL( surface, .not.exist, limiter_surf does not exist )
+ FATAL( surface, limiter <= plasma, something goes wrong the surface indexing )
+ call fousurf( limiter_surf, limiter )
+ endif
+
+ RETURN
+END SUBROUTINE surface
diff --git a/sources/surfsep.h b/sources/surfsep.f90
similarity index 92%
rename from sources/surfsep.h
rename to sources/surfsep.f90
index 516b234..164f646 100644
--- a/sources/surfsep.h
+++ b/sources/surfsep.f90
@@ -96,6 +96,7 @@ SUBROUTINE surfsep(ideriv)
if( ideriv >= 0 ) then
ivec = 1
do icoil = 1, Ncoils
+ if (coil(icoil)%type /= 1) cycle ! skip for other coils
coilsum = zero
if ( coil(icoil)%Lc /= 0 ) then
do jzeta = 0, Nzeta - 1
@@ -139,21 +140,23 @@ SUBROUTINE surfsep(ideriv)
endif
if ( coil(icoil)%Lc /= 0 ) then ! if geometry is free;
- do jzeta = 0, Nzeta - 1
- do iteta = 0, Nteta - 1
- if( myid.ne.modulo(jzeta*Nteta+iteta,ncpu) ) cycle ! parallelization loop;
- call CSPotential1(icoil, iteta, jzeta, d1S(idof+1:idof+ND), ND)
- l1S(idof+1:idof+ND) = l1S(idof+1:idof+ND) + d1S(idof+1:idof+ND) * surf(psurf)%ds(iteta, jzeta)
- enddo ! end do iteta
- enddo ! end do jzeta
- call MPI_BARRIER( MPI_COMM_WORLD, ierr )
- call MPI_REDUCE( l1S, jac(icoil, 1:Ndof), Ndof, MPI_DOUBLE_PRECISION, MPI_SUM, 0, MPI_COMM_WORLD, ierr )
- RlBCAST( jac(icoil, 1:Ndof), Ndof, 0 )
- ! L-M format of targets
- if (mcssep > 0) LM_fjac(ivec, 1:Ndof) = weight_cssep * jac(icoil, 1:Ndof)
- idof = idof + ND
- ivec = ivec + 1
- endif
+ if (coil(icoil)%type /= 1) then ! skip for other coils
+ do jzeta = 0, Nzeta - 1
+ do iteta = 0, Nteta - 1
+ if( myid.ne.modulo(jzeta*Nteta+iteta,ncpu) ) cycle ! parallelization loop;
+ call CSPotential1(icoil, iteta, jzeta, d1S(idof+1:idof+ND), ND)
+ l1S(idof+1:idof+ND) = l1S(idof+1:idof+ND) + d1S(idof+1:idof+ND) * surf(psurf)%ds(iteta, jzeta)
+ enddo ! end do iteta
+ enddo ! end do jzeta
+ call MPI_BARRIER( MPI_COMM_WORLD, ierr )
+ call MPI_REDUCE( l1S, jac(icoil, 1:Ndof), Ndof, MPI_DOUBLE_PRECISION, MPI_SUM, 0, MPI_COMM_WORLD, ierr )
+ RlBCAST( jac(icoil, 1:Ndof), Ndof, 0 )
+ ! L-M format of targets
+ if (mcssep > 0) LM_fjac(ivec, 1:Ndof) = weight_cssep * jac(icoil, 1:Ndof)
+ ivec = ivec + 1
+ endif
+ idof = idof + ND ! ND should be zero if Lc==0
+ endif
enddo ! end do icoil
FATAL( surfsep , idof .ne. Ndof, counting error in packing )
diff --git a/sources/torflux.h b/sources/torflux.f90
similarity index 56%
rename from sources/torflux.h
rename to sources/torflux.f90
index 2dd0dda..0d7af3d 100644
--- a/sources/torflux.h
+++ b/sources/torflux.f90
@@ -96,24 +96,23 @@ subroutine torflux( ideriv )
! ideriv = 2 -> calculate the toroidal flux constraint and its first & second derivatives;
!------------------------------------------------------------------------------------------------------
use globals, only: dp, zero, half, one, pi2, sqrtmachprec, bsconstant, ncpu, myid, ounit, &
- coil, DoF, surf, Ncoils, Nteta, Nzeta, discretefactor, Cdof, Npc, &
- tflux, t1F, t2F, Ndof, psi_avg, target_tflux, &
- itflux, mtflux, LM_fvec, LM_fjac, weight_tflux
-
+ coil, DoF, surf, Ncoils, Nteta, Nzeta, discretefactor, Cdof, &
+ tflux, t1F, t2F, Ndof, psi_avg, target_tflux, tflux_sign, &
+ itflux, mtflux, LM_fvec, LM_fjac, weight_tflux, plasma
+ use mpi
implicit none
- include "mpif.h"
INTEGER, INTENT(in) :: ideriv
!--------------------------------------------------------------------------------------------
INTEGER :: astat, ierr
- INTEGER :: icoil, iteta, jzeta, idof, ND, ip
+ INTEGER :: icoil, iteta, jzeta, idof, ND, isurf
REAL :: dflux, lflux, lsum
REAL :: lax, lay, laz ! local Ax, Ay and Az
REAL, dimension(0:Cdof, 0:Cdof) :: dAx, dAy, dAz ! dA of each coil;
REAL, dimension(1:Ndof, 0:Nzeta-1) :: ldF, dF
REAL, dimension(0:Nzeta-1) :: ldiff, psi_diff
!--------------------------initialize and allocate arrays-------------------------------------
-
+ isurf = plasma
tflux = zero ; lsum = zero ; psi_avg = zero ; dflux = zero ; psi_diff = zero
ldiff = zero ; lax = zero; lay = zero; laz = zero !already allocted; reset to zero;
@@ -126,20 +125,17 @@ subroutine torflux( ideriv )
lflux = zero
do iteta = 0, Nteta - 1
lax = zero; lay = zero; laz = zero
- do ip = 1, Npc
- do icoil = 1, Ncoils
- call bpotential0(icoil+(ip-1)*Ncoils, iteta, jzeta, dAx(0,0), dAy(0,0), dAz(0,0))
- lax = lax + dAx( 0, 0) * coil(icoil)%I * bsconstant
- lay = lay + dAy( 0, 0) * coil(icoil)%I * bsconstant
- laz = laz + dAz( 0, 0) * coil(icoil)%I * bsconstant
- enddo ! end do icoil
- enddo ! end do ip;
-
- lflux = lflux + lax * surf(1)%xt(iteta,jzeta) + & ! local flux;
- lay * surf(1)%yt(iteta,jzeta) + &
- laz * surf(1)%zt(iteta,jzeta)
+ do icoil = 1, Ncoils
+ call bpotential0(icoil, iteta, jzeta, dAx(0,0), dAy(0,0), dAz(0,0))
+ lax = lax + dAx( 0, 0) * coil(icoil)%I * bsconstant
+ lay = lay + dAy( 0, 0) * coil(icoil)%I * bsconstant
+ laz = laz + dAz( 0, 0) * coil(icoil)%I * bsconstant
+ enddo ! end do icoil
+ lflux = lflux + lax * surf(isurf)%xt(iteta,jzeta) + & ! local flux;
+ lay * surf(isurf)%yt(iteta,jzeta) + &
+ laz * surf(isurf)%zt(iteta,jzeta)
enddo ! end do iteta
- lflux = lflux * pi2/Nteta ! discretization factor;
+ lflux = lflux * pi2/Nteta * tflux_sign ! discretization factor;
lsum = lsum + lflux
ldiff(jzeta) = lflux - target_tflux
dflux = dflux + ldiff(jzeta)**2
@@ -171,44 +167,40 @@ subroutine torflux( ideriv )
do jzeta = 0, Nzeta - 1
if( myid.ne.modulo(jzeta,ncpu) ) cycle ! parallelization loop;
-
do iteta = 0, Nteta - 1
-
- do ip = 1, Npc
- idof = 0
- do icoil = 1, Ncoils
- ND = DoF(icoil)%ND
- if ( coil(icoil)%Ic /= 0 ) then !if current is free;
- call bpotential0(icoil, iteta, jzeta, &
- & dAx(0,0), dAy(0,0), dAz(0,0))
-
- ldF(idof+1, jzeta) = ldF(idof+1, jzeta) &
- & + bsconstant * ( dAx(0,0)*surf(1)%xt(iteta,jzeta) &
- & + dAy(0,0)*surf(1)%yt(iteta,jzeta) &
- & + dAz(0,0)*surf(1)%zt(iteta,jzeta) )
- idof = idof +1
- endif
-
- if ( coil(icoil)%Lc /= 0 ) then !if geometry is free;
- call bpotential1(icoil, iteta, jzeta, &
- & dAx(1:ND,0), dAy(1:ND,0), dAz(1:ND,0), ND)
-
- ldF(idof+1:idof+ND, jzeta) = ldF(idof+1:idof+ND, jzeta) &
- & + bsconstant * coil(icoil)%I * ( dAx(1:ND,0)*surf(1)%xt(iteta,jzeta) &
- & + dAy(1:ND,0)*surf(1)%yt(iteta,jzeta) &
- & + dAz(1:ND,0)*surf(1)%zt(iteta,jzeta) )
-
- idof = idof + ND
- endif
-
- enddo !end icoil;
- FATAL( torflux , idof .ne. Ndof, counting error in packing )
- enddo ! end do ip;
+ idof = 0
+ do icoil = 1, Ncoils
+ ND = DoF(icoil)%ND
+ if ( coil(icoil)%Ic /= 0 ) then !if current is free;
+ call bpotential0(icoil, iteta, jzeta, &
+ & dAx(0,0), dAy(0,0), dAz(0,0))
+
+ ldF(idof+1, jzeta) = ldF(idof+1, jzeta) &
+ & + bsconstant * ( dAx(0,0)*surf(isurf)%xt(iteta,jzeta) &
+ & + dAy(0,0)*surf(isurf)%yt(iteta,jzeta) &
+ & + dAz(0,0)*surf(isurf)%zt(iteta,jzeta) )
+ idof = idof +1
+ endif
+
+ if ( coil(icoil)%Lc /= 0 ) then !if geometry is free;
+ call bpotential1(icoil, iteta, jzeta, &
+ & dAx(1:ND,0), dAy(1:ND,0), dAz(1:ND,0), ND)
+
+ ldF(idof+1:idof+ND, jzeta) = ldF(idof+1:idof+ND, jzeta) &
+ & + bsconstant * coil(icoil)%I * ( dAx(1:ND,0)*surf(isurf)%xt(iteta,jzeta) &
+ & + dAy(1:ND,0)*surf(isurf)%yt(iteta,jzeta) &
+ & + dAz(1:ND,0)*surf(isurf)%zt(iteta,jzeta) )
+
+ idof = idof + ND
+ endif
+
+ enddo !end icoil;
+ FATAL( torflux , idof .ne. Ndof, counting error in packing )
enddo !end iteta;
enddo !end jzeta
- ldF = ldF * pi2/Nteta
+ ldF = ldF * pi2/Nteta * tflux_sign
call MPI_BARRIER( MPI_COMM_WORLD, ierr )
call MPI_REDUCE(ldF, dF, Ndof*Nzeta, MPI_DOUBLE_PRECISION, MPI_SUM, 0, MPI_COMM_WORLD, ierr )
@@ -227,7 +219,6 @@ subroutine torflux( ideriv )
endif
-
!--------------------------------------------------------------------------------------------
call MPI_barrier( MPI_COMM_WORLD, ierr )
@@ -237,52 +228,87 @@ end subroutine torflux
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-subroutine bpotential0(icoil, iteta, jzeta, Ax, Ay, Az)
+subroutine bpotential0(icoil, iteta, jzeta, tAx, tAy, tAz)
!------------------------------------------------------------------------------------------------------
-! DATE: 06/15/2017
+! DATE: 06/15/2017; 01/20/2020
! calculate the magnetic potential from coil(icoil) at the evaluation point (iteta, jzeta);
! Biot-Savart constant and currents are not included for later simplication.
! Discretizing factor is includeed; coil(icoil)%dd(kseg)
!------------------------------------------------------------------------------------------------------
- use globals, only: dp, coil, surf, Ncoils, Nteta, Nzeta, Npc, &
- zero, myid, ounit
+ use globals, only: dp, coil, surf, Ncoils, Nteta, Nzeta, &
+ zero, myid, ounit, plasma, Nfp, cosnfp, sinnfp, two, bsconstant
+ use mpi
implicit none
- include "mpif.h"
INTEGER, intent(in ) :: icoil, iteta, jzeta
- REAL , intent(out) :: Ax, Ay, Az
+ REAL , intent(out) :: tAx, tAy, tAz
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
- INTEGER :: ierr, astat, kseg
- REAL :: dlx, dly, dlz, rm, ltx, lty, ltz
+ INTEGER :: ierr, astat, kseg, isurf, ip, is, cs, Npc
+ REAL :: dlx, dly, dlz, rm, ltx, lty, ltz, &
+ & Ax, Ay, Az, xx, yy, zz, rr
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
- FATAL( bpotential0, icoil .lt. 1 .or. icoil .gt. Ncoils*Npc, icoil not in right range )
- FATAL( bpotential0, iteta .lt. 0 .or. iteta .gt. Nteta , iteta not in right range )
- FATAL( bpotential0, jzeta .lt. 0 .or. jzeta .gt. Nzeta , jzeta not in right range )
-
- dlx = zero; ltx = zero; Ax = zero
- dly = zero; lty = zero; Ay = zero
- dlz = zero; ltz = zero; Az = zero
-
- do kseg = 0, coil(icoil)%NS-1
-
- dlx = surf(1)%xx(iteta,jzeta) - coil(icoil)%xx(kseg)
- dly = surf(1)%yy(iteta,jzeta) - coil(icoil)%yy(kseg)
- dlz = surf(1)%zz(iteta,jzeta) - coil(icoil)%zz(kseg)
- rm = 1.0 / sqrt(dlx**2 + dly**2 + dlz**2)
-
- ltx = coil(icoil)%xt(kseg)
- lty = coil(icoil)%yt(kseg)
- ltz = coil(icoil)%zt(kseg)
-
- Ax = Ax + ltx * rm * coil(icoil)%dd(kseg)
- Ay = Ay + lty * rm * coil(icoil)%dd(kseg)
- Az = Az + ltz * rm * coil(icoil)%dd(kseg)
-
- enddo ! enddo kseg
+ isurf = plasma
+ FATAL( bpotential0, icoil .lt. 1 .or. icoil .gt. Ncoils, icoil not in right range )
+ FATAL( bpotential0, iteta .lt. 0 .or. iteta .gt. Nteta , iteta not in right range )
+ FATAL( bpotential0, jzeta .lt. 0 .or. jzeta .gt. Nzeta , jzeta not in right range )
+ ! initialization
+ Npc = 1 ; cs = 0
+ tAx = zero ; tAy = zero ; tAz = zero
+ dlx = zero ; dly = zero ; dlz = zero
+ ltx = zero ; lty = zero ; ltz = zero
+ ! check if the coil is stellarator symmetric
+ select case (coil(icoil)%symm)
+ case ( 0 )
+ cs = 0
+ Npc = 1
+ case ( 1 )
+ cs = 0
+ Npc = Nfp
+ case ( 2)
+ cs = 1
+ Npc = Nfp
+ end select
+
+ ! periodicity and stellarator symmetry
+ do ip = 1, Npc
+ do is = 0, cs
+ ! find the point on plasma by rotating in reverse direction. + symmetric
+ xx = ( surf(isurf)%xx(iteta,jzeta)*cosnfp(ip) + surf(isurf)%yy(iteta,jzeta)*sinnfp(ip) )
+ yy = (-surf(isurf)%xx(iteta,jzeta)*sinnfp(ip) + surf(isurf)%yy(iteta,jzeta)*cosnfp(ip) ) * (-1)**is
+ zz = surf(isurf)%zz(iteta,jzeta) * (-1)**is
+ Ax = zero; Ay = zero; Az = zero
+ select case (coil(icoil)%type)
+ case(1)
+ ! Fourier coils
+ do kseg = 0, coil(icoil)%NS-1
+ dlx = xx - coil(icoil)%xx(kseg)
+ dly = yy - coil(icoil)%yy(kseg)
+ dlz = zz - coil(icoil)%zz(kseg)
+ rm = 1.0 / sqrt(dlx**2 + dly**2 + dlz**2)
+ ltx = coil(icoil)%xt(kseg)
+ lty = coil(icoil)%yt(kseg)
+ ltz = coil(icoil)%zt(kseg)
+ Ax = Ax + ltx * rm * coil(icoil)%dd(kseg)
+ Ay = Ay + lty * rm * coil(icoil)%dd(kseg)
+ Az = Az + ltz * rm * coil(icoil)%dd(kseg)
+ enddo ! enddo kseg
+ case(3)
+ ! central current and vertical field (zero contribution)
+ rr = sqrt( xx**2 + yy**2 )
+ ! \vec A=-\frac{\mu_0I}{2\pi} \ln(r) \hat e_z
+ Az = -two*bsconstant*log(rr)
+ case default
+ FATAL(bpotential0, .true., not supported coil types)
+ end select
+ ! sum all the contributions
+ tAx = tAx + (Ax*cosnfp(ip) - Ay*sinnfp(ip))*(-1)**is
+ tAy = tAy + (Ay*cosnfp(ip) + Ax*sinnfp(ip))
+ tAz = tAz + Az
+ enddo
+ enddo
return
@@ -290,73 +316,97 @@ end subroutine bpotential0
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-subroutine bpotential1(icoil, iteta, jzeta, Ax, Ay, Az, ND)
+subroutine bpotential1(icoil, iteta, jzeta, tAx, tAy, tAz, ND)
!------------------------------------------------------------------------------------------------------
! DATE: 06/15/2017
! calculate the magnetic potential and its 1st derivatives from coil(icoil) at the evaluation point;
! Biot-Savart constant and currents are not included for later simplication.
! Discretizing factor is includeed; coil(icoil)%dd(kseg)
!------------------------------------------------------------------------------------------------------
- use globals, only: dp, coil, DoF, surf, NFcoil, Ncoils, Nteta, Nzeta, Npc, &
- zero, myid, ounit
+ use globals, only: dp, coil, DoF, surf, NFcoil, Ncoils, Nteta, Nzeta, &
+ zero, myid, ounit, plasma, Nfp, cosnfp, sinnfp
+ use mpi
implicit none
- include "mpif.h"
INTEGER, intent(in ) :: icoil, iteta, jzeta, ND
- REAL, dimension(1:1, 1:ND), intent(inout) :: Ax, Ay, Az
+ REAL, dimension(1:1, 1:ND), intent(inout) :: tAx, tAy, tAz
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
- INTEGER :: ierr, astat, kseg, NS
- REAL :: dlx, dly, dlz, r, rm3, ltx, lty, ltz
+ INTEGER :: ierr, astat, kseg, NS, isurf, ip, is, cs, Npc
+ REAL :: dlx, dly, dlz, r, rm3, ltx, lty, ltz, xx, yy, zz
+ REAL, dimension(1:1, 1:ND) :: Ax, Ay, Az
REAL, dimension(1:1, 0:coil(icoil)%NS-1) :: dAxx, dAxy, dAxz, dAyx, dAyy, dAyz, dAzx, dAzy, dAzz
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
-
- FATAL( bpotential1, icoil .lt. 1 .or. icoil .gt. Ncoils*Npc, &
- icoil not in right range )
- FATAL( bpotential1, iteta .lt. 0 .or. iteta .gt. Nteta , &
- iteta not in right range )
- FATAL( bpotential1, jzeta .lt. 0 .or. jzeta .gt. Nzeta , &
- jzeta not in right range )
+ isurf = plasma
+ FATAL( bpotential1, icoil .lt. 1 .or. icoil .gt. Ncoils, icoil not in right range )
+ FATAL( bpotential1, iteta .lt. 0 .or. iteta .gt. Nteta , iteta not in right range )
+ FATAL( bpotential1, jzeta .lt. 0 .or. jzeta .gt. Nzeta , jzeta not in right range )
FATAL( bpotential1, ND <= 0, wrong inout dimension of ND )
+
+ ! initialization
+ Npc = 1 ; cs = 0
+ tAx = zero ; tAy = zero ; tAz = zero
+ dlx = zero ; dly = zero ; dlz = zero
+ ltx = zero ; lty = zero ; ltz = zero
+ ! check if the coil is stellarator symmetric
+ select case (coil(icoil)%symm)
+ case ( 0 )
+ cs = 0
+ Npc = 1
+ case ( 1 )
+ cs = 0
+ Npc = Nfp
+ case ( 2)
+ cs = 1
+ Npc = Nfp
+ end select
NS = coil(icoil)%NS
-
- dlx = zero; ltx = zero; Ax = zero
- dly = zero; lty = zero; Ay = zero
- dlz = zero; ltz = zero; Az = zero
-
- do kseg = 0, NS-1
-
- dlx = surf(1)%xx(iteta,jzeta) - coil(icoil)%xx(kseg)
- dly = surf(1)%yy(iteta,jzeta) - coil(icoil)%yy(kseg)
- dlz = surf(1)%zz(iteta,jzeta) - coil(icoil)%zz(kseg)
-
- r = sqrt(dlx**2 + dly**2 + dlz**2); rm3 = r**(-3)
-
- ltx = coil(icoil)%xt(kseg)
- lty = coil(icoil)%yt(kseg)
- ltz = coil(icoil)%zt(kseg)
-
- dAxx(1,kseg) = - (dly*lty + dlz*ltz) * rm3 * coil(icoil)%dd(kseg) !Ax/x
- dAxy(1,kseg) = dly*ltx * rm3 * coil(icoil)%dd(kseg) !Ax/y
- dAxz(1,kseg) = dlz*ltx * rm3 * coil(icoil)%dd(kseg) !Ax/z
-
- dAyx(1,kseg) = dlx*lty * rm3 * coil(icoil)%dd(kseg) !Ay/x
- dAyy(1,kseg) = - (dlx*ltx + dlz*ltz) * rm3 * coil(icoil)%dd(kseg) !Ay/y
- dAyz(1,kseg) = dlz*lty * rm3 * coil(icoil)%dd(kseg) !Ay/z
-
- dAzx(1,kseg) = dlx*ltz * rm3 * coil(icoil)%dd(kseg) !Az/x
- dAzy(1,kseg) = dly*ltz * rm3 * coil(icoil)%dd(kseg) !Az/y
- dAzz(1,kseg) = - (dlx*ltx + dly*lty) * rm3 * coil(icoil)%dd(kseg) !Az/z
-
- enddo ! enddo kseg
-
- Ax(1:1, 1:ND) = matmul(dAxx, DoF(icoil)%xof) + matmul(dAxy, DoF(icoil)%yof) + matmul(dAxz, DoF(icoil)%zof)
- Ay(1:1, 1:ND) = matmul(dAyx, DoF(icoil)%xof) + matmul(dAyy, DoF(icoil)%yof) + matmul(dAyz, DoF(icoil)%zof)
- Az(1:1, 1:ND) = matmul(dAzx, DoF(icoil)%xof) + matmul(dAzy, DoF(icoil)%yof) + matmul(dAzz, DoF(icoil)%zof)
-
+ ! periodicity and stellarator symmetry
+ do ip = 1, Npc
+ do is = 0, cs
+ ! find the point on plasma by rotating in reverse direction. + symmetric
+ xx = ( surf(isurf)%xx(iteta,jzeta)*cosnfp(ip) + surf(isurf)%yy(iteta,jzeta)*sinnfp(ip) )
+ yy = (-surf(isurf)%xx(iteta,jzeta)*sinnfp(ip) + surf(isurf)%yy(iteta,jzeta)*cosnfp(ip) ) * (-1)**is
+ zz = surf(isurf)%zz(iteta,jzeta) * (-1)**is
+ Ax = zero; Ay = zero; Az = zero
+ select case (coil(icoil)%type)
+ case(1)
+ ! Fourier coils
+ do kseg = 0, NS-1
+ dlx = xx - coil(icoil)%xx(kseg)
+ dly = yy - coil(icoil)%yy(kseg)
+ dlz = zz - coil(icoil)%zz(kseg)
+ r = sqrt(dlx**2 + dly**2 + dlz**2); rm3 = r**(-3)
+ ltx = coil(icoil)%xt(kseg)
+ lty = coil(icoil)%yt(kseg)
+ ltz = coil(icoil)%zt(kseg)
+ dAxx(1,kseg) = - (dly*lty + dlz*ltz) * rm3 * coil(icoil)%dd(kseg) !Ax/x
+ dAxy(1,kseg) = dly*ltx * rm3 * coil(icoil)%dd(kseg) !Ax/y
+ dAxz(1,kseg) = dlz*ltx * rm3 * coil(icoil)%dd(kseg) !Ax/z
+ dAyx(1,kseg) = dlx*lty * rm3 * coil(icoil)%dd(kseg) !Ay/x
+ dAyy(1,kseg) = - (dlx*ltx + dlz*ltz) * rm3 * coil(icoil)%dd(kseg) !Ay/y
+ dAyz(1,kseg) = dlz*lty * rm3 * coil(icoil)%dd(kseg) !Ay/z
+ dAzx(1,kseg) = dlx*ltz * rm3 * coil(icoil)%dd(kseg) !Az/x
+ dAzy(1,kseg) = dly*ltz * rm3 * coil(icoil)%dd(kseg) !Az/y
+ dAzz(1,kseg) = - (dlx*ltx + dly*lty) * rm3 * coil(icoil)%dd(kseg) !Az/z
+ enddo ! enddo kseg
+ Ax(1:1, 1:ND) = matmul(dAxx, DoF(icoil)%xof) + matmul(dAxy, DoF(icoil)%yof) + matmul(dAxz, DoF(icoil)%zof)
+ Ay(1:1, 1:ND) = matmul(dAyx, DoF(icoil)%xof) + matmul(dAyy, DoF(icoil)%yof) + matmul(dAyz, DoF(icoil)%zof)
+ Az(1:1, 1:ND) = matmul(dAzx, DoF(icoil)%xof) + matmul(dAzy, DoF(icoil)%yof) + matmul(dAzz, DoF(icoil)%zof)
+ case(3)
+ continue
+ case default
+ FATAL(bpotential1, .true., not supported coil types)
+ end select
+ ! sum all the contributions
+ tAx = tAx + (Ax*cosnfp(ip) - Ay*sinnfp(ip))*(-1)**is
+ tAy = tAy + (Ay*cosnfp(ip) + Ax*sinnfp(ip))
+ tAz = tAz + Az
+ enddo
+ enddo
return
end subroutine bpotential1
diff --git a/sources/wtmgrid.f90 b/sources/wtmgrid.f90
new file mode 100644
index 0000000..b9256ea
--- /dev/null
+++ b/sources/wtmgrid.f90
@@ -0,0 +1,148 @@
+! write binary mgrid file
+module mgrid_mod
+ use globals, only : dp, zero, pi2
+ INTEGER :: NR = 101, NZ=101, NP=72, MFP=0
+ REAL :: Rmin=zero, Rmax=zero, Zmin=zero, Zmax=zero, Pmin=zero, Pmax=pi2
+ namelist / mgrid / Rmin, Rmax, Zmin, Zmax, Pmin, Pmax, NR, NZ, NP
+end module mgrid_mod
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+subroutine wtmgrid
+ use globals, only : dp, zero, half, pi2, ext, ncpu, myid, ounit, wunit, runit, surf, plasma, &
+ sqrtmachprec, master, nmaster, nworker, masterid, color, myworkid, &
+ MPI_COMM_MASTERS, MPI_COMM_MYWORLD, MPI_COMM_WORKERS
+ use mgrid_mod
+ implicit none
+ include "mpif.h"
+
+ !-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
+
+ LOGICAL :: exist
+ INTEGER :: ierr, astat, iostat, ip, iz, ir, nextcur, icpu
+ REAL :: RpZ(1:3), R, P, Z, B(1:3), pressure, gap, &
+ czeta, szeta, xx, yy, zz, dx, dy, dz, dBx, dBy, dBz
+ REAL, allocatable :: BRZp(:,:,:,:), BRpZ(:,:,:,:)
+ CHARACTER(LEN=100) :: mgrid_name
+ CHARACTER(LEN=30) :: curlabel(1:1)
+
+ do icpu = 1, ncpu
+ call MPI_BARRIER( MPI_COMM_WORLD, ierr )
+ if (myid == icpu-1) then ! each cpu read the namelist in turn;
+ open(runit, file=trim(trim(ext)//".input"), status="old", action='read')
+ read(runit, mgrid)
+ close(runit)
+ endif ! end of if( myid == 0 )
+ enddo
+
+ mgrid_name = "mgrid.focus_"//trim(ext) ! filename, could be user input
+ if (Mfp <= 0) Mfp = surf(plasma)%Nfp ! overrid to nfp_raw if not specified
+ B = zero ; dx = 1E-4 ; dy = 1E-4 ; dz = 1E-4
+
+ FATAL( wrmgrid, abs(Rmin)+abs(Rmax)=0) then
+ call MPI_ALLREDUCE( MPI_IN_PLACE, BRZp, 3*nr*nz*np, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_MASTERS, ierr)
+#ifdef DIV_CHECK
+ call MPI_ALLREDUCE( MPI_IN_PLACE, BRpZ, 2*nr*nz*np, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_MASTERS, ierr)
+#endif
+ CALL MPI_COMM_FREE(MPI_COMM_MASTERS, ierr)
+ endif
+
+ CALL MPI_COMM_FREE(MPI_COMM_MYWORLD, ierr)
+
+ if( myid.eq.0 ) then
+#ifdef DIV_CHECK
+ write(ounit, '("wtmgrid : max. div B = "ES23.15 " ; max. div B / |B| = "ES23.15 )') maxval(BRpZ(1,1:Nr,1:Nz,1:Np)), maxval(BRpZ(2,1:Nr,1:Nz,1:Np))
+#endif
+ nextcur = 1 ; curlabel(1) = "focus-coils"
+
+ write( ounit,'("wtmgrid : writing ",A," ; Mfp="i3" ;")') trim(mgrid_name), Mfp
+
+ !open( wunit, file=trim(ext)//".fo.mgrid", status="unknown", form="unformatted", iostat=iostat )
+ open( wunit, file=trim(mgrid_name), status="unknown", form="unformatted", iostat=iostat )
+ FATAL( wtmgrid, iostat.ne.0, error opening ext.fo.mgrid )
+ write(wunit) Nr, Nz, Np, Mfp, nextcur
+ write(wunit) Rmin, Zmin, Rmax, Zmax
+ write(wunit) curlabel(1:nextcur)
+ write(wunit) BRZp(1:3,1:Nr,1:Nz,1:Np)
+ close(wunit)
+
+ endif
+
+ DEALLOCATE(BRZp)
+#ifdef DIV_CHECK
+ DEALLOCATE(BRpZ)
+#endif
+
+ return
+
+end subroutine wtmgrid
+
+!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!